[flang][hlfir] Fixed missing deallocation for components of function …

[vzakhari]

…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.

[llvmbot]

@llvm/pr-subscribers-flang-fir-hlfir

Changes

…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.

---

Full diff: https://github.com/llvm/llvm-project/pull/67768.diff

2 Files Affected:

• (modified) flang/lib/Lower/ConvertCall.cpp (+30-18)
• (added) flang/test/Lower/HLFIR/function-return-destroy.f90 (+197)

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

[jeanPerier]

LGTM, thanks

[jeanPerier]

Thanks!