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