[flang] derived-type finalization

[clementval]

Summary

This patch implements the derived-type finalization for
monomorphic and polymorphic derived-type.

The finalization is done through a call to the Destroy
runtime function so the allocatable component object are also
finalized correctly when needed. It would be possible to finalize
monomorphic derived-type with non finalizable component with a
direct call to their finalize subroutine.

7.5.6.3 point 1: LHS nonallocatable object and LHS allocatable
object finalization. Done with call to Destroy for monomorphic
derived-type and through Assign for polymorphic entities.

7.5.6.3 point 2: Done within the deallocation calls.

7.5.6.3 point 3: A function context is added to the bridge to
attach finalization that need to happen on function/subroutine
exit.

7.5.6.3 point 4: BLOCK construct not yet implemented.

7.5.6.3 point 5/6: Finalization attach to the stmtCtx in a
similar way than 9.7.3.2 point 4.

7.5.6.3 point 7: INTENT(OUT) finalization done with a
call to Destroy runtime function call.

This patch passes 9/10 tests in the proposed test-suite
https://github.com/llvm/llvm-test-suite/pull/13

• The case with BLOCK construct will be implemented later when BLOCK are implemented upstream.

• Automatic deallocation is not yet implemented. Finalization triggered by automatic deallocation is then not triggered.

[clementval]

fix test

[jeanPerier]

Other than my comment about IsSaved and about the assignment case, this looks good to me.

flang/lib/Lower/Bridge.cpp

2815

I won't push you to deal with this now because I think you would have a better time doing this with HLFIR, but I do not think it is OK to destroy the lhs at that point in case the rhs overlaps/is the same as the lhs.
I guess this overlap scenario is even more relevant in the array assignment case (which I do not think this patch is covering since I think the code for array assignment is doing an early exit with genArrayAssignment).

In HLFIR, I think the solution will be to add a finalize optional unit attribute to hlfir::assign operation and to insert the lhs destroy after the rhs temporization if there is any possible aliasing. I am OK with leaving this a TODO in the current lowering for now.

By the way, do you know if it is possible to use assignments that require LHS finalization inside a FORALL ?

flang/lib/Lower/ConvertVariable.cpp

650

I think Saved objects may need to be excluded here. Point 3 sayes: "[...] before it would become undefined due to execution of a RETURN", but saved object do not become undefined with the execution of a RETURN. Also see NOTE 1 in "7.5.6.4" : "A nonpointer, nonallocatable object that has the SAVE attribute is never finalized as a direct consequence of the execution of a RETURN or END statement."

[clementval]

flang/lib/Lower/Bridge.cpp

2815

Good point indeed. I'll add a TODO.

I completely forgot the genArrayAssignment even it was under my radar.

I did not see any restriction regarding FORALL beside that the FINAL subroutine must be PURE.

flang/lib/Lower/ConvertVariable.cpp

650

Good catch. I'll update that.

[PeteSteinfeld]

Aside from the one nit, all builds and tests correctly and looks good.

flang/lib/Lower/ConvertCall.cpp

380–381

I didn't understand this sentence. Did you mean to say "Check of the derived-type is finalizable because it is a monomorphic derived-type."?

[clementval]

Add todo + IsSaved

flang/include/flang/Lower/AbstractConverter.h

public:
   virtual mlir::ModuleOp &getModuleOp() = 0;
   /// Get the MLIRContext
   virtual mlir::MLIRContext &getMLIRContext() = 0;
   /// Unique a symbol
   virtual std::string mangleName(const Fortran::semantics::Symbol &) = 0;
   /// Get the KindMap.
   virtual const fir::KindMapping &getKindMap() = 0;
 
+  virtual Fortran::lower::StatementContext &getFctCtx() = 0;
+
   AbstractConverter(const Fortran::lower::LoweringOptions &loweringOptions)
       : loweringOptions(loweringOptions) {}
   virtual ~AbstractConverter() = default;
 
   //===--------------------------------------------------------------------===//
   // Miscellaneous
   //===--------------------------------------------------------------------===//
 

flang/include/flang/Lower/Bridge.h

 
 #ifndef FORTRAN_LOWER_BRIDGE_H
 #define FORTRAN_LOWER_BRIDGE_H
 
 #include "flang/Common/Fortran.h"
 #include "flang/Lower/AbstractConverter.h"
 #include "flang/Lower/EnvironmentDefault.h"
 #include "flang/Lower/LoweringOptions.h"
+#include "flang/Lower/StatementContext.h"
 #include "flang/Optimizer/Builder/FIRBuilder.h"
 #include "flang/Optimizer/Support/KindMapping.h"
 #include "mlir/IR/BuiltinOps.h"
 
 namespace Fortran {
 namespace common {
 class IntrinsicTypeDefaultKinds;
 } // namespace common
public:
 
   /// Create a folding context. Careful: this is very expensive.
   Fortran::evaluate::FoldingContext createFoldingContext() const;
 
   Fortran::semantics::SemanticsContext &getSemanticsContext() const {
     return semanticsContext;
   }
 
+  Fortran::lower::StatementContext &fctCtx() { return functionContext; }
+
   bool validModule() { return getModule(); }
 
   //===--------------------------------------------------------------------===//
   // Perform the creation of an mlir::ModuleOp
   //===--------------------------------------------------------------------===//
 
   /// Read in an MLIR input file rather than lowering Fortran sources.
   /// This is intended to be used for testing.
explicit LoweringBridge(
       const Fortran::parser::AllCookedSources &cooked, llvm::StringRef triple,
       fir::KindMapping &kindMap,
       const Fortran::lower::LoweringOptions &loweringOptions,
       const std::vector<Fortran::lower::EnvironmentDefault> &envDefaults);
   LoweringBridge() = delete;
   LoweringBridge(const LoweringBridge &) = delete;
 
   Fortran::semantics::SemanticsContext &semanticsContext;
+  Fortran::lower::StatementContext functionContext;
   const Fortran::common::IntrinsicTypeDefaultKinds &defaultKinds;
   const Fortran::evaluate::IntrinsicProcTable &intrinsics;
   const Fortran::evaluate::TargetCharacteristics &targetCharacteristics;
   const Fortran::parser::AllCookedSources *cooked;
   mlir::MLIRContext &context;
   std::unique_ptr<mlir::ModuleOp> module;
   fir::KindMapping &kindMap;
   const Fortran::lower::LoweringOptions &loweringOptions;
   const std::vector<Fortran::lower::EnvironmentDefault> &envDefaults;
 };
 
 } // namespace lower
 } // namespace Fortran
 
 #endif // FORTRAN_LOWER_BRIDGE_H

flang/include/flang/Semantics/tools.h

inline bool IsAssumedSizeArray(const Symbol &symbol) {
   return details && details->IsAssumedSize();
 }
 bool IsAssumedLengthCharacter(const Symbol &);
 bool IsExternal(const Symbol &);
 bool IsModuleProcedure(const Symbol &);
 bool HasCoarray(const parser::Expr &);
 bool IsAssumedType(const Symbol &);
 bool IsPolymorphic(const Symbol &);
+bool IsUnlimitedPolymorphic(const Symbol &);
 bool IsPolymorphicAllocatable(const Symbol &);
 
 // Return an error if a symbol is not accessible from a scope
 std::optional<parser::MessageFormattedText> CheckAccessibleSymbol(
     const semantics::Scope &, const Symbol &);
 
 // Analysis of image control statements
 bool IsImageControlStmt(const parser::ExecutableConstruct &);

flang/lib/Lower/Bridge.cpp

public:
   mangleName(const Fortran::semantics::Symbol &symbol) override final {
     return Fortran::lower::mangle::mangleName(symbol);
   }
 
   const fir::KindMapping &getKindMap() override final {
     return bridge.getKindMap();
   }
 
+  Fortran::lower::StatementContext &getFctCtx() override final {
+    return bridge.fctCtx();
+  }
+
   mlir::Value hostAssocTupleValue() override final { return hostAssocTuple; }
 
   /// Record a binding for the ssa-value of the tuple for this function.
   void bindHostAssocTuple(mlir::Value val) override final {
     assert(!hostAssocTuple && val);
     hostAssocTuple = val;
   }
 
private:
   //===--------------------------------------------------------------------===//
   // Termination of symbolically referenced execution units
   //===--------------------------------------------------------------------===//
 
   /// END of program
   ///
   /// Generate the cleanup block before the program exits
   void genExitRoutine() {
+
     if (blockIsUnterminated())
       builder->create<mlir::func::ReturnOp>(toLocation());
   }
   void genFIR(const Fortran::parser::EndProgramStmt &) { genExitRoutine(); }
 
   /// END of procedure-like constructs
   ///
   /// Generate the cleanup block before the procedure exits
mlir::Value resultVal = resultSymBox.match(
           mlir::Type resultRefType = builder->getRefType(resultType);
           // A function with multiple entry points returning different types
           // tags all result variables with one of the largest types to allow
           // them to share the same storage.  Convert this to the actual type.
           if (resultRef.getType() != resultRefType)
             resultRef = builder->createConvert(loc, resultRefType, resultRef);
           return builder->create<fir::LoadOp>(loc, resultRef);
         });
+    bridge.fctCtx().finalizeAndPop();
     builder->create<mlir::func::ReturnOp>(loc, resultVal);
   }
 
   /// Get the return value of a call to \p symbol, which is a subroutine entry
   /// point that has alternative return specifiers.
   const mlir::Value
   getAltReturnResult(const Fortran::semantics::Symbol &symbol) {
     assert(Fortran::semantics::HasAlternateReturns(symbol) &&
if (mlir::Block *finalBlock = funit.finalBlock) {
       // Set insertion point to final block.
       builder->setInsertionPoint(finalBlock, finalBlock->end());
     }
     if (Fortran::semantics::IsFunction(symbol)) {
       genReturnSymbol(symbol);
     } else if (Fortran::semantics::HasAlternateReturns(symbol)) {
       mlir::Value retval = builder->create<fir::LoadOp>(
           toLocation(), getAltReturnResult(symbol));
+      bridge.fctCtx().finalizeAndPop();
       builder->create<mlir::func::ReturnOp>(toLocation(), retval);
     } else {
+      bridge.fctCtx().finalizeAndPop();
       genExitRoutine();
     }
   }
 
   //
   // Statements that have control-flow semantics
   //
 
std::visit(
                   Fortran::evaluate::GetLastSymbol(assign.lhs);
 
               if (!sym)
                 TODO(loc, "assignment to pointer result of function reference");
 
               std::optional<Fortran::evaluate::DynamicType> lhsType =
                   assign.lhs.GetType();
               assert(lhsType && "lhs cannot be typeless");
+
               // Assignment to polymorphic allocatables may require changing the
               // variable dynamic type (See Fortran 2018 10.2.1.3 p3).
-              if (lhsType->IsPolymorphic() &&
+              if ((lhsType->IsPolymorphic() ||
+                   lhsType->IsUnlimitedPolymorphic()) &&
                   Fortran::lower::isWholeAllocatable(assign.lhs)) {
                 mlir::Value lhs = genExprMutableBox(loc, assign.lhs).getAddr();
                 mlir::Value rhs =
                     fir::getBase(genExprBox(loc, assign.rhs, stmtCtx));
                 fir::runtime::genAssign(*builder, loc, lhs, rhs);
                 return;
               }
 
               // Note: No ad-hoc handling for pointers is required here. The
               // target will be assigned as per 2018 10.2.1.3 p2. genExprAddr
               // on a pointer returns the target address and not the address of
               // the pointer variable.
 
               if (assign.lhs.Rank() > 0 || explicitIterationSpace()) {
+                if (isDerivedCategory(lhsType->category()) &&
+                    Fortran::semantics::IsFinalizable(
+                        lhsType->GetDerivedTypeSpec()))
+                  TODO(loc, "derived-type finalization with array assignment");
                 // Array assignment
                 // See Fortran 2018 10.2.1.3 p5, p6, and p7
                 genArrayAssignment(assign, stmtCtx);
                 return;
               }
 
               // Scalar assignment
               const bool isNumericScalar =
                   isNumericScalarCategory(lhsType->category());
               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() ||
+                  (isDerivedCategory(lhsType->category()) &&
+                   Fortran::semantics::IsFinalizable(
+                       lhsType->GetDerivedTypeSpec()))) {
+                if (lhsIsWholeAllocatable) {
+                  lhsMutableBox = genExprMutableBox(loc, assign.lhs);
+                  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));
+                }
+              }
+
               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 "
if (var.hasSymbol() &&
         var.getSymbol().test(
             Fortran::semantics::Symbol::Flag::OmpThreadprivate))
       Fortran::lower::genThreadprivateOp(*this, var);
   }
 
   /// Start translation of a function.
   void startNewFunction(Fortran::lower::pft::FunctionLikeUnit &funit) {
     assert(!builder && "expected nullptr");
+    bridge.fctCtx().pushScope();
     const Fortran::semantics::Scope &scope = funit.getScope();
     LLVM_DEBUG(llvm::dbgs() << "\n[bridge - startNewFunction]";
                if (auto *sym = scope.symbol()) llvm::dbgs() << " " << *sym;
                llvm::dbgs() << "\n");
     Fortran::lower::CalleeInterface callee(funit, *this);
     mlir::func::FuncOp func = callee.addEntryBlockAndMapArguments();
     builder = new fir::FirOpBuilder(func, bridge.getKindMap());
     assert(builder && "FirOpBuilder did not instantiate");
#endif
   void maybeStartBlock(mlir::Block *newBlock) {
     if (newBlock)
       startBlock(newBlock);
   }
 
   /// Finish translation of a function.
   void endNewFunction(Fortran::lower::pft::FunctionLikeUnit &funit) {
     setCurrentPosition(Fortran::lower::pft::stmtSourceLoc(funit.endStmt));
-    if (funit.isMainProgram())
+    if (funit.isMainProgram()) {
+      bridge.fctCtx().finalizeAndPop();
       genExitRoutine();
-    else
+    } else {
       genFIRProcedureExit(funit, funit.getSubprogramSymbol());
+    }
     funit.finalBlock = nullptr;
     LLVM_DEBUG(llvm::dbgs() << "\n[bridge - endNewFunction";
                if (auto *sym = funit.scope->symbol()) llvm::dbgs()
                << " " << sym->name();
                llvm::dbgs() << "] generated IR:\n\n"
                             << *builder->getFunction() << '\n');
     // Eliminate dead code as a prerequisite to calling other IR passes.
     // FIXME: This simplification should happen in a normal pass, not here.

flang/lib/Lower/ConvertCall.cpp

 #include "flang/Lower/IntrinsicCall.h"
 #include "flang/Lower/StatementContext.h"
 #include "flang/Lower/SymbolMap.h"
 #include "flang/Optimizer/Builder/BoxValue.h"
 #include "flang/Optimizer/Builder/Character.h"
 #include "flang/Optimizer/Builder/FIRBuilder.h"
 #include "flang/Optimizer/Builder/LowLevelIntrinsics.h"
 #include "flang/Optimizer/Builder/MutableBox.h"
+#include "flang/Optimizer/Builder/Runtime/Derived.h"
 #include "flang/Optimizer/Builder/Todo.h"
 #include "flang/Optimizer/Dialect/FIROpsSupport.h"
 #include "flang/Optimizer/HLFIR/HLFIROps.h"
 #include "llvm/Support/Debug.h"
 #include <optional>
 
 #define DEBUG_TYPE "flang-lower-expr"
 
fir::ExtendedValue Fortran::lower::genCallOpAndResult(
   if (caller.mustSaveResult()) {
     assert(allocatedResult.has_value());
     builder.create<fir::SaveResultOp>(loc, callResult,
                                       fir::getBase(*allocatedResult),
                                       arrayResultShape, resultLengths);
   }
 
   if (allocatedResult) {
+    // 7.5.6.3 point 5. Derived-type finalization.
+    // Check if the derived-type is finalizable if it is a monorphic
+    // derived-type.
+    // For polymorphic and unlimited polymorphic enities call the runtime
+    // in any cases.
+    std::optional<Fortran::evaluate::DynamicType> retTy =
+        caller.getCallDescription().proc().GetType();
+    if (retTy && (retTy->category() == Fortran::common::TypeCategory::Derived ||
+                  retTy->IsPolymorphic() || retTy->IsUnlimitedPolymorphic())) {
+      if (retTy->IsPolymorphic() || retTy->IsUnlimitedPolymorphic()) {
+        auto *bldr = &converter.getFirOpBuilder();
+        stmtCtx.attachCleanup([bldr, loc, allocatedResult]() {
+          fir::runtime::genDerivedTypeDestroy(*bldr, loc,
+                                              fir::getBase(*allocatedResult));
+        });
+      } else {
+        const Fortran::semantics::DerivedTypeSpec &typeSpec =
+            retTy->GetDerivedTypeSpec();
+        if (Fortran::semantics::IsFinalizable(typeSpec)) {
+          auto *bldr = &converter.getFirOpBuilder();
+          stmtCtx.attachCleanup([bldr, loc, allocatedResult]() {
+            mlir::Value box = bldr->createBox(loc, *allocatedResult);
+            fir::runtime::genDerivedTypeDestroy(*bldr, loc, box);
+          });
+        }
+      }
+    }
     allocatedResult->match(
         [&](const fir::MutableBoxValue &box) {
           if (box.isAllocatable()) {
             // 9.7.3.2 point 4. Finalize allocatables.
             fir::FirOpBuilder *bldr = &converter.getFirOpBuilder();
             stmtCtx.attachCleanup([bldr, loc, box]() {
               fir::factory::genFinalization(*bldr, loc, box);
             });

flang/lib/Lower/ConvertType.cpp

struct TypeBuilderImpl {
 
   mlir::Type genDerivedType(const Fortran::semantics::DerivedTypeSpec &tySpec) {
     std::vector<std::pair<std::string, mlir::Type>> ps;
     std::vector<std::pair<std::string, mlir::Type>> cs;
     const Fortran::semantics::Symbol &typeSymbol = tySpec.typeSymbol();
     if (mlir::Type ty = getTypeIfDerivedAlreadyInConstruction(typeSymbol))
       return ty;
 
-    if (Fortran::semantics::IsFinalizable(tySpec))
-      TODO(converter.genLocation(tySpec.name()), "derived type finalization");
-
     auto rec = fir::RecordType::get(context,
                                     Fortran::lower::mangle::mangleName(tySpec));
     // Maintain the stack of types for recursive references.
     derivedTypeInConstruction.emplace_back(typeSymbol, rec);
 
     // Gather the record type fields.
     // (1) The data components.
     for (const auto &field :

flang/lib/Lower/ConvertVariable.cpp

hlfir::EntityWithAttributes loweredExpr =
         Fortran::lower::convertExprToHLFIR(loc, converter, expr, symMap,
                                            context);
     return hlfir::loadTrivialScalar(loc, converter.getFirOpBuilder(),
                                     loweredExpr);
   }
   return fir::getBase(Fortran::lower::createSomeExtendedExpression(
       loc, converter, expr, symMap, context));
 }
+
 /// Does this variable have a default initialization?
 static bool hasDefaultInitialization(const Fortran::semantics::Symbol &sym) {
   if (sym.has<Fortran::semantics::ObjectEntityDetails>() && sym.size())
     if (!Fortran::semantics::IsAllocatableOrPointer(sym))
       if (const Fortran::semantics::DeclTypeSpec *declTypeSpec = sym.GetType())
         if (const Fortran::semantics::DerivedTypeSpec *derivedTypeSpec =
                 declTypeSpec->AsDerived())
           return derivedTypeSpec->HasDefaultInitialization();
   return false;
 }
 
+// Does this variable have a finalization?
+static bool hasFinalization(const Fortran::semantics::Symbol &sym) {
+  if (sym.has<Fortran::semantics::ObjectEntityDetails>() && sym.size())
+    if (const Fortran::semantics::DeclTypeSpec *declTypeSpec = sym.GetType())
+      if (const Fortran::semantics::DerivedTypeSpec *derivedTypeSpec =
+              declTypeSpec->AsDerived())
+        return Fortran::semantics::IsFinalizable(*derivedTypeSpec);
+  return false;
+}
+
 //===----------------------------------------------------------------===//
 // Global variables instantiation (not for alias and common)
 //===----------------------------------------------------------------===//
 
 /// Helper to generate expression value inside global initializer.
 static fir::ExtendedValue
 genInitializerExprValue(Fortran::lower::AbstractConverter &converter,
                         mlir::Location loc,
builder.genIfThen(loc, isPresent)
         })
         .end();
   } else {
     mlir::Value box = builder.createBox(loc, exv);
     fir::runtime::genDerivedTypeInitialize(builder, loc, box);
   }
 }
 
+/// Check whether a variable needs to be finalized according to clause 7.5.6.3
+/// point 3.
+/// Must be nonpointer, nonallocatable object that is not a dummy argument or
+/// function result.
+static bool needEndFinalization(const Fortran::lower::pft::Variable &var) {
+  if (!var.hasSymbol())
+    return false;
+  const Fortran::semantics::Symbol &sym = var.getSymbol();
+  if (!Fortran::semantics::IsPointer(sym) &&
+      !Fortran::semantics::IsAllocatable(sym) &&
+      !Fortran::semantics::IsDummy(sym) &&
+      !Fortran::semantics::IsFunctionResult(sym) &&
+      !Fortran::semantics::IsSaved(sym))
+    return hasFinalization(sym);
+  return false;
+}
+
+/// Check whether a variable needs the be finalized according to clause 7.5.6.3
+/// point 7.
+/// Must be nonpointer, nonallocatable, INTENT (OUT) dummy argument.
+static bool
+needDummyIntentoutFinalization(const Fortran::lower::pft::Variable &var) {
+  if (!var.hasSymbol())
+    return false;
+  const Fortran::semantics::Symbol &sym = var.getSymbol();
+  if (!Fortran::semantics::IsDummy(sym) ||
+      !Fortran::semantics::IsIntentOut(sym) ||
+      Fortran::semantics::IsAllocatable(sym) ||
+      Fortran::semantics::IsPointer(sym))
+    return false;
+  // Polymorphic and unlimited polymorphic intent(out) dummy argument might need
+  // finalization at runtime.
+  if (Fortran::semantics::IsPolymorphic(sym) ||
+      Fortran::semantics::IsUnlimitedPolymorphic(sym))
+    return true;
+  // Intent(out) dummies must be finalized at runtime if their type has a
+  // finalization.
+  return hasFinalization(sym);
+}
+
+/// Call default initialization runtime routine to initialize \p var.
+static void finalizeAtRuntime(Fortran::lower::AbstractConverter &converter,
+                              const Fortran::lower::pft::Variable &var,
+                              Fortran::lower::SymMap &symMap) {
+  fir::FirOpBuilder &builder = converter.getFirOpBuilder();
+  mlir::Location loc = converter.getCurrentLocation();
+  const Fortran::semantics::Symbol &sym = var.getSymbol();
+  fir::ExtendedValue exv = symMap.lookupSymbol(sym).toExtendedValue();
+  if (Fortran::semantics::IsOptional(sym)) {
+    // Only finalize if present.
+    auto isPresent = builder.create<fir::IsPresentOp>(loc, builder.getI1Type(),
+                                                      fir::getBase(exv));
+    builder.genIfThen(loc, isPresent)
+        .genThen([&]() {
+          auto box = builder.createBox(loc, exv);
+          fir::runtime::genDerivedTypeDestroy(builder, loc, box);
+        })
+        .end();
+  } else {
+    mlir::Value box = builder.createBox(loc, exv);
+    fir::runtime::genDerivedTypeDestroy(builder, loc, box);
+  }
+}
+
 // Fortran 2018 - 9.7.3.2 point 6
 // When a procedure is invoked, any allocated allocatable object that is an
 // actual argument corresponding to an INTENT(OUT) allocatable dummy argument
 // is deallocated; any allocated allocatable object that is a subobject of an
 // actual argument corresponding to an INTENT(OUT) dummy argument is
 // deallocated.
 static void deallocateIntentOut(Fortran::lower::AbstractConverter &converter,
                                 const Fortran::lower::pft::Variable &var,

 /// which its properties depend will already have been visited.
 static void instantiateLocal(Fortran::lower::AbstractConverter &converter,
                              const Fortran::lower::pft::Variable &var,
                              Fortran::lower::SymMap &symMap) {
   assert(!var.isAlias());
   Fortran::lower::StatementContext stmtCtx;
   mapSymbolAttributes(converter, var, symMap, stmtCtx);
   deallocateIntentOut(converter, var, symMap);
+  if (needDummyIntentoutFinalization(var))
+    finalizeAtRuntime(converter, var, symMap);
   if (mustBeDefaultInitializedAtRuntime(var))
     defaultInitializeAtRuntime(converter, var, symMap);
+  if (needEndFinalization(var)) {
+    auto *builder = &converter.getFirOpBuilder();
+    mlir::Location loc = converter.getCurrentLocation();
+    fir::ExtendedValue exv =
+        symMap.lookupSymbol(var.getSymbol()).toExtendedValue();
+    converter.getFctCtx().attachCleanup([builder, loc, exv]() {
+      mlir::Value box = builder->createBox(loc, exv);
+      fir::runtime::genDerivedTypeDestroy(*builder, loc, box);
+    });
+  }
 }
 
 //===----------------------------------------------------------------===//
 // Aliased (EQUIVALENCE) variables instantiation
 //===----------------------------------------------------------------===//
 
 /// Insert \p aggregateStore instance into an AggregateStoreMap.
 static void insertAggregateStore(Fortran::lower::AggregateStoreMap &storeMap,

flang/lib/Semantics/tools.cpp

 
 bool IsPolymorphic(const Symbol &symbol) {
   if (const DeclTypeSpec * type{symbol.GetType()}) {
     return type->IsPolymorphic();
   }
   return false;
 }
 
+bool IsUnlimitedPolymorphic(const Symbol &symbol) {
+  if (const DeclTypeSpec * type{symbol.GetType()}) {
+    return type->IsUnlimitedPolymorphic();
+  }
+  return false;
+}
+
 bool IsPolymorphicAllocatable(const Symbol &symbol) {
   return IsAllocatable(symbol) && IsPolymorphic(symbol);
 }
 
 std::optional<parser::MessageFormattedText> CheckAccessibleSymbol(
     const Scope &scope, const Symbol &symbol) {
   if (symbol.attrs().test(Attr::PRIVATE)) {
     if (FindModuleFileContaining(scope)) {

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
+
+contains
+
+  subroutine t1_final(this)
+    type(t1) :: 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
+    type(t1) :: rhs
+    lhs = rhs
+  end subroutine
+
+! CHECK-LABEL: func.func @_QMderived_type_finalizationPtest_lhs() {
+! CHECK: %[[LHS:.*]] = fir.alloca !fir.type<_QMderived_type_finalizationTt1{a:i32}> {bindc_name = "lhs", uniq_name = "_QMderived_type_finalizationFtest_lhsElhs"}
+! CHECK: %[[RHS:.*]] = fir.alloca !fir.type<_QMderived_type_finalizationTt1{a:i32}> {bindc_name = "rhs", uniq_name = "_QMderived_type_finalizationFtest_lhsErhs"}
+! CHECK: %[[EMBOX:.*]] = fir.embox %[[LHS]] : (!fir.ref<!fir.type<_QMderived_type_finalizationTt1{a:i32}>>) -> !fir.box<!fir.type<_QMderived_type_finalizationTt1{a:i32}>>
+! CHECK: %[[BOX_NONE:.*]] = fir.convert %[[EMBOX]] : (!fir.box<!fir.type<_QMderived_type_finalizationTt1{a:i32}>>) -> !fir.box<none>
+! CHECK: %{{.*}} = fir.call @_FortranADestroy(%[[BOX_NONE]]) {{.*}} : (!fir.box<none>) -> none
+
+! CHECK-LABEL: func.func @_QMderived_type_finalizationPtest_lhs_allocatable() {
+! CHECK: %[[LHS:.*]] = fir.alloca !fir.box<!fir.heap<!fir.type<_QMderived_type_finalizationTt1{a:i32}>>> {bindc_name = "lhs", uniq_name = "_QMderived_type_finalizationFtest_lhs_allocatableElhs"}
+! CHECK: %[[LHS_ADDR:.*]] = fir.alloca !fir.heap<!fir.type<_QMderived_type_finalizationTt1{a:i32}>> {uniq_name = "_QMderived_type_finalizationFtest_lhs_allocatableElhs.addr"}
+! CHECK: %[[RHS:.*]] = fir.alloca !fir.type<_QMderived_type_finalizationTt1{a:i32}> {bindc_name = "rhs", uniq_name = "_QMderived_type_finalizationFtest_lhs_allocatableErhs"}
+! CHECK: %[[LHS_ADDR_LOAD:.*]] = fir.load %[[LHS_ADDR]] : !fir.ref<!fir.heap<!fir.type<_QMderived_type_finalizationTt1{a:i32}>>>
+! CHECK: %[[ADDR_I64:.*]] = fir.convert %[[LHS_ADDR_LOAD]] : (!fir.heap<!fir.type<_QMderived_type_finalizationTt1{a:i32}>>) -> i64
+! CHECK: %[[C0:.*]] = arith.constant 0 : i64
+! CHECK: %[[IS_NULL:.*]] = arith.cmpi ne, %[[ADDR_I64]], %[[C0]] : i64
+! CHECK: fir.if %[[IS_NULL]] {
+! CHECK:   %[[BOX_NONE:.*]] = fir.convert %[[LHS]] : (!fir.ref<!fir.box<!fir.heap<!fir.type<_QMderived_type_finalizationTt1{a:i32}>>>>) -> !fir.box<none>
+! CHECK:   %{{.*}} = fir.call @_FortranADestroy(%[[BOX_NONE]]) {{.*}} : (!fir.box<none>) -> none
+! CHECK: }
+
+  ! 7.5.6.3 point 2. Finalization on explicit deallocation.
+  subroutine test_deallocate()
+    type(t1), allocatable :: t
+    allocate(t)
+    deallocate(t)
+  end subroutine
+
+! CHECK-LABEL: func.func @_QMderived_type_finalizationPtest_deallocate() {
+! CHECK: %[[LOCAL_T:.*]] = fir.alloca !fir.box<!fir.heap<!fir.type<_QMderived_type_finalizationTt1{a:i32}>>> {bindc_name = "t", uniq_name = "_QMderived_type_finalizationFtest_deallocateEt"}
+! CHECK: %{{.*}} = fir.call @_FortranAAllocatableAllocate
+! CHECK: %[[BOX_NONE:.*]] = fir.convert %[[LOCAL_T]] : (!fir.ref<!fir.box<!fir.heap<!fir.type<_QMderived_type_finalizationTt1{a:i32}>>>>) -> !fir.ref<!fir.box<none>>
+! CHECK: %{{.*}} = fir.call @_FortranAAllocatableDeallocate(%[[BOX_NONE]], %{{.*}}, %{{.*}}, %{{.*}}, %{{.*}}) {{.*}} : (!fir.ref<!fir.box<none>>, i1, !fir.box<none>, !fir.ref<i8>, i32) -> i32
+
+  ! 7.5.6.3 point 2. Finalization of disassociated target.
+  subroutine test_target_finalization()
+    type(t1), pointer :: p
+    allocate(p, source=t1(a=2))
+    deallocate(p)
+  end subroutine
+
+! CHECK-LABEL: func.func @_QMderived_type_finalizationPtest_target_finalization() {
+! CHECK: %[[P:.*]] = fir.alloca !fir.box<!fir.ptr<!fir.type<_QMderived_type_finalizationTt1{a:i32}>>> {bindc_name = "p", uniq_name = "_QMderived_type_finalizationFtest_target_finalizationEp"}
+! CHECK: fir.call @_FortranAInitialize
+! CHECK: fir.call @_FortranAPointerAllocateSource
+! CHECK: %[[P_BOX_NONE:.*]] = fir.convert %[[P]] : (!fir.ref<!fir.box<!fir.ptr<!fir.type<_QMderived_type_finalizationTt1{a:i32}>>>>) -> !fir.ref<!fir.box<none>>
+! CHECK: %{{.*}} = fir.call @_FortranAPointerDeallocate(%[[P_BOX_NONE]], %{{.*}}, %{{.*}}, %{{.*}}, %{{.*}}) {{.*}} : (!fir.ref<!fir.box<none>>, i1, !fir.box<none>, !fir.ref<i8>, i32) -> i32
+
+  ! 7.5.6.3 point 3. Finalize on END.
+  subroutine test_end_finalization()
+    type(t1) :: t
+  end subroutine
+
+! CHECK-LABEL: func.func @_QMderived_type_finalizationPtest_end_finalization() {
+! CHECK: %[[LOCAL_T:.*]] = fir.alloca !fir.type<_QMderived_type_finalizationTt1{a:i32}> {bindc_name = "t", uniq_name = "_QMderived_type_finalizationFtest_end_finalizationEt"}
+! CHECK: %[[EMBOX:.*]] = fir.embox %[[LOCAL_T]] : (!fir.ref<!fir.type<_QMderived_type_finalizationTt1{a:i32}>>) -> !fir.box<!fir.type<_QMderived_type_finalizationTt1{a:i32}>>
+! CHECK: %[[BOX_NONE:.*]] = fir.convert %[[EMBOX]] : (!fir.box<!fir.type<_QMderived_type_finalizationTt1{a:i32}>>) -> !fir.box<none>
+! CHECK: %{{.*}} = fir.call @_FortranADestroy(%[[BOX_NONE]]) {{.*}} : (!fir.box<none>) -> none
+! CHECK: return
+
+  ! test with multiple return.
+  subroutine test_end_finalization2(a)
+    type(t1) :: t
+    logical :: a
+    if (a) return
+    t%a = 10
+  end subroutine
+
+! CHECK-LABEL: func.func @_QMderived_type_finalizationPtest_end_finalization2(
+! CHECK-SAME: %[[A:.*]]: !fir.ref<!fir.logical<4>> {fir.bindc_name = "a"}) {
+! CHECK:   %[[T:.*]] = fir.alloca !fir.type<_QMderived_type_finalizationTt1{a:i32}> {bindc_name = "t", uniq_name = "_QMderived_type_finalizationFtest_end_finalization2Et"}
+! CHECK:   %[[LOAD_A:.*]] = fir.load %[[A]] : !fir.ref<!fir.logical<4>>
+! CHECK:   %[[CONV_A:.*]] = fir.convert %[[LOAD_A]] : (!fir.logical<4>) -> i1
+! CHECK:   cf.cond_br %[[CONV_A]], ^bb1, ^bb2
+! CHECK: ^bb1:
+! CHECK:   cf.br ^bb3
+! CHECK: ^bb2:
+! CHECK:   %[[C10:.*]] = arith.constant 10 : i32
+! CHECK:   %[[FIELD_A:.*]] = fir.field_index a, !fir.type<_QMderived_type_finalizationTt1{a:i32}>
+! CHECK:   %[[COORD_A:.*]] = fir.coordinate_of %[[T]], %[[FIELD_A]] : (!fir.ref<!fir.type<_QMderived_type_finalizationTt1{a:i32}>>, !fir.field) -> !fir.ref<i32>
+! CHECK:   fir.store %[[C10]] to %[[COORD_A]] : !fir.ref<i32>
+! CHECK:   cf.br ^bb3
+! CHECK: ^bb3:
+! CHECK:   %[[EMBOX:.*]] = fir.embox %[[T]] : (!fir.ref<!fir.type<_QMderived_type_finalizationTt1{a:i32}>>) -> !fir.box<!fir.type<_QMderived_type_finalizationTt1{a:i32}>>
+! CHECK:   %[[BOX_NONE:.*]] = fir.convert %[[EMBOX]] : (!fir.box<!fir.type<_QMderived_type_finalizationTt1{a:i32}>>) -> !fir.box<none>
+! CHECK:   %{{.*}} = fir.call @_FortranADestroy(%[[BOX_NONE]]) {{.*}} : (!fir.box<none>) -> none
+! CHECK:   return
+! CHECK: }
+
+  function ret_type() result(ty)
+    type(t1) :: ty
+  end function
+
+  ! 7.5.6.3 point 5. Finalization of a function reference on the RHS of an intrinsic assignment.
+  subroutine test_fct_ref()
+    type(t1), allocatable :: ty
+    ty = ret_type()
+  end subroutine
+
+! CHECK-LABEL: func.func @_QMderived_type_finalizationPtest_fct_ref() {
+! CHECK: %[[RESULT:.*]] = fir.alloca !fir.type<_QMderived_type_finalizationTt1{a:i32}> {bindc_name = ".result"}
+! CHECK: %[[CALL_RES:.*]] = fir.call @_QMderived_type_finalizationPret_type()
+! CHECK: fir.save_result %[[CALL_RES]] to %[[RESULT]] : !fir.type<_QMderived_type_finalizationTt1{a:i32}>, !fir.ref<!fir.type<_QMderived_type_finalizationTt1{a:i32}>>
+! CHECK: %[[EMBOX:.*]] = fir.embox %[[RESULT]] : (!fir.ref<!fir.type<_QMderived_type_finalizationTt1{a:i32}>>) -> !fir.box<!fir.type<_QMderived_type_finalizationTt1{a:i32}>>
+! CHECK: %[[BOX_NONE:.*]] = fir.convert %[[EMBOX]] : (!fir.box<!fir.type<_QMderived_type_finalizationTt1{a:i32}>>) -> !fir.box<none>
+! CHECK: %{{.*}} = fir.call @_FortranADestroy(%[[BOX_NONE]]) {{.*}} : (!fir.box<none>) -> none
+! CHECK: return
+
+  subroutine test_finalize_intent_out(t)
+    type(t1), intent(out) :: t
+  end subroutine
+
+! CHECK-LABEL: func.func @_QMderived_type_finalizationPtest_finalize_intent_out(
+! CHECK-SAME: %[[T:.*]]: !fir.ref<!fir.type<_QMderived_type_finalizationTt1{a:i32}>> {fir.bindc_name = "t"}) {
+! CHECK: %[[EMBOX:.*]] = fir.embox %[[T]] : (!fir.ref<!fir.type<_QMderived_type_finalizationTt1{a:i32}>>) -> !fir.box<!fir.type<_QMderived_type_finalizationTt1{a:i32}>>
+! CHECK: %[[BOX_NONE:.*]] = fir.convert %[[EMBOX]] : (!fir.box<!fir.type<_QMderived_type_finalizationTt1{a:i32}>>) -> !fir.box<none>
+! CHECK: %{{.*}} = fir.call @_FortranADestroy(%[[BOX_NONE]]) {{.*}}: (!fir.box<none>) -> none
+! CHECK: return
+
+end module

flang/test/Lower/polymorphic.f90

! CHECK: fir.save_result %[[RES]] to %[[RES_TMP]] : !fir.class<!fir.heap<!fir.array<?xnone>>>, !fir.ref<!fir.class<!fir.heap<!fir.array<?xnone>>>>
 
   subroutine test_unlimited_polymorphic_intentout(a)
     class(*), intent(out) :: a
   end subroutine
 
 ! CHECK-LABEL: func.func @_QMpolymorphic_testPtest_unlimited_polymorphic_intentout(
 ! CHECK-SAME: %[[ARG0:.*]]: !fir.class<none> {fir.bindc_name = "a"}) {
 ! CHECK: %[[BOX_NONE:.*]] = fir.convert %[[ARG0]] : (!fir.class<none>) -> !fir.box<none>
+! CHECK: %{{.*}} = fir.call @_FortranADestroy(%[[BOX_NONE]]) {{.*}} : (!fir.box<none>) -> none 
+! CHECK: %[[BOX_NONE:.*]] = fir.convert %[[ARG0]] : (!fir.class<none>) -> !fir.box<none>
 ! CHECK: %{{.*}} = fir.call @_FortranAInitialize(%[[BOX_NONE]], %{{.*}}, %{{.*}}) {{.*}} : (!fir.box<none>, !fir.ref<i8>, i32) -> none
 
   subroutine test_polymorphic_intentout(a)
     class(p1), intent(out) :: a
   end subroutine
 
 ! CHECK-LABEL: func.func @_QMpolymorphic_testPtest_polymorphic_intentout(
 ! CHECK-SAME: %[[ARG0:.*]]: !fir.class<!fir.type<_QMpolymorphic_testTp1{a:i32,b:i32}>> {fir.bindc_name = "a"}) {
 ! CHECK: %[[BOX_NONE:.*]] = fir.convert %[[ARG0]] : (!fir.class<!fir.type<_QMpolymorphic_testTp1{a:i32,b:i32}>>) -> !fir.box<none>
+! CHECK: %{{.*}} = fir.call @_FortranADestroy(%[[BOX_NONE]]) {{.*}} : (!fir.box<none>) -> none 
+! CHECK: %[[BOX_NONE:.*]] = fir.convert %[[ARG0]] : (!fir.class<!fir.type<_QMpolymorphic_testTp1{a:i32,b:i32}>>) -> !fir.box<none>
 ! CHECK: %{{.*}} = fir.call @_FortranAInitialize(%[[BOX_NONE]], %{{.*}}, %{{.*}}) {{.*}} : (!fir.box<none>, !fir.ref<i8>, i32) -> none
 
   subroutine rebox_up_to_record_type(p)
     class(*), allocatable, target :: p(:,:)
     type(non_extensible), pointer :: t(:,:)
     t => p
   end subroutine