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     mlir::Value backupBox;
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               Fortran::semantics::GetExpr(*lbExpr), stmtCtx, loc));
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           Fortran::semantics::GetExpr(std::get<1>(shapeSpec.t)), stmtCtx, loc));
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             Fortran::semantics::GetExpr(*lbExpr), stmtCtx, loc));
409       else
410         lb = builder.createIntegerConstant(loc, idxTy, 1);
411       mlir::Value ub = fir::getBase(converter.genExprValue(
412           Fortran::semantics::GetExpr(std::get<1>(bounds)), stmtCtx, loc));
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(lenExpr, stmtCtx, &loc)));
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