[flang-commits] [flang] 97492fd - [flang] derived-type finalization
Valentin Clement via flang-commits
flang-commits at lists.llvm.org
Tue Jan 31 04:46:46 PST 2023
Author: Valentin Clement
Date: 2023-01-31T13:46:39+01:00
New Revision: 97492fd1aed56e3d041952914849d95b5ff999af
URL: https://github.com/llvm/llvm-project/commit/97492fd1aed56e3d041952914849d95b5ff999af
DIFF: https://github.com/llvm/llvm-project/commit/97492fd1aed56e3d041952914849d95b5ff999af.diff
LOG: [flang] derived-type finalization
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.
Reviewed By: jeanPerier, PeteSteinfeld
Differential Revision: https://reviews.llvm.org/D142707
Added:
flang/test/Lower/derived-type-finalization.f90
Modified:
flang/include/flang/Lower/AbstractConverter.h
flang/include/flang/Lower/Bridge.h
flang/include/flang/Semantics/tools.h
flang/lib/Lower/Bridge.cpp
flang/lib/Lower/ConvertCall.cpp
flang/lib/Lower/ConvertType.cpp
flang/lib/Lower/ConvertVariable.cpp
flang/lib/Semantics/tools.cpp
flang/test/Lower/polymorphic.f90
Removed:
################################################################################
diff --git a/flang/include/flang/Lower/AbstractConverter.h b/flang/include/flang/Lower/AbstractConverter.h
index f7529499432f..7a82c376020a 100644
--- a/flang/include/flang/Lower/AbstractConverter.h
+++ b/flang/include/flang/Lower/AbstractConverter.h
@@ -234,6 +234,8 @@ class AbstractConverter {
/// 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;
diff --git a/flang/include/flang/Lower/Bridge.h b/flang/include/flang/Lower/Bridge.h
index dabbe72fc376..6766613ebc27 100644
--- a/flang/include/flang/Lower/Bridge.h
+++ b/flang/include/flang/Lower/Bridge.h
@@ -17,6 +17,7 @@
#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"
@@ -105,6 +106,8 @@ class LoweringBridge {
return semanticsContext;
}
+ Fortran::lower::StatementContext &fctCtx() { return functionContext; }
+
bool validModule() { return getModule(); }
//===--------------------------------------------------------------------===//
@@ -134,6 +137,7 @@ class LoweringBridge {
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;
diff --git a/flang/include/flang/Semantics/tools.h b/flang/include/flang/Semantics/tools.h
index 4703f2515c43..f72373f9da5e 100644
--- a/flang/include/flang/Semantics/tools.h
+++ b/flang/include/flang/Semantics/tools.h
@@ -186,6 +186,7 @@ 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
diff --git a/flang/lib/Lower/Bridge.cpp b/flang/lib/Lower/Bridge.cpp
index 3a34db82d394..4f9848d599ef 100644
--- a/flang/lib/Lower/Bridge.cpp
+++ b/flang/lib/Lower/Bridge.cpp
@@ -734,6 +734,10 @@ class FirConverter : public Fortran::lower::AbstractConverter {
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.
@@ -942,6 +946,7 @@ class FirConverter : public Fortran::lower::AbstractConverter {
///
/// Generate the cleanup block before the program exits
void genExitRoutine() {
+
if (blockIsUnterminated())
builder->create<mlir::func::ReturnOp>(toLocation());
}
@@ -977,6 +982,7 @@ class FirConverter : public Fortran::lower::AbstractConverter {
resultRef = builder->createConvert(loc, resultRefType, resultRef);
return builder->create<fir::LoadOp>(loc, resultRef);
});
+ bridge.fctCtx().finalizeAndPop();
builder->create<mlir::func::ReturnOp>(loc, resultVal);
}
@@ -1003,8 +1009,10 @@ class FirConverter : public Fortran::lower::AbstractConverter {
} 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();
}
}
@@ -2764,9 +2772,11 @@ class FirConverter : public Fortran::lower::AbstractConverter {
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 =
@@ -2781,6 +2791,10 @@ class FirConverter : public Fortran::lower::AbstractConverter {
// 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);
@@ -2797,6 +2811,31 @@ class FirConverter : public Fortran::lower::AbstractConverter {
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);
@@ -3213,6 +3252,7 @@ class FirConverter : public Fortran::lower::AbstractConverter {
/// 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;
@@ -3397,10 +3437,12 @@ class FirConverter : public Fortran::lower::AbstractConverter {
/// 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()
diff --git a/flang/lib/Lower/ConvertCall.cpp b/flang/lib/Lower/ConvertCall.cpp
index 5d1257258ce0..a18c1ec8b7d6 100644
--- a/flang/lib/Lower/ConvertCall.cpp
+++ b/flang/lib/Lower/ConvertCall.cpp
@@ -22,6 +22,7 @@
#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"
@@ -375,6 +376,33 @@ fir::ExtendedValue Fortran::lower::genCallOpAndResult(
}
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()) {
diff --git a/flang/lib/Lower/ConvertType.cpp b/flang/lib/Lower/ConvertType.cpp
index db18553ab9a7..e8d688a042d6 100644
--- a/flang/lib/Lower/ConvertType.cpp
+++ b/flang/lib/Lower/ConvertType.cpp
@@ -302,9 +302,6 @@ struct TypeBuilderImpl {
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.
diff --git a/flang/lib/Lower/ConvertVariable.cpp b/flang/lib/Lower/ConvertVariable.cpp
index 83b56567d5f2..6434e3d4c2dd 100644
--- a/flang/lib/Lower/ConvertVariable.cpp
+++ b/flang/lib/Lower/ConvertVariable.cpp
@@ -61,6 +61,7 @@ static mlir::Value genScalarValue(Fortran::lower::AbstractConverter &converter,
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())
@@ -72,6 +73,16 @@ static bool hasDefaultInitialization(const Fortran::semantics::Symbol &sym) {
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)
//===----------------------------------------------------------------===//
@@ -625,6 +636,70 @@ defaultInitializeAtRuntime(Fortran::lower::AbstractConverter &converter,
}
}
+/// 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
@@ -697,8 +772,20 @@ static void instantiateLocal(Fortran::lower::AbstractConverter &converter,
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);
+ });
+ }
}
//===----------------------------------------------------------------===//
diff --git a/flang/lib/Semantics/tools.cpp b/flang/lib/Semantics/tools.cpp
index 73f3a20d78f1..a7c56c7a2aa1 100644
--- a/flang/lib/Semantics/tools.cpp
+++ b/flang/lib/Semantics/tools.cpp
@@ -961,6 +961,13 @@ bool IsPolymorphic(const Symbol &symbol) {
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);
}
diff --git a/flang/test/Lower/derived-type-finalization.f90 b/flang/test/Lower/derived-type-finalization.f90
new file mode 100644
index 000000000000..81a8a895e11e
--- /dev/null
+++ b/flang/test/Lower/derived-type-finalization.f90
@@ -0,0 +1,151 @@
+! 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
diff --git a/flang/test/Lower/polymorphic.f90 b/flang/test/Lower/polymorphic.f90
index bcdd4d5bd1e3..c8b580855843 100644
--- a/flang/test/Lower/polymorphic.f90
+++ b/flang/test/Lower/polymorphic.f90
@@ -745,6 +745,8 @@ subroutine test_unlimited_polymorphic_intentout(a)
! 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)
@@ -754,6 +756,8 @@ subroutine test_polymorphic_intentout(a)
! 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)
More information about the flang-commits
mailing list