1215 lines · cpp
1//===-- Allocatable.cpp -- Allocatable statements lowering ----------------===//2//3// Part of the LLVM Project, under the Apache License v2.0 with LLVM Exceptions.4// See https://llvm.org/LICENSE.txt for license information.5// SPDX-License-Identifier: Apache-2.0 WITH LLVM-exception6//7//===----------------------------------------------------------------------===//8//9// Coding style: https://mlir.llvm.org/getting_started/DeveloperGuide/10//11//===----------------------------------------------------------------------===//12 13#include "flang/Lower/Allocatable.h"14#include "flang/Evaluate/tools.h"15#include "flang/Lower/AbstractConverter.h"16#include "flang/Lower/CUDA.h"17#include "flang/Lower/ConvertType.h"18#include "flang/Lower/ConvertVariable.h"19#include "flang/Lower/IterationSpace.h"20#include "flang/Lower/Mangler.h"21#include "flang/Lower/OpenACC.h"22#include "flang/Lower/PFTBuilder.h"23#include "flang/Lower/Runtime.h"24#include "flang/Lower/StatementContext.h"25#include "flang/Optimizer/Builder/CUFCommon.h"26#include "flang/Optimizer/Builder/FIRBuilder.h"27#include "flang/Optimizer/Builder/Runtime/RTBuilder.h"28#include "flang/Optimizer/Builder/Todo.h"29#include "flang/Optimizer/Dialect/CUF/CUFOps.h"30#include "flang/Optimizer/Dialect/FIROps.h"31#include "flang/Optimizer/Dialect/FIROpsSupport.h"32#include "flang/Optimizer/HLFIR/HLFIROps.h"33#include "flang/Optimizer/Support/FatalError.h"34#include "flang/Optimizer/Support/InternalNames.h"35#include "flang/Parser/parse-tree.h"36#include "flang/Runtime/allocatable.h"37#include "flang/Runtime/pointer.h"38#include "flang/Semantics/tools.h"39#include "flang/Semantics/type.h"40#include "llvm/Support/CommandLine.h"41 42/// By default fir memory operation fir::AllocMemOp/fir::FreeMemOp are used.43/// This switch allow forcing the use of runtime and descriptors for everything.44/// This is mainly intended as a debug switch.45static llvm::cl::opt<bool> useAllocateRuntime(46 "use-alloc-runtime",47 llvm::cl::desc("Lower allocations to fortran runtime calls"),48 llvm::cl::init(false));49/// Switch to force lowering of allocatable and pointers to descriptors in all50/// cases. This is now turned on by default since that is what will happen with51/// HLFIR lowering, so this allows getting early feedback of the impact.52/// If this turns out to cause performance regressions, a dedicated fir.box53/// "discretization pass" would make more sense to cover all the fir.box usage54/// (taking advantage of any future inlining for instance).55static llvm::cl::opt<bool> useDescForMutableBox(56 "use-desc-for-alloc",57 llvm::cl::desc("Always use descriptors for POINTER and ALLOCATABLE"),58 llvm::cl::init(true));59 60//===----------------------------------------------------------------------===//61// Error management62//===----------------------------------------------------------------------===//63 64namespace {65// Manage STAT and ERRMSG specifier information across a sequence of runtime66// calls for an ALLOCATE/DEALLOCATE stmt.67struct ErrorManager {68 void init(Fortran::lower::AbstractConverter &converter, mlir::Location loc,69 const Fortran::lower::SomeExpr *statExpr,70 const Fortran::lower::SomeExpr *errMsgExpr) {71 Fortran::lower::StatementContext stmtCtx;72 fir::FirOpBuilder &builder = converter.getFirOpBuilder();73 hasStat = builder.createBool(loc, statExpr != nullptr);74 statAddr = statExpr75 ? fir::getBase(converter.genExprAddr(loc, statExpr, stmtCtx))76 : mlir::Value{};77 errMsgAddr =78 statExpr && errMsgExpr79 ? builder.createBox(loc,80 converter.genExprAddr(loc, errMsgExpr, stmtCtx))81 : fir::AbsentOp::create(82 builder, loc,83 fir::BoxType::get(mlir::NoneType::get(builder.getContext())));84 sourceFile = fir::factory::locationToFilename(builder, loc);85 sourceLine = fir::factory::locationToLineNo(builder, loc,86 builder.getIntegerType(32));87 }88 89 bool hasStatSpec() const { return static_cast<bool>(statAddr); }90 91 void genStatCheck(fir::FirOpBuilder &builder, mlir::Location loc) {92 if (statValue) {93 mlir::Value zero =94 builder.createIntegerConstant(loc, statValue.getType(), 0);95 auto cmp = mlir::arith::CmpIOp::create(96 builder, loc, mlir::arith::CmpIPredicate::eq, statValue, zero);97 auto ifOp = fir::IfOp::create(builder, loc, cmp,98 /*withElseRegion=*/false);99 builder.setInsertionPointToStart(&ifOp.getThenRegion().front());100 }101 }102 103 void assignStat(fir::FirOpBuilder &builder, mlir::Location loc,104 mlir::Value stat) {105 if (hasStatSpec()) {106 assert(stat && "missing stat value");107 mlir::Value castStat = builder.createConvert(108 loc, fir::dyn_cast_ptrEleTy(statAddr.getType()), stat);109 fir::StoreOp::create(builder, loc, castStat, statAddr);110 statValue = stat;111 }112 }113 114 mlir::Value hasStat;115 mlir::Value errMsgAddr;116 mlir::Value sourceFile;117 mlir::Value sourceLine;118 119private:120 mlir::Value statAddr; // STAT variable address121 mlir::Value statValue; // current runtime STAT value122};123 124//===----------------------------------------------------------------------===//125// Allocatables runtime call generators126//===----------------------------------------------------------------------===//127 128using namespace Fortran::runtime;129/// Generate a runtime call to set the bounds of an allocatable or pointer130/// descriptor.131static void genRuntimeSetBounds(fir::FirOpBuilder &builder, mlir::Location loc,132 const fir::MutableBoxValue &box,133 mlir::Value dimIndex, mlir::Value lowerBound,134 mlir::Value upperBound) {135 mlir::func::FuncOp callee =136 box.isPointer()137 ? fir::runtime::getRuntimeFunc<mkRTKey(PointerSetBounds)>(loc,138 builder)139 : fir::runtime::getRuntimeFunc<mkRTKey(AllocatableSetBounds)>(140 loc, builder);141 const auto args = fir::runtime::createArguments(142 builder, loc, callee.getFunctionType(), box.getAddr(), dimIndex,143 lowerBound, upperBound);144 fir::CallOp::create(builder, loc, callee, args);145}146 147/// Generate runtime call to set the lengths of a character allocatable or148/// pointer descriptor.149static void genRuntimeInitCharacter(fir::FirOpBuilder &builder,150 mlir::Location loc,151 const fir::MutableBoxValue &box,152 mlir::Value len, int64_t kind = 0) {153 mlir::func::FuncOp callee =154 box.isPointer()155 ? fir::runtime::getRuntimeFunc<mkRTKey(PointerNullifyCharacter)>(156 loc, builder)157 : fir::runtime::getRuntimeFunc<mkRTKey(158 AllocatableInitCharacterForAllocate)>(loc, builder);159 llvm::ArrayRef<mlir::Type> inputTypes = callee.getFunctionType().getInputs();160 if (inputTypes.size() != 5)161 fir::emitFatalError(162 loc, "AllocatableInitCharacter runtime interface not as expected");163 llvm::SmallVector<mlir::Value> args = {box.getAddr(), len};164 if (kind == 0)165 kind = mlir::cast<fir::CharacterType>(box.getEleTy()).getFKind();166 args.push_back(builder.createIntegerConstant(loc, inputTypes[2], kind));167 int rank = box.rank();168 args.push_back(builder.createIntegerConstant(loc, inputTypes[3], rank));169 // TODO: coarrays170 int corank = 0;171 args.push_back(builder.createIntegerConstant(loc, inputTypes[4], corank));172 const auto convertedArgs = fir::runtime::createArguments(173 builder, loc, callee.getFunctionType(), args);174 fir::CallOp::create(builder, loc, callee, convertedArgs);175}176 177/// Generate a sequence of runtime calls to allocate memory.178static mlir::Value genRuntimeAllocate(fir::FirOpBuilder &builder,179 mlir::Location loc,180 const fir::MutableBoxValue &box,181 ErrorManager &errorManager) {182 mlir::func::FuncOp callee =183 box.isPointer()184 ? fir::runtime::getRuntimeFunc<mkRTKey(PointerAllocate)>(loc, builder)185 : fir::runtime::getRuntimeFunc<mkRTKey(AllocatableAllocate)>(loc,186 builder);187 llvm::SmallVector<mlir::Value> args{box.getAddr()};188 if (!box.isPointer())189 args.push_back(190 builder.createIntegerConstant(loc, builder.getI64Type(), -1));191 args.push_back(errorManager.hasStat);192 args.push_back(errorManager.errMsgAddr);193 args.push_back(errorManager.sourceFile);194 args.push_back(errorManager.sourceLine);195 const auto convertedArgs = fir::runtime::createArguments(196 builder, loc, callee.getFunctionType(), args);197 return fir::CallOp::create(builder, loc, callee, convertedArgs).getResult(0);198}199 200/// Generate a sequence of runtime calls to allocate memory and assign with the201/// \p source.202static mlir::Value genRuntimeAllocateSource(fir::FirOpBuilder &builder,203 mlir::Location loc,204 const fir::MutableBoxValue &box,205 fir::ExtendedValue source,206 ErrorManager &errorManager) {207 mlir::func::FuncOp callee =208 box.isPointer()209 ? fir::runtime::getRuntimeFunc<mkRTKey(PointerAllocateSource)>(210 loc, builder)211 : fir::runtime::getRuntimeFunc<mkRTKey(AllocatableAllocateSource)>(212 loc, builder);213 const auto args = fir::runtime::createArguments(214 builder, loc, callee.getFunctionType(), box.getAddr(),215 fir::getBase(source), errorManager.hasStat, errorManager.errMsgAddr,216 errorManager.sourceFile, errorManager.sourceLine);217 return fir::CallOp::create(builder, loc, callee, args).getResult(0);218}219 220/// Generate runtime call to apply mold to the descriptor.221static void genRuntimeAllocateApplyMold(fir::FirOpBuilder &builder,222 mlir::Location loc,223 const fir::MutableBoxValue &box,224 fir::ExtendedValue mold, int rank) {225 mlir::func::FuncOp callee =226 box.isPointer()227 ? fir::runtime::getRuntimeFunc<mkRTKey(PointerApplyMold)>(loc,228 builder)229 : fir::runtime::getRuntimeFunc<mkRTKey(AllocatableApplyMold)>(230 loc, builder);231 const auto args = fir::runtime::createArguments(232 builder, loc, callee.getFunctionType(),233 fir::factory::getMutableIRBox(builder, loc, box), fir::getBase(mold),234 builder.createIntegerConstant(235 loc, callee.getFunctionType().getInputs()[2], rank));236 fir::CallOp::create(builder, loc, callee, args);237}238 239/// Generate a runtime call to deallocate memory.240static mlir::Value genRuntimeDeallocate(fir::FirOpBuilder &builder,241 mlir::Location loc,242 const fir::MutableBoxValue &box,243 ErrorManager &errorManager,244 mlir::Value declaredTypeDesc = {}) {245 // Ensure fir.box is up-to-date before passing it to deallocate runtime.246 mlir::Value boxAddress = fir::factory::getMutableIRBox(builder, loc, box);247 mlir::func::FuncOp callee;248 llvm::SmallVector<mlir::Value> args;249 llvm::SmallVector<mlir::Value> operands;250 if (box.isPolymorphic() || box.isUnlimitedPolymorphic()) {251 callee = box.isPointer()252 ? fir::runtime::getRuntimeFunc<mkRTKey(253 PointerDeallocatePolymorphic)>(loc, builder)254 : fir::runtime::getRuntimeFunc<mkRTKey(255 AllocatableDeallocatePolymorphic)>(loc, builder);256 if (!declaredTypeDesc)257 declaredTypeDesc = builder.createNullConstant(loc);258 operands = fir::runtime::createArguments(259 builder, loc, callee.getFunctionType(), boxAddress, declaredTypeDesc,260 errorManager.hasStat, errorManager.errMsgAddr, errorManager.sourceFile,261 errorManager.sourceLine);262 } else {263 callee = box.isPointer()264 ? fir::runtime::getRuntimeFunc<mkRTKey(PointerDeallocate)>(265 loc, builder)266 : fir::runtime::getRuntimeFunc<mkRTKey(AllocatableDeallocate)>(267 loc, builder);268 operands = fir::runtime::createArguments(269 builder, loc, callee.getFunctionType(), boxAddress,270 errorManager.hasStat, errorManager.errMsgAddr, errorManager.sourceFile,271 errorManager.sourceLine);272 }273 return fir::CallOp::create(builder, loc, callee, operands).getResult(0);274}275 276//===----------------------------------------------------------------------===//277// Allocate statement implementation278//===----------------------------------------------------------------------===//279 280/// Helper to get symbol from AllocateObject.281static const Fortran::semantics::Symbol &282unwrapSymbol(const Fortran::parser::AllocateObject &allocObj) {283 const Fortran::parser::Name &lastName =284 Fortran::parser::GetLastName(allocObj);285 assert(lastName.symbol);286 return *lastName.symbol;287}288 289static fir::MutableBoxValue290genMutableBoxValue(Fortran::lower::AbstractConverter &converter,291 mlir::Location loc,292 const Fortran::parser::AllocateObject &allocObj) {293 const Fortran::lower::SomeExpr *expr = Fortran::semantics::GetExpr(allocObj);294 assert(expr && "semantic analysis failure");295 return converter.genExprMutableBox(loc, *expr);296}297 298/// Implement Allocate statement lowering.299class AllocateStmtHelper {300public:301 AllocateStmtHelper(Fortran::lower::AbstractConverter &converter,302 const Fortran::parser::AllocateStmt &stmt,303 mlir::Location loc)304 : converter{converter}, builder{converter.getFirOpBuilder()}, stmt{stmt},305 loc{loc} {}306 307 void lower() {308 visitAllocateOptions();309 lowerAllocateLengthParameters();310 errorManager.init(converter, loc, statExpr, errMsgExpr);311 Fortran::lower::StatementContext stmtCtx;312 if (sourceExpr)313 sourceExv = converter.genExprBox(loc, *sourceExpr, stmtCtx);314 if (moldExpr)315 moldExv = converter.genExprBox(loc, *moldExpr, stmtCtx);316 mlir::OpBuilder::InsertPoint insertPt = builder.saveInsertionPoint();317 for (const auto &allocation :318 std::get<std::list<Fortran::parser::Allocation>>(stmt.t))319 lowerAllocation(unwrapAllocation(allocation));320 builder.restoreInsertionPoint(insertPt);321 }322 323private:324 struct Allocation {325 const Fortran::parser::Allocation &alloc;326 const Fortran::semantics::DeclTypeSpec &type;327 bool hasCoarraySpec() const {328 return std::get<std::optional<Fortran::parser::AllocateCoarraySpec>>(329 alloc.t)330 .has_value();331 }332 const Fortran::parser::AllocateObject &getAllocObj() const {333 return std::get<Fortran::parser::AllocateObject>(alloc.t);334 }335 const Fortran::semantics::Symbol &getSymbol() const {336 return unwrapSymbol(getAllocObj());337 }338 const std::list<Fortran::parser::AllocateShapeSpec> &getShapeSpecs() const {339 return std::get<std::list<Fortran::parser::AllocateShapeSpec>>(alloc.t);340 }341 };342 343 Allocation unwrapAllocation(const Fortran::parser::Allocation &alloc) {344 const auto &allocObj = std::get<Fortran::parser::AllocateObject>(alloc.t);345 const Fortran::semantics::Symbol &symbol = unwrapSymbol(allocObj);346 assert(symbol.GetType());347 return Allocation{alloc, *symbol.GetType()};348 }349 350 void visitAllocateOptions() {351 for (const auto &allocOption :352 std::get<std::list<Fortran::parser::AllocOpt>>(stmt.t))353 Fortran::common::visit(354 Fortran::common::visitors{355 [&](const Fortran::parser::StatOrErrmsg &statOrErr) {356 Fortran::common::visit(357 Fortran::common::visitors{358 [&](const Fortran::parser::StatVariable &statVar) {359 statExpr = Fortran::semantics::GetExpr(statVar);360 },361 [&](const Fortran::parser::MsgVariable &errMsgVar) {362 errMsgExpr = Fortran::semantics::GetExpr(errMsgVar);363 },364 },365 statOrErr.u);366 },367 [&](const Fortran::parser::AllocOpt::Source &source) {368 sourceExpr = Fortran::semantics::GetExpr(source.v.value());369 },370 [&](const Fortran::parser::AllocOpt::Mold &mold) {371 moldExpr = Fortran::semantics::GetExpr(mold.v.value());372 },373 [&](const Fortran::parser::AllocOpt::Stream &stream) {374 streamExpr = Fortran::semantics::GetExpr(stream.v.value());375 },376 [&](const Fortran::parser::AllocOpt::Pinned &pinned) {377 pinnedExpr = Fortran::semantics::GetExpr(pinned.v.value());378 },379 },380 allocOption.u);381 }382 383 void lowerAllocation(const Allocation &alloc) {384 fir::MutableBoxValue boxAddr =385 genMutableBoxValue(converter, loc, alloc.getAllocObj());386 387 if (sourceExpr)388 genSourceMoldAllocation(alloc, boxAddr, /*isSource=*/true);389 else if (moldExpr)390 genSourceMoldAllocation(alloc, boxAddr, /*isSource=*/false);391 else392 genSimpleAllocation(alloc, boxAddr);393 }394 395 static bool lowerBoundsAreOnes(const Allocation &alloc) {396 for (const Fortran::parser::AllocateShapeSpec &shapeSpec :397 alloc.getShapeSpecs())398 if (std::get<0>(shapeSpec.t))399 return false;400 return true;401 }402 403 /// Build name for the fir::allocmem generated for alloc.404 std::string mangleAlloc(const Allocation &alloc) {405 return converter.mangleName(alloc.getSymbol()) + ".alloc";406 }407 408 /// Generate allocation without runtime calls.409 /// Only for intrinsic types. No coarrays, no polymorphism. No error recovery.410 void genInlinedAllocation(const Allocation &alloc,411 const fir::MutableBoxValue &box) {412 llvm::SmallVector<mlir::Value> lbounds;413 llvm::SmallVector<mlir::Value> extents;414 Fortran::lower::StatementContext stmtCtx;415 mlir::Type idxTy = builder.getIndexType();416 bool lBoundsAreOnes = lowerBoundsAreOnes(alloc);417 mlir::Value one = builder.createIntegerConstant(loc, idxTy, 1);418 for (const Fortran::parser::AllocateShapeSpec &shapeSpec :419 alloc.getShapeSpecs()) {420 mlir::Value lb;421 if (!lBoundsAreOnes) {422 if (const std::optional<Fortran::parser::BoundExpr> &lbExpr =423 std::get<0>(shapeSpec.t)) {424 lb = fir::getBase(converter.genExprValue(425 loc, Fortran::semantics::GetExpr(*lbExpr), stmtCtx));426 lb = builder.createConvert(loc, idxTy, lb);427 } else {428 lb = one;429 }430 lbounds.emplace_back(lb);431 }432 mlir::Value ub = fir::getBase(converter.genExprValue(433 loc, Fortran::semantics::GetExpr(std::get<1>(shapeSpec.t)), stmtCtx));434 ub = builder.createConvert(loc, idxTy, ub);435 if (lb) {436 mlir::Value diff = mlir::arith::SubIOp::create(builder, loc, ub, lb);437 extents.emplace_back(438 mlir::arith::AddIOp::create(builder, loc, diff, one));439 } else {440 extents.emplace_back(ub);441 }442 }443 fir::factory::genInlinedAllocation(builder, loc, box, lbounds, extents,444 lenParams, mangleAlloc(alloc),445 /*mustBeHeap=*/true);446 }447 448 void postAllocationAction(const Allocation &alloc,449 const fir::MutableBoxValue &box) {450 if (alloc.getSymbol().test(Fortran::semantics::Symbol::Flag::AccDeclare))451 Fortran::lower::attachDeclarePostAllocAction(converter, builder,452 alloc.getSymbol());453 }454 455 void setPinnedToFalse() {456 if (!pinnedExpr)457 return;458 Fortran::lower::StatementContext stmtCtx;459 mlir::Value pinned =460 fir::getBase(converter.genExprAddr(loc, *pinnedExpr, stmtCtx));461 mlir::Location loc = pinned.getLoc();462 mlir::Value falseValue = builder.createBool(loc, false);463 mlir::Value falseConv = builder.createConvert(464 loc, fir::unwrapRefType(pinned.getType()), falseValue);465 fir::StoreOp::create(builder, loc, falseConv, pinned);466 }467 468 void genSimpleAllocation(const Allocation &alloc,469 const fir::MutableBoxValue &box) {470 bool isCudaAllocate =471 Fortran::semantics::HasCUDAAttr(alloc.getSymbol()) ||472 Fortran::semantics::HasCUDAComponent(alloc.getSymbol());473 bool isCudaDeviceContext = cuf::isCUDADeviceContext(builder.getRegion());474 bool inlineAllocation = !box.isDerived() && !errorManager.hasStatSpec() &&475 !alloc.type.IsPolymorphic() &&476 !alloc.hasCoarraySpec() && !useAllocateRuntime &&477 !box.isPointer();478 unsigned allocatorIdx = Fortran::lower::getAllocatorIdx(alloc.getSymbol());479 480 if (inlineAllocation &&481 ((isCudaAllocate && isCudaDeviceContext) || !isCudaAllocate)) {482 // Pointers must use PointerAllocate so that their deallocations483 // can be validated.484 genInlinedAllocation(alloc, box);485 postAllocationAction(alloc, box);486 setPinnedToFalse();487 return;488 }489 490 // Preserve characters' dynamic length.491 if (lenParams.empty() && box.isCharacter() &&492 !box.hasNonDeferredLenParams()) {493 auto charTy = mlir::dyn_cast<fir::CharacterType>(box.getEleTy());494 if (charTy && charTy.hasDynamicLen()) {495 fir::ExtendedValue exv{box};496 lenParams.push_back(fir::factory::readCharLen(builder, loc, exv));497 }498 }499 500 // Generate a sequence of runtime calls.501 errorManager.genStatCheck(builder, loc);502 genAllocateObjectInit(box, allocatorIdx);503 if (alloc.hasCoarraySpec())504 TODO(loc, "coarray: allocation of a coarray object");505 if (alloc.type.IsPolymorphic())506 genSetType(alloc, box, loc);507 genSetDeferredLengthParameters(alloc, box);508 genAllocateObjectBounds(alloc, box);509 mlir::Value stat;510 if (!isCudaAllocate) {511 stat = genRuntimeAllocate(builder, loc, box, errorManager);512 setPinnedToFalse();513 } else {514 stat =515 genCudaAllocate(builder, loc, box, errorManager, alloc.getSymbol());516 }517 fir::factory::syncMutableBoxFromIRBox(builder, loc, box);518 postAllocationAction(alloc, box);519 errorManager.assignStat(builder, loc, stat);520 }521 522 /// Lower the length parameters that may be specified in the optional523 /// type specification.524 void lowerAllocateLengthParameters() {525 const Fortran::semantics::DeclTypeSpec *typeSpec =526 getIfAllocateStmtTypeSpec();527 if (!typeSpec)528 return;529 if (const Fortran::semantics::DerivedTypeSpec *derived =530 typeSpec->AsDerived())531 if (Fortran::semantics::CountLenParameters(*derived) > 0)532 TODO(loc, "setting derived type params in allocation");533 if (typeSpec->category() ==534 Fortran::semantics::DeclTypeSpec::Category::Character) {535 Fortran::semantics::ParamValue lenParam =536 typeSpec->characterTypeSpec().length();537 if (Fortran::semantics::MaybeIntExpr intExpr = lenParam.GetExplicit()) {538 Fortran::lower::StatementContext stmtCtx;539 Fortran::lower::SomeExpr lenExpr{*intExpr};540 lenParams.push_back(541 fir::getBase(converter.genExprValue(loc, lenExpr, stmtCtx)));542 }543 }544 }545 546 // Set length parameters in the box stored in boxAddr.547 // This must be called before setting the bounds because it may use548 // Init runtime calls that may set the bounds to zero.549 void genSetDeferredLengthParameters(const Allocation &alloc,550 const fir::MutableBoxValue &box) {551 if (lenParams.empty())552 return;553 // TODO: in case a length parameter was not deferred, insert a runtime check554 // that the length is the same (AllocatableCheckLengthParameter runtime555 // call).556 if (box.isCharacter())557 genRuntimeInitCharacter(builder, loc, box, lenParams[0]);558 559 if (box.isDerived())560 TODO(loc, "derived type length parameters in allocate");561 }562 563 void genAllocateObjectInit(const fir::MutableBoxValue &box,564 unsigned allocatorIdx) {565 if (box.isPointer()) {566 // For pointers, the descriptor may still be uninitialized (see Fortran567 // 2018 19.5.2.2). The allocation runtime needs to be given a descriptor568 // with initialized rank, types and attributes. Initialize the descriptor569 // here to ensure these constraints are fulfilled.570 mlir::Value nullPointer = fir::factory::createUnallocatedBox(571 builder, loc, box.getBoxTy(), box.nonDeferredLenParams(),572 /*typeSourceBox=*/{}, allocatorIdx);573 fir::StoreOp::create(builder, loc, nullPointer, box.getAddr());574 } else {575 assert(box.isAllocatable() && "must be an allocatable");576 // For allocatables, sync the MutableBoxValue and descriptor before the577 // calls in case it is tracked locally by a set of variables.578 fir::factory::getMutableIRBox(builder, loc, box);579 }580 }581 582 void genAllocateObjectBounds(const Allocation &alloc,583 const fir::MutableBoxValue &box) {584 // Set bounds for arrays585 mlir::Type idxTy = builder.getIndexType();586 mlir::Type i32Ty = builder.getIntegerType(32);587 Fortran::lower::StatementContext stmtCtx;588 for (const auto &iter : llvm::enumerate(alloc.getShapeSpecs())) {589 mlir::Value lb;590 const auto &bounds = iter.value().t;591 if (const std::optional<Fortran::parser::BoundExpr> &lbExpr =592 std::get<0>(bounds))593 lb = fir::getBase(converter.genExprValue(594 loc, Fortran::semantics::GetExpr(*lbExpr), stmtCtx));595 else596 lb = builder.createIntegerConstant(loc, idxTy, 1);597 mlir::Value ub = fir::getBase(converter.genExprValue(598 loc, Fortran::semantics::GetExpr(std::get<1>(bounds)), stmtCtx));599 mlir::Value dimIndex =600 builder.createIntegerConstant(loc, i32Ty, iter.index());601 // Runtime call602 genRuntimeSetBounds(builder, loc, box, dimIndex, lb, ub);603 }604 if (sourceExpr && sourceExpr->Rank() > 0 &&605 alloc.getShapeSpecs().size() == 0) {606 // If the alloc object does not have shape list, get the bounds from the607 // source expression.608 mlir::Value one = builder.createIntegerConstant(loc, idxTy, 1);609 const auto *sourceBox = sourceExv.getBoxOf<fir::BoxValue>();610 assert(sourceBox && "source expression should be lowered to one box");611 for (int i = 0; i < sourceExpr->Rank(); ++i) {612 auto dimVal = builder.createIntegerConstant(loc, idxTy, i);613 auto dimInfo = fir::BoxDimsOp::create(builder, loc, idxTy, idxTy, idxTy,614 sourceBox->getAddr(), dimVal);615 mlir::Value lb =616 fir::factory::readLowerBound(builder, loc, sourceExv, i, one);617 mlir::Value extent = dimInfo.getResult(1);618 mlir::Value ub = mlir::arith::SubIOp::create(619 builder, loc, mlir::arith::AddIOp::create(builder, loc, extent, lb),620 one);621 mlir::Value dimIndex = builder.createIntegerConstant(loc, i32Ty, i);622 genRuntimeSetBounds(builder, loc, box, dimIndex, lb, ub);623 }624 }625 }626 627 void genSourceMoldAllocation(const Allocation &alloc,628 const fir::MutableBoxValue &box, bool isSource) {629 unsigned allocatorIdx = Fortran::lower::getAllocatorIdx(alloc.getSymbol());630 fir::ExtendedValue exv = isSource ? sourceExv : moldExv;631 632 if (const Fortran::semantics::Symbol *sym{GetLastSymbol(sourceExpr)})633 if (Fortran::semantics::IsCUDADevice(*sym))634 TODO(loc, "CUDA Fortran: allocate with device source");635 636 // Generate a sequence of runtime calls.637 errorManager.genStatCheck(builder, loc);638 genAllocateObjectInit(box, allocatorIdx);639 if (alloc.hasCoarraySpec())640 TODO(loc, "coarray: allocation of a coarray object");641 // Set length of the allocate object if it has. Otherwise, get the length642 // from source for the deferred length parameter.643 const bool isDeferredLengthCharacter =644 box.isCharacter() && !box.hasNonDeferredLenParams();645 if (lenParams.empty() && isDeferredLengthCharacter)646 lenParams.push_back(fir::factory::readCharLen(builder, loc, exv));647 if (!isSource || alloc.type.IsPolymorphic())648 genRuntimeAllocateApplyMold(builder, loc, box, exv,649 alloc.getSymbol().Rank());650 if (isDeferredLengthCharacter)651 genSetDeferredLengthParameters(alloc, box);652 genAllocateObjectBounds(alloc, box);653 mlir::Value stat;654 if (Fortran::semantics::HasCUDAAttr(alloc.getSymbol())) {655 stat =656 genCudaAllocate(builder, loc, box, errorManager, alloc.getSymbol());657 } else {658 if (isSource)659 stat = genRuntimeAllocateSource(builder, loc, box, exv, errorManager);660 else661 stat = genRuntimeAllocate(builder, loc, box, errorManager);662 setPinnedToFalse();663 }664 fir::factory::syncMutableBoxFromIRBox(builder, loc, box);665 postAllocationAction(alloc, box);666 errorManager.assignStat(builder, loc, stat);667 }668 669 /// Generate call to PointerNullifyDerived or AllocatableInitDerived670 /// to set the dynamic type information.671 void genInitDerived(const fir::MutableBoxValue &box, mlir::Value typeDescAddr,672 int rank, int corank = 0) {673 mlir::func::FuncOp callee =674 box.isPointer()675 ? fir::runtime::getRuntimeFunc<mkRTKey(PointerNullifyDerived)>(676 loc, builder)677 : fir::runtime::getRuntimeFunc<mkRTKey(678 AllocatableInitDerivedForAllocate)>(loc, builder);679 680 llvm::ArrayRef<mlir::Type> inputTypes =681 callee.getFunctionType().getInputs();682 mlir::Value rankValue =683 builder.createIntegerConstant(loc, inputTypes[2], rank);684 mlir::Value corankValue =685 builder.createIntegerConstant(loc, inputTypes[3], corank);686 const auto args = fir::runtime::createArguments(687 builder, loc, callee.getFunctionType(), box.getAddr(), typeDescAddr,688 rankValue, corankValue);689 fir::CallOp::create(builder, loc, callee, args);690 }691 692 /// Generate call to PointerNullifyIntrinsic or AllocatableInitIntrinsic to693 /// set the dynamic type information for a polymorphic entity from an694 /// intrinsic type spec.695 void genInitIntrinsic(const fir::MutableBoxValue &box,696 const TypeCategory category, int64_t kind, int rank,697 int corank = 0) {698 mlir::func::FuncOp callee =699 box.isPointer()700 ? fir::runtime::getRuntimeFunc<mkRTKey(PointerNullifyIntrinsic)>(701 loc, builder)702 : fir::runtime::getRuntimeFunc<mkRTKey(703 AllocatableInitIntrinsicForAllocate)>(loc, builder);704 705 llvm::ArrayRef<mlir::Type> inputTypes =706 callee.getFunctionType().getInputs();707 mlir::Value categoryValue = builder.createIntegerConstant(708 loc, inputTypes[1], static_cast<int32_t>(category));709 mlir::Value kindValue =710 builder.createIntegerConstant(loc, inputTypes[2], kind);711 mlir::Value rankValue =712 builder.createIntegerConstant(loc, inputTypes[3], rank);713 mlir::Value corankValue =714 builder.createIntegerConstant(loc, inputTypes[4], corank);715 const auto args = fir::runtime::createArguments(716 builder, loc, callee.getFunctionType(), box.getAddr(), categoryValue,717 kindValue, rankValue, corankValue);718 fir::CallOp::create(builder, loc, callee, args);719 }720 721 /// Generate call to the AllocatableInitDerived to set up the type descriptor722 /// and other part of the descriptor for derived type.723 void genSetType(const Allocation &alloc, const fir::MutableBoxValue &box,724 mlir::Location loc) {725 const Fortran::semantics::DeclTypeSpec *typeSpec =726 getIfAllocateStmtTypeSpec();727 728 // No type spec provided in allocate statement so the declared type spec is729 // used.730 if (!typeSpec)731 typeSpec = &alloc.type;732 assert(typeSpec && "type spec missing for polymorphic allocation");733 734 // Set up the descriptor for allocation for intrinsic type spec on735 // unlimited polymorphic entity.736 if (typeSpec->AsIntrinsic() &&737 fir::isUnlimitedPolymorphicType(fir::getBase(box).getType())) {738 if (typeSpec->AsIntrinsic()->category() == TypeCategory::Character) {739 genRuntimeInitCharacter(740 builder, loc, box, lenParams[0],741 Fortran::evaluate::ToInt64(typeSpec->AsIntrinsic()->kind())742 .value());743 } else {744 genInitIntrinsic(745 box, typeSpec->AsIntrinsic()->category(),746 Fortran::evaluate::ToInt64(typeSpec->AsIntrinsic()->kind()).value(),747 alloc.getSymbol().Rank());748 }749 return;750 }751 752 // Do not generate calls for non derived-type type spec.753 if (!typeSpec->AsDerived())754 return;755 756 auto typeDescAddr = Fortran::lower::getTypeDescAddr(757 converter, loc, typeSpec->derivedTypeSpec());758 genInitDerived(box, typeDescAddr, alloc.getSymbol().Rank());759 }760 761 /// Returns a pointer to the DeclTypeSpec if a type-spec is provided in the762 /// allocate statement. Returns a null pointer otherwise.763 const Fortran::semantics::DeclTypeSpec *getIfAllocateStmtTypeSpec() const {764 if (const auto &typeSpec =765 std::get<std::optional<Fortran::parser::TypeSpec>>(stmt.t))766 return typeSpec->declTypeSpec;767 return nullptr;768 }769 770 mlir::Value genCudaAllocate(fir::FirOpBuilder &builder, mlir::Location loc,771 const fir::MutableBoxValue &box,772 ErrorManager &errorManager,773 const Fortran::semantics::Symbol &sym) {774 775 if (const Fortran::semantics::DeclTypeSpec *declTypeSpec = sym.GetType())776 if (const Fortran::semantics::DerivedTypeSpec *derivedTypeSpec =777 declTypeSpec->AsDerived())778 if (derivedTypeSpec->HasDefaultInitialization(779 /*ignoreAllocatable=*/true, /*ignorePointer=*/true))780 TODO(loc,781 "CUDA Fortran: allocate on device with default initialization");782 783 Fortran::lower::StatementContext stmtCtx;784 cuf::DataAttributeAttr cudaAttr =785 Fortran::lower::translateSymbolCUFDataAttribute(builder.getContext(),786 sym);787 mlir::Value errmsg = errMsgExpr ? errorManager.errMsgAddr : nullptr;788 mlir::Value stream =789 streamExpr790 ? fir::getBase(converter.genExprAddr(loc, *streamExpr, stmtCtx))791 : nullptr;792 mlir::Value pinned =793 pinnedExpr794 ? fir::getBase(converter.genExprAddr(loc, *pinnedExpr, stmtCtx))795 : nullptr;796 mlir::Value source = sourceExpr ? fir::getBase(sourceExv) : nullptr;797 798 // Keep return type the same as a standard AllocatableAllocate call.799 mlir::Type retTy = fir::runtime::getModel<int>()(builder.getContext());800 801 return cuf::AllocateOp::create(802 builder, loc, retTy, box.getAddr(), errmsg, stream, pinned,803 source, cudaAttr,804 errorManager.hasStatSpec() ? builder.getUnitAttr() : nullptr)805 .getResult();806 }807 808 Fortran::lower::AbstractConverter &converter;809 fir::FirOpBuilder &builder;810 const Fortran::parser::AllocateStmt &stmt;811 const Fortran::lower::SomeExpr *sourceExpr{nullptr};812 const Fortran::lower::SomeExpr *moldExpr{nullptr};813 const Fortran::lower::SomeExpr *statExpr{nullptr};814 const Fortran::lower::SomeExpr *errMsgExpr{nullptr};815 const Fortran::lower::SomeExpr *pinnedExpr{nullptr};816 const Fortran::lower::SomeExpr *streamExpr{nullptr};817 // If the allocate has a type spec, lenParams contains the818 // value of the length parameters that were specified inside.819 llvm::SmallVector<mlir::Value> lenParams;820 ErrorManager errorManager;821 // 9.7.1.2(7) The source-expr is evaluated exactly once for each AllocateStmt.822 fir::ExtendedValue sourceExv;823 fir::ExtendedValue moldExv;824 825 mlir::Location loc;826};827} // namespace828 829void Fortran::lower::genAllocateStmt(830 Fortran::lower::AbstractConverter &converter,831 const Fortran::parser::AllocateStmt &stmt, mlir::Location loc) {832 AllocateStmtHelper{converter, stmt, loc}.lower();833}834 835//===----------------------------------------------------------------------===//836// Deallocate statement implementation837//===----------------------------------------------------------------------===//838 839static void preDeallocationAction(Fortran::lower::AbstractConverter &converter,840 fir::FirOpBuilder &builder,841 mlir::Value beginOpValue,842 const Fortran::semantics::Symbol &sym) {843 if (sym.test(Fortran::semantics::Symbol::Flag::AccDeclare))844 Fortran::lower::attachDeclarePreDeallocAction(converter, builder,845 beginOpValue, sym);846}847 848static void postDeallocationAction(Fortran::lower::AbstractConverter &converter,849 fir::FirOpBuilder &builder,850 const Fortran::semantics::Symbol &sym) {851 if (sym.test(Fortran::semantics::Symbol::Flag::AccDeclare))852 Fortran::lower::attachDeclarePostDeallocAction(converter, builder, sym);853}854 855static mlir::Value genCudaDeallocate(fir::FirOpBuilder &builder,856 mlir::Location loc,857 const fir::MutableBoxValue &box,858 ErrorManager &errorManager,859 const Fortran::semantics::Symbol &sym) {860 cuf::DataAttributeAttr cudaAttr =861 Fortran::lower::translateSymbolCUFDataAttribute(builder.getContext(),862 sym);863 mlir::Value errmsg =864 mlir::isa<fir::AbsentOp>(errorManager.errMsgAddr.getDefiningOp())865 ? nullptr866 : errorManager.errMsgAddr;867 868 // Keep return type the same as a standard AllocatableAllocate call.869 mlir::Type retTy = fir::runtime::getModel<int>()(builder.getContext());870 return cuf::DeallocateOp::create(871 builder, loc, retTy, box.getAddr(), errmsg, cudaAttr,872 errorManager.hasStatSpec() ? builder.getUnitAttr() : nullptr)873 .getResult();874}875 876// Generate deallocation of a pointer/allocatable.877static mlir::Value878genDeallocate(fir::FirOpBuilder &builder,879 Fortran::lower::AbstractConverter &converter, mlir::Location loc,880 const fir::MutableBoxValue &box, ErrorManager &errorManager,881 mlir::Value declaredTypeDesc = {},882 const Fortran::semantics::Symbol *symbol = nullptr) {883 bool isCudaSymbol = symbol && Fortran::semantics::HasCUDAAttr(*symbol);884 bool isCudaDeviceContext = cuf::isCUDADeviceContext(builder.getRegion());885 bool inlineDeallocation =886 !box.isDerived() && !box.isPolymorphic() && !box.hasAssumedRank() &&887 !box.isUnlimitedPolymorphic() && !errorManager.hasStatSpec() &&888 !useAllocateRuntime && !box.isPointer();889 // Deallocate intrinsic types inline.890 if (inlineDeallocation &&891 ((isCudaSymbol && isCudaDeviceContext) || !isCudaSymbol)) {892 // Pointers must use PointerDeallocate so that their deallocations893 // can be validated.894 mlir::Value ret = fir::factory::genFreemem(builder, loc, box);895 if (symbol)896 postDeallocationAction(converter, builder, *symbol);897 return ret;898 }899 // Use runtime calls to deallocate descriptor cases. Sync MutableBoxValue900 // with its descriptor before and after calls if needed.901 errorManager.genStatCheck(builder, loc);902 mlir::Value stat;903 if (!isCudaSymbol)904 stat =905 genRuntimeDeallocate(builder, loc, box, errorManager, declaredTypeDesc);906 else907 stat = genCudaDeallocate(builder, loc, box, errorManager, *symbol);908 fir::factory::syncMutableBoxFromIRBox(builder, loc, box);909 if (symbol)910 postDeallocationAction(converter, builder, *symbol);911 errorManager.assignStat(builder, loc, stat);912 return stat;913}914 915void Fortran::lower::genDeallocateBox(916 Fortran::lower::AbstractConverter &converter,917 const fir::MutableBoxValue &box, mlir::Location loc,918 const Fortran::semantics::Symbol *sym, mlir::Value declaredTypeDesc) {919 const Fortran::lower::SomeExpr *statExpr = nullptr;920 const Fortran::lower::SomeExpr *errMsgExpr = nullptr;921 ErrorManager errorManager;922 errorManager.init(converter, loc, statExpr, errMsgExpr);923 fir::FirOpBuilder &builder = converter.getFirOpBuilder();924 genDeallocate(builder, converter, loc, box, errorManager, declaredTypeDesc,925 sym);926}927 928void Fortran::lower::genDeallocateIfAllocated(929 Fortran::lower::AbstractConverter &converter,930 const fir::MutableBoxValue &box, mlir::Location loc,931 const Fortran::semantics::Symbol *sym) {932 fir::FirOpBuilder &builder = converter.getFirOpBuilder();933 mlir::Value isAllocated =934 fir::factory::genIsAllocatedOrAssociatedTest(builder, loc, box);935 builder.genIfThen(loc, isAllocated)936 .genThen([&]() {937 if (mlir::Type eleType = box.getEleTy();938 mlir::isa<fir::RecordType>(eleType) && box.isPolymorphic()) {939 mlir::Value declaredTypeDesc = fir::TypeDescOp::create(940 builder, loc, mlir::TypeAttr::get(eleType));941 genDeallocateBox(converter, box, loc, sym, declaredTypeDesc);942 } else {943 genDeallocateBox(converter, box, loc, sym);944 }945 })946 .end();947}948 949void Fortran::lower::genDeallocateStmt(950 Fortran::lower::AbstractConverter &converter,951 const Fortran::parser::DeallocateStmt &stmt, mlir::Location loc) {952 const Fortran::lower::SomeExpr *statExpr = nullptr;953 const Fortran::lower::SomeExpr *errMsgExpr = nullptr;954 for (const Fortran::parser::StatOrErrmsg &statOrErr :955 std::get<std::list<Fortran::parser::StatOrErrmsg>>(stmt.t))956 Fortran::common::visit(957 Fortran::common::visitors{958 [&](const Fortran::parser::StatVariable &statVar) {959 statExpr = Fortran::semantics::GetExpr(statVar);960 },961 [&](const Fortran::parser::MsgVariable &errMsgVar) {962 errMsgExpr = Fortran::semantics::GetExpr(errMsgVar);963 },964 },965 statOrErr.u);966 ErrorManager errorManager;967 errorManager.init(converter, loc, statExpr, errMsgExpr);968 fir::FirOpBuilder &builder = converter.getFirOpBuilder();969 mlir::OpBuilder::InsertPoint insertPt = builder.saveInsertionPoint();970 for (const Fortran::parser::AllocateObject &allocateObject :971 std::get<std::list<Fortran::parser::AllocateObject>>(stmt.t)) {972 const Fortran::semantics::Symbol &symbol = unwrapSymbol(allocateObject);973 fir::MutableBoxValue box =974 genMutableBoxValue(converter, loc, allocateObject);975 mlir::Value declaredTypeDesc = {};976 if (box.isPolymorphic()) {977 mlir::Type eleType = box.getEleTy();978 if (mlir::isa<fir::RecordType>(eleType))979 if (const Fortran::semantics::DerivedTypeSpec *derivedTypeSpec =980 symbol.GetType()->AsDerived()) {981 declaredTypeDesc =982 Fortran::lower::getTypeDescAddr(converter, loc, *derivedTypeSpec);983 }984 }985 mlir::Value beginOpValue = genDeallocate(986 builder, converter, loc, box, errorManager, declaredTypeDesc, &symbol);987 preDeallocationAction(converter, builder, beginOpValue, symbol);988 }989 builder.restoreInsertionPoint(insertPt);990}991 992//===----------------------------------------------------------------------===//993// MutableBoxValue creation implementation994//===----------------------------------------------------------------------===//995 996/// Is this symbol a pointer to a pointer array that does not have the997/// CONTIGUOUS attribute ?998static inline bool999isNonContiguousArrayPointer(const Fortran::semantics::Symbol &sym) {1000 return Fortran::semantics::IsPointer(sym) && sym.Rank() != 0 &&1001 !sym.attrs().test(Fortran::semantics::Attr::CONTIGUOUS);1002}1003 1004/// Is this symbol a polymorphic pointer?1005static inline bool isPolymorphicPointer(const Fortran::semantics::Symbol &sym) {1006 return Fortran::semantics::IsPointer(sym) &&1007 Fortran::semantics::IsPolymorphic(sym);1008}1009 1010/// Is this symbol a polymorphic allocatable?1011static inline bool1012isPolymorphicAllocatable(const Fortran::semantics::Symbol &sym) {1013 return Fortran::semantics::IsAllocatable(sym) &&1014 Fortran::semantics::IsPolymorphic(sym);1015}1016 1017/// Is this a local procedure symbol in a procedure that contains internal1018/// procedures ?1019static bool mayBeCapturedInInternalProc(const Fortran::semantics::Symbol &sym) {1020 const Fortran::semantics::Scope &owner = sym.owner();1021 Fortran::semantics::Scope::Kind kind = owner.kind();1022 // Test if this is a procedure scope that contains a subprogram scope that is1023 // not an interface.1024 if (kind == Fortran::semantics::Scope::Kind::Subprogram ||1025 kind == Fortran::semantics::Scope::Kind::MainProgram)1026 for (const Fortran::semantics::Scope &childScope : owner.children())1027 if (childScope.kind() == Fortran::semantics::Scope::Kind::Subprogram)1028 if (const Fortran::semantics::Symbol *childSym = childScope.symbol())1029 if (const auto *details =1030 childSym->detailsIf<Fortran::semantics::SubprogramDetails>())1031 if (!details->isInterface())1032 return true;1033 return false;1034}1035 1036/// In case it is safe to track the properties in variables outside a1037/// descriptor, create the variables to hold the mutable properties of the1038/// entity var. The variables are not initialized here.1039static fir::MutableProperties1040createMutableProperties(Fortran::lower::AbstractConverter &converter,1041 mlir::Location loc,1042 const Fortran::lower::pft::Variable &var,1043 mlir::ValueRange nonDeferredParams, bool alwaysUseBox) {1044 fir::FirOpBuilder &builder = converter.getFirOpBuilder();1045 const Fortran::semantics::Symbol &sym = var.getSymbol();1046 // Globals and dummies may be associated, creating local variables would1047 // require keeping the values and descriptor before and after every single1048 // impure calls in the current scope (not only the ones taking the variable as1049 // arguments. All.) Volatile means the variable may change in ways not defined1050 // per Fortran, so lowering can most likely not keep the descriptor and values1051 // in sync as needed.1052 // Pointers to non contiguous arrays need to be represented with a fir.box to1053 // account for the discontiguity.1054 // Pointer/Allocatable in internal procedure are descriptors in the host link,1055 // and it would increase complexity to sync this descriptor with the local1056 // values every time the host link is escaping.1057 if (alwaysUseBox || var.isGlobal() || Fortran::semantics::IsDummy(sym) ||1058 Fortran::semantics::IsFunctionResult(sym) ||1059 sym.attrs().test(Fortran::semantics::Attr::VOLATILE) ||1060 isNonContiguousArrayPointer(sym) || useAllocateRuntime ||1061 useDescForMutableBox || mayBeCapturedInInternalProc(sym) ||1062 isPolymorphicPointer(sym) || isPolymorphicAllocatable(sym))1063 return {};1064 fir::MutableProperties mutableProperties;1065 std::string name = converter.mangleName(sym);1066 mlir::Type baseAddrTy = converter.genType(sym);1067 if (auto boxType = mlir::dyn_cast<fir::BaseBoxType>(baseAddrTy))1068 baseAddrTy = boxType.getEleTy();1069 // Allocate and set a variable to hold the address.1070 // It will be set to null in setUnallocatedStatus.1071 mutableProperties.addr =1072 builder.allocateLocal(loc, baseAddrTy, name + ".addr", "",1073 /*shape=*/{}, /*typeparams=*/{});1074 // Allocate variables to hold lower bounds and extents.1075 int rank = sym.Rank();1076 mlir::Type idxTy = builder.getIndexType();1077 for (decltype(rank) i = 0; i < rank; ++i) {1078 mlir::Value lboundVar =1079 builder.allocateLocal(loc, idxTy, name + ".lb" + std::to_string(i), "",1080 /*shape=*/{}, /*typeparams=*/{});1081 mlir::Value extentVar =1082 builder.allocateLocal(loc, idxTy, name + ".ext" + std::to_string(i), "",1083 /*shape=*/{}, /*typeparams=*/{});1084 mutableProperties.lbounds.emplace_back(lboundVar);1085 mutableProperties.extents.emplace_back(extentVar);1086 }1087 1088 // Allocate variable to hold deferred length parameters.1089 mlir::Type eleTy = baseAddrTy;1090 if (auto newTy = fir::dyn_cast_ptrEleTy(eleTy))1091 eleTy = newTy;1092 if (auto seqTy = mlir::dyn_cast<fir::SequenceType>(eleTy))1093 eleTy = seqTy.getEleTy();1094 if (auto record = mlir::dyn_cast<fir::RecordType>(eleTy))1095 if (record.getNumLenParams() != 0)1096 TODO(loc, "deferred length type parameters.");1097 if (fir::isa_char(eleTy) && nonDeferredParams.empty()) {1098 mlir::Value lenVar = builder.allocateLocal(1099 loc, builder.getCharacterLengthType(), name + ".len", "", /*shape=*/{},1100 /*typeparams=*/{});1101 mutableProperties.deferredParams.emplace_back(lenVar);1102 }1103 return mutableProperties;1104}1105 1106fir::MutableBoxValue Fortran::lower::createMutableBox(1107 Fortran::lower::AbstractConverter &converter, mlir::Location loc,1108 const Fortran::lower::pft::Variable &var, mlir::Value boxAddr,1109 mlir::ValueRange nonDeferredParams, bool alwaysUseBox, unsigned allocator) {1110 fir::MutableProperties mutableProperties = createMutableProperties(1111 converter, loc, var, nonDeferredParams, alwaysUseBox);1112 fir::MutableBoxValue box(boxAddr, nonDeferredParams, mutableProperties);1113 fir::FirOpBuilder &builder = converter.getFirOpBuilder();1114 if (!var.isGlobal() && !Fortran::semantics::IsDummy(var.getSymbol()))1115 fir::factory::disassociateMutableBox(builder, loc, box,1116 /*polymorphicSetType=*/false,1117 allocator);1118 return box;1119}1120 1121//===----------------------------------------------------------------------===//1122// MutableBoxValue reading interface implementation1123//===----------------------------------------------------------------------===//1124 1125bool Fortran::lower::isArraySectionWithoutVectorSubscript(1126 const Fortran::lower::SomeExpr &expr) {1127 return expr.Rank() > 0 && Fortran::evaluate::IsVariable(expr) &&1128 !Fortran::evaluate::UnwrapWholeSymbolDataRef(expr) &&1129 !Fortran::evaluate::HasVectorSubscript(expr);1130}1131 1132void Fortran::lower::associateMutableBox(1133 Fortran::lower::AbstractConverter &converter, mlir::Location loc,1134 const fir::MutableBoxValue &box, const Fortran::lower::SomeExpr &source,1135 mlir::ValueRange lbounds, Fortran::lower::StatementContext &stmtCtx) {1136 fir::FirOpBuilder &builder = converter.getFirOpBuilder();1137 if (Fortran::evaluate::UnwrapExpr<Fortran::evaluate::NullPointer>(source)) {1138 fir::factory::disassociateMutableBox(builder, loc, box);1139 cuf::genPointerSync(box.getAddr(), builder);1140 return;1141 }1142 if (converter.getLoweringOptions().getLowerToHighLevelFIR()) {1143 fir::ExtendedValue rhs = converter.genExprAddr(loc, source, stmtCtx);1144 fir::factory::associateMutableBox(builder, loc, box, rhs, lbounds);1145 cuf::genPointerSync(box.getAddr(), builder);1146 return;1147 }1148 // The right hand side is not be evaluated into a temp. Array sections can1149 // typically be represented as a value of type `!fir.box`. However, an1150 // expression that uses vector subscripts cannot be emboxed. In that case,1151 // generate a reference to avoid having to later use a fir.rebox to implement1152 // the pointer association.1153 fir::ExtendedValue rhs = isArraySectionWithoutVectorSubscript(source)1154 ? converter.genExprBox(loc, source, stmtCtx)1155 : converter.genExprAddr(loc, source, stmtCtx);1156 1157 fir::factory::associateMutableBox(builder, loc, box, rhs, lbounds);1158}1159 1160bool Fortran::lower::isWholeAllocatable(const Fortran::lower::SomeExpr &expr) {1161 if (const Fortran::semantics::Symbol *sym =1162 Fortran::evaluate::UnwrapWholeSymbolOrComponentDataRef(expr))1163 return Fortran::semantics::IsAllocatable(sym->GetUltimate());1164 return false;1165}1166 1167bool Fortran::lower::isWholePointer(const Fortran::lower::SomeExpr &expr) {1168 if (const Fortran::semantics::Symbol *sym =1169 Fortran::evaluate::UnwrapWholeSymbolOrComponentDataRef(expr))1170 return Fortran::semantics::IsPointer(sym->GetUltimate());1171 return false;1172}1173 1174mlir::Value Fortran::lower::getAssumedCharAllocatableOrPointerLen(1175 fir::FirOpBuilder &builder, mlir::Location loc,1176 const Fortran::semantics::Symbol &sym, mlir::Value box) {1177 // Read length from fir.box (explicit expr cannot safely be re-evaluated1178 // here).1179 auto readLength = [&]() {1180 fir::BoxValue boxLoad =1181 fir::LoadOp::create(builder, loc, fir::getBase(box)).getResult();1182 return fir::factory::readCharLen(builder, loc, boxLoad);1183 };1184 if (Fortran::semantics::IsOptional(sym)) {1185 mlir::IndexType idxTy = builder.getIndexType();1186 // It is not safe to unconditionally read boxes of optionals in case1187 // they are absents. According to 15.5.2.12 3 (9), it is illegal to1188 // inquire the length of absent optional, even if non deferred, so1189 // it's fine to use undefOp in this case.1190 auto isPresent = fir::IsPresentOp::create(builder, loc, builder.getI1Type(),1191 fir::getBase(box));1192 mlir::Value len =1193 builder.genIfOp(loc, {idxTy}, isPresent, true)1194 .genThen(1195 [&]() { fir::ResultOp::create(builder, loc, readLength()); })1196 .genElse([&]() {1197 auto undef = fir::UndefOp::create(builder, loc, idxTy);1198 fir::ResultOp::create(builder, loc, undef.getResult());1199 })1200 .getResults()[0];1201 return len;1202 }1203 1204 return readLength();1205}1206 1207mlir::Value Fortran::lower::getTypeDescAddr(1208 AbstractConverter &converter, mlir::Location loc,1209 const Fortran::semantics::DerivedTypeSpec &typeSpec) {1210 mlir::Type typeDesc =1211 Fortran::lower::translateDerivedTypeToFIRType(converter, typeSpec);1212 fir::FirOpBuilder &builder = converter.getFirOpBuilder();1213 return fir::TypeDescOp::create(builder, loc, mlir::TypeAttr::get(typeDesc));1214}1215