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/IterationSpace.h"
17 #include "flang/Lower/PFTBuilder.h"
18 #include "flang/Lower/Runtime.h"
19 #include "flang/Lower/StatementContext.h"
20 #include "flang/Optimizer/Builder/FIRBuilder.h"
21 #include "flang/Optimizer/Builder/Runtime/RTBuilder.h"
22 #include "flang/Optimizer/Builder/Todo.h"
23 #include "flang/Optimizer/Dialect/FIROps.h"
24 #include "flang/Optimizer/Dialect/FIROpsSupport.h"
25 #include "flang/Optimizer/Support/FatalError.h"
26 #include "flang/Parser/parse-tree.h"
27 #include "flang/Runtime/allocatable.h"
28 #include "flang/Runtime/pointer.h"
29 #include "flang/Semantics/tools.h"
30 #include "flang/Semantics/type.h"
31 #include "llvm/Support/CommandLine.h"
32 
33 /// By default fir memory operation fir::AllocMemOp/fir::FreeMemOp are used.
34 /// This switch allow forcing the use of runtime and descriptors for everything.
35 /// This is mainly intended as a debug switch.
36 static llvm::cl::opt<bool> useAllocateRuntime(
37     "use-alloc-runtime",
38     llvm::cl::desc("Lower allocations to fortran runtime calls"),
39     llvm::cl::init(false));
40 /// Switch to force lowering of allocatable and pointers to descriptors in all
41 /// cases for debug purposes.
42 static llvm::cl::opt<bool> useDescForMutableBox(
43     "use-desc-for-alloc",
44     llvm::cl::desc("Always use descriptors for POINTER and ALLOCATABLE"),
45     llvm::cl::init(false));
46 
47 //===----------------------------------------------------------------------===//
48 // Error management
49 //===----------------------------------------------------------------------===//
50 
51 namespace {
52 // Manage STAT and ERRMSG specifier information across a sequence of runtime
53 // calls for an ALLOCATE/DEALLOCATE stmt.
54 struct ErrorManager {
55   void init(Fortran::lower::AbstractConverter &converter, mlir::Location loc,
56             const Fortran::lower::SomeExpr *statExpr,
57             const Fortran::lower::SomeExpr *errMsgExpr) {
58     Fortran::lower::StatementContext stmtCtx;
59     fir::FirOpBuilder &builder = converter.getFirOpBuilder();
60     hasStat = builder.createBool(loc, statExpr != nullptr);
61     statAddr = statExpr
62                    ? fir::getBase(converter.genExprAddr(loc, statExpr, stmtCtx))
63                    : mlir::Value{};
64     errMsgAddr =
65         statExpr && errMsgExpr
66             ? builder.createBox(loc,
67                                 converter.genExprAddr(loc, errMsgExpr, stmtCtx))
68             : builder.create<fir::AbsentOp>(
69                   loc,
70                   fir::BoxType::get(mlir::NoneType::get(builder.getContext())));
71     sourceFile = fir::factory::locationToFilename(builder, loc);
72     sourceLine = fir::factory::locationToLineNo(builder, loc,
73                                                 builder.getIntegerType(32));
74   }
75 
76   bool hasStatSpec() const { return static_cast<bool>(statAddr); }
77 
78   void genStatCheck(fir::FirOpBuilder &builder, mlir::Location loc) {
79     if (statValue) {
80       mlir::Value zero =
81           builder.createIntegerConstant(loc, statValue.getType(), 0);
82       auto cmp = builder.create<mlir::arith::CmpIOp>(
83           loc, mlir::arith::CmpIPredicate::eq, statValue, zero);
84       auto ifOp = builder.create<fir::IfOp>(loc, cmp,
85                                             /*withElseRegion=*/false);
86       builder.setInsertionPointToStart(&ifOp.getThenRegion().front());
87     }
88   }
89 
90   void assignStat(fir::FirOpBuilder &builder, mlir::Location loc,
91                   mlir::Value stat) {
92     if (hasStatSpec()) {
93       assert(stat && "missing stat value");
94       mlir::Value castStat = builder.createConvert(
95           loc, fir::dyn_cast_ptrEleTy(statAddr.getType()), stat);
96       builder.create<fir::StoreOp>(loc, castStat, statAddr);
97       statValue = stat;
98     }
99   }
100 
101   mlir::Value hasStat;
102   mlir::Value errMsgAddr;
103   mlir::Value sourceFile;
104   mlir::Value sourceLine;
105 
106 private:
107   mlir::Value statAddr;  // STAT variable address
108   mlir::Value statValue; // current runtime STAT value
109 };
110 
111 //===----------------------------------------------------------------------===//
112 // Allocatables runtime call generators
113 //===----------------------------------------------------------------------===//
114 
115 using namespace Fortran::runtime;
116 /// Generate a runtime call to set the bounds of an allocatable or pointer
117 /// descriptor.
118 static void genRuntimeSetBounds(fir::FirOpBuilder &builder, mlir::Location loc,
119                                 const fir::MutableBoxValue &box,
120                                 mlir::Value dimIndex, mlir::Value lowerBound,
121                                 mlir::Value upperBound) {
122   mlir::func::FuncOp callee =
123       box.isPointer()
124           ? fir::runtime::getRuntimeFunc<mkRTKey(PointerSetBounds)>(loc,
125                                                                     builder)
126           : fir::runtime::getRuntimeFunc<mkRTKey(AllocatableSetBounds)>(
127                 loc, builder);
128   llvm::SmallVector<mlir::Value> args{box.getAddr(), dimIndex, lowerBound,
129                                       upperBound};
130   llvm::SmallVector<mlir::Value> operands;
131   for (auto [fst, snd] : llvm::zip(args, callee.getFunctionType().getInputs()))
132     operands.emplace_back(builder.createConvert(loc, snd, fst));
133   builder.create<fir::CallOp>(loc, callee, operands);
134 }
135 
136 /// Generate runtime call to set the lengths of a character allocatable or
137 /// pointer descriptor.
138 static void genRuntimeInitCharacter(fir::FirOpBuilder &builder,
139                                     mlir::Location loc,
140                                     const fir::MutableBoxValue &box,
141                                     mlir::Value len) {
142   mlir::func::FuncOp callee =
143       box.isPointer()
144           ? fir::runtime::getRuntimeFunc<mkRTKey(PointerNullifyCharacter)>(
145                 loc, builder)
146           : fir::runtime::getRuntimeFunc<mkRTKey(AllocatableInitCharacter)>(
147                 loc, builder);
148   llvm::ArrayRef<mlir::Type> inputTypes = callee.getFunctionType().getInputs();
149   if (inputTypes.size() != 5)
150     fir::emitFatalError(
151         loc, "AllocatableInitCharacter runtime interface not as expected");
152   llvm::SmallVector<mlir::Value> args;
153   args.push_back(builder.createConvert(loc, inputTypes[0], box.getAddr()));
154   args.push_back(builder.createConvert(loc, inputTypes[1], len));
155   int kind = box.getEleTy().cast<fir::CharacterType>().getFKind();
156   args.push_back(builder.createIntegerConstant(loc, inputTypes[2], kind));
157   int rank = box.rank();
158   args.push_back(builder.createIntegerConstant(loc, inputTypes[3], rank));
159   // TODO: coarrays
160   int corank = 0;
161   args.push_back(builder.createIntegerConstant(loc, inputTypes[4], corank));
162   builder.create<fir::CallOp>(loc, callee, args);
163 }
164 
165 /// Generate a sequence of runtime calls to allocate memory.
166 static mlir::Value genRuntimeAllocate(fir::FirOpBuilder &builder,
167                                       mlir::Location loc,
168                                       const fir::MutableBoxValue &box,
169                                       ErrorManager &errorManager) {
170   mlir::func::FuncOp callee =
171       box.isPointer()
172           ? fir::runtime::getRuntimeFunc<mkRTKey(PointerAllocate)>(loc, builder)
173           : fir::runtime::getRuntimeFunc<mkRTKey(AllocatableAllocate)>(loc,
174                                                                        builder);
175   llvm::SmallVector<mlir::Value> args{
176       box.getAddr(), errorManager.hasStat, errorManager.errMsgAddr,
177       errorManager.sourceFile, errorManager.sourceLine};
178   llvm::SmallVector<mlir::Value> operands;
179   for (auto [fst, snd] : llvm::zip(args, callee.getFunctionType().getInputs()))
180     operands.emplace_back(builder.createConvert(loc, snd, fst));
181   return builder.create<fir::CallOp>(loc, callee, operands).getResult(0);
182 }
183 
184 /// Generate a runtime call to deallocate memory.
185 static mlir::Value genRuntimeDeallocate(fir::FirOpBuilder &builder,
186                                         mlir::Location loc,
187                                         const fir::MutableBoxValue &box,
188                                         ErrorManager &errorManager) {
189   // Ensure fir.box is up-to-date before passing it to deallocate runtime.
190   mlir::Value boxAddress = fir::factory::getMutableIRBox(builder, loc, box);
191   mlir::func::FuncOp callee =
192       box.isPointer()
193           ? fir::runtime::getRuntimeFunc<mkRTKey(PointerDeallocate)>(loc,
194                                                                      builder)
195           : fir::runtime::getRuntimeFunc<mkRTKey(AllocatableDeallocate)>(
196                 loc, builder);
197   llvm::SmallVector<mlir::Value> args{
198       boxAddress, errorManager.hasStat, errorManager.errMsgAddr,
199       errorManager.sourceFile, errorManager.sourceLine};
200   llvm::SmallVector<mlir::Value> operands;
201   for (auto [fst, snd] : llvm::zip(args, callee.getFunctionType().getInputs()))
202     operands.emplace_back(builder.createConvert(loc, snd, fst));
203   return builder.create<fir::CallOp>(loc, callee, operands).getResult(0);
204 }
205 
206 //===----------------------------------------------------------------------===//
207 // Allocate statement implementation
208 //===----------------------------------------------------------------------===//
209 
210 /// Helper to get symbol from AllocateObject.
211 static const Fortran::semantics::Symbol &
212 unwrapSymbol(const Fortran::parser::AllocateObject &allocObj) {
213   const Fortran::parser::Name &lastName =
214       Fortran::parser::GetLastName(allocObj);
215   assert(lastName.symbol);
216   return *lastName.symbol;
217 }
218 
219 static fir::MutableBoxValue
220 genMutableBoxValue(Fortran::lower::AbstractConverter &converter,
221                    mlir::Location loc,
222                    const Fortran::parser::AllocateObject &allocObj) {
223   const Fortran::lower::SomeExpr *expr = Fortran::semantics::GetExpr(allocObj);
224   assert(expr && "semantic analysis failure");
225   return converter.genExprMutableBox(loc, *expr);
226 }
227 
228 /// Implement Allocate statement lowering.
229 class AllocateStmtHelper {
230 public:
231   AllocateStmtHelper(Fortran::lower::AbstractConverter &converter,
232                      const Fortran::parser::AllocateStmt &stmt,
233                      mlir::Location loc)
234       : converter{converter}, builder{converter.getFirOpBuilder()}, stmt{stmt},
235         loc{loc} {}
236 
237   void lower() {
238     visitAllocateOptions();
239     lowerAllocateLengthParameters();
240     errorManager.init(converter, loc, statExpr, errMsgExpr);
241     if (sourceExpr || moldExpr)
242       TODO(loc, "lower MOLD/SOURCE expr in allocate");
243     mlir::OpBuilder::InsertPoint insertPt = builder.saveInsertionPoint();
244     for (const auto &allocation :
245          std::get<std::list<Fortran::parser::Allocation>>(stmt.t))
246       lowerAllocation(unwrapAllocation(allocation));
247     builder.restoreInsertionPoint(insertPt);
248   }
249 
250 private:
251   struct Allocation {
252     const Fortran::parser::Allocation &alloc;
253     const Fortran::semantics::DeclTypeSpec &type;
254     bool hasCoarraySpec() const {
255       return std::get<std::optional<Fortran::parser::AllocateCoarraySpec>>(
256                  alloc.t)
257           .has_value();
258     }
259     const Fortran::parser::AllocateObject &getAllocObj() const {
260       return std::get<Fortran::parser::AllocateObject>(alloc.t);
261     }
262     const Fortran::semantics::Symbol &getSymbol() const {
263       return unwrapSymbol(getAllocObj());
264     }
265     const std::list<Fortran::parser::AllocateShapeSpec> &getShapeSpecs() const {
266       return std::get<std::list<Fortran::parser::AllocateShapeSpec>>(alloc.t);
267     }
268   };
269 
270   Allocation unwrapAllocation(const Fortran::parser::Allocation &alloc) {
271     const auto &allocObj = std::get<Fortran::parser::AllocateObject>(alloc.t);
272     const Fortran::semantics::Symbol &symbol = unwrapSymbol(allocObj);
273     assert(symbol.GetType());
274     return Allocation{alloc, *symbol.GetType()};
275   }
276 
277   void visitAllocateOptions() {
278     for (const auto &allocOption :
279          std::get<std::list<Fortran::parser::AllocOpt>>(stmt.t))
280       std::visit(
281           Fortran::common::visitors{
282               [&](const Fortran::parser::StatOrErrmsg &statOrErr) {
283                 std::visit(
284                     Fortran::common::visitors{
285                         [&](const Fortran::parser::StatVariable &statVar) {
286                           statExpr = Fortran::semantics::GetExpr(statVar);
287                         },
288                         [&](const Fortran::parser::MsgVariable &errMsgVar) {
289                           errMsgExpr = Fortran::semantics::GetExpr(errMsgVar);
290                         },
291                     },
292                     statOrErr.u);
293               },
294               [&](const Fortran::parser::AllocOpt::Source &source) {
295                 sourceExpr = Fortran::semantics::GetExpr(source.v.value());
296               },
297               [&](const Fortran::parser::AllocOpt::Mold &mold) {
298                 moldExpr = Fortran::semantics::GetExpr(mold.v.value());
299               },
300           },
301           allocOption.u);
302   }
303 
304   void lowerAllocation(const Allocation &alloc) {
305     fir::MutableBoxValue boxAddr =
306         genMutableBoxValue(converter, loc, alloc.getAllocObj());
307 
308     if (sourceExpr) {
309       genSourceAllocation(alloc, boxAddr);
310     } else if (moldExpr) {
311       genMoldAllocation(alloc, boxAddr);
312     } else {
313       genSimpleAllocation(alloc, boxAddr);
314     }
315   }
316 
317   static bool lowerBoundsAreOnes(const Allocation &alloc) {
318     for (const Fortran::parser::AllocateShapeSpec &shapeSpec :
319          alloc.getShapeSpecs())
320       if (std::get<0>(shapeSpec.t))
321         return false;
322     return true;
323   }
324 
325   /// Build name for the fir::allocmem generated for alloc.
326   std::string mangleAlloc(const Allocation &alloc) {
327     return converter.mangleName(alloc.getSymbol()) + ".alloc";
328   }
329 
330   /// Generate allocation without runtime calls.
331   /// Only for intrinsic types. No coarrays, no polymorphism. No error recovery.
332   void genInlinedAllocation(const Allocation &alloc,
333                             const fir::MutableBoxValue &box) {
334     llvm::SmallVector<mlir::Value> lbounds;
335     llvm::SmallVector<mlir::Value> extents;
336     Fortran::lower::StatementContext stmtCtx;
337     mlir::Type idxTy = builder.getIndexType();
338     bool lBoundsAreOnes = lowerBoundsAreOnes(alloc);
339     mlir::Value one = builder.createIntegerConstant(loc, idxTy, 1);
340     for (const Fortran::parser::AllocateShapeSpec &shapeSpec :
341          alloc.getShapeSpecs()) {
342       mlir::Value lb;
343       if (!lBoundsAreOnes) {
344         if (const std::optional<Fortran::parser::BoundExpr> &lbExpr =
345                 std::get<0>(shapeSpec.t)) {
346           lb = fir::getBase(converter.genExprValue(
347               loc, Fortran::semantics::GetExpr(*lbExpr), stmtCtx));
348           lb = builder.createConvert(loc, idxTy, lb);
349         } else {
350           lb = one;
351         }
352         lbounds.emplace_back(lb);
353       }
354       mlir::Value ub = fir::getBase(converter.genExprValue(
355           loc, Fortran::semantics::GetExpr(std::get<1>(shapeSpec.t)), stmtCtx));
356       ub = builder.createConvert(loc, idxTy, ub);
357       if (lb) {
358         mlir::Value diff = builder.create<mlir::arith::SubIOp>(loc, ub, lb);
359         extents.emplace_back(
360             builder.create<mlir::arith::AddIOp>(loc, diff, one));
361       } else {
362         extents.emplace_back(ub);
363       }
364     }
365     fir::factory::genInlinedAllocation(builder, loc, box, lbounds, extents,
366                                        lenParams, mangleAlloc(alloc));
367   }
368 
369   void genSimpleAllocation(const Allocation &alloc,
370                            const fir::MutableBoxValue &box) {
371     if (!box.isDerived() && !errorManager.hasStatSpec() &&
372         !alloc.type.IsPolymorphic() && !alloc.hasCoarraySpec() &&
373         !useAllocateRuntime) {
374       genInlinedAllocation(alloc, box);
375       return;
376     }
377     // Generate a sequence of runtime calls.
378     errorManager.genStatCheck(builder, loc);
379     if (box.isPointer()) {
380       // For pointers, the descriptor may still be uninitialized (see Fortran
381       // 2018 19.5.2.2). The allocation runtime needs to be given a descriptor
382       // with initialized rank, types and attributes. Initialize the descriptor
383       // here to ensure these constraints are fulfilled.
384       mlir::Value nullPointer = fir::factory::createUnallocatedBox(
385           builder, loc, box.getBoxTy(), box.nonDeferredLenParams());
386       builder.create<fir::StoreOp>(loc, nullPointer, box.getAddr());
387     } else {
388       assert(box.isAllocatable() && "must be an allocatable");
389       // For allocatables, sync the MutableBoxValue and descriptor before the
390       // calls in case it is tracked locally by a set of variables.
391       fir::factory::getMutableIRBox(builder, loc, box);
392     }
393     if (alloc.hasCoarraySpec())
394       TODO(loc, "coarray allocation");
395     if (alloc.type.IsPolymorphic())
396       genSetType(alloc, box);
397     genSetDeferredLengthParameters(alloc, box);
398     // Set bounds for arrays
399     mlir::Type idxTy = builder.getIndexType();
400     mlir::Type i32Ty = builder.getIntegerType(32);
401     Fortran::lower::StatementContext stmtCtx;
402     for (const auto &iter : llvm::enumerate(alloc.getShapeSpecs())) {
403       mlir::Value lb;
404       const auto &bounds = iter.value().t;
405       if (const std::optional<Fortran::parser::BoundExpr> &lbExpr =
406               std::get<0>(bounds))
407         lb = fir::getBase(converter.genExprValue(
408             loc, Fortran::semantics::GetExpr(*lbExpr), stmtCtx));
409       else
410         lb = builder.createIntegerConstant(loc, idxTy, 1);
411       mlir::Value ub = fir::getBase(converter.genExprValue(
412           loc, Fortran::semantics::GetExpr(std::get<1>(bounds)), stmtCtx));
413       mlir::Value dimIndex =
414           builder.createIntegerConstant(loc, i32Ty, iter.index());
415       // Runtime call
416       genRuntimeSetBounds(builder, loc, box, dimIndex, lb, ub);
417     }
418     mlir::Value stat = genRuntimeAllocate(builder, loc, box, errorManager);
419     fir::factory::syncMutableBoxFromIRBox(builder, loc, box);
420     errorManager.assignStat(builder, loc, stat);
421   }
422 
423   /// Lower the length parameters that may be specified in the optional
424   /// type specification.
425   void lowerAllocateLengthParameters() {
426     const Fortran::semantics::DeclTypeSpec *typeSpec =
427         getIfAllocateStmtTypeSpec();
428     if (!typeSpec)
429       return;
430     if (const Fortran::semantics::DerivedTypeSpec *derived =
431             typeSpec->AsDerived())
432       if (Fortran::semantics::CountLenParameters(*derived) > 0)
433         TODO(loc, "TODO: setting derived type params in allocation");
434     if (typeSpec->category() ==
435         Fortran::semantics::DeclTypeSpec::Category::Character) {
436       Fortran::semantics::ParamValue lenParam =
437           typeSpec->characterTypeSpec().length();
438       if (Fortran::semantics::MaybeIntExpr intExpr = lenParam.GetExplicit()) {
439         Fortran::lower::StatementContext stmtCtx;
440         Fortran::lower::SomeExpr lenExpr{*intExpr};
441         lenParams.push_back(
442             fir::getBase(converter.genExprValue(loc, lenExpr, stmtCtx)));
443       }
444     }
445   }
446 
447   // Set length parameters in the box stored in boxAddr.
448   // This must be called before setting the bounds because it may use
449   // Init runtime calls that may set the bounds to zero.
450   void genSetDeferredLengthParameters(const Allocation &alloc,
451                                       const fir::MutableBoxValue &box) {
452     if (lenParams.empty())
453       return;
454     // TODO: in case a length parameter was not deferred, insert a runtime check
455     // that the length is the same (AllocatableCheckLengthParameter runtime
456     // call).
457     if (box.isCharacter())
458       genRuntimeInitCharacter(builder, loc, box, lenParams[0]);
459 
460     if (box.isDerived())
461       TODO(loc, "derived type length parameters in allocate");
462   }
463 
464   void genSourceAllocation(const Allocation &, const fir::MutableBoxValue &) {
465     TODO(loc, "SOURCE allocation lowering");
466   }
467   void genMoldAllocation(const Allocation &, const fir::MutableBoxValue &) {
468     TODO(loc, "MOLD allocation lowering");
469   }
470   void genSetType(const Allocation &, const fir::MutableBoxValue &) {
471     TODO(loc, "Polymorphic entity allocation lowering");
472   }
473 
474   /// Returns a pointer to the DeclTypeSpec if a type-spec is provided in the
475   /// allocate statement. Returns a null pointer otherwise.
476   const Fortran::semantics::DeclTypeSpec *getIfAllocateStmtTypeSpec() const {
477     if (const auto &typeSpec =
478             std::get<std::optional<Fortran::parser::TypeSpec>>(stmt.t))
479       return typeSpec->declTypeSpec;
480     return nullptr;
481   }
482 
483   Fortran::lower::AbstractConverter &converter;
484   fir::FirOpBuilder &builder;
485   const Fortran::parser::AllocateStmt &stmt;
486   const Fortran::lower::SomeExpr *sourceExpr{nullptr};
487   const Fortran::lower::SomeExpr *moldExpr{nullptr};
488   const Fortran::lower::SomeExpr *statExpr{nullptr};
489   const Fortran::lower::SomeExpr *errMsgExpr{nullptr};
490   // If the allocate has a type spec, lenParams contains the
491   // value of the length parameters that were specified inside.
492   llvm::SmallVector<mlir::Value> lenParams;
493   ErrorManager errorManager;
494 
495   mlir::Location loc;
496 };
497 } // namespace
498 
499 void Fortran::lower::genAllocateStmt(
500     Fortran::lower::AbstractConverter &converter,
501     const Fortran::parser::AllocateStmt &stmt, mlir::Location loc) {
502   AllocateStmtHelper{converter, stmt, loc}.lower();
503   return;
504 }
505 
506 //===----------------------------------------------------------------------===//
507 // Deallocate statement implementation
508 //===----------------------------------------------------------------------===//
509 
510 // Generate deallocation of a pointer/allocatable.
511 static void genDeallocate(fir::FirOpBuilder &builder, mlir::Location loc,
512                           const fir::MutableBoxValue &box,
513                           ErrorManager &errorManager) {
514   // Deallocate intrinsic types inline.
515   if (!box.isDerived() && !errorManager.hasStatSpec() && !useAllocateRuntime) {
516     fir::factory::genInlinedDeallocate(builder, loc, box);
517     return;
518   }
519   // Use runtime calls to deallocate descriptor cases. Sync MutableBoxValue
520   // with its descriptor before and after calls if needed.
521   errorManager.genStatCheck(builder, loc);
522   mlir::Value stat = genRuntimeDeallocate(builder, loc, box, errorManager);
523   fir::factory::syncMutableBoxFromIRBox(builder, loc, box);
524   errorManager.assignStat(builder, loc, stat);
525 }
526 
527 void Fortran::lower::genDeallocateStmt(
528     Fortran::lower::AbstractConverter &converter,
529     const Fortran::parser::DeallocateStmt &stmt, mlir::Location loc) {
530   const Fortran::lower::SomeExpr *statExpr = nullptr;
531   const Fortran::lower::SomeExpr *errMsgExpr = nullptr;
532   for (const Fortran::parser::StatOrErrmsg &statOrErr :
533        std::get<std::list<Fortran::parser::StatOrErrmsg>>(stmt.t))
534     std::visit(Fortran::common::visitors{
535                    [&](const Fortran::parser::StatVariable &statVar) {
536                      statExpr = Fortran::semantics::GetExpr(statVar);
537                    },
538                    [&](const Fortran::parser::MsgVariable &errMsgVar) {
539                      errMsgExpr = Fortran::semantics::GetExpr(errMsgVar);
540                    },
541                },
542                statOrErr.u);
543   ErrorManager errorManager;
544   errorManager.init(converter, loc, statExpr, errMsgExpr);
545   fir::FirOpBuilder &builder = converter.getFirOpBuilder();
546   mlir::OpBuilder::InsertPoint insertPt = builder.saveInsertionPoint();
547   for (const Fortran::parser::AllocateObject &allocateObject :
548        std::get<std::list<Fortran::parser::AllocateObject>>(stmt.t)) {
549     fir::MutableBoxValue box =
550         genMutableBoxValue(converter, loc, allocateObject);
551     genDeallocate(builder, loc, box, errorManager);
552   }
553   builder.restoreInsertionPoint(insertPt);
554 }
555 
556 //===----------------------------------------------------------------------===//
557 // MutableBoxValue creation implementation
558 //===----------------------------------------------------------------------===//
559 
560 /// Is this symbol a pointer to a pointer array that does not have the
561 /// CONTIGUOUS attribute ?
562 static inline bool
563 isNonContiguousArrayPointer(const Fortran::semantics::Symbol &sym) {
564   return Fortran::semantics::IsPointer(sym) && sym.Rank() != 0 &&
565          !sym.attrs().test(Fortran::semantics::Attr::CONTIGUOUS);
566 }
567 
568 /// Is this a local procedure symbol in a procedure that contains internal
569 /// procedures ?
570 static bool mayBeCapturedInInternalProc(const Fortran::semantics::Symbol &sym) {
571   const Fortran::semantics::Scope &owner = sym.owner();
572   Fortran::semantics::Scope::Kind kind = owner.kind();
573   // Test if this is a procedure scope that contains a subprogram scope that is
574   // not an interface.
575   if (kind == Fortran::semantics::Scope::Kind::Subprogram ||
576       kind == Fortran::semantics::Scope::Kind::MainProgram)
577     for (const Fortran::semantics::Scope &childScope : owner.children())
578       if (childScope.kind() == Fortran::semantics::Scope::Kind::Subprogram)
579         if (const Fortran::semantics::Symbol *childSym = childScope.symbol())
580           if (const auto *details =
581                   childSym->detailsIf<Fortran::semantics::SubprogramDetails>())
582             if (!details->isInterface())
583               return true;
584   return false;
585 }
586 
587 /// In case it is safe to track the properties in variables outside a
588 /// descriptor, create the variables to hold the mutable properties of the
589 /// entity var. The variables are not initialized here.
590 static fir::MutableProperties
591 createMutableProperties(Fortran::lower::AbstractConverter &converter,
592                         mlir::Location loc,
593                         const Fortran::lower::pft::Variable &var,
594                         mlir::ValueRange nonDeferredParams) {
595   fir::FirOpBuilder &builder = converter.getFirOpBuilder();
596   const Fortran::semantics::Symbol &sym = var.getSymbol();
597   // Globals and dummies may be associated, creating local variables would
598   // require keeping the values and descriptor before and after every single
599   // impure calls in the current scope (not only the ones taking the variable as
600   // arguments. All.) Volatile means the variable may change in ways not defined
601   // per Fortran, so lowering can most likely not keep the descriptor and values
602   // in sync as needed.
603   // Pointers to non contiguous arrays need to be represented with a fir.box to
604   // account for the discontiguity.
605   // Pointer/Allocatable in internal procedure are descriptors in the host link,
606   // and it would increase complexity to sync this descriptor with the local
607   // values every time the host link is escaping.
608   if (var.isGlobal() || Fortran::semantics::IsDummy(sym) ||
609       Fortran::semantics::IsFunctionResult(sym) ||
610       sym.attrs().test(Fortran::semantics::Attr::VOLATILE) ||
611       isNonContiguousArrayPointer(sym) || useAllocateRuntime ||
612       useDescForMutableBox || mayBeCapturedInInternalProc(sym))
613     return {};
614   fir::MutableProperties mutableProperties;
615   std::string name = converter.mangleName(sym);
616   mlir::Type baseAddrTy = converter.genType(sym);
617   if (auto boxType = baseAddrTy.dyn_cast<fir::BoxType>())
618     baseAddrTy = boxType.getEleTy();
619   // Allocate and set a variable to hold the address.
620   // It will be set to null in setUnallocatedStatus.
621   mutableProperties.addr =
622       builder.allocateLocal(loc, baseAddrTy, name + ".addr", "",
623                             /*shape=*/llvm::None, /*typeparams=*/llvm::None);
624   // Allocate variables to hold lower bounds and extents.
625   int rank = sym.Rank();
626   mlir::Type idxTy = builder.getIndexType();
627   for (decltype(rank) i = 0; i < rank; ++i) {
628     mlir::Value lboundVar =
629         builder.allocateLocal(loc, idxTy, name + ".lb" + std::to_string(i), "",
630                               /*shape=*/llvm::None, /*typeparams=*/llvm::None);
631     mlir::Value extentVar =
632         builder.allocateLocal(loc, idxTy, name + ".ext" + std::to_string(i), "",
633                               /*shape=*/llvm::None, /*typeparams=*/llvm::None);
634     mutableProperties.lbounds.emplace_back(lboundVar);
635     mutableProperties.extents.emplace_back(extentVar);
636   }
637 
638   // Allocate variable to hold deferred length parameters.
639   mlir::Type eleTy = baseAddrTy;
640   if (auto newTy = fir::dyn_cast_ptrEleTy(eleTy))
641     eleTy = newTy;
642   if (auto seqTy = eleTy.dyn_cast<fir::SequenceType>())
643     eleTy = seqTy.getEleTy();
644   if (auto record = eleTy.dyn_cast<fir::RecordType>())
645     if (record.getNumLenParams() != 0)
646       TODO(loc, "deferred length type parameters.");
647   if (fir::isa_char(eleTy) && nonDeferredParams.empty()) {
648     mlir::Value lenVar =
649         builder.allocateLocal(loc, builder.getCharacterLengthType(),
650                               name + ".len", "", /*shape=*/llvm::None,
651                               /*typeparams=*/llvm::None);
652     mutableProperties.deferredParams.emplace_back(lenVar);
653   }
654   return mutableProperties;
655 }
656 
657 fir::MutableBoxValue Fortran::lower::createMutableBox(
658     Fortran::lower::AbstractConverter &converter, mlir::Location loc,
659     const Fortran::lower::pft::Variable &var, mlir::Value boxAddr,
660     mlir::ValueRange nonDeferredParams) {
661 
662   fir::MutableProperties mutableProperties =
663       createMutableProperties(converter, loc, var, nonDeferredParams);
664   fir::MutableBoxValue box(boxAddr, nonDeferredParams, mutableProperties);
665   fir::FirOpBuilder &builder = converter.getFirOpBuilder();
666   if (!var.isGlobal() && !Fortran::semantics::IsDummy(var.getSymbol()))
667     fir::factory::disassociateMutableBox(builder, loc, box);
668   return box;
669 }
670 
671 //===----------------------------------------------------------------------===//
672 // MutableBoxValue reading interface implementation
673 //===----------------------------------------------------------------------===//
674 
675 bool Fortran::lower::isArraySectionWithoutVectorSubscript(
676     const Fortran::lower::SomeExpr &expr) {
677   return expr.Rank() > 0 && Fortran::evaluate::IsVariable(expr) &&
678          !Fortran::evaluate::UnwrapWholeSymbolDataRef(expr) &&
679          !Fortran::evaluate::HasVectorSubscript(expr);
680 }
681 
682 void Fortran::lower::associateMutableBox(
683     Fortran::lower::AbstractConverter &converter, mlir::Location loc,
684     const fir::MutableBoxValue &box, const Fortran::lower::SomeExpr &source,
685     mlir::ValueRange lbounds, Fortran::lower::StatementContext &stmtCtx) {
686   fir::FirOpBuilder &builder = converter.getFirOpBuilder();
687   if (Fortran::evaluate::UnwrapExpr<Fortran::evaluate::NullPointer>(source)) {
688     fir::factory::disassociateMutableBox(builder, loc, box);
689     return;
690   }
691 
692   // The right hand side is not be evaluated into a temp. Array sections can
693   // typically be represented as a value of type `!fir.box`. However, an
694   // expression that uses vector subscripts cannot be emboxed. In that case,
695   // generate a reference to avoid having to later use a fir.rebox to implement
696   // the pointer association.
697   fir::ExtendedValue rhs = isArraySectionWithoutVectorSubscript(source)
698                                ? converter.genExprBox(loc, source, stmtCtx)
699                                : converter.genExprAddr(loc, source, stmtCtx);
700   fir::factory::associateMutableBox(builder, loc, box, rhs, lbounds);
701 }
702 
703 bool Fortran::lower::isWholeAllocatable(const Fortran::lower::SomeExpr &expr) {
704   if (const Fortran::semantics::Symbol *sym =
705           Fortran::evaluate::UnwrapWholeSymbolOrComponentDataRef(expr))
706     return Fortran::semantics::IsAllocatable(*sym);
707   return false;
708 }
709 
710 bool Fortran::lower::isWholePointer(const Fortran::lower::SomeExpr &expr) {
711   if (const Fortran::semantics::Symbol *sym =
712           Fortran::evaluate::UnwrapWholeSymbolOrComponentDataRef(expr))
713     return Fortran::semantics::IsPointer(*sym);
714   return false;
715 }
716