[flang] Avoid double finalization when intrinsic assignment is done in the runtime

[clementval]

Summary

genRecordAssignment is emitting code to call Assign in the runtime for some cases.
In these cases, the finalization is done by the runtime so we do not need to do it in
a separate cal to avoid multiple finalization..
Also refactor the code in Bridge so the actual finalization of allocatable
is done before any reallocation. We might need to push this into ReallocIfNeeded.
It is not clear if the allocatable lhs needs to be finalized in any cases or only if it is
reallocated.

[clementval]

Add tests for func return

[jeanPerier]

Other than my question, LGTM.

flang/lib/Lower/Bridge.cpp

2821

Why ruling out the left hand side function result case?

[clementval]

flang/lib/Lower/Bridge.cpp

2821

I guess this is debatable.

In this case you would have the f finalized

type :: t
  integer :: a
contains
 final :: finalize
end type
type(t) function f(n)
 integer, intent(in) :: n
 f = t(n)
end function

and if you write it like that you don't obviously

type(t) function f(n)
 integer, intent(in) :: n
 f%a = n
end function

Is the func result part of 7.5.6.3 point 1. I guess since there is mention of func result we should treat it as any other variable. What do you think?

[jeanPerier]

flang/lib/Lower/Bridge.cpp

2821

Thanks for the explanation. Reading at the standard, I would expect f to be finalized before the assignment. It fits in the point 1 (it's a normal variable that can be read/written several times inside the function).

I think this would happen anyway if t is a type with allocatable components where we always use genAssign to deal with the assignment. Then the finalizer would be called in genAssign.

[clementval]

Keep finalizing function result

flang/lib/Lower/Bridge.cpp

2821

Let's keep finalization for function result. We can revise this in case it should not.

flang/include/flang/Optimizer/Builder/FIRBuilder.h

 #include "mlir/IR/Builders.h"
 #include "mlir/IR/BuiltinOps.h"
 #include "llvm/ADT/DenseMap.h"
 #include <optional>
 
 namespace fir {
 class AbstractArrayBox;
 class ExtendedValue;
+class MutableBoxValue;
 class BoxValue;
 
 //===----------------------------------------------------------------------===//
 // FirOpBuilder
 //===----------------------------------------------------------------------===//
 
 /// Extends the MLIR OpBuilder to provide methods for building common FIR
 /// patterns.

 void genScalarAssignment(fir::FirOpBuilder &builder, mlir::Location loc,
                          const fir::ExtendedValue &lhs,
                          const fir::ExtendedValue &rhs);
 /// Assign \p rhs to \p lhs. Both \p rhs and \p lhs must be scalar derived
 /// types. The assignment follows Fortran intrinsic assignment semantic for
 /// derived types (10.2.1.3 point 13).
 void genRecordAssignment(fir::FirOpBuilder &builder, mlir::Location loc,
                          const fir::ExtendedValue &lhs,
-                         const fir::ExtendedValue &rhs);
+                         const fir::ExtendedValue &rhs,
+                         bool needFinalization = false);
 
 /// Builds and returns the type of a ragged array header used to cache mask
 /// evaluations. RaggedArrayHeader is defined in
 /// flang/include/flang/Runtime/ragged.h.
 mlir::TupleType getRaggedArrayHeaderType(fir::FirOpBuilder &builder);
 
 /// Generate the, possibly dynamic, LEN of a CHARACTER. \p arrLoad determines
 /// the base array. After applying \p path, the result must be a reference to a

flang/lib/Lower/Bridge.cpp

std::visit(
               fir::ExtendedValue rhs = isNumericScalar
                                            ? genExprValue(assign.rhs, stmtCtx)
                                            : genExprAddr(assign.rhs, stmtCtx);
               const bool lhsIsWholeAllocatable =
                   Fortran::lower::isWholeAllocatable(assign.lhs);
               std::optional<fir::factory::MutableBoxReallocation> lhsRealloc;
               std::optional<fir::MutableBoxValue> lhsMutableBox;
 
-              // Finalize LHS on intrinsic assignment.
-              if (lhsType->IsPolymorphic() ||
-                  lhsType->IsUnlimitedPolymorphic() ||
+              // Set flag to know if the LHS needs finalization. Polymorphic,
+              // unlimited polymorphic assignment will be done with genAssign.
+              // Assign runtime function performs the finalization.
+              bool needFinalization = !lhsType->IsPolymorphic() &&
+                                      !lhsType->IsUnlimitedPolymorphic() &&
                                       (isDerivedCategory(lhsType->category()) &&
                                        Fortran::semantics::IsFinalizable(
-                       lhsType->GetDerivedTypeSpec()))) {
+                                           lhsType->GetDerivedTypeSpec()));
+
+              auto lhs = [&]() -> fir::ExtendedValue {
                 if (lhsIsWholeAllocatable) {
                   lhsMutableBox = genExprMutableBox(loc, assign.lhs);
+                  // Finalize if needed.
+                  if (needFinalization) {
                     mlir::Value isAllocated =
                         fir::factory::genIsAllocatedOrAssociatedTest(
                             *builder, loc, *lhsMutableBox);
                     builder->genIfThen(loc, isAllocated)
                         .genThen([&]() {
                           fir::runtime::genDerivedTypeDestroy(
                               *builder, loc, fir::getBase(*lhsMutableBox));
                         })
                         .end();
-                } else {
-                  fir::ExtendedValue exv = genExprBox(loc, assign.lhs, stmtCtx);
-                  fir::runtime::genDerivedTypeDestroy(*builder, loc,
-                                                      fir::getBase(exv));
-                }
+                    needFinalization = false;
                   }
 
-              auto lhs = [&]() -> fir::ExtendedValue {
-                if (lhsIsWholeAllocatable) {
-                  lhsMutableBox = genExprMutableBox(loc, assign.lhs);
                   llvm::SmallVector<mlir::Value> lengthParams;
                   if (const fir::CharBoxValue *charBox = rhs.getCharBox())
                     lengthParams.push_back(charBox->getLen());
                   else if (fir::isDerivedWithLenParameters(rhs))
                     TODO(loc, "assignment to derived type allocatable with "
                               "LEN parameters");
                   lhsRealloc = fir::factory::genReallocIfNeeded(
                       *builder, loc, *lhsMutableBox,
std::visit(
                 builder->create<fir::StoreOp>(loc, cast, addr);
               } else if (isCharacterCategory(lhsType->category())) {
                 // Fortran 2018 10.2.1.3 p10 and p11
                 fir::factory::CharacterExprHelper{*builder, loc}.createAssign(
                     lhs, rhs);
               } else if (isDerivedCategory(lhsType->category())) {
                 // Fortran 2018 10.2.1.3 p13 and p14
                 // Recursively gen an assignment on each element pair.
-                fir::factory::genRecordAssignment(*builder, loc, lhs, rhs);
+                fir::factory::genRecordAssignment(*builder, loc, lhs, rhs,
+                                                  needFinalization);
               } else {
                 llvm_unreachable("unknown category");
               }
               if (lhsIsWholeAllocatable) {
                 assert(lhsRealloc.has_value());
                 fir::factory::finalizeRealloc(*builder, loc, *lhsMutableBox,
                                               /*lbounds=*/std::nullopt,
                                               /*takeLboundsIfRealloc=*/false,

flang/lib/Optimizer/Builder/FIRBuilder.cpp

 //===-- FIRBuilder.cpp ----------------------------------------------------===//
 //
 // Part of the LLVM Project, under the Apache License v2.0 with LLVM Exceptions.
 // See https://llvm.org/LICENSE.txt for license information.
 // SPDX-License-Identifier: Apache-2.0 WITH LLVM-exception
 //
 //===----------------------------------------------------------------------===//
 
 #include "flang/Optimizer/Builder/FIRBuilder.h"
 #include "flang/Optimizer/Builder/BoxValue.h"
 #include "flang/Optimizer/Builder/Character.h"
 #include "flang/Optimizer/Builder/Complex.h"
 #include "flang/Optimizer/Builder/MutableBox.h"
 #include "flang/Optimizer/Builder/Runtime/Assign.h"
+#include "flang/Optimizer/Builder/Runtime/Derived.h"
 #include "flang/Optimizer/Builder/Todo.h"
 #include "flang/Optimizer/Dialect/FIRAttr.h"
 #include "flang/Optimizer/Dialect/FIROpsSupport.h"
 #include "flang/Optimizer/Support/FatalError.h"
 #include "flang/Optimizer/Support/InternalNames.h"
 #include "mlir/Dialect/OpenMP/OpenMPDialect.h"
 #include "llvm/ADT/ArrayRef.h"
 #include "llvm/ADT/StringExtras.h"
static bool recordTypeCanBeMemCopied(fir::RecordType recordType) {
   // Constant size components without user defined assignment and pointers can
   // be memcopied.
   return true;
 }
 
 void fir::factory::genRecordAssignment(fir::FirOpBuilder &builder,
                                        mlir::Location loc,
                                        const fir::ExtendedValue &lhs,
-                                       const fir::ExtendedValue &rhs) {
+                                       const fir::ExtendedValue &rhs,
+                                       bool needFinalization) {
   assert(lhs.rank() == 0 && rhs.rank() == 0 && "assume scalar assignment");
   auto baseTy = fir::dyn_cast_ptrOrBoxEleTy(fir::getBase(lhs).getType());
   assert(baseTy && "must be a memory type");
   // Box operands may be polymorphic, it is not entirely clear from 10.2.1.3
   // if the assignment is performed on the dynamic of declared type. Use the
   // runtime assuming it is performed on the dynamic type.
   bool hasBoxOperands = fir::getBase(lhs).getType().isa<fir::BaseBoxType>() ||
                         fir::getBase(rhs).getType().isa<fir::BaseBoxType>();
   auto recTy = baseTy.dyn_cast<fir::RecordType>();
   assert(recTy && "must be a record type");
   if (hasBoxOperands || !recordTypeCanBeMemCopied(recTy)) {
     auto to = fir::getBase(builder.createBox(loc, lhs));
     auto from = fir::getBase(builder.createBox(loc, rhs));
     // The runtime entry point may modify the LHS descriptor if it is
     // an allocatable. Allocatable assignment is handle elsewhere in lowering,
     // so just create a fir.ref<fir.box<>> from the fir.box to comply with the
     // runtime interface, but assume the fir.box is unchanged.
     // TODO: does this holds true with polymorphic entities ?
     auto toMutableBox = builder.createTemporary(loc, to.getType());
     builder.create<fir::StoreOp>(loc, to, toMutableBox);
     fir::runtime::genAssign(builder, loc, toMutableBox, from);
     return;
   }
+
+  // Finalize LHS on intrinsic assignment.
+  if (needFinalization) {
+    mlir::Value box = builder.createBox(loc, lhs);
+    fir::runtime::genDerivedTypeDestroy(builder, loc, box);
+  }
+
   // Otherwise, the derived type has compile time constant size and for which
   // the component by component assignment can be replaced by a memory copy.
   // Since we do not know the size of the derived type in lowering, do a
   // component by component assignment. Note that a single fir.load/fir.store
   // could be used on "small" record types, but as the type size grows, this
   // leads to issues in LLVM (long compile times, long IR files, and even
   // asserts at some point). Since there is no good size boundary, just always
   // use component by component assignment here.

flang/test/Lower/derived-type-finalization.f90

 ! Test derived type finalization
 ! RUN: bbc -polymorphic-type -emit-fir %s -o - | FileCheck %s
 
 ! Missing tests:
 ! - finalization within BLOCK construct
 
 module derived_type_finalization
 
   type :: t1
     integer :: a
   contains
     final :: t1_final
   end type
 
+  type :: t2
+    integer, allocatable, dimension(:) :: a
+  contains
+    final :: t2_final
+  end type
+
+  type :: t3
+    type(t2) :: t
+  end type
+
 contains
 
   subroutine t1_final(this)
     type(t1) :: this
   end subroutine
 
+  subroutine t2_final(this)
+    type(t2) :: this
+  end subroutine
+
   ! 7.5.6.3 point 1. Finalization of LHS.
   subroutine test_lhs()
     type(t1) :: lhs, rhs
     lhs = rhs
   end subroutine
 
   subroutine test_lhs_allocatable()
     type(t1), allocatable :: lhs

 ! CHECK: %{{.*}} = fir.call @_FortranAioBeginExternalListOutput
 ! CHECK: %[[RES:.*]] = fir.call @_QMderived_type_finalizationPget_t1(%{{.*}}) {{.*}} : (!fir.ref<i32>) -> !fir.box<!fir.ptr<!fir.type<_QMderived_type_finalizationTt1{a:i32}>>>
 ! CHECK: fir.save_result %[[RES]] to %[[TMP]] : !fir.box<!fir.ptr<!fir.type<_QMderived_type_finalizationTt1{a:i32}>>>, !fir.ref<!fir.box<!fir.ptr<!fir.type<_QMderived_type_finalizationTt1{a:i32}>>>>
 ! CHECK: %{{.*}} = fir.call @_FortranAioOutputDescriptor
 ! CHECK-NOT: %{{.*}} = fir.call @_FortranADestroy
 ! CHECK: %{{.*}} = fir.call @_FortranAioEndIoStatement
 ! CHECK: return
 
+  subroutine test_avoid_double_finalization(a)
+    type(t3), intent(inout) :: a
+    type(t3)                :: b
+    b = a
+  end subroutine
+
+! CHECK-LABEL: func.func @_QMderived_type_finalizationPtest_avoid_double_finalization(
+! CHECK: fir.call @_FortranAInitialize(
+! CHECK-NOT: %{{.*}} = fir.call @_FortranADestroy
+! CHECK: %{{.*}} = fir.call @_FortranAAssign(
+! CHECK: %{{.*}} = fir.call @_FortranADestroy(
+
+  function no_func_ret_finalize() result(ty)
+    type(t1) :: ty
+    ty = t1(10)
+  end function
+
+! CHECK-LABEL: func.func @_QMderived_type_finalizationPno_func_ret_finalize() -> !fir.type<_QMderived_type_finalizationTt1{a:i32}> {
+! CHECK: %{{.*}} = fir.call @_FortranADestroy
+! CHECK: return %{{.*}} : !fir.type<_QMderived_type_finalizationTt1{a:i32}>
+
 end module
 
 program p
   use derived_type_finalization
   type(t1) :: t
   if (t%a == 10) return
   print *, 'end of program'
 end program