From b0e85485fbf042abccee5c0a9eb499da386c8db3 Mon Sep 17 00:00:00 2001 From: Paul Thomas Date: Fri, 14 Apr 2023 11:14:00 +0100 Subject: [PATCH] Fortran: Fix an excess finalization during allocation [PR104272] 2023-04-14 Paul Thomas 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 --- gcc/fortran/gfortran.h | 2 + gcc/fortran/resolve.cc | 3 ++ gcc/fortran/trans-stmt.cc | 7 +++- gcc/testsuite/gfortran.dg/class_result_8.f90 | 2 +- gcc/testsuite/gfortran.dg/finalize_52.f90 | 57 ++++++++++++++++++++++++++++ 5 files changed, 68 insertions(+), 3 deletions(-) create mode 100644 gcc/testsuite/gfortran.dg/finalize_52.f90 diff --git a/gcc/fortran/gfortran.h b/gcc/fortran/gfortran.h index 130d5d7..db77d24 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 58013d4..55d8e32 100644 --- a/gcc/fortran/resolve.cc +++ b/gcc/fortran/resolve.cc @@ -8089,6 +8089,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) { @@ -8097,6 +8098,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 @@ -8104,6 +8106,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 f788754..776f98d 100644 --- a/gcc/fortran/trans-stmt.cc +++ b/gcc/fortran/trans-stmt.cc @@ -6458,12 +6458,15 @@ gfc_trans_allocate (gfc_code * code) /* Deallocate any allocatable components in expressions that use a temporary object, i.e. are not a simple alias of to an EXPR_VARIABLE. E.g. temporaries of a function call need freeing of their components - here. */ + here. Explicit derived type allocation of class entities uses expr3 + to carry the default initializer. This must not be deallocated or + finalized. */ if ((code->expr3->ts.type == BT_DERIVED || code->expr3->ts.type == BT_CLASS) && (code->expr3->expr_type != EXPR_VARIABLE || temp_obj_created) && code->expr3->ts.u.derived->attr.alloc_comp - && !code->expr3->must_finalize) + && !code->expr3->must_finalize + && !code->ext.alloc.expr3_not_explicit) { tmp = gfc_deallocate_alloc_comp (code->expr3->ts.u.derived, expr3, code->expr3->rank); diff --git a/gcc/testsuite/gfortran.dg/class_result_8.f90 b/gcc/testsuite/gfortran.dg/class_result_8.f90 index 573dd44..9a1fb2b 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" } } diff --git a/gcc/testsuite/gfortran.dg/finalize_52.f90 b/gcc/testsuite/gfortran.dg/finalize_52.f90 new file mode 100644 index 0000000..be2ca17 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/finalize_52.f90 @@ -0,0 +1,57 @@ +! { dg-do run } +! +! Test the fix for PR104272 in which allocate caused an unwanted finalization +! +! Contributed by Kai Germaschewski +! +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 -- 2.7.4