| //===-- Allocatable.cpp -- Allocatable statements lowering ----------------===// |
| // |
| // Part of the LLVM Project, under the Apache License v2.0 with LLVM Exceptions. |
| // See https://llvm.org/LICENSE.txt for license information. |
| // SPDX-License-Identifier: Apache-2.0 WITH LLVM-exception |
| // |
| //===----------------------------------------------------------------------===// |
| // |
| // Coding style: https://mlir.llvm.org/getting_started/DeveloperGuide/ |
| // |
| //===----------------------------------------------------------------------===// |
| |
| #include "flang/Lower/Allocatable.h" |
| #include "flang/Evaluate/tools.h" |
| #include "flang/Lower/AbstractConverter.h" |
| #include "flang/Lower/CUDA.h" |
| #include "flang/Lower/ConvertType.h" |
| #include "flang/Lower/ConvertVariable.h" |
| #include "flang/Lower/Mangler.h" |
| #include "flang/Lower/MultiImageFortran.h" |
| #include "flang/Lower/OpenACC.h" |
| #include "flang/Lower/PFTBuilder.h" |
| #include "flang/Lower/Runtime.h" |
| #include "flang/Lower/StatementContext.h" |
| #include "flang/Optimizer/Builder/CUFCommon.h" |
| #include "flang/Optimizer/Builder/FIRBuilder.h" |
| #include "flang/Optimizer/Builder/Runtime/RTBuilder.h" |
| #include "flang/Optimizer/Builder/Todo.h" |
| #include "flang/Optimizer/Dialect/CUF/CUFOps.h" |
| #include "flang/Optimizer/Dialect/FIROps.h" |
| #include "flang/Optimizer/Dialect/MIF/MIFOps.h" |
| #include "flang/Optimizer/Support/FatalError.h" |
| #include "flang/Parser/parse-tree.h" |
| #include "flang/Runtime/allocatable.h" |
| #include "flang/Runtime/pointer.h" |
| #include "flang/Semantics/tools.h" |
| #include "flang/Semantics/type.h" |
| #include "flang/Support/Fortran-features.h" |
| #include "llvm/Support/CommandLine.h" |
| |
| /// By default fir memory operation fir::AllocMemOp/fir::FreeMemOp are used. |
| /// This switch allow forcing the use of runtime and descriptors for everything. |
| /// This is mainly intended as a debug switch. |
| static llvm::cl::opt<bool> useAllocateRuntime( |
| "use-alloc-runtime", |
| llvm::cl::desc("Lower allocations to fortran runtime calls"), |
| llvm::cl::init(false)); |
| |
| //===----------------------------------------------------------------------===// |
| // Error management |
| //===----------------------------------------------------------------------===// |
| |
| namespace { |
| // Manage STAT and ERRMSG specifier information across a sequence of runtime |
| // calls for an ALLOCATE/DEALLOCATE stmt. |
| struct ErrorManager { |
| void init(Fortran::lower::AbstractConverter &converter, mlir::Location loc, |
| const Fortran::lower::SomeExpr *statExpr, |
| const Fortran::lower::SomeExpr *errMsgExpr) { |
| Fortran::lower::StatementContext stmtCtx; |
| fir::FirOpBuilder &builder = converter.getFirOpBuilder(); |
| hasStat = builder.createBool(loc, statExpr != nullptr); |
| statAddr = statExpr |
| ? fir::getBase(converter.genExprAddr(loc, statExpr, stmtCtx)) |
| : mlir::Value{}; |
| errMsgAddr = |
| statExpr && errMsgExpr |
| ? builder.createBox(loc, |
| converter.genExprAddr(loc, errMsgExpr, stmtCtx)) |
| : fir::AbsentOp::create( |
| builder, loc, |
| fir::BoxType::get(mlir::NoneType::get(builder.getContext()))); |
| sourceFile = fir::factory::locationToFilename(builder, loc); |
| sourceLine = fir::factory::locationToLineNo(builder, loc, |
| builder.getIntegerType(32)); |
| } |
| |
| bool hasStatSpec() const { return static_cast<bool>(statAddr); } |
| |
| void genStatCheck(fir::FirOpBuilder &builder, mlir::Location loc) { |
| if (statValue) { |
| mlir::Value zero = |
| builder.createIntegerConstant(loc, statValue.getType(), 0); |
| auto cmp = mlir::arith::CmpIOp::create( |
| builder, loc, mlir::arith::CmpIPredicate::eq, statValue, zero); |
| auto ifOp = fir::IfOp::create(builder, loc, cmp, |
| /*withElseRegion=*/false); |
| builder.setInsertionPointToStart(&ifOp.getThenRegion().front()); |
| } |
| } |
| |
| void assignStat(fir::FirOpBuilder &builder, mlir::Location loc, |
| mlir::Value stat) { |
| if (hasStatSpec()) { |
| assert(stat && "missing stat value"); |
| mlir::Value castStat = builder.createConvert( |
| loc, fir::dyn_cast_ptrEleTy(statAddr.getType()), stat); |
| fir::StoreOp::create(builder, loc, castStat, statAddr); |
| statValue = stat; |
| } |
| } |
| |
| mlir::Value hasStat; |
| mlir::Value errMsgAddr; |
| mlir::Value sourceFile; |
| mlir::Value sourceLine; |
| |
| private: |
| mlir::Value statAddr; // STAT variable address |
| mlir::Value statValue; // current runtime STAT value |
| }; |
| |
| //===----------------------------------------------------------------------===// |
| // Allocatables runtime call generators |
| //===----------------------------------------------------------------------===// |
| |
| using namespace Fortran::runtime; |
| /// Generate a runtime call to set the bounds of an allocatable or pointer |
| /// descriptor. |
| static void genRuntimeSetBounds(fir::FirOpBuilder &builder, mlir::Location loc, |
| const fir::MutableBoxValue &box, |
| mlir::Value dimIndex, mlir::Value lowerBound, |
| mlir::Value upperBound) { |
| mlir::func::FuncOp callee = |
| box.isPointer() |
| ? fir::runtime::getRuntimeFunc<mkRTKey(PointerSetBounds)>(loc, |
| builder) |
| : fir::runtime::getRuntimeFunc<mkRTKey(AllocatableSetBounds)>( |
| loc, builder); |
| const auto args = fir::runtime::createArguments( |
| builder, loc, callee.getFunctionType(), box.getAddr(), dimIndex, |
| lowerBound, upperBound); |
| fir::CallOp::create(builder, loc, callee, args); |
| } |
| |
| /// Generate runtime call to set the lengths of a character allocatable or |
| /// pointer descriptor. |
| static void genRuntimeInitCharacter(fir::FirOpBuilder &builder, |
| mlir::Location loc, |
| const fir::MutableBoxValue &box, |
| mlir::Value len, int64_t kind = 0) { |
| mlir::func::FuncOp callee = |
| box.isPointer() |
| ? fir::runtime::getRuntimeFunc<mkRTKey(PointerNullifyCharacter)>( |
| loc, builder) |
| : fir::runtime::getRuntimeFunc<mkRTKey( |
| AllocatableInitCharacterForAllocate)>(loc, builder); |
| llvm::ArrayRef<mlir::Type> inputTypes = callee.getFunctionType().getInputs(); |
| if (inputTypes.size() != 5) |
| fir::emitFatalError( |
| loc, "AllocatableInitCharacter runtime interface not as expected"); |
| llvm::SmallVector<mlir::Value> args = {box.getAddr(), len}; |
| if (kind == 0) |
| kind = mlir::cast<fir::CharacterType>(box.getEleTy()).getFKind(); |
| args.push_back(builder.createIntegerConstant(loc, inputTypes[2], kind)); |
| int rank = box.rank(); |
| args.push_back(builder.createIntegerConstant(loc, inputTypes[3], rank)); |
| // TODO: coarrays |
| int corank = 0; |
| args.push_back(builder.createIntegerConstant(loc, inputTypes[4], corank)); |
| const auto convertedArgs = fir::runtime::createArguments( |
| builder, loc, callee.getFunctionType(), args); |
| fir::CallOp::create(builder, loc, callee, convertedArgs); |
| } |
| |
| /// Generate a sequence of runtime calls to allocate memory. |
| static mlir::Value genRuntimeAllocate(fir::FirOpBuilder &builder, |
| mlir::Location loc, |
| const fir::MutableBoxValue &box, |
| ErrorManager &errorManager) { |
| mlir::func::FuncOp callee = |
| box.isPointer() |
| ? fir::runtime::getRuntimeFunc<mkRTKey(PointerAllocate)>(loc, builder) |
| : fir::runtime::getRuntimeFunc<mkRTKey(AllocatableAllocate)>(loc, |
| builder); |
| llvm::SmallVector<mlir::Value> args{box.getAddr()}; |
| if (!box.isPointer()) |
| args.push_back( |
| builder.createIntegerConstant(loc, builder.getI64Type(), -1)); |
| args.push_back(errorManager.hasStat); |
| args.push_back(errorManager.errMsgAddr); |
| args.push_back(errorManager.sourceFile); |
| args.push_back(errorManager.sourceLine); |
| args.push_back(builder.createBool(loc, false)); |
| const auto convertedArgs = fir::runtime::createArguments( |
| builder, loc, callee.getFunctionType(), args); |
| return fir::CallOp::create(builder, loc, callee, convertedArgs).getResult(0); |
| } |
| |
| /// Generate a sequence of runtime calls to allocate memory and assign with the |
| /// \p source. |
| static mlir::Value genRuntimeAllocateSource(fir::FirOpBuilder &builder, |
| mlir::Location loc, |
| const fir::MutableBoxValue &box, |
| fir::ExtendedValue source, |
| ErrorManager &errorManager) { |
| mlir::func::FuncOp callee = |
| box.isPointer() |
| ? fir::runtime::getRuntimeFunc<mkRTKey(PointerAllocateSource)>( |
| loc, builder) |
| : fir::runtime::getRuntimeFunc<mkRTKey(AllocatableAllocateSource)>( |
| loc, builder); |
| const auto args = fir::runtime::createArguments( |
| builder, loc, callee.getFunctionType(), box.getAddr(), |
| fir::getBase(source), errorManager.hasStat, errorManager.errMsgAddr, |
| errorManager.sourceFile, errorManager.sourceLine); |
| return fir::CallOp::create(builder, loc, callee, args).getResult(0); |
| } |
| |
| /// Generate runtime call to apply mold to the descriptor. |
| static void genRuntimeAllocateApplyMold(fir::FirOpBuilder &builder, |
| mlir::Location loc, |
| const fir::MutableBoxValue &box, |
| fir::ExtendedValue mold, int rank) { |
| mlir::func::FuncOp callee = |
| box.isPointer() |
| ? fir::runtime::getRuntimeFunc<mkRTKey(PointerApplyMold)>(loc, |
| builder) |
| : fir::runtime::getRuntimeFunc<mkRTKey(AllocatableApplyMold)>( |
| loc, builder); |
| const auto args = fir::runtime::createArguments( |
| builder, loc, callee.getFunctionType(), |
| fir::factory::getMutableIRBox(builder, loc, box), fir::getBase(mold), |
| builder.createIntegerConstant( |
| loc, callee.getFunctionType().getInputs()[2], rank)); |
| fir::CallOp::create(builder, loc, callee, args); |
| } |
| |
| /// Generate a runtime call to deallocate memory. |
| static mlir::Value genRuntimeDeallocate(fir::FirOpBuilder &builder, |
| mlir::Location loc, |
| const fir::MutableBoxValue &box, |
| 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; |
| llvm::SmallVector<mlir::Value> args; |
| llvm::SmallVector<mlir::Value> operands; |
| if (box.isPolymorphic() || box.isUnlimitedPolymorphic()) { |
| callee = box.isPointer() |
| ? fir::runtime::getRuntimeFunc<mkRTKey( |
| PointerDeallocatePolymorphic)>(loc, builder) |
| : fir::runtime::getRuntimeFunc<mkRTKey( |
| AllocatableDeallocatePolymorphic)>(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<mkRTKey(PointerDeallocate)>( |
| loc, builder) |
| : fir::runtime::getRuntimeFunc<mkRTKey(AllocatableDeallocate)>( |
| loc, builder); |
| operands = fir::runtime::createArguments( |
| builder, loc, callee.getFunctionType(), boxAddress, |
| errorManager.hasStat, errorManager.errMsgAddr, errorManager.sourceFile, |
| errorManager.sourceLine); |
| } |
| return fir::CallOp::create(builder, loc, callee, operands).getResult(0); |
| } |
| |
| //===----------------------------------------------------------------------===// |
| // Allocate statement implementation |
| //===----------------------------------------------------------------------===// |
| |
| /// Helper to get symbol from AllocateObject. |
| static const Fortran::semantics::Symbol & |
| unwrapSymbol(const Fortran::parser::AllocateObject &allocObj) { |
| const Fortran::parser::Name &lastName = |
| Fortran::parser::GetLastName(allocObj); |
| assert(lastName.symbol); |
| return *lastName.symbol; |
| } |
| |
| static fir::MutableBoxValue |
| genMutableBoxValue(Fortran::lower::AbstractConverter &converter, |
| mlir::Location loc, |
| const Fortran::parser::AllocateObject &allocObj) { |
| const Fortran::lower::SomeExpr *expr = Fortran::semantics::GetExpr(allocObj); |
| assert(expr && "semantic analysis failure"); |
| return converter.genExprMutableBox(loc, *expr); |
| } |
| |
| /// Implement Allocate statement lowering. |
| class AllocateStmtHelper { |
| public: |
| AllocateStmtHelper(Fortran::lower::AbstractConverter &converter, |
| const Fortran::parser::AllocateStmt &stmt, |
| mlir::Location loc) |
| : converter{converter}, builder{converter.getFirOpBuilder()}, stmt{stmt}, |
| loc{loc} {} |
| |
| void lower() { |
| visitAllocateOptions(); |
| lowerAllocateLengthParameters(); |
| errorManager.init(converter, loc, statExpr, errMsgExpr); |
| Fortran::lower::StatementContext stmtCtx; |
| if (sourceExpr) |
| sourceExv = converter.genExprBox(loc, *sourceExpr, stmtCtx); |
| if (moldExpr) |
| moldExv = converter.genExprBox(loc, *moldExpr, stmtCtx); |
| mlir::OpBuilder::InsertPoint insertPt = builder.saveInsertionPoint(); |
| for (const auto &allocation : |
| std::get<std::list<Fortran::parser::Allocation>>(stmt.t)) |
| lowerAllocation(unwrapAllocation(allocation)); |
| builder.restoreInsertionPoint(insertPt); |
| } |
| |
| private: |
| struct Allocation { |
| const Fortran::parser::Allocation &alloc; |
| const Fortran::semantics::DeclTypeSpec &type; |
| const std::optional<Fortran::parser::AllocateCoarraySpec> & |
| getCoarraySpec() const { |
| return std::get<std::optional<Fortran::parser::AllocateCoarraySpec>>( |
| alloc.t); |
| } |
| bool hasCoarraySpec() const { return getCoarraySpec().has_value(); } |
| const Fortran::parser::AllocateObject &getAllocObj() const { |
| return std::get<Fortran::parser::AllocateObject>(alloc.t); |
| } |
| const Fortran::semantics::Symbol &getSymbol() const { |
| return unwrapSymbol(getAllocObj()); |
| } |
| const std::list<Fortran::parser::AllocateShapeSpec> &getShapeSpecs() const { |
| return std::get<std::list<Fortran::parser::AllocateShapeSpec>>(alloc.t); |
| } |
| }; |
| |
| Allocation unwrapAllocation(const Fortran::parser::Allocation &alloc) { |
| const auto &allocObj = std::get<Fortran::parser::AllocateObject>(alloc.t); |
| const Fortran::semantics::Symbol &symbol = unwrapSymbol(allocObj); |
| assert(symbol.GetType()); |
| return Allocation{alloc, *symbol.GetType()}; |
| } |
| |
| void visitAllocateOptions() { |
| for (const auto &allocOption : |
| std::get<std::list<Fortran::parser::AllocOpt>>(stmt.t)) |
| Fortran::common::visit( |
| Fortran::common::visitors{ |
| [&](const Fortran::parser::StatOrErrmsg &statOrErr) { |
| Fortran::common::visit( |
| Fortran::common::visitors{ |
| [&](const Fortran::parser::StatVariable &statVar) { |
| statExpr = Fortran::semantics::GetExpr(statVar); |
| }, |
| [&](const Fortran::parser::MsgVariable &errMsgVar) { |
| errMsgExpr = Fortran::semantics::GetExpr(errMsgVar); |
| }, |
| }, |
| statOrErr.u); |
| }, |
| [&](const Fortran::parser::AllocOpt::Source &source) { |
| sourceExpr = Fortran::semantics::GetExpr(source.v.value()); |
| }, |
| [&](const Fortran::parser::AllocOpt::Mold &mold) { |
| moldExpr = Fortran::semantics::GetExpr(mold.v.value()); |
| }, |
| [&](const Fortran::parser::AllocOpt::Stream &stream) { |
| streamExpr = Fortran::semantics::GetExpr(stream.v.value()); |
| }, |
| [&](const Fortran::parser::AllocOpt::Pinned &pinned) { |
| pinnedExpr = Fortran::semantics::GetExpr(pinned.v.value()); |
| }, |
| }, |
| allocOption.u); |
| } |
| |
| void lowerAllocation(const Allocation &alloc) { |
| fir::MutableBoxValue boxAddr = |
| genMutableBoxValue(converter, loc, alloc.getAllocObj()); |
| |
| if (sourceExpr) |
| genSourceMoldAllocation(alloc, boxAddr, /*isSource=*/true); |
| else if (moldExpr) |
| genSourceMoldAllocation(alloc, boxAddr, /*isSource=*/false); |
| else |
| genSimpleAllocation(alloc, boxAddr); |
| } |
| |
| static bool lowerBoundsAreOnes(const Allocation &alloc) { |
| for (const Fortran::parser::AllocateShapeSpec &shapeSpec : |
| alloc.getShapeSpecs()) |
| if (std::get<0>(shapeSpec.t)) |
| return false; |
| return true; |
| } |
| |
| /// Build name for the fir::allocmem generated for alloc. |
| std::string mangleAlloc(const Allocation &alloc) { |
| return converter.mangleName(alloc.getSymbol()) + ".alloc"; |
| } |
| |
| /// Generate allocation without runtime calls. |
| /// Only for intrinsic types. No coarrays, no polymorphism. No error recovery. |
| void genInlinedAllocation(const Allocation &alloc, |
| const fir::MutableBoxValue &box) { |
| llvm::SmallVector<mlir::Value> lbounds; |
| llvm::SmallVector<mlir::Value> extents; |
| Fortran::lower::StatementContext stmtCtx; |
| mlir::Type idxTy = builder.getIndexType(); |
| bool lBoundsAreOnes = lowerBoundsAreOnes(alloc); |
| mlir::Value one = builder.createIntegerConstant(loc, idxTy, 1); |
| for (const Fortran::parser::AllocateShapeSpec &shapeSpec : |
| alloc.getShapeSpecs()) { |
| mlir::Value lb; |
| if (!lBoundsAreOnes) { |
| if (const std::optional<Fortran::parser::BoundExpr> &lbExpr = |
| std::get<0>(shapeSpec.t)) { |
| lb = fir::getBase(converter.genExprValue( |
| loc, Fortran::semantics::GetExpr(*lbExpr), stmtCtx)); |
| lb = builder.createConvert(loc, idxTy, lb); |
| } else { |
| lb = one; |
| } |
| lbounds.emplace_back(lb); |
| } |
| mlir::Value ub = fir::getBase(converter.genExprValue( |
| loc, Fortran::semantics::GetExpr(std::get<1>(shapeSpec.t)), stmtCtx)); |
| ub = builder.createConvert(loc, idxTy, ub); |
| if (lb) { |
| mlir::Value diff = mlir::arith::SubIOp::create(builder, loc, ub, lb); |
| extents.emplace_back( |
| mlir::arith::AddIOp::create(builder, loc, diff, one)); |
| } else { |
| extents.emplace_back(ub); |
| } |
| } |
| fir::factory::genInlinedAllocation(builder, loc, box, lbounds, extents, |
| lenParams, mangleAlloc(alloc), |
| /*mustBeHeap=*/true); |
| } |
| |
| void postAllocationAction(const Allocation &alloc, |
| const fir::MutableBoxValue &box) { |
| if (alloc.getSymbol().test(Fortran::semantics::Symbol::Flag::AccDeclare)) |
| Fortran::lower::attachDeclarePostAllocAction(converter, builder, |
| alloc.getSymbol()); |
| } |
| |
| void setPinnedToFalse() { |
| if (!pinnedExpr) |
| return; |
| Fortran::lower::StatementContext stmtCtx; |
| mlir::Value pinned = |
| fir::getBase(converter.genExprAddr(loc, *pinnedExpr, stmtCtx)); |
| mlir::Location loc = pinned.getLoc(); |
| mlir::Value falseValue = builder.createBool(loc, false); |
| mlir::Value falseConv = builder.createConvert( |
| loc, fir::unwrapRefType(pinned.getType()), falseValue); |
| fir::StoreOp::create(builder, loc, falseConv, pinned); |
| } |
| |
| /// Search a DataRef for a symbol with CUDA attributes. Returns true and |
| /// sets \p sym if found. |
| static bool findCUDAAttrInDataRef(const Fortran::parser::DataRef &ref, |
| const Fortran::semantics::Symbol *&sym) { |
| return Fortran::common::visit( |
| Fortran::common::visitors{ |
| [&](const Fortran::parser::Name &name) { |
| if (name.symbol && |
| Fortran::semantics::HasCUDAAttr(*name.symbol)) { |
| sym = name.symbol; |
| return true; |
| } |
| return false; |
| }, |
| [&](const Fortran::common::Indirection< |
| Fortran::parser::StructureComponent> &sc) { |
| if (sc.value().Component().symbol && |
| Fortran::semantics::HasCUDAAttr( |
| *sc.value().Component().symbol)) { |
| sym = sc.value().Component().symbol; |
| return true; |
| } |
| return findCUDAAttrInDataRef(sc.value().Base(), sym); |
| }, |
| [&](const Fortran::common::Indirection< |
| Fortran::parser::ArrayElement> &ae) { |
| return findCUDAAttrInDataRef(ae.value().Base(), sym); |
| }, |
| [&](const Fortran::common::Indirection< |
| Fortran::parser::CoindexedNamedObject> &) { return false; }, |
| }, |
| ref.u); |
| } |
| |
| /// When the allocate object is a structure component (e.g., |
| /// managed_var(1)%component or a%b%c), walk the DataRef chain and check |
| /// whether any parent has CUDA attributes. If so, update \p sym to that |
| /// symbol and return true so allocations use its memory space. |
| bool propagateCUDAAttrsFromParent(const Allocation &alloc, |
| const Fortran::semantics::Symbol *&sym) { |
| if (const auto *sc = std::get_if<Fortran::parser::StructureComponent>( |
| &alloc.getAllocObj().u)) |
| return findCUDAAttrInDataRef(sc->Base(), sym); |
| return false; |
| } |
| |
| void genSimpleAllocation(const Allocation &alloc, |
| const fir::MutableBoxValue &box) { |
| bool isCudaAllocate = |
| Fortran::semantics::HasCUDAAttr(alloc.getSymbol()) || |
| Fortran::semantics::HasCUDAComponent(alloc.getSymbol()); |
| const Fortran::semantics::Symbol *cudaSymForAlloc = &alloc.getSymbol(); |
| if (!isCudaAllocate) |
| isCudaAllocate = propagateCUDAAttrsFromParent(alloc, cudaSymForAlloc); |
| |
| bool isCudaDeviceContext = cuf::isCUDADeviceContext(builder.getRegion()); |
| unsigned allocatorIdx = Fortran::lower::getAllocatorIdx(*cudaSymForAlloc); |
| |
| // Under -gpu=mem:unified, back plain (unattributed) allocatables/pointers |
| // with managed memory by selecting the unified allocator index at the |
| // ALLOCATE site. The symbol stays unattributed, so argument passing, |
| // interfaces, and COMMON legality are unaffected. |
| bool implicitManagedBacking = false; |
| if (allocatorIdx == kDefaultAllocator && !isCudaAllocate && |
| !isCudaDeviceContext && (box.isAllocatable() || box.isPointer()) && |
| converter.getFoldingContext().languageFeatures().IsEnabled( |
| Fortran::common::LanguageFeature::CudaUnified)) { |
| allocatorIdx = kUnifiedAllocatorPos; |
| implicitManagedBacking = true; |
| } |
| |
| // The inlined allocation path emits a plain heap allocmem that ignores the |
| // allocator index; use the runtime path when we redirected an otherwise |
| // plain allocatable to a managed allocator so the index is honored. |
| bool inlineAllocation = !box.isDerived() && !errorManager.hasStatSpec() && |
| !alloc.type.IsPolymorphic() && |
| !alloc.hasCoarraySpec() && !useAllocateRuntime && |
| !box.isPointer() && !implicitManagedBacking; |
| |
| if (inlineAllocation && !alloc.hasCoarraySpec() && |
| ((isCudaAllocate && isCudaDeviceContext) || !isCudaAllocate)) { |
| // Pointers must use PointerAllocate so that their deallocations |
| // can be validated. |
| genInlinedAllocation(alloc, box); |
| postAllocationAction(alloc, box); |
| setPinnedToFalse(); |
| return; |
| } |
| |
| // Preserve characters' dynamic length. |
| if (lenParams.empty() && box.isCharacter() && |
| !box.hasNonDeferredLenParams()) { |
| auto charTy = mlir::dyn_cast<fir::CharacterType>(box.getEleTy()); |
| if (charTy && charTy.hasDynamicLen()) { |
| fir::ExtendedValue exv{box}; |
| lenParams.push_back(fir::factory::readCharLen(builder, loc, exv)); |
| } |
| } |
| |
| // Generate a sequence of runtime calls. |
| errorManager.genStatCheck(builder, loc); |
| genAllocateObjectInit(box, allocatorIdx); |
| if (alloc.type.IsPolymorphic()) |
| genSetType(alloc, box, loc); |
| genSetDeferredLengthParameters(alloc, box); |
| genAllocateObjectBounds(alloc, box); |
| mlir::Value stat; |
| if (alloc.hasCoarraySpec()) { |
| stat = Fortran::lower::genAllocateCoarray( |
| converter, loc, alloc.getSymbol(), box.getAddr(), |
| alloc.getCoarraySpec(), errorManager.errMsgAddr, |
| errorManager.hasStatSpec()); |
| } else if (!isCudaAllocate) { |
| stat = genRuntimeAllocate(builder, loc, box, errorManager); |
| setPinnedToFalse(); |
| } else { |
| stat = genCudaAllocate(builder, loc, box, errorManager, *cudaSymForAlloc); |
| } |
| fir::factory::syncMutableBoxFromIRBox(builder, loc, box); |
| postAllocationAction(alloc, box); |
| errorManager.assignStat(builder, loc, stat); |
| } |
| |
| /// Lower the length parameters that may be specified in the optional |
| /// type specification. |
| void lowerAllocateLengthParameters() { |
| const Fortran::semantics::DeclTypeSpec *typeSpec = |
| getIfAllocateStmtTypeSpec(); |
| if (!typeSpec) |
| return; |
| if (const Fortran::semantics::DerivedTypeSpec *derived = |
| typeSpec->AsDerived()) |
| if (Fortran::semantics::CountLenParameters(*derived) > 0) |
| TODO(loc, "setting derived type params in allocation"); |
| if (typeSpec->category() == |
| Fortran::semantics::DeclTypeSpec::Category::Character) { |
| Fortran::semantics::ParamValue lenParam = |
| typeSpec->characterTypeSpec().length(); |
| if (Fortran::semantics::MaybeIntExpr intExpr = lenParam.GetExplicit()) { |
| Fortran::lower::StatementContext stmtCtx; |
| Fortran::lower::SomeExpr lenExpr{*intExpr}; |
| lenParams.push_back( |
| fir::getBase(converter.genExprValue(loc, lenExpr, stmtCtx))); |
| } |
| } |
| } |
| |
| // Set length parameters in the box stored in boxAddr. |
| // This must be called before setting the bounds because it may use |
| // Init runtime calls that may set the bounds to zero. |
| void genSetDeferredLengthParameters(const Allocation &alloc, |
| const fir::MutableBoxValue &box) { |
| if (lenParams.empty()) |
| return; |
| // TODO: in case a length parameter was not deferred, insert a runtime check |
| // that the length is the same (AllocatableCheckLengthParameter runtime |
| // call). |
| if (box.isCharacter()) |
| genRuntimeInitCharacter(builder, loc, box, lenParams[0]); |
| |
| if (box.isDerived()) |
| TODO(loc, "derived type length parameters in allocate"); |
| } |
| |
| void genAllocateObjectInit(const fir::MutableBoxValue &box, |
| unsigned allocatorIdx) { |
| if (box.isPointer()) { |
| // For pointers, the descriptor may still be uninitialized (see Fortran |
| // 2018 19.5.2.2). The allocation runtime needs to be given a descriptor |
| // with initialized rank, types and attributes. Initialize the descriptor |
| // here to ensure these constraints are fulfilled. |
| mlir::Value nullPointer = fir::factory::createUnallocatedBox( |
| builder, loc, box.getBoxTy(), box.nonDeferredLenParams(), |
| /*typeSourceBox=*/{}, allocatorIdx); |
| fir::StoreOp::create(builder, loc, nullPointer, box.getAddr()); |
| } else { |
| assert(box.isAllocatable() && "must be an allocatable"); |
| // For allocatables, re-establish the descriptor with the correct |
| // allocator index so that AllocatableAllocate uses the right memory |
| // space. |
| if (allocatorIdx != kDefaultAllocator) { |
| fir::factory::disassociateMutableBox(builder, loc, box, |
| /*polymorphicSetType=*/false, |
| allocatorIdx); |
| } |
| // Sync the MutableBoxValue and descriptor before the calls in case |
| // it is tracked locally by a set of variables. |
| fir::factory::getMutableIRBox(builder, loc, box); |
| } |
| } |
| |
| void genAllocateObjectBounds(const Allocation &alloc, |
| const fir::MutableBoxValue &box) { |
| // Set bounds for arrays |
| mlir::Type idxTy = builder.getIndexType(); |
| mlir::Type i32Ty = builder.getIntegerType(32); |
| Fortran::lower::StatementContext stmtCtx; |
| for (const auto &iter : llvm::enumerate(alloc.getShapeSpecs())) { |
| mlir::Value lb; |
| const auto &bounds = iter.value().t; |
| if (const std::optional<Fortran::parser::BoundExpr> &lbExpr = |
| std::get<0>(bounds)) |
| lb = fir::getBase(converter.genExprValue( |
| loc, Fortran::semantics::GetExpr(*lbExpr), stmtCtx)); |
| else |
| lb = builder.createIntegerConstant(loc, idxTy, 1); |
| mlir::Value ub = fir::getBase(converter.genExprValue( |
| loc, Fortran::semantics::GetExpr(std::get<1>(bounds)), stmtCtx)); |
| mlir::Value dimIndex = |
| builder.createIntegerConstant(loc, i32Ty, iter.index()); |
| // Runtime call |
| genRuntimeSetBounds(builder, loc, box, dimIndex, lb, ub); |
| } |
| if (sourceExpr && sourceExpr->Rank() > 0 && |
| alloc.getShapeSpecs().size() == 0) { |
| // If the alloc object does not have shape list, get the bounds from the |
| // source expression. |
| mlir::Value one = builder.createIntegerConstant(loc, idxTy, 1); |
| const auto *sourceBox = sourceExv.getBoxOf<fir::BoxValue>(); |
| assert(sourceBox && "source expression should be lowered to one box"); |
| for (int i = 0; i < sourceExpr->Rank(); ++i) { |
| auto dimVal = builder.createIntegerConstant(loc, idxTy, i); |
| auto dimInfo = fir::BoxDimsOp::create(builder, loc, idxTy, idxTy, idxTy, |
| sourceBox->getAddr(), dimVal); |
| mlir::Value lb = |
| fir::factory::readLowerBound(builder, loc, sourceExv, i, one); |
| mlir::Value extent = dimInfo.getResult(1); |
| mlir::Value ub = mlir::arith::SubIOp::create( |
| builder, loc, mlir::arith::AddIOp::create(builder, loc, extent, lb), |
| one); |
| mlir::Value dimIndex = builder.createIntegerConstant(loc, i32Ty, i); |
| genRuntimeSetBounds(builder, loc, box, dimIndex, lb, ub); |
| } |
| } |
| } |
| |
| void genSourceMoldAllocation(const Allocation &alloc, |
| const fir::MutableBoxValue &box, bool isSource) { |
| bool isCudaAllocate = Fortran::semantics::HasCUDAAttr(alloc.getSymbol()); |
| const Fortran::semantics::Symbol *cudaSymForAlloc = &alloc.getSymbol(); |
| if (!isCudaAllocate) |
| isCudaAllocate = propagateCUDAAttrsFromParent(alloc, cudaSymForAlloc); |
| unsigned allocatorIdx = Fortran::lower::getAllocatorIdx(*cudaSymForAlloc); |
| fir::ExtendedValue exv = isSource ? sourceExv : moldExv; |
| |
| bool sourceIsDevice = false; |
| if (const Fortran::semantics::Symbol *sym{GetLastSymbol(sourceExpr)}) |
| if (Fortran::semantics::IsCUDADevice(*sym)) |
| sourceIsDevice = true; |
| |
| // Generate a sequence of runtime calls. |
| errorManager.genStatCheck(builder, loc); |
| genAllocateObjectInit(box, allocatorIdx); |
| // Set length of the allocate object if it has. Otherwise, get the length |
| // from source for the deferred length parameter. |
| const bool isDeferredLengthCharacter = |
| box.isCharacter() && !box.hasNonDeferredLenParams(); |
| if (lenParams.empty() && isDeferredLengthCharacter) |
| lenParams.push_back(fir::factory::readCharLen(builder, loc, exv)); |
| if (!isSource || alloc.type.IsPolymorphic()) |
| genRuntimeAllocateApplyMold(builder, loc, box, exv, |
| alloc.getSymbol().Rank()); |
| if (isDeferredLengthCharacter) |
| genSetDeferredLengthParameters(alloc, box); |
| genAllocateObjectBounds(alloc, box); |
| mlir::Value stat; |
| if (alloc.hasCoarraySpec()) { |
| stat = Fortran::lower::genAllocateCoarray( |
| converter, loc, alloc.getSymbol(), box.getAddr(), |
| alloc.getCoarraySpec(), errorManager.errMsgAddr, |
| errorManager.hasStatSpec()); |
| } else if (isCudaAllocate || sourceIsDevice) { |
| stat = genCudaAllocate(builder, loc, box, errorManager, *cudaSymForAlloc); |
| } else { |
| if (isSource) |
| stat = genRuntimeAllocateSource(builder, loc, box, exv, errorManager); |
| else |
| stat = genRuntimeAllocate(builder, loc, box, errorManager); |
| setPinnedToFalse(); |
| } |
| fir::factory::syncMutableBoxFromIRBox(builder, loc, box); |
| postAllocationAction(alloc, box); |
| errorManager.assignStat(builder, loc, stat); |
| } |
| |
| /// Generate call to PointerNullifyDerived or AllocatableInitDerived |
| /// to set the dynamic type information. |
| void genInitDerived(const fir::MutableBoxValue &box, mlir::Value typeDescAddr, |
| int rank, int corank = 0) { |
| mlir::func::FuncOp callee = |
| box.isPointer() |
| ? fir::runtime::getRuntimeFunc<mkRTKey(PointerNullifyDerived)>( |
| loc, builder) |
| : fir::runtime::getRuntimeFunc<mkRTKey( |
| AllocatableInitDerivedForAllocate)>(loc, builder); |
| |
| llvm::ArrayRef<mlir::Type> inputTypes = |
| callee.getFunctionType().getInputs(); |
| mlir::Value rankValue = |
| builder.createIntegerConstant(loc, inputTypes[2], rank); |
| mlir::Value corankValue = |
| builder.createIntegerConstant(loc, inputTypes[3], corank); |
| const auto args = fir::runtime::createArguments( |
| builder, loc, callee.getFunctionType(), box.getAddr(), typeDescAddr, |
| rankValue, corankValue); |
| fir::CallOp::create(builder, loc, callee, args); |
| } |
| |
| /// Generate call to PointerNullifyIntrinsic or AllocatableInitIntrinsic to |
| /// set the dynamic type information for a polymorphic entity from an |
| /// intrinsic type spec. |
| void genInitIntrinsic(const fir::MutableBoxValue &box, |
| const TypeCategory category, int64_t kind, int rank, |
| int corank = 0) { |
| mlir::func::FuncOp callee = |
| box.isPointer() |
| ? fir::runtime::getRuntimeFunc<mkRTKey(PointerNullifyIntrinsic)>( |
| loc, builder) |
| : fir::runtime::getRuntimeFunc<mkRTKey( |
| AllocatableInitIntrinsicForAllocate)>(loc, builder); |
| |
| llvm::ArrayRef<mlir::Type> inputTypes = |
| callee.getFunctionType().getInputs(); |
| mlir::Value categoryValue = builder.createIntegerConstant( |
| loc, inputTypes[1], static_cast<int32_t>(category)); |
| mlir::Value kindValue = |
| builder.createIntegerConstant(loc, inputTypes[2], kind); |
| mlir::Value rankValue = |
| builder.createIntegerConstant(loc, inputTypes[3], rank); |
| mlir::Value corankValue = |
| builder.createIntegerConstant(loc, inputTypes[4], corank); |
| const auto args = fir::runtime::createArguments( |
| builder, loc, callee.getFunctionType(), box.getAddr(), categoryValue, |
| kindValue, rankValue, corankValue); |
| fir::CallOp::create(builder, loc, callee, args); |
| } |
| |
| /// Generate call to the AllocatableInitDerived to set up the type descriptor |
| /// and other part of the descriptor for derived type. |
| void genSetType(const Allocation &alloc, const fir::MutableBoxValue &box, |
| mlir::Location loc) { |
| const Fortran::semantics::DeclTypeSpec *typeSpec = |
| getIfAllocateStmtTypeSpec(); |
| |
| // No type spec provided in allocate statement so the declared type spec is |
| // used. |
| if (!typeSpec) |
| typeSpec = &alloc.type; |
| assert(typeSpec && "type spec missing for polymorphic allocation"); |
| |
| // Set up the descriptor for allocation for intrinsic type spec on |
| // unlimited polymorphic entity. |
| if (typeSpec->AsIntrinsic() && |
| fir::isUnlimitedPolymorphicType(fir::getBase(box).getType())) { |
| if (typeSpec->AsIntrinsic()->category() == TypeCategory::Character) { |
| genRuntimeInitCharacter( |
| builder, loc, box, lenParams[0], |
| Fortran::evaluate::ToInt64(typeSpec->AsIntrinsic()->kind()) |
| .value()); |
| } else { |
| genInitIntrinsic( |
| box, typeSpec->AsIntrinsic()->category(), |
| Fortran::evaluate::ToInt64(typeSpec->AsIntrinsic()->kind()).value(), |
| alloc.getSymbol().Rank()); |
| } |
| return; |
| } |
| |
| // Do not generate calls for non derived-type type spec. |
| if (!typeSpec->AsDerived()) |
| return; |
| |
| auto typeDescAddr = Fortran::lower::getTypeDescAddr( |
| converter, loc, typeSpec->derivedTypeSpec()); |
| genInitDerived(box, typeDescAddr, alloc.getSymbol().Rank()); |
| } |
| |
| /// Returns a pointer to the DeclTypeSpec if a type-spec is provided in the |
| /// allocate statement. Returns a null pointer otherwise. |
| const Fortran::semantics::DeclTypeSpec *getIfAllocateStmtTypeSpec() const { |
| if (const auto &typeSpec = |
| std::get<std::optional<Fortran::parser::TypeSpec>>(stmt.t)) |
| return typeSpec->declTypeSpec; |
| return nullptr; |
| } |
| |
| mlir::Value genCudaAllocate(fir::FirOpBuilder &builder, mlir::Location loc, |
| const fir::MutableBoxValue &box, |
| ErrorManager &errorManager, |
| const Fortran::semantics::Symbol &sym) { |
| Fortran::lower::StatementContext stmtCtx; |
| cuf::DataAttributeAttr cudaAttr = |
| Fortran::lower::translateSymbolCUFDataAttribute(builder.getContext(), |
| sym); |
| mlir::Value errmsg = errMsgExpr ? errorManager.errMsgAddr : nullptr; |
| mlir::Value stream = |
| streamExpr |
| ? fir::getBase(converter.genExprAddr(loc, *streamExpr, stmtCtx)) |
| : nullptr; |
| mlir::Value pinned = |
| pinnedExpr |
| ? fir::getBase(converter.genExprAddr(loc, *pinnedExpr, stmtCtx)) |
| : nullptr; |
| mlir::Value source = sourceExpr ? fir::getBase(sourceExv) : nullptr; |
| |
| // Keep return type the same as a standard AllocatableAllocate call. |
| mlir::Type retTy = fir::runtime::getModel<int>()(builder.getContext()); |
| |
| bool isSourceDevice = false; |
| if (const Fortran::semantics::Symbol *sym{GetLastSymbol(sourceExpr)}) |
| if (Fortran::semantics::IsCUDADevice(*sym)) |
| isSourceDevice = true; |
| |
| bool doubleDescriptors = Fortran::lower::hasDoubleDescriptor(box.getAddr()); |
| return cuf::AllocateOp::create( |
| builder, loc, retTy, box.getAddr(), errmsg, stream, pinned, |
| source, cudaAttr, |
| errorManager.hasStatSpec() ? builder.getUnitAttr() : nullptr, |
| doubleDescriptors ? builder.getUnitAttr() : nullptr, |
| box.isPointer() ? builder.getUnitAttr() : nullptr, |
| isSourceDevice ? builder.getUnitAttr() : nullptr) |
| .getResult(); |
| } |
| |
| Fortran::lower::AbstractConverter &converter; |
| fir::FirOpBuilder &builder; |
| const Fortran::parser::AllocateStmt &stmt; |
| const Fortran::lower::SomeExpr *sourceExpr{nullptr}; |
| const Fortran::lower::SomeExpr *moldExpr{nullptr}; |
| const Fortran::lower::SomeExpr *statExpr{nullptr}; |
| const Fortran::lower::SomeExpr *errMsgExpr{nullptr}; |
| const Fortran::lower::SomeExpr *pinnedExpr{nullptr}; |
| const Fortran::lower::SomeExpr *streamExpr{nullptr}; |
| // If the allocate has a type spec, lenParams contains the |
| // value of the length parameters that were specified inside. |
| llvm::SmallVector<mlir::Value> lenParams; |
| ErrorManager errorManager; |
| // 9.7.1.2(7) The source-expr is evaluated exactly once for each AllocateStmt. |
| fir::ExtendedValue sourceExv; |
| fir::ExtendedValue moldExv; |
| |
| mlir::Location loc; |
| }; |
| } // namespace |
| |
| void Fortran::lower::genAllocateStmt( |
| Fortran::lower::AbstractConverter &converter, |
| const Fortran::parser::AllocateStmt &stmt, mlir::Location loc) { |
| AllocateStmtHelper{converter, stmt, loc}.lower(); |
| } |
| |
| //===----------------------------------------------------------------------===// |
| // Deallocate statement implementation |
| //===----------------------------------------------------------------------===// |
| |
| static void preDeallocationAction(Fortran::lower::AbstractConverter &converter, |
| fir::FirOpBuilder &builder, |
| mlir::Value beginOpValue, |
| const Fortran::semantics::Symbol &sym) { |
| if (sym.test(Fortran::semantics::Symbol::Flag::AccDeclare)) |
| Fortran::lower::attachDeclarePreDeallocAction(converter, builder, |
| beginOpValue, sym); |
| } |
| |
| static void postDeallocationAction(Fortran::lower::AbstractConverter &converter, |
| fir::FirOpBuilder &builder, |
| const Fortran::semantics::Symbol &sym) { |
| if (sym.test(Fortran::semantics::Symbol::Flag::AccDeclare)) |
| Fortran::lower::attachDeclarePostDeallocAction(converter, builder, sym); |
| } |
| |
| static mlir::Value genCudaDeallocate(fir::FirOpBuilder &builder, |
| mlir::Location loc, |
| const fir::MutableBoxValue &box, |
| ErrorManager &errorManager, |
| const Fortran::semantics::Symbol &sym) { |
| cuf::DataAttributeAttr cudaAttr = |
| Fortran::lower::translateSymbolCUFDataAttribute(builder.getContext(), |
| sym); |
| mlir::Value errmsg = |
| mlir::isa<fir::AbsentOp>(errorManager.errMsgAddr.getDefiningOp()) |
| ? nullptr |
| : errorManager.errMsgAddr; |
| |
| // Keep return type the same as a standard AllocatableDeallocate call. |
| mlir::Type retTy = fir::runtime::getModel<int>()(builder.getContext()); |
| bool doubleDescriptors = Fortran::lower::hasDoubleDescriptor(box.getAddr()); |
| return cuf::DeallocateOp::create( |
| builder, loc, retTy, box.getAddr(), errmsg, cudaAttr, |
| errorManager.hasStatSpec() ? builder.getUnitAttr() : nullptr, |
| doubleDescriptors ? builder.getUnitAttr() : nullptr, |
| box.isPointer() ? builder.getUnitAttr() : nullptr) |
| .getResult(); |
| } |
| |
| // Generate deallocation of a pointer/allocatable. |
| static mlir::Value |
| genDeallocate(fir::FirOpBuilder &builder, |
| Fortran::lower::AbstractConverter &converter, mlir::Location loc, |
| const fir::MutableBoxValue &box, ErrorManager &errorManager, |
| mlir::Value declaredTypeDesc = {}, |
| const Fortran::semantics::Symbol *symbol = nullptr) { |
| bool isCudaSymbol = symbol && Fortran::semantics::HasCUDAAttr(*symbol); |
| bool isCudaDeviceContext = cuf::isCUDADeviceContext(builder.getRegion()); |
| // A plain allocatable/pointer under -gpu=mem:unified was given the unified |
| // allocator index at ALLOCATE, so its deallocation must go through the |
| // runtime (which honors that index) rather than an inlined freemem that would |
| // call libc free() on managed memory. |
| bool implicitManagedBacking = |
| !isCudaSymbol && !isCudaDeviceContext && |
| (box.isAllocatable() || box.isPointer()) && |
| converter.getFoldingContext().languageFeatures().IsEnabled( |
| Fortran::common::LanguageFeature::CudaUnified); |
| bool inlineDeallocation = |
| !box.isDerived() && !box.isPolymorphic() && !box.hasAssumedRank() && |
| !box.isUnlimitedPolymorphic() && !errorManager.hasStatSpec() && |
| !useAllocateRuntime && !box.isPointer() && !implicitManagedBacking; |
| bool isCoarraySymbol = symbol && Fortran::evaluate::IsCoarray(*symbol); |
| |
| // Deallocate intrinsic types inline. |
| if (inlineDeallocation && !isCoarraySymbol && |
| ((isCudaSymbol && isCudaDeviceContext) || !isCudaSymbol)) { |
| // Pointers must use PointerDeallocate so that their deallocations |
| // can be validated. |
| mlir::Value ret = fir::factory::genFreemem(builder, loc, box); |
| if (symbol) |
| postDeallocationAction(converter, builder, *symbol); |
| return ret; |
| } |
| // 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; |
| if (isCoarraySymbol) { |
| stat = errorManager.hasStatSpec() |
| ? builder.createTemporary(loc, builder.getI32Type()) |
| : fir::AbsentOp::create( |
| builder, loc, builder.getRefType(builder.getI32Type())); |
| mif::DeallocCoarrayOp::create(builder, loc, box.getAddr(), stat, |
| errorManager.errMsgAddr); |
| if (errorManager.hasStatSpec()) |
| stat = fir::LoadOp::create(builder, loc, stat); |
| } else if (!isCudaSymbol) |
| stat = |
| genRuntimeDeallocate(builder, loc, box, errorManager, declaredTypeDesc); |
| else |
| stat = genCudaDeallocate(builder, loc, box, errorManager, *symbol); |
| fir::factory::syncMutableBoxFromIRBox(builder, loc, box); |
| if (symbol) |
| postDeallocationAction(converter, builder, *symbol); |
| errorManager.assignStat(builder, loc, stat); |
| return stat; |
| } |
| |
| void Fortran::lower::genDeallocateBox( |
| Fortran::lower::AbstractConverter &converter, |
| const fir::MutableBoxValue &box, mlir::Location loc, |
| const Fortran::semantics::Symbol *sym, 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, converter, loc, box, errorManager, declaredTypeDesc, |
| sym); |
| } |
| |
| void Fortran::lower::genDeallocateIfAllocated( |
| Fortran::lower::AbstractConverter &converter, |
| const fir::MutableBoxValue &box, mlir::Location loc, |
| const Fortran::semantics::Symbol *sym) { |
| fir::FirOpBuilder &builder = converter.getFirOpBuilder(); |
| mlir::Value isAllocated = |
| fir::factory::genIsAllocatedOrAssociatedTest(builder, loc, box); |
| builder.genIfThen(loc, isAllocated) |
| .genThen([&]() { |
| if (mlir::Type eleType = box.getEleTy(); |
| mlir::isa<fir::RecordType>(eleType) && box.isPolymorphic()) { |
| mlir::Value declaredTypeDesc = fir::TypeDescOp::create( |
| builder, loc, mlir::TypeAttr::get(eleType)); |
| genDeallocateBox(converter, box, loc, sym, declaredTypeDesc); |
| } else { |
| genDeallocateBox(converter, box, loc, sym); |
| } |
| }) |
| .end(); |
| } |
| |
| void Fortran::lower::genDeallocateStmt( |
| Fortran::lower::AbstractConverter &converter, |
| const Fortran::parser::DeallocateStmt &stmt, mlir::Location loc) { |
| const Fortran::lower::SomeExpr *statExpr = nullptr; |
| const Fortran::lower::SomeExpr *errMsgExpr = nullptr; |
| for (const Fortran::parser::StatOrErrmsg &statOrErr : |
| std::get<std::list<Fortran::parser::StatOrErrmsg>>(stmt.t)) |
| Fortran::common::visit( |
| Fortran::common::visitors{ |
| [&](const Fortran::parser::StatVariable &statVar) { |
| statExpr = Fortran::semantics::GetExpr(statVar); |
| }, |
| [&](const Fortran::parser::MsgVariable &errMsgVar) { |
| errMsgExpr = Fortran::semantics::GetExpr(errMsgVar); |
| }, |
| }, |
| statOrErr.u); |
| ErrorManager errorManager; |
| errorManager.init(converter, loc, statExpr, errMsgExpr); |
| fir::FirOpBuilder &builder = converter.getFirOpBuilder(); |
| mlir::OpBuilder::InsertPoint insertPt = builder.saveInsertionPoint(); |
| for (const Fortran::parser::AllocateObject &allocateObject : |
| std::get<std::list<Fortran::parser::AllocateObject>>(stmt.t)) { |
| const Fortran::semantics::Symbol &symbol = unwrapSymbol(allocateObject); |
| fir::MutableBoxValue box = |
| genMutableBoxValue(converter, loc, allocateObject); |
| mlir::Value declaredTypeDesc = {}; |
| if (box.isPolymorphic()) { |
| mlir::Type eleType = box.getEleTy(); |
| if (mlir::isa<fir::RecordType>(eleType)) |
| if (const Fortran::semantics::DerivedTypeSpec *derivedTypeSpec = |
| symbol.GetType()->AsDerived()) { |
| declaredTypeDesc = |
| Fortran::lower::getTypeDescAddr(converter, loc, *derivedTypeSpec); |
| } |
| } |
| mlir::Value beginOpValue = genDeallocate( |
| builder, converter, loc, box, errorManager, declaredTypeDesc, &symbol); |
| preDeallocationAction(converter, builder, beginOpValue, symbol); |
| } |
| builder.restoreInsertionPoint(insertPt); |
| } |
| |
| //===----------------------------------------------------------------------===// |
| // MutableBoxValue creation implementation |
| //===----------------------------------------------------------------------===// |
| |
| fir::MutableBoxValue Fortran::lower::createMutableBox( |
| Fortran::lower::AbstractConverter &converter, mlir::Location loc, |
| const Fortran::lower::pft::Variable &var, mlir::Value boxAddr, |
| mlir::ValueRange nonDeferredParams, unsigned allocator) { |
| fir::MutableBoxValue box(boxAddr, nonDeferredParams, |
| /*mutableProperties=*/{}); |
| fir::FirOpBuilder &builder = converter.getFirOpBuilder(); |
| if (!var.isGlobal() && !Fortran::semantics::IsDummy(var.getSymbol())) |
| fir::factory::disassociateMutableBox(builder, loc, box, |
| /*polymorphicSetType=*/false, |
| allocator); |
| return box; |
| } |
| |
| //===----------------------------------------------------------------------===// |
| // MutableBoxValue reading interface implementation |
| //===----------------------------------------------------------------------===// |
| |
| bool Fortran::lower::isArraySectionWithoutVectorSubscript( |
| const Fortran::lower::SomeExpr &expr) { |
| return expr.Rank() > 0 && Fortran::evaluate::IsVariable(expr) && |
| !Fortran::evaluate::UnwrapWholeSymbolDataRef(expr) && |
| !Fortran::evaluate::HasVectorSubscript(expr); |
| } |
| |
| void Fortran::lower::associateMutableBox( |
| Fortran::lower::AbstractConverter &converter, mlir::Location loc, |
| const fir::MutableBoxValue &box, const Fortran::lower::SomeExpr &source, |
| mlir::ValueRange lbounds, Fortran::lower::StatementContext &stmtCtx) { |
| fir::FirOpBuilder &builder = converter.getFirOpBuilder(); |
| if (Fortran::evaluate::UnwrapExpr<Fortran::evaluate::NullPointer>(source)) { |
| fir::factory::disassociateMutableBox(builder, loc, box); |
| cuf::genPointerSync(box.getAddr(), builder); |
| return; |
| } |
| fir::ExtendedValue rhs = converter.genExprAddr(loc, source, stmtCtx); |
| fir::factory::associateMutableBox(builder, loc, box, rhs, lbounds); |
| cuf::genPointerSync(box.getAddr(), builder); |
| } |
| |
| bool Fortran::lower::isWholeAllocatable(const Fortran::lower::SomeExpr &expr) { |
| if (const Fortran::semantics::Symbol *sym = |
| Fortran::evaluate::UnwrapWholeSymbolOrComponentDataRef(expr)) |
| return Fortran::semantics::IsAllocatable(sym->GetUltimate()); |
| return false; |
| } |
| |
| bool Fortran::lower::isWholePointer(const Fortran::lower::SomeExpr &expr) { |
| if (const Fortran::semantics::Symbol *sym = |
| Fortran::evaluate::UnwrapWholeSymbolOrComponentDataRef(expr)) |
| return Fortran::semantics::IsPointer(sym->GetUltimate()); |
| return false; |
| } |
| |
| mlir::Value Fortran::lower::getAssumedCharAllocatableOrPointerLen( |
| fir::FirOpBuilder &builder, mlir::Location loc, |
| const Fortran::semantics::Symbol &sym, mlir::Value box) { |
| // Read length from fir.box (explicit expr cannot safely be re-evaluated |
| // here). |
| auto readLength = [&]() { |
| fir::BoxValue boxLoad = |
| fir::LoadOp::create(builder, loc, fir::getBase(box)).getResult(); |
| return fir::factory::readCharLen(builder, loc, boxLoad); |
| }; |
| if (Fortran::semantics::IsOptional(sym)) { |
| mlir::IndexType idxTy = builder.getIndexType(); |
| // It is not safe to unconditionally read boxes of optionals in case |
| // they are absents. According to 15.5.2.12 3 (9), it is illegal to |
| // inquire the length of absent optional, even if non deferred, so |
| // it's fine to use undefOp in this case. |
| auto isPresent = fir::IsPresentOp::create(builder, loc, builder.getI1Type(), |
| fir::getBase(box)); |
| mlir::Value len = |
| builder.genIfOp(loc, {idxTy}, isPresent, true) |
| .genThen( |
| [&]() { fir::ResultOp::create(builder, loc, readLength()); }) |
| .genElse([&]() { |
| auto undef = fir::UndefOp::create(builder, loc, idxTy); |
| fir::ResultOp::create(builder, loc, undef.getResult()); |
| }) |
| .getResults()[0]; |
| return len; |
| } |
| |
| return readLength(); |
| } |
| |
| mlir::Value Fortran::lower::getTypeDescAddr( |
| AbstractConverter &converter, mlir::Location loc, |
| const Fortran::semantics::DerivedTypeSpec &typeSpec) { |
| mlir::Type typeDesc = |
| Fortran::lower::translateDerivedTypeToFIRType(converter, typeSpec); |
| fir::FirOpBuilder &builder = converter.getFirOpBuilder(); |
| return fir::TypeDescOp::create(builder, loc, mlir::TypeAttr::get(typeDesc)); |
| } |
