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.
45static llvm::cl::opt<bool> useAllocateRuntime(
46 "use-alloc-runtime",
47 llvm::cl::desc("Lower allocations to fortran runtime calls"),
48 llvm::cl::init(Val: 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).
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(Val: true));
59
60//===----------------------------------------------------------------------===//
61// Error management
62//===----------------------------------------------------------------------===//
63
64namespace {
65// Manage STAT and ERRMSG specifier information across a sequence of runtime
66// 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 = 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
119private:
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
128using namespace Fortran::runtime;
129/// Generate a runtime call to set the bounds of an allocatable or pointer
130/// 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 builder.create<fir::CallOp>(loc, callee, args);
145}
146
147/// Generate runtime call to set the lengths of a character allocatable or
148/// 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: coarrays
170 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 builder.create<fir::CallOp>(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 builder.create<fir::CallOp>(loc, callee, convertedArgs).getResult(0);
198}
199
200/// Generate a sequence of runtime calls to allocate memory and assign with the
201/// \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 builder.create<fir::CallOp>(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 builder.create<fir::CallOp>(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 builder.create<fir::CallOp>(loc, callee, operands).getResult(0);
274}
275
276//===----------------------------------------------------------------------===//
277// Allocate statement implementation
278//===----------------------------------------------------------------------===//
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::MutableBoxValue
290genMutableBoxValue(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 else
392 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 = builder.create<mlir::arith::SubIOp>(loc, ub, lb);
437 extents.emplace_back(
438 builder.create<mlir::arith::AddIOp>(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 if (alloc.getSymbol().test(Fortran::semantics::Symbol::Flag::AccDeclare))
450 Fortran::lower::attachDeclarePostAllocAction(converter, builder,
451 alloc.getSymbol());
452 }
453
454 void setPinnedToFalse() {
455 if (!pinnedExpr)
456 return;
457 Fortran::lower::StatementContext stmtCtx;
458 mlir::Value pinned =
459 fir::getBase(converter.genExprAddr(loc, *pinnedExpr, stmtCtx));
460 mlir::Location loc = pinned.getLoc();
461 mlir::Value falseValue = builder.createBool(loc, false);
462 mlir::Value falseConv = builder.createConvert(
463 loc, fir::unwrapRefType(pinned.getType()), falseValue);
464 builder.create<fir::StoreOp>(loc, falseConv, pinned);
465 }
466
467 void genSimpleAllocation(const Allocation &alloc,
468 const fir::MutableBoxValue &box) {
469 bool isCudaSymbol = Fortran::semantics::HasCUDAAttr(alloc.getSymbol());
470 bool isCudaDeviceContext = cuf::isCUDADeviceContext(builder.getRegion());
471 bool inlineAllocation = !box.isDerived() && !errorManager.hasStatSpec() &&
472 !alloc.type.IsPolymorphic() &&
473 !alloc.hasCoarraySpec() && !useAllocateRuntime &&
474 !box.isPointer();
475 unsigned allocatorIdx = Fortran::lower::getAllocatorIdx(alloc.getSymbol());
476
477 if (inlineAllocation &&
478 ((isCudaSymbol && isCudaDeviceContext) || !isCudaSymbol)) {
479 // Pointers must use PointerAllocate so that their deallocations
480 // can be validated.
481 genInlinedAllocation(alloc, box);
482 postAllocationAction(alloc);
483 setPinnedToFalse();
484 return;
485 }
486
487 // Generate a sequence of runtime calls.
488 errorManager.genStatCheck(builder, loc);
489 genAllocateObjectInit(box, allocatorIdx);
490 if (alloc.hasCoarraySpec())
491 TODO(loc, "coarray: allocation of a coarray object");
492 if (alloc.type.IsPolymorphic())
493 genSetType(alloc, box, loc);
494 genSetDeferredLengthParameters(alloc, box);
495 genAllocateObjectBounds(alloc, box);
496 mlir::Value stat;
497 if (!isCudaSymbol) {
498 stat = genRuntimeAllocate(builder, loc, box, errorManager);
499 setPinnedToFalse();
500 } else {
501 stat =
502 genCudaAllocate(builder, loc, box, errorManager, alloc.getSymbol());
503 }
504 fir::factory::syncMutableBoxFromIRBox(builder, loc, box);
505 postAllocationAction(alloc);
506 errorManager.assignStat(builder, loc, stat);
507 }
508
509 /// Lower the length parameters that may be specified in the optional
510 /// type specification.
511 void lowerAllocateLengthParameters() {
512 const Fortran::semantics::DeclTypeSpec *typeSpec =
513 getIfAllocateStmtTypeSpec();
514 if (!typeSpec)
515 return;
516 if (const Fortran::semantics::DerivedTypeSpec *derived =
517 typeSpec->AsDerived())
518 if (Fortran::semantics::CountLenParameters(*derived) > 0)
519 TODO(loc, "setting derived type params in allocation");
520 if (typeSpec->category() ==
521 Fortran::semantics::DeclTypeSpec::Category::Character) {
522 Fortran::semantics::ParamValue lenParam =
523 typeSpec->characterTypeSpec().length();
524 if (Fortran::semantics::MaybeIntExpr intExpr = lenParam.GetExplicit()) {
525 Fortran::lower::StatementContext stmtCtx;
526 Fortran::lower::SomeExpr lenExpr{*intExpr};
527 lenParams.push_back(
528 fir::getBase(converter.genExprValue(loc, lenExpr, stmtCtx)));
529 }
530 }
531 }
532
533 // Set length parameters in the box stored in boxAddr.
534 // This must be called before setting the bounds because it may use
535 // Init runtime calls that may set the bounds to zero.
536 void genSetDeferredLengthParameters(const Allocation &alloc,
537 const fir::MutableBoxValue &box) {
538 if (lenParams.empty())
539 return;
540 // TODO: in case a length parameter was not deferred, insert a runtime check
541 // that the length is the same (AllocatableCheckLengthParameter runtime
542 // call).
543 if (box.isCharacter())
544 genRuntimeInitCharacter(builder, loc, box, lenParams[0]);
545
546 if (box.isDerived())
547 TODO(loc, "derived type length parameters in allocate");
548 }
549
550 void genAllocateObjectInit(const fir::MutableBoxValue &box,
551 unsigned allocatorIdx) {
552 if (box.isPointer()) {
553 // For pointers, the descriptor may still be uninitialized (see Fortran
554 // 2018 19.5.2.2). The allocation runtime needs to be given a descriptor
555 // with initialized rank, types and attributes. Initialize the descriptor
556 // here to ensure these constraints are fulfilled.
557 mlir::Value nullPointer = fir::factory::createUnallocatedBox(
558 builder, loc, box.getBoxTy(), box.nonDeferredLenParams(),
559 /*typeSourceBox=*/{}, allocatorIdx);
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 unsigned allocatorIdx = Fortran::lower::getAllocatorIdx(alloc.getSymbol());
616 fir::ExtendedValue exv = isSource ? sourceExv : moldExv;
617
618 // Generate a sequence of runtime calls.
619 errorManager.genStatCheck(builder, loc);
620 genAllocateObjectInit(box, allocatorIdx);
621 if (alloc.hasCoarraySpec())
622 TODO(loc, "coarray: allocation of a coarray object");
623 // Set length of the allocate object if it has. Otherwise, get the length
624 // from source for the deferred length parameter.
625 const bool isDeferredLengthCharacter =
626 box.isCharacter() && !box.hasNonDeferredLenParams();
627 if (lenParams.empty() && isDeferredLengthCharacter)
628 lenParams.push_back(fir::factory::readCharLen(builder, loc, exv));
629 if (!isSource || alloc.type.IsPolymorphic())
630 genRuntimeAllocateApplyMold(builder, loc, box, exv,
631 alloc.getSymbol().Rank());
632 if (isDeferredLengthCharacter)
633 genSetDeferredLengthParameters(alloc, box);
634 genAllocateObjectBounds(alloc, box);
635 mlir::Value stat;
636 if (Fortran::semantics::HasCUDAAttr(alloc.getSymbol())) {
637 stat =
638 genCudaAllocate(builder, loc, box, errorManager, alloc.getSymbol());
639 } else {
640 if (isSource)
641 stat = genRuntimeAllocateSource(builder, loc, box, exv, errorManager);
642 else
643 stat = genRuntimeAllocate(builder, loc, box, errorManager);
644 setPinnedToFalse();
645 }
646 fir::factory::syncMutableBoxFromIRBox(builder, loc, box);
647 postAllocationAction(alloc);
648 errorManager.assignStat(builder, loc, stat);
649 }
650
651 /// Generate call to PointerNullifyDerived or AllocatableInitDerived
652 /// to set the dynamic type information.
653 void genInitDerived(const fir::MutableBoxValue &box, mlir::Value typeDescAddr,
654 int rank, int corank = 0) {
655 mlir::func::FuncOp callee =
656 box.isPointer()
657 ? fir::runtime::getRuntimeFunc<mkRTKey(PointerNullifyDerived)>(
658 loc, builder)
659 : fir::runtime::getRuntimeFunc<mkRTKey(
660 AllocatableInitDerivedForAllocate)>(loc, builder);
661
662 llvm::ArrayRef<mlir::Type> inputTypes =
663 callee.getFunctionType().getInputs();
664 mlir::Value rankValue =
665 builder.createIntegerConstant(loc, inputTypes[2], rank);
666 mlir::Value corankValue =
667 builder.createIntegerConstant(loc, inputTypes[3], corank);
668 const auto args = fir::runtime::createArguments(
669 builder, loc, callee.getFunctionType(), box.getAddr(), typeDescAddr,
670 rankValue, corankValue);
671 builder.create<fir::CallOp>(loc, callee, args);
672 }
673
674 /// Generate call to PointerNullifyIntrinsic or AllocatableInitIntrinsic to
675 /// set the dynamic type information for a polymorphic entity from an
676 /// intrinsic type spec.
677 void genInitIntrinsic(const fir::MutableBoxValue &box,
678 const TypeCategory category, int64_t kind, int rank,
679 int corank = 0) {
680 mlir::func::FuncOp callee =
681 box.isPointer()
682 ? fir::runtime::getRuntimeFunc<mkRTKey(PointerNullifyIntrinsic)>(
683 loc, builder)
684 : fir::runtime::getRuntimeFunc<mkRTKey(
685 AllocatableInitIntrinsicForAllocate)>(loc, builder);
686
687 llvm::ArrayRef<mlir::Type> inputTypes =
688 callee.getFunctionType().getInputs();
689 mlir::Value categoryValue = builder.createIntegerConstant(
690 loc, inputTypes[1], static_cast<int32_t>(category));
691 mlir::Value kindValue =
692 builder.createIntegerConstant(loc, inputTypes[2], kind);
693 mlir::Value rankValue =
694 builder.createIntegerConstant(loc, inputTypes[3], rank);
695 mlir::Value corankValue =
696 builder.createIntegerConstant(loc, inputTypes[4], corank);
697 const auto args = fir::runtime::createArguments(
698 builder, loc, callee.getFunctionType(), box.getAddr(), categoryValue,
699 kindValue, rankValue, corankValue);
700 builder.create<fir::CallOp>(loc, callee, args);
701 }
702
703 /// Generate call to the AllocatableInitDerived to set up the type descriptor
704 /// and other part of the descriptor for derived type.
705 void genSetType(const Allocation &alloc, const fir::MutableBoxValue &box,
706 mlir::Location loc) {
707 const Fortran::semantics::DeclTypeSpec *typeSpec =
708 getIfAllocateStmtTypeSpec();
709
710 // No type spec provided in allocate statement so the declared type spec is
711 // used.
712 if (!typeSpec)
713 typeSpec = &alloc.type;
714 assert(typeSpec && "type spec missing for polymorphic allocation");
715
716 // Set up the descriptor for allocation for intrinsic type spec on
717 // unlimited polymorphic entity.
718 if (typeSpec->AsIntrinsic() &&
719 fir::isUnlimitedPolymorphicType(fir::getBase(box).getType())) {
720 if (typeSpec->AsIntrinsic()->category() == TypeCategory::Character) {
721 genRuntimeInitCharacter(
722 builder, loc, box, lenParams[0],
723 Fortran::evaluate::ToInt64(typeSpec->AsIntrinsic()->kind())
724 .value());
725 } else {
726 genInitIntrinsic(
727 box, typeSpec->AsIntrinsic()->category(),
728 Fortran::evaluate::ToInt64(typeSpec->AsIntrinsic()->kind()).value(),
729 alloc.getSymbol().Rank());
730 }
731 return;
732 }
733
734 // Do not generate calls for non derived-type type spec.
735 if (!typeSpec->AsDerived())
736 return;
737
738 auto typeDescAddr = Fortran::lower::getTypeDescAddr(
739 converter, loc, typeSpec->derivedTypeSpec());
740 genInitDerived(box, typeDescAddr, alloc.getSymbol().Rank());
741 }
742
743 /// Returns a pointer to the DeclTypeSpec if a type-spec is provided in the
744 /// allocate statement. Returns a null pointer otherwise.
745 const Fortran::semantics::DeclTypeSpec *getIfAllocateStmtTypeSpec() const {
746 if (const auto &typeSpec =
747 std::get<std::optional<Fortran::parser::TypeSpec>>(stmt.t))
748 return typeSpec->declTypeSpec;
749 return nullptr;
750 }
751
752 mlir::Value genCudaAllocate(fir::FirOpBuilder &builder, mlir::Location loc,
753 const fir::MutableBoxValue &box,
754 ErrorManager &errorManager,
755 const Fortran::semantics::Symbol &sym) {
756 Fortran::lower::StatementContext stmtCtx;
757 cuf::DataAttributeAttr cudaAttr =
758 Fortran::lower::translateSymbolCUFDataAttribute(builder.getContext(),
759 sym);
760 mlir::Value errmsg = errMsgExpr ? errorManager.errMsgAddr : nullptr;
761 mlir::Value stream =
762 streamExpr
763 ? fir::getBase(converter.genExprAddr(loc, *streamExpr, stmtCtx))
764 : nullptr;
765 mlir::Value pinned =
766 pinnedExpr
767 ? fir::getBase(converter.genExprAddr(loc, *pinnedExpr, stmtCtx))
768 : nullptr;
769 mlir::Value source = sourceExpr ? fir::getBase(sourceExv) : nullptr;
770
771 // Keep return type the same as a standard AllocatableAllocate call.
772 mlir::Type retTy = fir::runtime::getModel<int>()(builder.getContext());
773 return builder
774 .create<cuf::AllocateOp>(
775 loc, retTy, box.getAddr(), errmsg, stream, pinned, source, cudaAttr,
776 errorManager.hasStatSpec() ? builder.getUnitAttr() : nullptr)
777 .getResult();
778 }
779
780 Fortran::lower::AbstractConverter &converter;
781 fir::FirOpBuilder &builder;
782 const Fortran::parser::AllocateStmt &stmt;
783 const Fortran::lower::SomeExpr *sourceExpr{nullptr};
784 const Fortran::lower::SomeExpr *moldExpr{nullptr};
785 const Fortran::lower::SomeExpr *statExpr{nullptr};
786 const Fortran::lower::SomeExpr *errMsgExpr{nullptr};
787 const Fortran::lower::SomeExpr *pinnedExpr{nullptr};
788 const Fortran::lower::SomeExpr *streamExpr{nullptr};
789 // If the allocate has a type spec, lenParams contains the
790 // value of the length parameters that were specified inside.
791 llvm::SmallVector<mlir::Value> lenParams;
792 ErrorManager errorManager;
793 // 9.7.1.2(7) The source-expr is evaluated exactly once for each AllocateStmt.
794 fir::ExtendedValue sourceExv;
795 fir::ExtendedValue moldExv;
796
797 mlir::Location loc;
798};
799} // namespace
800
801void Fortran::lower::genAllocateStmt(
802 Fortran::lower::AbstractConverter &converter,
803 const Fortran::parser::AllocateStmt &stmt, mlir::Location loc) {
804 AllocateStmtHelper{converter, stmt, loc}.lower();
805}
806
807//===----------------------------------------------------------------------===//
808// Deallocate statement implementation
809//===----------------------------------------------------------------------===//
810
811static void preDeallocationAction(Fortran::lower::AbstractConverter &converter,
812 fir::FirOpBuilder &builder,
813 mlir::Value beginOpValue,
814 const Fortran::semantics::Symbol &sym) {
815 if (sym.test(Fortran::semantics::Symbol::Flag::AccDeclare))
816 Fortran::lower::attachDeclarePreDeallocAction(converter, builder,
817 beginOpValue, sym);
818}
819
820static void postDeallocationAction(Fortran::lower::AbstractConverter &converter,
821 fir::FirOpBuilder &builder,
822 const Fortran::semantics::Symbol &sym) {
823 if (sym.test(Fortran::semantics::Symbol::Flag::AccDeclare))
824 Fortran::lower::attachDeclarePostDeallocAction(converter, builder, sym);
825}
826
827static mlir::Value genCudaDeallocate(fir::FirOpBuilder &builder,
828 mlir::Location loc,
829 const fir::MutableBoxValue &box,
830 ErrorManager &errorManager,
831 const Fortran::semantics::Symbol &sym) {
832 cuf::DataAttributeAttr cudaAttr =
833 Fortran::lower::translateSymbolCUFDataAttribute(builder.getContext(),
834 sym);
835 mlir::Value errmsg =
836 mlir::isa<fir::AbsentOp>(errorManager.errMsgAddr.getDefiningOp())
837 ? nullptr
838 : errorManager.errMsgAddr;
839
840 // Keep return type the same as a standard AllocatableAllocate call.
841 mlir::Type retTy = fir::runtime::getModel<int>()(builder.getContext());
842 return builder
843 .create<cuf::DeallocateOp>(
844 loc, retTy, box.getAddr(), errmsg, cudaAttr,
845 errorManager.hasStatSpec() ? builder.getUnitAttr() : nullptr)
846 .getResult();
847}
848
849// Generate deallocation of a pointer/allocatable.
850static mlir::Value
851genDeallocate(fir::FirOpBuilder &builder,
852 Fortran::lower::AbstractConverter &converter, mlir::Location loc,
853 const fir::MutableBoxValue &box, ErrorManager &errorManager,
854 mlir::Value declaredTypeDesc = {},
855 const Fortran::semantics::Symbol *symbol = nullptr) {
856 bool isCudaSymbol = symbol && Fortran::semantics::HasCUDAAttr(*symbol);
857 bool isCudaDeviceContext = cuf::isCUDADeviceContext(builder.getRegion());
858 bool inlineDeallocation =
859 !box.isDerived() && !box.isPolymorphic() && !box.hasAssumedRank() &&
860 !box.isUnlimitedPolymorphic() && !errorManager.hasStatSpec() &&
861 !useAllocateRuntime && !box.isPointer();
862 // Deallocate intrinsic types inline.
863 if (inlineDeallocation &&
864 ((isCudaSymbol && isCudaDeviceContext) || !isCudaSymbol)) {
865 // Pointers must use PointerDeallocate so that their deallocations
866 // can be validated.
867 mlir::Value ret = fir::factory::genFreemem(builder, loc, box);
868 if (symbol)
869 postDeallocationAction(converter, builder, *symbol);
870 return ret;
871 }
872 // Use runtime calls to deallocate descriptor cases. Sync MutableBoxValue
873 // with its descriptor before and after calls if needed.
874 errorManager.genStatCheck(builder, loc);
875 mlir::Value stat;
876 if (!isCudaSymbol)
877 stat =
878 genRuntimeDeallocate(builder, loc, box, errorManager, declaredTypeDesc);
879 else
880 stat = genCudaDeallocate(builder, loc, box, errorManager, *symbol);
881 fir::factory::syncMutableBoxFromIRBox(builder, loc, box);
882 if (symbol)
883 postDeallocationAction(converter, builder, *symbol);
884 errorManager.assignStat(builder, loc, stat);
885 return stat;
886}
887
888void Fortran::lower::genDeallocateBox(
889 Fortran::lower::AbstractConverter &converter,
890 const fir::MutableBoxValue &box, mlir::Location loc,
891 const Fortran::semantics::Symbol *sym, mlir::Value declaredTypeDesc) {
892 const Fortran::lower::SomeExpr *statExpr = nullptr;
893 const Fortran::lower::SomeExpr *errMsgExpr = nullptr;
894 ErrorManager errorManager;
895 errorManager.init(converter, loc, statExpr, errMsgExpr);
896 fir::FirOpBuilder &builder = converter.getFirOpBuilder();
897 genDeallocate(builder, converter, loc, box, errorManager, declaredTypeDesc,
898 sym);
899}
900
901void Fortran::lower::genDeallocateIfAllocated(
902 Fortran::lower::AbstractConverter &converter,
903 const fir::MutableBoxValue &box, mlir::Location loc,
904 const Fortran::semantics::Symbol *sym) {
905 fir::FirOpBuilder &builder = converter.getFirOpBuilder();
906 mlir::Value isAllocated =
907 fir::factory::genIsAllocatedOrAssociatedTest(builder, loc, box);
908 builder.genIfThen(loc, isAllocated)
909 .genThen([&]() {
910 if (mlir::Type eleType = box.getEleTy();
911 mlir::isa<fir::RecordType>(eleType) && box.isPolymorphic()) {
912 mlir::Value declaredTypeDesc = builder.create<fir::TypeDescOp>(
913 loc, mlir::TypeAttr::get(eleType));
914 genDeallocateBox(converter, box, loc, sym, declaredTypeDesc);
915 } else {
916 genDeallocateBox(converter, box, loc, sym);
917 }
918 })
919 .end();
920}
921
922void Fortran::lower::genDeallocateStmt(
923 Fortran::lower::AbstractConverter &converter,
924 const Fortran::parser::DeallocateStmt &stmt, mlir::Location loc) {
925 const Fortran::lower::SomeExpr *statExpr = nullptr;
926 const Fortran::lower::SomeExpr *errMsgExpr = nullptr;
927 for (const Fortran::parser::StatOrErrmsg &statOrErr :
928 std::get<std::list<Fortran::parser::StatOrErrmsg>>(stmt.t))
929 Fortran::common::visit(
930 Fortran::common::visitors{
931 [&](const Fortran::parser::StatVariable &statVar) {
932 statExpr = Fortran::semantics::GetExpr(statVar);
933 },
934 [&](const Fortran::parser::MsgVariable &errMsgVar) {
935 errMsgExpr = Fortran::semantics::GetExpr(errMsgVar);
936 },
937 },
938 statOrErr.u);
939 ErrorManager errorManager;
940 errorManager.init(converter, loc, statExpr, errMsgExpr);
941 fir::FirOpBuilder &builder = converter.getFirOpBuilder();
942 mlir::OpBuilder::InsertPoint insertPt = builder.saveInsertionPoint();
943 for (const Fortran::parser::AllocateObject &allocateObject :
944 std::get<std::list<Fortran::parser::AllocateObject>>(stmt.t)) {
945 const Fortran::semantics::Symbol &symbol = unwrapSymbol(allocateObject);
946 fir::MutableBoxValue box =
947 genMutableBoxValue(converter, loc, allocateObject);
948 mlir::Value declaredTypeDesc = {};
949 if (box.isPolymorphic()) {
950 mlir::Type eleType = box.getEleTy();
951 if (mlir::isa<fir::RecordType>(eleType))
952 if (const Fortran::semantics::DerivedTypeSpec *derivedTypeSpec =
953 symbol.GetType()->AsDerived()) {
954 declaredTypeDesc =
955 Fortran::lower::getTypeDescAddr(converter, loc, *derivedTypeSpec);
956 }
957 }
958 mlir::Value beginOpValue = genDeallocate(
959 builder, converter, loc, box, errorManager, declaredTypeDesc, &symbol);
960 preDeallocationAction(converter, builder, beginOpValue, symbol);
961 }
962 builder.restoreInsertionPoint(insertPt);
963}
964
965//===----------------------------------------------------------------------===//
966// MutableBoxValue creation implementation
967//===----------------------------------------------------------------------===//
968
969/// Is this symbol a pointer to a pointer array that does not have the
970/// CONTIGUOUS attribute ?
971static inline bool
972isNonContiguousArrayPointer(const Fortran::semantics::Symbol &sym) {
973 return Fortran::semantics::IsPointer(sym) && sym.Rank() != 0 &&
974 !sym.attrs().test(Fortran::semantics::Attr::CONTIGUOUS);
975}
976
977/// Is this symbol a polymorphic pointer?
978static inline bool isPolymorphicPointer(const Fortran::semantics::Symbol &sym) {
979 return Fortran::semantics::IsPointer(sym) &&
980 Fortran::semantics::IsPolymorphic(sym);
981}
982
983/// Is this symbol a polymorphic allocatable?
984static inline bool
985isPolymorphicAllocatable(const Fortran::semantics::Symbol &sym) {
986 return Fortran::semantics::IsAllocatable(sym) &&
987 Fortran::semantics::IsPolymorphic(sym);
988}
989
990/// Is this a local procedure symbol in a procedure that contains internal
991/// procedures ?
992static bool mayBeCapturedInInternalProc(const Fortran::semantics::Symbol &sym) {
993 const Fortran::semantics::Scope &owner = sym.owner();
994 Fortran::semantics::Scope::Kind kind = owner.kind();
995 // Test if this is a procedure scope that contains a subprogram scope that is
996 // not an interface.
997 if (kind == Fortran::semantics::Scope::Kind::Subprogram ||
998 kind == Fortran::semantics::Scope::Kind::MainProgram)
999 for (const Fortran::semantics::Scope &childScope : owner.children())
1000 if (childScope.kind() == Fortran::semantics::Scope::Kind::Subprogram)
1001 if (const Fortran::semantics::Symbol *childSym = childScope.symbol())
1002 if (const auto *details =
1003 childSym->detailsIf<Fortran::semantics::SubprogramDetails>())
1004 if (!details->isInterface())
1005 return true;
1006 return false;
1007}
1008
1009/// In case it is safe to track the properties in variables outside a
1010/// descriptor, create the variables to hold the mutable properties of the
1011/// entity var. The variables are not initialized here.
1012static fir::MutableProperties
1013createMutableProperties(Fortran::lower::AbstractConverter &converter,
1014 mlir::Location loc,
1015 const Fortran::lower::pft::Variable &var,
1016 mlir::ValueRange nonDeferredParams, bool alwaysUseBox) {
1017 fir::FirOpBuilder &builder = converter.getFirOpBuilder();
1018 const Fortran::semantics::Symbol &sym = var.getSymbol();
1019 // Globals and dummies may be associated, creating local variables would
1020 // require keeping the values and descriptor before and after every single
1021 // impure calls in the current scope (not only the ones taking the variable as
1022 // arguments. All.) Volatile means the variable may change in ways not defined
1023 // per Fortran, so lowering can most likely not keep the descriptor and values
1024 // in sync as needed.
1025 // Pointers to non contiguous arrays need to be represented with a fir.box to
1026 // account for the discontiguity.
1027 // Pointer/Allocatable in internal procedure are descriptors in the host link,
1028 // and it would increase complexity to sync this descriptor with the local
1029 // values every time the host link is escaping.
1030 if (alwaysUseBox || var.isGlobal() || Fortran::semantics::IsDummy(sym) ||
1031 Fortran::semantics::IsFunctionResult(sym) ||
1032 sym.attrs().test(Fortran::semantics::Attr::VOLATILE) ||
1033 isNonContiguousArrayPointer(sym) || useAllocateRuntime ||
1034 useDescForMutableBox || mayBeCapturedInInternalProc(sym) ||
1035 isPolymorphicPointer(sym) || isPolymorphicAllocatable(sym))
1036 return {};
1037 fir::MutableProperties mutableProperties;
1038 std::string name = converter.mangleName(sym);
1039 mlir::Type baseAddrTy = converter.genType(sym);
1040 if (auto boxType = mlir::dyn_cast<fir::BaseBoxType>(baseAddrTy))
1041 baseAddrTy = boxType.getEleTy();
1042 // Allocate and set a variable to hold the address.
1043 // It will be set to null in setUnallocatedStatus.
1044 mutableProperties.addr = builder.allocateLocal(
1045 loc, baseAddrTy, name + ".addr", "",
1046 /*shape=*/std::nullopt, /*typeparams=*/std::nullopt);
1047 // Allocate variables to hold lower bounds and extents.
1048 int rank = sym.Rank();
1049 mlir::Type idxTy = builder.getIndexType();
1050 for (decltype(rank) i = 0; i < rank; ++i) {
1051 mlir::Value lboundVar = builder.allocateLocal(
1052 loc, idxTy, name + ".lb" + std::to_string(i), "",
1053 /*shape=*/std::nullopt, /*typeparams=*/std::nullopt);
1054 mlir::Value extentVar = builder.allocateLocal(
1055 loc, idxTy, name + ".ext" + std::to_string(i), "",
1056 /*shape=*/std::nullopt, /*typeparams=*/std::nullopt);
1057 mutableProperties.lbounds.emplace_back(lboundVar);
1058 mutableProperties.extents.emplace_back(extentVar);
1059 }
1060
1061 // Allocate variable to hold deferred length parameters.
1062 mlir::Type eleTy = baseAddrTy;
1063 if (auto newTy = fir::dyn_cast_ptrEleTy(eleTy))
1064 eleTy = newTy;
1065 if (auto seqTy = mlir::dyn_cast<fir::SequenceType>(eleTy))
1066 eleTy = seqTy.getEleTy();
1067 if (auto record = mlir::dyn_cast<fir::RecordType>(eleTy))
1068 if (record.getNumLenParams() != 0)
1069 TODO(loc, "deferred length type parameters.");
1070 if (fir::isa_char(eleTy) && nonDeferredParams.empty()) {
1071 mlir::Value lenVar =
1072 builder.allocateLocal(loc, builder.getCharacterLengthType(),
1073 name + ".len", "", /*shape=*/std::nullopt,
1074 /*typeparams=*/std::nullopt);
1075 mutableProperties.deferredParams.emplace_back(lenVar);
1076 }
1077 return mutableProperties;
1078}
1079
1080fir::MutableBoxValue Fortran::lower::createMutableBox(
1081 Fortran::lower::AbstractConverter &converter, mlir::Location loc,
1082 const Fortran::lower::pft::Variable &var, mlir::Value boxAddr,
1083 mlir::ValueRange nonDeferredParams, bool alwaysUseBox, unsigned allocator) {
1084 fir::MutableProperties mutableProperties = createMutableProperties(
1085 converter, loc, var, nonDeferredParams, alwaysUseBox);
1086 fir::MutableBoxValue box(boxAddr, nonDeferredParams, mutableProperties);
1087 fir::FirOpBuilder &builder = converter.getFirOpBuilder();
1088 if (!var.isGlobal() && !Fortran::semantics::IsDummy(var.getSymbol()))
1089 fir::factory::disassociateMutableBox(builder, loc, box,
1090 /*polymorphicSetType=*/false,
1091 allocator);
1092 return box;
1093}
1094
1095//===----------------------------------------------------------------------===//
1096// MutableBoxValue reading interface implementation
1097//===----------------------------------------------------------------------===//
1098
1099bool Fortran::lower::isArraySectionWithoutVectorSubscript(
1100 const Fortran::lower::SomeExpr &expr) {
1101 return expr.Rank() > 0 && Fortran::evaluate::IsVariable(expr) &&
1102 !Fortran::evaluate::UnwrapWholeSymbolDataRef(expr) &&
1103 !Fortran::evaluate::HasVectorSubscript(expr);
1104}
1105
1106void Fortran::lower::associateMutableBox(
1107 Fortran::lower::AbstractConverter &converter, mlir::Location loc,
1108 const fir::MutableBoxValue &box, const Fortran::lower::SomeExpr &source,
1109 mlir::ValueRange lbounds, Fortran::lower::StatementContext &stmtCtx) {
1110 fir::FirOpBuilder &builder = converter.getFirOpBuilder();
1111 if (Fortran::evaluate::UnwrapExpr<Fortran::evaluate::NullPointer>(source)) {
1112 fir::factory::disassociateMutableBox(builder, loc, box);
1113 cuf::genPointerSync(box.getAddr(), builder);
1114 return;
1115 }
1116 if (converter.getLoweringOptions().getLowerToHighLevelFIR()) {
1117 fir::ExtendedValue rhs = converter.genExprAddr(loc, source, stmtCtx);
1118 fir::factory::associateMutableBox(builder, loc, box, rhs, lbounds);
1119 cuf::genPointerSync(box.getAddr(), builder);
1120 return;
1121 }
1122 // The right hand side is not be evaluated into a temp. Array sections can
1123 // typically be represented as a value of type `!fir.box`. However, an
1124 // expression that uses vector subscripts cannot be emboxed. In that case,
1125 // generate a reference to avoid having to later use a fir.rebox to implement
1126 // the pointer association.
1127 fir::ExtendedValue rhs = isArraySectionWithoutVectorSubscript(source)
1128 ? converter.genExprBox(loc, source, stmtCtx)
1129 : converter.genExprAddr(loc, source, stmtCtx);
1130
1131 fir::factory::associateMutableBox(builder, loc, box, rhs, lbounds);
1132}
1133
1134bool Fortran::lower::isWholeAllocatable(const Fortran::lower::SomeExpr &expr) {
1135 if (const Fortran::semantics::Symbol *sym =
1136 Fortran::evaluate::UnwrapWholeSymbolOrComponentDataRef(expr))
1137 return Fortran::semantics::IsAllocatable(sym->GetUltimate());
1138 return false;
1139}
1140
1141bool Fortran::lower::isWholePointer(const Fortran::lower::SomeExpr &expr) {
1142 if (const Fortran::semantics::Symbol *sym =
1143 Fortran::evaluate::UnwrapWholeSymbolOrComponentDataRef(expr))
1144 return Fortran::semantics::IsPointer(sym->GetUltimate());
1145 return false;
1146}
1147
1148mlir::Value Fortran::lower::getAssumedCharAllocatableOrPointerLen(
1149 fir::FirOpBuilder &builder, mlir::Location loc,
1150 const Fortran::semantics::Symbol &sym, mlir::Value box) {
1151 // Read length from fir.box (explicit expr cannot safely be re-evaluated
1152 // here).
1153 auto readLength = [&]() {
1154 fir::BoxValue boxLoad =
1155 builder.create<fir::LoadOp>(loc, fir::getBase(box)).getResult();
1156 return fir::factory::readCharLen(builder, loc, boxLoad);
1157 };
1158 if (Fortran::semantics::IsOptional(sym)) {
1159 mlir::IndexType idxTy = builder.getIndexType();
1160 // It is not safe to unconditionally read boxes of optionals in case
1161 // they are absents. According to 15.5.2.12 3 (9), it is illegal to
1162 // inquire the length of absent optional, even if non deferred, so
1163 // it's fine to use undefOp in this case.
1164 auto isPresent = builder.create<fir::IsPresentOp>(loc, builder.getI1Type(),
1165 fir::getBase(box));
1166 mlir::Value len =
1167 builder.genIfOp(loc, {idxTy}, isPresent, true)
1168 .genThen(
1169 [&]() { builder.create<fir::ResultOp>(loc, readLength()); })
1170 .genElse([&]() {
1171 auto undef = builder.create<fir::UndefOp>(loc, idxTy);
1172 builder.create<fir::ResultOp>(loc, undef.getResult());
1173 })
1174 .getResults()[0];
1175 return len;
1176 }
1177
1178 return readLength();
1179}
1180
1181mlir::Value Fortran::lower::getTypeDescAddr(
1182 AbstractConverter &converter, mlir::Location loc,
1183 const Fortran::semantics::DerivedTypeSpec &typeSpec) {
1184 mlir::Type typeDesc =
1185 Fortran::lower::translateDerivedTypeToFIRType(converter, typeSpec);
1186 fir::FirOpBuilder &builder = converter.getFirOpBuilder();
1187 return builder.create<fir::TypeDescOp>(loc, mlir::TypeAttr::get(typeDesc));
1188}
1189

source code of flang/lib/Lower/Allocatable.cpp