diff --git a/flang/include/flang/Lower/Allocatable.h b/flang/include/flang/Lower/Allocatable.h --- a/flang/include/flang/Lower/Allocatable.h +++ b/flang/include/flang/Lower/Allocatable.h @@ -35,6 +35,7 @@ namespace semantics { class Symbol; +class DerivedTypeSpec; } // namespace semantics namespace lower { @@ -53,7 +54,8 @@ const parser::DeallocateStmt &stmt, mlir::Location loc); void genDeallocateBox(AbstractConverter &converter, - const fir::MutableBoxValue &box, mlir::Location loc); + const fir::MutableBoxValue &box, mlir::Location loc, + mlir::Value declaredTypeDesc = {}); /// Create a MutableBoxValue for an allocatable or pointer entity. /// If the variables is a local variable that is not a dummy, it will be @@ -85,6 +87,11 @@ fir::FirOpBuilder &builder, mlir::Location loc, const Fortran::semantics::Symbol &sym, mlir::Value box); +/// Retrieve the address of a type descriptor from its derived type spec. +mlir::Value +getTypeDescAddr(fir::FirOpBuilder &builder, mlir::Location loc, + const Fortran::semantics::DerivedTypeSpec &typeSpec); + } // namespace lower } // namespace Fortran diff --git a/flang/include/flang/Optimizer/Builder/Runtime/RTBuilder.h b/flang/include/flang/Optimizer/Builder/Runtime/RTBuilder.h --- a/flang/include/flang/Optimizer/Builder/Runtime/RTBuilder.h +++ b/flang/include/flang/Optimizer/Builder/Runtime/RTBuilder.h @@ -290,6 +290,13 @@ }; } template <> +constexpr TypeBuilderFunc +getModel() { + return [](mlir::MLIRContext *context) -> mlir::Type { + return fir::ReferenceType::get(mlir::NoneType::get(context)); + }; +} +template <> constexpr TypeBuilderFunc getModel() { return [](mlir::MLIRContext *context) -> mlir::Type { return mlir::NoneType::get(context); diff --git a/flang/include/flang/Runtime/allocatable.h b/flang/include/flang/Runtime/allocatable.h --- a/flang/include/flang/Runtime/allocatable.h +++ b/flang/include/flang/Runtime/allocatable.h @@ -104,6 +104,13 @@ const Descriptor *errMsg = nullptr, const char *sourceFile = nullptr, int sourceLine = 0); +// Same as AllocatableDeallocate but also set the dynamic type as the declared +// type as mentioned in 7.3.2.3 note 7. +int RTNAME(AllocatableDeallocatePolymorphic)(Descriptor &, + const typeInfo::DerivedType *, bool hasStat = false, + const Descriptor *errMsg = nullptr, const char *sourceFile = nullptr, + int sourceLine = 0); + // Variant of above that does not finalize; for intermediate results void RTNAME(AllocatableDeallocateNoFinal)( Descriptor &, const char *sourceFile = nullptr, int sourceLine = 0); diff --git a/flang/include/flang/Runtime/pointer.h b/flang/include/flang/Runtime/pointer.h --- a/flang/include/flang/Runtime/pointer.h +++ b/flang/include/flang/Runtime/pointer.h @@ -91,13 +91,20 @@ // Deallocates a data pointer, which must have been allocated by // PointerAllocate(), possibly copied with PointerAssociate(). -// Finalizes elements &/or components as needed. The pointer is left +// Finalizes elements &/or components as needed. The pointer is left // in an initialized disassociated state suitable for reallocation // with the same bounds, cobounds, and length type parameters. int RTNAME(PointerDeallocate)(Descriptor &, bool hasStat = false, const Descriptor *errMsg = nullptr, const char *sourceFile = nullptr, int sourceLine = 0); +// Same as PointerDeallocate but also set the dynamic type as the declared type +// as mentioned in 7.3.2.3 note 7. +int RTNAME(PointerDeallocatePolymorphic)(Descriptor &, + const typeInfo::DerivedType *, bool hasStat = false, + const Descriptor *errMsg = nullptr, const char *sourceFile = nullptr, + int sourceLine = 0); + // Association inquiries for ASSOCIATED() // True when the pointer is not disassociated. diff --git a/flang/lib/Lower/Allocatable.cpp b/flang/lib/Lower/Allocatable.cpp --- a/flang/lib/Lower/Allocatable.cpp +++ b/flang/lib/Lower/Allocatable.cpp @@ -187,21 +187,36 @@ static mlir::Value genRuntimeDeallocate(fir::FirOpBuilder &builder, mlir::Location loc, const fir::MutableBoxValue &box, - ErrorManager &errorManager) { + ErrorManager &errorManager, + mlir::Value declaredTypeDesc = {}) { // Ensure fir.box is up-to-date before passing it to deallocate runtime. mlir::Value boxAddress = fir::factory::getMutableIRBox(builder, loc, box); - mlir::func::FuncOp callee = - box.isPointer() - ? fir::runtime::getRuntimeFunc(loc, - builder) - : fir::runtime::getRuntimeFunc( - loc, builder); - llvm::SmallVector args{ - boxAddress, errorManager.hasStat, errorManager.errMsgAddr, - errorManager.sourceFile, errorManager.sourceLine}; + mlir::func::FuncOp callee; + llvm::SmallVector args; llvm::SmallVector operands; - for (auto [fst, snd] : llvm::zip(args, callee.getFunctionType().getInputs())) - operands.emplace_back(builder.createConvert(loc, snd, fst)); + if (box.isPolymorphic() || box.isUnlimitedPolymorphic()) { + callee = box.isPointer() + ? fir::runtime::getRuntimeFunc(loc, builder) + : fir::runtime::getRuntimeFunc(loc, builder); + if (!declaredTypeDesc) + declaredTypeDesc = builder.createNullConstant(loc); + operands = fir::runtime::createArguments( + builder, loc, callee.getFunctionType(), boxAddress, declaredTypeDesc, + errorManager.hasStat, errorManager.errMsgAddr, errorManager.sourceFile, + errorManager.sourceLine); + } else { + callee = box.isPointer() + ? fir::runtime::getRuntimeFunc( + loc, builder) + : fir::runtime::getRuntimeFunc( + loc, builder); + operands = fir::runtime::createArguments( + builder, loc, callee.getFunctionType(), boxAddress, + errorManager.hasStat, errorManager.errMsgAddr, errorManager.sourceFile, + errorManager.sourceLine); + } return builder.create(loc, callee, operands).getResult(0); } @@ -519,19 +534,8 @@ if (!typeSpec->AsDerived()) return; - // Set up descriptor for allocation with derived type spec. - std::string typeName = - Fortran::lower::mangle::mangleName(typeSpec->derivedTypeSpec()); - std::string typeDescName = - fir::NameUniquer::getTypeDescriptorName(typeName); - - auto typeDescGlobal = - builder.getModule().lookupSymbol(typeDescName); - if (!typeDescGlobal) - fir::emitFatalError(loc, "type descriptor not defined"); - auto typeDescAddr = builder.create( - loc, fir::ReferenceType::get(typeDescGlobal.getType()), - typeDescGlobal.getSymbol()); + auto typeDescAddr = Fortran::lower::getTypeDescAddr( + builder, loc, typeSpec->derivedTypeSpec()); mlir::func::FuncOp callee = box.isPointer() ? fir::runtime::getRuntimeFunc( @@ -590,7 +594,8 @@ // Generate deallocation of a pointer/allocatable. static void genDeallocate(fir::FirOpBuilder &builder, mlir::Location loc, const fir::MutableBoxValue &box, - ErrorManager &errorManager) { + ErrorManager &errorManager, + mlir::Value declaredTypeDesc = {}) { // Deallocate intrinsic types inline. if (!box.isDerived() && !box.isPolymorphic() && !box.isUnlimitedPolymorphic() && !errorManager.hasStatSpec() && @@ -601,20 +606,22 @@ // Use runtime calls to deallocate descriptor cases. Sync MutableBoxValue // with its descriptor before and after calls if needed. errorManager.genStatCheck(builder, loc); - mlir::Value stat = genRuntimeDeallocate(builder, loc, box, errorManager); + mlir::Value stat = + genRuntimeDeallocate(builder, loc, box, errorManager, declaredTypeDesc); fir::factory::syncMutableBoxFromIRBox(builder, loc, box); errorManager.assignStat(builder, loc, stat); } void Fortran::lower::genDeallocateBox( Fortran::lower::AbstractConverter &converter, - const fir::MutableBoxValue &box, mlir::Location loc) { + const fir::MutableBoxValue &box, mlir::Location loc, + mlir::Value declaredTypeDesc) { const Fortran::lower::SomeExpr *statExpr = nullptr; const Fortran::lower::SomeExpr *errMsgExpr = nullptr; ErrorManager errorManager; errorManager.init(converter, loc, statExpr, errMsgExpr); fir::FirOpBuilder &builder = converter.getFirOpBuilder(); - genDeallocate(builder, loc, box, errorManager); + genDeallocate(builder, loc, box, errorManager, declaredTypeDesc); } void Fortran::lower::genDeallocateStmt( @@ -641,7 +648,18 @@ std::get>(stmt.t)) { fir::MutableBoxValue box = genMutableBoxValue(converter, loc, allocateObject); - genDeallocate(builder, loc, box, errorManager); + + mlir::Value declaredTypeDesc = {}; + if (box.isPolymorphic()) { + const Fortran::semantics::Symbol &symbol = unwrapSymbol(allocateObject); + assert(symbol.GetType()); + if (const Fortran::semantics::DerivedTypeSpec *derivedTypeSpec = + symbol.GetType()->AsDerived()) { + declaredTypeDesc = + Fortran::lower::getTypeDescAddr(builder, loc, *derivedTypeSpec); + } + } + genDeallocate(builder, loc, box, errorManager, declaredTypeDesc); } builder.restoreInsertionPoint(insertPt); } @@ -855,3 +873,17 @@ return readLength(); } + +mlir::Value Fortran::lower::getTypeDescAddr( + fir::FirOpBuilder &builder, mlir::Location loc, + const Fortran::semantics::DerivedTypeSpec &typeSpec) { + std::string typeName = Fortran::lower::mangle::mangleName(typeSpec); + std::string typeDescName = fir::NameUniquer::getTypeDescriptorName(typeName); + auto typeDescGlobal = + builder.getModule().lookupSymbol(typeDescName); + if (!typeDescGlobal) + fir::emitFatalError(loc, "type descriptor not defined"); + return builder.create( + loc, fir::ReferenceType::get(typeDescGlobal.getType()), + typeDescGlobal.getSymbol()); +} diff --git a/flang/lib/Lower/ConvertVariable.cpp b/flang/lib/Lower/ConvertVariable.cpp --- a/flang/lib/Lower/ConvertVariable.cpp +++ b/flang/lib/Lower/ConvertVariable.cpp @@ -35,6 +35,7 @@ #include "flang/Optimizer/HLFIR/HLFIROps.h" #include "flang/Optimizer/Support/FIRContext.h" #include "flang/Optimizer/Support/FatalError.h" +#include "flang/Optimizer/Support/InternalNames.h" #include "flang/Semantics/runtime-type-info.h" #include "flang/Semantics/tools.h" #include "llvm/Support/Debug.h" @@ -662,7 +663,20 @@ mlir::Value isAlloc = fir::factory::genIsAllocatedOrAssociatedTest( builder, loc, *mutBox); builder.genIfThen(loc, isAlloc) - .genThen([&]() { genDeallocateBox(converter, *mutBox, loc); }) + .genThen([&]() { + if (mutBox->isPolymorphic()) { + mlir::Value declaredTypeDesc; + assert(sym.GetType()); + if (const Fortran::semantics::DerivedTypeSpec + *derivedTypeSpec = sym.GetType()->AsDerived()) { + declaredTypeDesc = Fortran::lower::getTypeDescAddr( + builder, loc, *derivedTypeSpec); + } + genDeallocateBox(converter, *mutBox, loc, declaredTypeDesc); + } else { + genDeallocateBox(converter, *mutBox, loc); + } + }) .end(); } else { genDeallocateBox(converter, *mutBox, loc); diff --git a/flang/runtime/allocatable.cpp b/flang/runtime/allocatable.cpp --- a/flang/runtime/allocatable.cpp +++ b/flang/runtime/allocatable.cpp @@ -100,6 +100,17 @@ return ReturnError(terminator, descriptor.Destroy(true), errMsg, hasStat); } +int RTNAME(AllocatableDeallocatePolymorphic)(Descriptor &descriptor, + const typeInfo::DerivedType *derivedType, bool hasStat, + const Descriptor *errMsg, const char *sourceFile, int sourceLine) { + int stat{RTNAME(AllocatableDeallocate)( + descriptor, hasStat, errMsg, sourceFile, sourceLine)}; + DescriptorAddendum *addendum{descriptor.Addendum()}; + INTERNAL_CHECK(addendum != nullptr); + addendum->set_derivedType(derivedType); + return stat; +} + void RTNAME(AllocatableDeallocateNoFinal)( Descriptor &descriptor, const char *sourceFile, int sourceLine) { Terminator terminator{sourceFile, sourceLine}; diff --git a/flang/runtime/pointer.cpp b/flang/runtime/pointer.cpp --- a/flang/runtime/pointer.cpp +++ b/flang/runtime/pointer.cpp @@ -144,6 +144,17 @@ return ReturnError(terminator, pointer.Destroy(true, true), errMsg, hasStat); } +int RTNAME(PointerDeallocatePolymorphic)(Descriptor &pointer, + const typeInfo::DerivedType *derivedType, bool hasStat, + const Descriptor *errMsg, const char *sourceFile, int sourceLine) { + int stat{RTNAME(PointerDeallocate)( + pointer, hasStat, errMsg, sourceFile, sourceLine)}; + DescriptorAddendum *addendum{pointer.Addendum()}; + INTERNAL_CHECK(addendum != nullptr); + addendum->set_derivedType(derivedType); + return stat; +} + bool RTNAME(PointerIsAssociated)(const Descriptor &pointer) { return pointer.raw().base_addr != nullptr; } diff --git a/flang/test/Lower/allocatable-polymorphic.f90 b/flang/test/Lower/allocatable-polymorphic.f90 --- a/flang/test/Lower/allocatable-polymorphic.f90 +++ b/flang/test/Lower/allocatable-polymorphic.f90 @@ -178,20 +178,31 @@ ! CHECK: %[[C4_BOXED:.*]] = fir.embox %[[C4_COORD]] tdesc %[[C4_TDESC]] : (!fir.ref>, !fir.tdesc) -> !fir.class> ! CHECK: fir.dispatch "proc2"(%[[C4_BOXED]] : !fir.class>) (%[[C4_BOXED]] : !fir.class>) {pass_arg_pos = 0 : i32} + +! CHECK: %[[TYPE_DESC_ADDR:.*]] = fir.address_of(@_QMpolyE.dt.p1) : !fir.ref> ! CHECK: %[[P_CAST:.*]] = fir.convert %[[P_DESC]] : (!fir.ref>>>) -> !fir.ref> -! CHECK: %{{.*}} = fir.call @_FortranAPointerDeallocate(%[[P_CAST]], %{{.*}}, %{{.*}}, %{{.*}}, %{{.*}}) {{.*}}: (!fir.ref>, i1, !fir.box, !fir.ref, i32) -> i32 +! CHECK: %[[TYPE_NONE:.*]] = fir.convert %[[TYPE_DESC_ADDR]] : (!fir.ref>) -> !fir.ref +! CHECK: %{{.*}} = fir.call @_FortranAPointerDeallocatePolymorphic(%[[P_CAST]], %[[TYPE_NONE]], %{{.*}}, %{{.*}}, %{{.*}}, %{{.*}}) {{.*}}: (!fir.ref>, !fir.ref, i1, !fir.box, !fir.ref, i32) -> i32 +! CHECK: %[[TYPE_DESC_ADDR:.*]] = fir.address_of(@_QMpolyE.dt.p1) : !fir.ref> ! CHECK: %[[C1_DESC_CAST:.*]] = fir.convert %[[C1_DESC]] : (!fir.ref>>>) -> !fir.ref> -! CHECK: %{{.*}} = fir.call @_FortranAPointerDeallocate(%[[C1_DESC_CAST]], %{{.*}}, %{{.*}}, %{{.*}}, %{{.*}}) {{.*}}: (!fir.ref>, i1, !fir.box, !fir.ref, i32) -> i32 +! CHECK: %[[TYPE_NONE:.*]] = fir.convert %[[TYPE_DESC_ADDR]] : (!fir.ref>) -> !fir.ref +! CHECK: %{{.*}} = fir.call @_FortranAPointerDeallocatePolymorphic(%[[C1_DESC_CAST]], %[[TYPE_NONE]], %{{.*}}, %{{.*}}, %{{.*}}, %{{.*}}) {{.*}}: (!fir.ref>, !fir.ref, i1, !fir.box, !fir.ref, i32) -> i32 +! CHECK: %[[TYPE_DESC_ADDR:.*]] = fir.address_of(@_QMpolyE.dt.p1) : !fir.ref> ! CHECK: %[[C2_DESC_CAST:.*]] = fir.convert %[[C2_DESC]] : (!fir.ref>>>) -> !fir.ref> -! CHECK: %{{.*}} = fir.call @_FortranAPointerDeallocate(%[[C2_DESC_CAST]], %{{.*}}, %{{.*}}, %{{.*}}, %{{.*}}) {{.*}}: (!fir.ref>, i1, !fir.box, !fir.ref, i32) -> i32 +! CHECK: %[[TYPE_NONE:.*]] = fir.convert %[[TYPE_DESC_ADDR]] : (!fir.ref>) -> !fir.ref +! CHECK: %{{.*}} = fir.call @_FortranAPointerDeallocatePolymorphic(%[[C2_DESC_CAST]], %[[TYPE_NONE]], %{{.*}}, %{{.*}}, %{{.*}}, %{{.*}}) {{.*}}: (!fir.ref>, !fir.ref, i1, !fir.box, !fir.ref, i32) -> i32 +! CHECK: %[[TYPE_DESC_ADDR:.*]] = fir.address_of(@_QMpolyE.dt.p1) : !fir.ref> ! CHECK: %[[C3_DESC_CAST:.*]] = fir.convert %[[C3_DESC]] : (!fir.ref>>>>) -> !fir.ref> -! CHECK: %{{.*}} = fir.call @_FortranAPointerDeallocate(%[[C3_DESC_CAST]], %{{.*}}, %{{.*}}, %{{.*}}, %{{.*}}) {{.*}}: (!fir.ref>, i1, !fir.box, !fir.ref, i32) -> i32 +! CHECK: %[[TYPE_NONE:.*]] = fir.convert %[[TYPE_DESC_ADDR]] : (!fir.ref>) -> !fir.ref +! CHECK: %{{.*}} = fir.call @_FortranAPointerDeallocatePolymorphic(%[[C3_DESC_CAST]], %[[TYPE_NONE]], %{{.*}}, %{{.*}}, %{{.*}}, %{{.*}}) {{.*}}: (!fir.ref>, !fir.ref, i1, !fir.box, !fir.ref, i32) -> i32 +! CHECK: %[[TYPE_DESC_ADDR:.*]] = fir.address_of(@_QMpolyE.dt.p1) : !fir.ref> ! CHECK: %[[C4_DESC_CAST:.*]] = fir.convert %[[C4_DESC]] : (!fir.ref>>>>) -> !fir.ref> -! CHECK: %{{.*}} = fir.call @_FortranAPointerDeallocate(%[[C4_DESC_CAST]], %{{.*}}, %{{.*}}, %{{.*}}, %{{.*}}) {{.*}}: (!fir.ref>, i1, !fir.box, !fir.ref, i32) -> i32 +! CHECK: %[[TYPE_NONE:.*]] = fir.convert %[[TYPE_DESC_ADDR]] : (!fir.ref>) -> !fir.ref +! CHECK: %{{.*}} = fir.call @_FortranAPointerDeallocatePolymorphic(%[[C4_DESC_CAST]], %[[TYPE_NONE]], %{{.*}}, %{{.*}}, %{{.*}}, %{{.*}}) {{.*}}: (!fir.ref>, !fir.ref, i1, !fir.box, !fir.ref, i32) -> i32 ! ------------------------------------------------------------------------------ ! Test lowering of ALLOCATE statement for polymoprhic allocatable @@ -330,20 +341,30 @@ ! CHECK: %[[C4_EMBOX:.*]] = fir.embox %[[C4_COORD]] tdesc %[[C4_TDESC]] : (!fir.ref>, !fir.tdesc) -> !fir.class> ! CHECK: fir.dispatch "proc2"(%[[C4_EMBOX]] : !fir.class>) (%[[C4_EMBOX]] : !fir.class>) {pass_arg_pos = 0 : i32} +! CHECK: %[[TYPE_DESC_ADDR:.*]] = fir.address_of(@_QMpolyE.dt.p1) : !fir.ref> ! CHECK: %[[P_CAST:.*]] = fir.convert %[[P]] : (!fir.ref>>>) -> !fir.ref> -! CHECK: %{{.*}} = fir.call @_FortranAAllocatableDeallocate(%[[P_CAST]], %{{.*}}, %{{.*}}, %1{{.*}}, %{{.*}}) {{.*}}: (!fir.ref>, i1, !fir.box, !fir.ref, i32) -> i32 +! CHECK: %[[TYPE_NONE:.*]] = fir.convert %[[TYPE_DESC_ADDR]] : (!fir.ref>) -> !fir.ref +! CHECK: %{{.*}} = fir.call @_FortranAAllocatableDeallocatePolymorphic(%[[P_CAST]], %[[TYPE_NONE]], %{{.*}}, %1{{.*}}, %{{.*}}, %{{.*}}) {{.*}}: (!fir.ref>, !fir.ref, i1, !fir.box, !fir.ref, i32) -> i32 +! CHECK: %[[TYPE_DESC_ADDR:.*]] = fir.address_of(@_QMpolyE.dt.p1) : !fir.ref> ! CHECK: %[[C1_CAST:.*]] = fir.convert %[[C1]] : (!fir.ref>>>) -> !fir.ref> -! CHECK: %{{.*}} = fir.call @_FortranAAllocatableDeallocate(%[[C1_CAST]], %{{.*}}, %{{.*}}, %{{.*}}, %{{.*}}) {{.*}}: (!fir.ref>, i1, !fir.box, !fir.ref, i32) -> i32 +! CHECK: %[[TYPE_NONE:.*]] = fir.convert %[[TYPE_DESC_ADDR]] : (!fir.ref>) -> !fir.ref +! CHECK: %{{.*}} = fir.call @_FortranAAllocatableDeallocatePolymorphic(%[[C1_CAST]], %[[TYPE_NONE]], %{{.*}}, %{{.*}}, %{{.*}}, %{{.*}}) {{.*}}: (!fir.ref>, !fir.ref, i1, !fir.box, !fir.ref, i32) -> i32 +! CHECK: %[[TYPE_DESC_ADDR:.*]] = fir.address_of(@_QMpolyE.dt.p1) : !fir.ref> ! CHECK: %[[C2_CAST:.*]] = fir.convert %[[C2]] : (!fir.ref>>>) -> !fir.ref> -! CHECK: %{{.*}} = fir.call @_FortranAAllocatableDeallocate(%[[C2_CAST]], %{{.*}}, %{{.*}}, %{{.*}}, %{{.*}}) {{.*}}: (!fir.ref>, i1, !fir.box, !fir.ref, i32) -> i32 +! CHECK: %[[TYPE_NONE:.*]] = fir.convert %[[TYPE_DESC_ADDR]] : (!fir.ref>) -> !fir.ref +! CHECK: %{{.*}} = fir.call @_FortranAAllocatableDeallocatePolymorphic(%[[C2_CAST]], %[[TYPE_NONE]], %{{.*}}, %{{.*}}, %{{.*}}, %{{.*}}) {{.*}}: (!fir.ref>, !fir.ref, i1, !fir.box, !fir.ref, i32) -> i32 +! CHECK: %[[TYPE_DESC_ADDR:.*]] = fir.address_of(@_QMpolyE.dt.p1) : !fir.ref> ! CHECK: %[[C3_CAST:.*]] = fir.convert %[[C3]] : (!fir.ref>>>>) -> !fir.ref> -! CHECK: %{{.*}} = fir.call @_FortranAAllocatableDeallocate(%[[C3_CAST]], %{{.*}}, %{{.*}}, %{{.*}}, %{{.*}}) {{.*}}: (!fir.ref>, i1, !fir.box, !fir.ref, i32) -> i32 +! CHECK: %[[TYPE_NONE:.*]] = fir.convert %[[TYPE_DESC_ADDR]] : (!fir.ref>) -> !fir.ref +! CHECK: %{{.*}} = fir.call @_FortranAAllocatableDeallocatePolymorphic(%[[C3_CAST]], %[[TYPE_NONE]], %{{.*}}, %{{.*}}, %{{.*}}, %{{.*}}) {{.*}}: (!fir.ref>, !fir.ref, i1, !fir.box, !fir.ref, i32) -> i32 +! CHECK: %[[TYPE_DESC_ADDR:.*]] = fir.address_of(@_QMpolyE.dt.p1) : !fir.ref> ! CHECK: %[[C4_CAST:.*]] = fir.convert %[[C4]] : (!fir.ref>>>>) -> !fir.ref> -! CHECK: %{{.*}} = fir.call @_FortranAAllocatableDeallocate(%[[C4_CAST]], %{{.*}}, %{{.*}}, %{{.*}}, %{{.*}}) {{.*}}: (!fir.ref>, i1, !fir.box, !fir.ref, i32) -> i32 +! CHECK: %[[TYPE_NONE:.*]] = fir.convert %[[TYPE_DESC_ADDR]] : (!fir.ref>) -> !fir.ref +! CHECK: %{{.*}} = fir.call @_FortranAAllocatableDeallocatePolymorphic(%[[C4_CAST]], %[[TYPE_NONE]], %{{.*}}, %{{.*}}, %{{.*}}, %{{.*}}) {{.*}}: (!fir.ref>, !fir.ref, i1, !fir.box, !fir.ref, i32) -> i32 subroutine test_unlimited_polymorphic_with_intrinsic_type_spec() class(*), allocatable :: p @@ -377,6 +398,10 @@ ! CHECK: %[[BOX_NONE:.*]] = fir.convert %[[PTR]] : (!fir.ref>>) -> !fir.ref> ! CHECK: %{{.*}} = fir.call @_FortranAPointerAllocate(%[[BOX_NONE]], %{{.*}}, %{{.*}}, %{{.*}}, %{{.*}}) {{.*}} : (!fir.ref>, i1, !fir.box, !fir.ref, i32) -> i32 +! CHECK: %[[NULL_TYPE_DESC:.*]] = fir.zero_bits !fir.ref +! CHECK: %[[BOX_NONE:.*]] = fir.convert %[[PTR]] : (!fir.ref>>) -> !fir.ref> +! CHECK: %{{.*}} = fir.call @_FortranAPointerDeallocatePolymorphic(%[[BOX_NONE]], %[[NULL_TYPE_DESC]], %{{.*}}, %{{.*}}, %{{.*}}, %{{.*}}) {{.*}} : (!fir.ref>, !fir.ref, i1, !fir.box, !fir.ref, i32) -> i32 + ! Test code generation of deallocate subroutine test_deallocate() class(p1), allocatable :: p @@ -494,4 +519,4 @@ ! LLVM: store { ptr, i64, i32, i8, i8, i8, i8, ptr, [1 x i64] } %[[LOAD]], ptr %[[ALLOCA2]] ! LLVM: %{{.*}} = call {} @_FortranAAllocatableInitDerived(ptr %[[ALLOCA2]], ptr @_QMpolyE.dt.p1, i32 0, i32 0) ! LLVM: %{{.*}} = call i32 @_FortranAAllocatableAllocate(ptr %[[ALLOCA2]], i1 false, ptr null, ptr @_QQcl.{{.*}}, i32 {{.*}}) -! LLVM: %{{.*}} = call i32 @_FortranAAllocatableDeallocate(ptr %[[ALLOCA2]], i1 false, ptr null, ptr @_QQcl.{{.*}}, i32 {{.*}}) +! LLVM: %{{.*}} = call i32 @_FortranAAllocatableDeallocatePolymorphic(ptr %[[ALLOCA2]], ptr {{.*}}, i1 false, ptr null, ptr @_QQcl.{{.*}}, i32 {{.*}}) diff --git a/flang/test/Lower/intentout-deallocate.f90 b/flang/test/Lower/intentout-deallocate.f90 --- a/flang/test/Lower/intentout-deallocate.f90 +++ b/flang/test/Lower/intentout-deallocate.f90 @@ -215,8 +215,10 @@ ! CHECK: %[[C0:.*]] = arith.constant 0 : i64 ! CHECK: %[[IS_ALLOCATED:.*]] = arith.cmpi ne, %[[BOX_ADDR_PTR]], %[[C0]] : i64 ! CHECK: fir.if %[[IS_ALLOCATED]] { +! CHECK: %[[TYPE_DESC_ADDR:.*]] = fir.address_of(@_QMmod1E.dt.t) : !fir.ref> ! CHECK: %[[BOX_NONE:.*]] = fir.convert %[[ARG0]] : (!fir.ref>>>) -> !fir.ref> -! CHECK: %{{.*}} = fir.call @_FortranAAllocatableDeallocate(%[[BOX_NONE]], %{{.*}}, %{{.*}}, %{{.*}}, %{{.*}}) {{.*}} : (!fir.ref>, i1, !fir.box, !fir.ref, i32) -> i32 +! CHECK: %[[TYPE_NONE:.*]] = fir.convert %9 : (!fir.ref>) -> !fir.ref +! CHECK: %{{.*}} = fir.call @_FortranAAllocatableDeallocatePolymorphic(%[[BOX_NONE]], %[[TYPE_NONE]], %{{.*}}, %{{.*}}, %{{.*}}) {{.*}} : (!fir.ref>, !fir.ref, i1, !fir.box, !fir.ref, i32) -> i32 ! CHECK: } subroutine sub15(p) @@ -231,8 +233,9 @@ ! CHECK: %[[C0:.*]] = arith.constant 0 : i64 ! CHECK: %[[IS_ALLOCATED:.*]] = arith.cmpi ne, %[[BOX_ADDR_PTR]], %[[C0]] : i64 ! CHECK: fir.if %[[IS_ALLOCATED]] { +! CHECK: %[[NULL_TYPE_DESC:.*]] = fir.zero_bits !fir.ref ! CHECK: %[[BOX_NONE:.*]] = fir.convert %[[ARG0]] : (!fir.ref>>) -> !fir.ref> -! CHECK: %{{.*}} = fir.call @_FortranAAllocatableDeallocate(%[[BOX_NONE]], %{{.*}}, %{{.*}}, %{{.*}}, %{{.*}}) {{.*}} : (!fir.ref>, i1, !fir.box, !fir.ref, i32) -> i32 +! CHECK: %{{.*}} = fir.call @_FortranAAllocatableDeallocatePolymorphic(%[[BOX_NONE]], %[[NULL_TYPE_DESC]], %{{.*}}, %{{.*}}, %{{.*}}) {{.*}} : (!fir.ref>, !fir.ref, i1, !fir.box, !fir.ref, i32) -> i32 ! CHECK: } end module diff --git a/flang/test/Lower/polymorphic-types.f90 b/flang/test/Lower/polymorphic-types.f90 --- a/flang/test/Lower/polymorphic-types.f90 +++ b/flang/test/Lower/polymorphic-types.f90 @@ -57,7 +57,7 @@ ! CHECK-LABEL: func.func @_QMpolymorphic_typesPpolymorphic_allocatable_intentout( ! CHECK-SAME: %[[ARG0:.*]]: !fir.ref>>> ! CHECK: %[[BOX_NONE:.*]] = fir.convert %[[ARG0]] : (!fir.ref>>>) -> !fir.ref> -! CHECK: %{{.*}} = fir.call @_FortranAAllocatableDeallocate(%[[BOX_NONE]], %{{.*}}, %{{.*}}, %{{.*}}, %{{.*}}) {{.*}}: (!fir.ref>, i1, !fir.box, !fir.ref, i32) -> i32 +! CHECK: %{{.*}} = fir.call @_FortranAAllocatableDeallocatePolymorphic(%[[BOX_NONE]], %{{.*}}, %{{.*}}, %{{.*}}, %{{.*}}) {{.*}}: (!fir.ref>, !fir.ref, i1, !fir.box, !fir.ref, i32) -> i32 ! ------------------------------------------------------------------------------ ! Test unlimited polymorphic dummy argument types @@ -105,7 +105,7 @@ ! CHECK-LABEL: func.func @_QMpolymorphic_typesPunlimited_polymorphic_allocatable_intentout( ! CHECK-SAME: %[[ARG0:.*]]: !fir.ref>> ! CHECK: %[[BOX_NONE:.*]] = fir.convert %[[ARG0]] : (!fir.ref>>) -> !fir.ref> -! CHECK: %{{.*}} = fir.call @_FortranAAllocatableDeallocate(%[[BOX_NONE]], %{{.*}}, %{{.*}}, %{{.*}}, %{{.*}}) {{.*}}: (!fir.ref>, i1, !fir.box, !fir.ref, i32) -> i32 +! CHECK: %{{.*}} = fir.call @_FortranAAllocatableDeallocatePolymorphic(%[[BOX_NONE]], %{{.*}}, %{{.*}}, %{{.*}}, %{{.*}}) {{.*}}: (!fir.ref>, !fir.ref, i1, !fir.box, !fir.ref, i32) -> i32 ! ------------------------------------------------------------------------------ ! Test polymorphic function return types