[flang-commits] [flang] [flang][hlfir] Fixed missing deallocation for components of function … (PR #67768)
Slava Zakharin via flang-commits
flang-commits at lists.llvm.org
Thu Sep 28 23:42:42 PDT 2023
https://github.com/vzakhari created https://github.com/llvm/llvm-project/pull/67768
…result.
If function result have allocatable components or components that may require finalization, we have to call Destroy runtime for them. We also have to free the top-level entity's memory regardless of whether we called Destroy or not.
>From aa20a6e3613421d89a08a06902cfc72f68d30e58 Mon Sep 17 00:00:00 2001
From: Slava Zakharin <szakharin at nvidia.com>
Date: Thu, 28 Sep 2023 18:28:07 -0700
Subject: [PATCH] [flang][hlfir] Fixed missing deallocation for components of
function result.
If function result have allocatable components or components that may
require finalization, we have to call Destroy runtime for them.
We also have to free the top-level entity's memory regardless of whether
we called Destroy or not.
---
flang/lib/Lower/ConvertCall.cpp | 48 +++--
.../Lower/HLFIR/function-return-destroy.f90 | 197 ++++++++++++++++++
2 files changed, 227 insertions(+), 18 deletions(-)
create mode 100644 flang/test/Lower/HLFIR/function-return-destroy.f90
diff --git a/flang/lib/Lower/ConvertCall.cpp b/flang/lib/Lower/ConvertCall.cpp
index 0510965a596fb05..09b1b3ab7f5aa34 100644
--- a/flang/lib/Lower/ConvertCall.cpp
+++ b/flang/lib/Lower/ConvertCall.cpp
@@ -428,6 +428,29 @@ fir::ExtendedValue Fortran::lower::genCallOpAndResult(
}
if (allocatedResult) {
+ // The result must be optionally destroyed (if it is of a derived type
+ // that may need finalization or deallocation of the components).
+ // For an allocatable result we have to free the memory allocated
+ // for the top-level entity. Note that the Destroy calls below
+ // do not deallocate the top-level entity. The two clean-ups
+ // must be pushed in reverse order, so that the final order is:
+ // Destroy(desc)
+ // free(desc->base_addr)
+ allocatedResult->match(
+ [&](const fir::MutableBoxValue &box) {
+ if (box.isAllocatable()) {
+ // 9.7.3.2 point 4. Deallocate allocatable results. Note that
+ // finalization was done independently by calling
+ // genDerivedTypeDestroy above and is not triggered by this inline
+ // deallocation.
+ fir::FirOpBuilder *bldr = &converter.getFirOpBuilder();
+ stmtCtx.attachCleanup([bldr, loc, box]() {
+ fir::factory::genFreememIfAllocated(*bldr, loc, box);
+ });
+ }
+ },
+ [](const auto &) {});
+
// 7.5.6.3 point 5. Derived-type finalization for nonpointer function.
// Check if the derived-type is finalizable if it is a monomorphic
// derived-type.
@@ -435,7 +458,6 @@ fir::ExtendedValue Fortran::lower::genCallOpAndResult(
// in any cases.
std::optional<Fortran::evaluate::DynamicType> retTy =
caller.getCallDescription().proc().GetType();
- bool cleanupWithDestroy = false;
// With HLFIR lowering, isElemental must be set to true
// if we are producing an elemental call. In this case,
// the elemental results must not be destroyed, instead,
@@ -451,34 +473,24 @@ fir::ExtendedValue Fortran::lower::genCallOpAndResult(
fir::runtime::genDerivedTypeDestroy(*bldr, loc,
fir::getBase(*allocatedResult));
});
- cleanupWithDestroy = true;
} else {
const Fortran::semantics::DerivedTypeSpec &typeSpec =
retTy->GetDerivedTypeSpec();
- if (Fortran::semantics::IsFinalizable(typeSpec)) {
+ // If the result type is finalizable or may require finalization
+ // or have allocatable components, we need to make sure
+ // everything is properly finalized/deallocated.
+ if (Fortran::semantics::IsFinalizable(typeSpec) ||
+ Fortran::semantics::MayRequireFinalization(typeSpec) ||
+ // We can use DerivedTypeDestroy even if finalization is not needed.
+ hlfir::mayHaveAllocatableComponent(funcType.getResults()[0])) {
auto *bldr = &converter.getFirOpBuilder();
stmtCtx.attachCleanup([bldr, loc, allocatedResult]() {
mlir::Value box = bldr->createBox(loc, *allocatedResult);
fir::runtime::genDerivedTypeDestroy(*bldr, loc, box);
});
- cleanupWithDestroy = true;
}
}
}
- allocatedResult->match(
- [&](const fir::MutableBoxValue &box) {
- if (box.isAllocatable() && !cleanupWithDestroy) {
- // 9.7.3.2 point 4. Deallocate allocatable results. Note that
- // finalization was done independently by calling
- // genDerivedTypeDestroy above and is not triggered by this inline
- // deallocation.
- fir::FirOpBuilder *bldr = &converter.getFirOpBuilder();
- stmtCtx.attachCleanup([bldr, loc, box]() {
- fir::factory::genFreememIfAllocated(*bldr, loc, box);
- });
- }
- },
- [](const auto &) {});
return *allocatedResult;
}
diff --git a/flang/test/Lower/HLFIR/function-return-destroy.f90 b/flang/test/Lower/HLFIR/function-return-destroy.f90
new file mode 100644
index 000000000000000..4663dc57e0457f5
--- /dev/null
+++ b/flang/test/Lower/HLFIR/function-return-destroy.f90
@@ -0,0 +1,197 @@
+! RUN: bbc -emit-hlfir -polymorphic-type %s -o - -I nowhere | FileCheck %s
+
+module types
+ type t1
+ real :: x
+ end type t1
+ type t2
+ real, allocatable :: x
+ end type t2
+ type t3
+ real, pointer :: p
+ end type t3
+ type t4
+ type(t1) :: c
+ end type t4
+ type t5
+ type(t2) :: c
+ end type t5
+ type t6
+ contains
+ final :: finalize_t6
+ end type t6
+ type, extends(t1) :: t7
+ end type t7
+ type, extends(t2) :: t8
+ end type t8
+ type, extends(t6) :: t9
+ end type t9
+contains
+ subroutine finalize_t6(x)
+ type(t6), intent(inout) :: x
+ end subroutine finalize_t6
+end module types
+
+subroutine test1
+ use types
+ interface
+ function ret_type_t1
+ use types
+ type(t1) :: ret_type_t1
+ end function ret_type_t1
+ end interface
+ type(t1) :: x
+ x = ret_type_t1()
+end subroutine test1
+! CHECK-LABEL: func.func @_QPtest1() {
+! CHECK-NOT: fir.call{{.*}}Destroy
+
+subroutine test1a
+ use types
+ interface
+ function ret_type_t1a
+ use types
+ type(t1), allocatable :: ret_type_t1a
+ end function ret_type_t1a
+ end interface
+ type(t1), allocatable :: x
+ x = ret_type_t1a()
+end subroutine test1a
+! CHECK-LABEL: func.func @_QPtest1a() {
+! CHECK-NOT: fir.call{{.*}}Destroy
+! CHECK: fir.if %{{.*}} {
+! CHECK-NEXT: fir.freemem %{{.*}} : !fir.heap<!fir.type<_QMtypesTt1{x:f32}>>
+! CHECK-NOT: fir.call{{.*}}Destroy
+! CHECK: fir.if %{{.*}} {
+! CHECK: fir.call @_FortranAAllocatableDeallocate({{.*}}) fastmath<contract> : (!fir.ref<!fir.box<none>>, i1, !fir.box<none>, !fir.ref<i8>, i32) -> i32
+! CHECK-NOT: fir.call{{.*}}Destroy
+
+subroutine test1c
+ use types
+ interface
+ function ret_class_t1
+ use types
+ class(t1), allocatable :: ret_class_t1
+ end function ret_class_t1
+ end interface
+ type(t1) :: x
+ x = ret_class_t1()
+end subroutine test1c
+! CHECK-LABEL: func.func @_QPtest1c() {
+! CHECK: fir.call @_FortranADestroy
+! CHECK: fir.if %{{.*}} {
+! CHECK-NEXT: fir.freemem %{{.*}} : !fir.heap<!fir.type<_QMtypesTt1{x:f32}>>
+
+subroutine test2
+ use types
+ interface
+ function ret_type_t2
+ use types
+ type(t2) :: ret_type_t2
+ end function ret_type_t2
+ end interface
+ type(t2) :: x
+ x = ret_type_t2()
+end subroutine test2
+! CHECK-LABEL: func.func @_QPtest2() {
+! CHECK: fir.call @_FortranADestroy
+
+subroutine test3
+ use types
+ interface
+ function ret_type_t3
+ use types
+ type(t3) :: ret_type_t3
+ end function ret_type_t3
+ end interface
+ type(t3) :: x
+ x = ret_type_t3()
+end subroutine test3
+! CHECK-LABEL: func.func @_QPtest3() {
+! CHECK-NOT: fir.call{{.*}}Destroy
+
+subroutine test4
+ use types
+ interface
+ function ret_type_t4
+ use types
+ type(t4) :: ret_type_t4
+ end function ret_type_t4
+ end interface
+ type(t4) :: x
+ x = ret_type_t4()
+end subroutine test4
+! CHECK-LABEL: func.func @_QPtest4() {
+! CHECK-NOT: fir.call{{.*}}Destroy
+
+subroutine test5
+ use types
+ interface
+ function ret_type_t5
+ use types
+ type(t5) :: ret_type_t5
+ end function ret_type_t5
+ end interface
+ type(t5) :: x
+ x = ret_type_t5()
+end subroutine test5
+! CHECK-LABEL: func.func @_QPtest5() {
+! CHECK: fir.call @_FortranADestroy
+
+subroutine test6
+ use types
+ interface
+ function ret_type_t6
+ use types
+ type(t6) :: ret_type_t6
+ end function ret_type_t6
+ end interface
+ type(t6) :: x
+ x = ret_type_t6()
+end subroutine test6
+! CHECK-LABEL: func.func @_QPtest6() {
+! CHECK: fir.call @_FortranADestroy
+! CHECK: fir.call @_FortranADestroy
+
+subroutine test7
+ use types
+ interface
+ function ret_type_t7
+ use types
+ type(t7) :: ret_type_t7
+ end function ret_type_t7
+ end interface
+ type(t7) :: x
+ x = ret_type_t7()
+end subroutine test7
+! CHECK-LABEL: func.func @_QPtest7() {
+! CHECK-NOT: fir.call{{.*}}Destroy
+
+subroutine test8
+ use types
+ interface
+ function ret_type_t8
+ use types
+ type(t8) :: ret_type_t8
+ end function ret_type_t8
+ end interface
+ type(t8) :: x
+ x = ret_type_t8()
+end subroutine test8
+! CHECK-LABEL: func.func @_QPtest8() {
+! CHECK: fir.call @_FortranADestroy
+
+subroutine test9
+ use types
+ interface
+ function ret_type_t9
+ use types
+ type(t9) :: ret_type_t9
+ end function ret_type_t9
+ end interface
+ type(t9) :: x
+ x = ret_type_t9()
+end subroutine test9
+! CHECK-LABEL: func.func @_QPtest9() {
+! CHECK: fir.call @_FortranADestroy
+! CHECK: fir.call @_FortranADestroy
More information about the flang-commits
mailing list