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

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