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