| //===-- 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); | |
| } | |
| /// 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 \p allocObj is a structure component (e.g. a%b%c), return the first | |
| /// parent carrying CUDA attributes, or nullptr when there is none. | |
| static const Fortran::semantics::Symbol * | |
| getCUDAAttrParentSymbol(const Fortran::parser::AllocateObject &allocObj) { | |
| if (const auto *sc = | |
| std::get_if<Fortran::parser::StructureComponent>(&allocObj.u)) { | |
| const Fortran::semantics::Symbol *sym = nullptr; | |
| if (findCUDAAttrInDataRef(sc->Base(), sym)) | |
| return sym; | |
| } | |
| return nullptr; | |
| } | |
| /// 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) { | |
| auto &ult = alloc.getSymbol().GetUltimate(); | |
| if (ult.test(Fortran::semantics::Symbol::Flag::AccDeclare)) | |
| Fortran::lower::attachDeclarePostAllocAction(converter, builder, ult); | |
| } | |
| 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); | |
| } | |
| /// 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 Fortran::semantics::Symbol *parent = | |
| getCUDAAttrParentSymbol(alloc.getAllocObj())) { | |
| sym = parent; | |
| return true; | |
| } | |
| 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); | |
| const auto *details{ | |
| alloc.getSymbol() | |
| .GetUltimate() | |
| .detailsIf<Fortran::semantics::ObjectEntityDetails>()}; | |
| const bool attrIsImplicit{details && details->cudaDataAttrIsImplicit()}; | |
| // An enclosing object that did ask for a memory space of its own takes | |
| // precedence over implicit an attribute. | |
| if (attrIsImplicit) { | |
| // The result is deliberately unused: reaching here means the object | |
| // carries an attribute, so isCudaAllocate is already true. Only the | |
| // symbol the allocator is taken from needs to change. | |
| 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) { | |
| auto &ult = sym.GetUltimate(); | |
| if (ult.test(Fortran::semantics::Symbol::Flag::AccDeclare)) | |
| Fortran::lower::attachDeclarePreDeallocAction(converter, builder, | |
| beginOpValue, ult); | |
| } | |
| static void postDeallocationAction(Fortran::lower::AbstractConverter &converter, | |
| fir::FirOpBuilder &builder, | |
| const Fortran::semantics::Symbol &sym) { | |
| auto &ult = sym.GetUltimate(); | |
| if (ult.test(Fortran::semantics::Symbol::Flag::AccDeclare)) | |
| Fortran::lower::attachDeclarePostDeallocAction(converter, builder, ult); | |
| } | |
| 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, | |
| const Fortran::semantics::Symbol *cudaSymbol = nullptr) { | |
| // A component inherits its parent's memory space at ALLOCATE, so the | |
| // deallocation must use the parent's attribute too. | |
| if (!cudaSymbol) | |
| cudaSymbol = symbol; | |
| bool isCudaSymbol = | |
| cudaSymbol && Fortran::semantics::HasCUDAAttr(*cudaSymbol); | |
| 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, *cudaSymbol); | |
| 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); | |
| } | |
| } | |
| const auto *details{ | |
| symbol.GetUltimate() | |
| .detailsIf<Fortran::semantics::ObjectEntityDetails>()}; | |
| // An enclosing object that did ask for a memory space of its own takes | |
| // precedence over implicit an attribute. | |
| const bool attrIsImplicit{details && details->cudaDataAttrIsImplicit()}; | |
| const Fortran::semantics::Symbol *cudaSymbol = nullptr; | |
| if ((!Fortran::semantics::HasCUDAAttr(symbol) || attrIsImplicit) && | |
| !Fortran::semantics::HasCUDAComponent(symbol)) | |
| cudaSymbol = getCUDAAttrParentSymbol(allocateObject); | |
| mlir::Value beginOpValue = | |
| genDeallocate(builder, converter, loc, box, errorManager, | |
| declaredTypeDesc, &symbol, cudaSymbol); | |
| 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)); | |
| } |