diff --git a/flang/include/flang/Lower/AbstractConverter.h b/flang/include/flang/Lower/AbstractConverter.h index f7529499432f9..7a82c376020a3 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 dabbe72fc3764..6766613ebc27d 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 4703f2515c435..f72373f9da5e3 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 3a34db82d3941..4f9848d599ef7 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(toLocation()); } @@ -977,6 +982,7 @@ class FirConverter : public Fortran::lower::AbstractConverter { resultRef = builder->createConvert(loc, resultRefType, resultRef); return builder->create(loc, resultRef); }); + bridge.fctCtx().finalizeAndPop(); builder->create(loc, resultVal); } @@ -1003,8 +1009,10 @@ class FirConverter : public Fortran::lower::AbstractConverter { } else if (Fortran::semantics::HasAlternateReturns(symbol)) { mlir::Value retval = builder->create( toLocation(), getAltReturnResult(symbol)); + bridge.fctCtx().finalizeAndPop(); builder->create(toLocation(), retval); } else { + bridge.fctCtx().finalizeAndPop(); genExitRoutine(); } } @@ -2764,9 +2772,11 @@ class FirConverter : public Fortran::lower::AbstractConverter { std::optional 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 lhsRealloc; std::optional 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 5d1257258ce01..a18c1ec8b7d6c 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 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 db18553ab9a7f..e8d688a042d66 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 83b56567d5f24..6434e3d4c2dd3 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() && 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() && 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(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 73f3a20d78f13..a7c56c7a2aa17 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 0000000000000..81a8a895e11e2 --- /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.box> +! CHECK: %[[BOX_NONE:.*]] = fir.convert %[[EMBOX]] : (!fir.box>) -> !fir.box +! CHECK: %{{.*}} = fir.call @_FortranADestroy(%[[BOX_NONE]]) {{.*}} : (!fir.box) -> none + +! CHECK-LABEL: func.func @_QMderived_type_finalizationPtest_lhs_allocatable() { +! CHECK: %[[LHS:.*]] = fir.alloca !fir.box>> {bindc_name = "lhs", uniq_name = "_QMderived_type_finalizationFtest_lhs_allocatableElhs"} +! CHECK: %[[LHS_ADDR:.*]] = fir.alloca !fir.heap> {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>> +! CHECK: %[[ADDR_I64:.*]] = fir.convert %[[LHS_ADDR_LOAD]] : (!fir.heap>) -> 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 +! CHECK: %{{.*}} = fir.call @_FortranADestroy(%[[BOX_NONE]]) {{.*}} : (!fir.box) -> 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>> {bindc_name = "t", uniq_name = "_QMderived_type_finalizationFtest_deallocateEt"} +! CHECK: %{{.*}} = fir.call @_FortranAAllocatableAllocate +! CHECK: %[[BOX_NONE:.*]] = fir.convert %[[LOCAL_T]] : (!fir.ref>>>) -> !fir.ref> +! CHECK: %{{.*}} = fir.call @_FortranAAllocatableDeallocate(%[[BOX_NONE]], %{{.*}}, %{{.*}}, %{{.*}}, %{{.*}}) {{.*}} : (!fir.ref>, i1, !fir.box, !fir.ref, 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>> {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.ref> +! CHECK: %{{.*}} = fir.call @_FortranAPointerDeallocate(%[[P_BOX_NONE]], %{{.*}}, %{{.*}}, %{{.*}}, %{{.*}}) {{.*}} : (!fir.ref>, i1, !fir.box, !fir.ref, 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.box> +! CHECK: %[[BOX_NONE:.*]] = fir.convert %[[EMBOX]] : (!fir.box>) -> !fir.box +! CHECK: %{{.*}} = fir.call @_FortranADestroy(%[[BOX_NONE]]) {{.*}} : (!fir.box) -> 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.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> +! 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.field) -> !fir.ref +! CHECK: fir.store %[[C10]] to %[[COORD_A]] : !fir.ref +! CHECK: cf.br ^bb3 +! CHECK: ^bb3: +! CHECK: %[[EMBOX:.*]] = fir.embox %[[T]] : (!fir.ref>) -> !fir.box> +! CHECK: %[[BOX_NONE:.*]] = fir.convert %[[EMBOX]] : (!fir.box>) -> !fir.box +! CHECK: %{{.*}} = fir.call @_FortranADestroy(%[[BOX_NONE]]) {{.*}} : (!fir.box) -> 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> +! CHECK: %[[EMBOX:.*]] = fir.embox %[[RESULT]] : (!fir.ref>) -> !fir.box> +! CHECK: %[[BOX_NONE:.*]] = fir.convert %[[EMBOX]] : (!fir.box>) -> !fir.box +! CHECK: %{{.*}} = fir.call @_FortranADestroy(%[[BOX_NONE]]) {{.*}} : (!fir.box) -> 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.bindc_name = "t"}) { +! CHECK: %[[EMBOX:.*]] = fir.embox %[[T]] : (!fir.ref>) -> !fir.box> +! CHECK: %[[BOX_NONE:.*]] = fir.convert %[[EMBOX]] : (!fir.box>) -> !fir.box +! CHECK: %{{.*}} = fir.call @_FortranADestroy(%[[BOX_NONE]]) {{.*}}: (!fir.box) -> none +! CHECK: return + +end module diff --git a/flang/test/Lower/polymorphic.f90 b/flang/test/Lower/polymorphic.f90 index bcdd4d5bd1e31..c8b5808558438 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 {fir.bindc_name = "a"}) { ! CHECK: %[[BOX_NONE:.*]] = fir.convert %[[ARG0]] : (!fir.class) -> !fir.box +! CHECK: %{{.*}} = fir.call @_FortranADestroy(%[[BOX_NONE]]) {{.*}} : (!fir.box) -> none +! CHECK: %[[BOX_NONE:.*]] = fir.convert %[[ARG0]] : (!fir.class) -> !fir.box ! CHECK: %{{.*}} = fir.call @_FortranAInitialize(%[[BOX_NONE]], %{{.*}}, %{{.*}}) {{.*}} : (!fir.box, !fir.ref, 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.bindc_name = "a"}) { ! CHECK: %[[BOX_NONE:.*]] = fir.convert %[[ARG0]] : (!fir.class>) -> !fir.box +! CHECK: %{{.*}} = fir.call @_FortranADestroy(%[[BOX_NONE]]) {{.*}} : (!fir.box) -> none +! CHECK: %[[BOX_NONE:.*]] = fir.convert %[[ARG0]] : (!fir.class>) -> !fir.box ! CHECK: %{{.*}} = fir.call @_FortranAInitialize(%[[BOX_NONE]], %{{.*}}, %{{.*}}) {{.*}} : (!fir.box, !fir.ref, i32) -> none subroutine rebox_up_to_record_type(p)