Hi All,
This is a first in my recent experience - a very old bug that produces too
many finalizations! It results from a bit of a fix up, where class objects
are allocated using the derived typespec, rather than a source or mold
expression. This occurs upstream in resolve.cc, where the default
initializer is assigned to expr3 but no means are provided to identify what
it is. The patch applies a signaling bit-field to the ext field of
gfc_code, which then suppresses the deallocation of allocatable components
in the allocate expression. I have checked that this does not cause memory
leaks, even though the number of builtin_frees in class_result_8.f90 goes
down by one.
OK for mainline?
Paul
Fortran: Fix and excess finalization during allocation [PR104272]
2023-04-04 Paul Thomas <pa...@gcc.gnu.org>
gcc/fortran
PR fortran/104272
* gfortran.h : Add expr3_not_explicit bit field to gfc_code.
* resolve.cc (resolve_allocate_expr): Set bit field when the
default initializer is applied to expr3.
* trans-stmt.cc (gfc_trans_allocate): If expr3_not_explicit is
set, do not deallocate expr3.
gcc/testsuite/
PR fortran/104272
* gfortran.dg/class_result_8.f90 : Number of builtin_frees down
from 6 to 5 without memory leaks.
* gfortran.dg/finalize_52.f90: New test
diff --git a/gcc/fortran/gfortran.h b/gcc/fortran/gfortran.h
index 9bab2c40ead..3efe6634908 100644
--- a/gcc/fortran/gfortran.h
+++ b/gcc/fortran/gfortran.h
@@ -3005,6 +3005,8 @@ typedef struct gfc_code
/* Take the array specification from expr3 to allocate arrays
without an explicit array specification. */
unsigned arr_spec_from_expr3:1;
+ /* expr3 is not explicit */
+ unsigned expr3_not_explicit:1;
}
alloc;
diff --git a/gcc/fortran/resolve.cc b/gcc/fortran/resolve.cc
index 1a03e458d99..ebe58d1d3b6 100644
--- a/gcc/fortran/resolve.cc
+++ b/gcc/fortran/resolve.cc
@@ -8072,6 +8072,7 @@ resolve_allocate_expr (gfc_expr *e, gfc_code *code, bool *array_alloc_wo_spec)
if (!t)
goto failure;
+ code->ext.alloc.expr3_not_explicit = 0;
if (e->ts.type == BT_CLASS && CLASS_DATA (e)->attr.dimension
&& !code->expr3 && code->ext.alloc.ts.type == BT_DERIVED)
{
@@ -8080,6 +8081,7 @@ resolve_allocate_expr (gfc_expr *e, gfc_code *code, bool *array_alloc_wo_spec)
when the allocated type is different from the declared type but
no SOURCE exists by setting expr3. */
code->expr3 = gfc_default_initializer (&code->ext.alloc.ts);
+ code->ext.alloc.expr3_not_explicit = 1;
}
else if (flag_coarray != GFC_FCOARRAY_LIB && e->ts.type == BT_DERIVED
&& e->ts.u.derived->from_intmod == INTMOD_ISO_FORTRAN_ENV
@@ -8087,6 +8089,7 @@ resolve_allocate_expr (gfc_expr *e, gfc_code *code, bool *array_alloc_wo_spec)
{
/* We have to zero initialize the integer variable. */
code->expr3 = gfc_get_int_expr (gfc_default_integer_kind, &e->where, 0);
+ code->ext.alloc.expr3_not_explicit = 1;
}
if (e->ts.type == BT_CLASS && !unlimited && !UNLIMITED_POLY (code->expr3))
diff --git a/gcc/fortran/trans-stmt.cc b/gcc/fortran/trans-stmt.cc
index f78875455a5..0b03fd5ed2f 100644
--- a/gcc/fortran/trans-stmt.cc
+++ b/gcc/fortran/trans-stmt.cc
@@ -6465,8 +6465,10 @@ gfc_trans_allocate (gfc_code * code)
&& code->expr3->ts.u.derived->attr.alloc_comp
&& !code->expr3->must_finalize)
{
- tmp = gfc_deallocate_alloc_comp (code->expr3->ts.u.derived,
- expr3, code->expr3->rank);
+ /* Switch off finalization if expr3 is implicit. */
+ if (code->ext.alloc.expr3_not_explicit == 0)
+ tmp = gfc_deallocate_alloc_comp (code->expr3->ts.u.derived,
+ expr3, code->expr3->rank);
gfc_prepend_expr_to_block (&post, tmp);
}
diff --git a/gcc/testsuite/gfortran.dg/class_result_8.f90 b/gcc/testsuite/gfortran.dg/class_result_8.f90
index 573dd44daad..9a1fb2ba50f 100644
--- a/gcc/testsuite/gfortran.dg/class_result_8.f90
+++ b/gcc/testsuite/gfortran.dg/class_result_8.f90
@@ -37,5 +37,5 @@ program polymorphic_operators_memory_leaks
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_free" 5 "original" } }
! { dg-final { scan-tree-dump-times "builtin_malloc" 7 "original" } }
! { dg-do run }
!
! Test the fix for PR104272 in which allocate caused an unwanted finalization
!
! Contributed by Kai Germaschewski <kai.germaschew...@gmail.com>
!
module solver_m
implicit none
type, abstract, public :: solver_base_t
end type solver_base_t
type, public, extends(solver_base_t) :: solver_gpu_t
complex, dimension(:), allocatable :: x
contains
final :: solver_gpu_final
end type solver_gpu_t
type, public, extends(solver_gpu_t) :: solver_sparse_gpu_t
contains
final :: solver_sparse_gpu_final
end type solver_sparse_gpu_t
integer :: final_counts = 0
contains
impure elemental subroutine solver_gpu_final(this)
type(solver_gpu_t), intent(INOUT) :: this
final_counts = final_counts + 1
end subroutine solver_gpu_final
impure elemental subroutine solver_sparse_gpu_final(this)
type(solver_sparse_gpu_t), intent(INOUT) :: this
final_counts = final_counts + 10
end subroutine solver_sparse_gpu_final
end module solver_m
subroutine test
use solver_m
implicit none
class(solver_base_t), dimension(:), allocatable :: solver
allocate(solver_sparse_gpu_t :: solver(2))
if (final_counts .ne. 0) stop 1
end subroutine
program main
use solver_m
implicit none
call test
if (final_counts .ne. 22) stop 2 ! Scalar finalizers for rank 1/size 2
end program
