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 {
init__anon5a2fc0790111::ErrorManager55   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 
hasStatSpec__anon5a2fc0790111::ErrorManager76   bool hasStatSpec() const { return static_cast<bool>(statAddr); }
77 
genStatCheck__anon5a2fc0790111::ErrorManager78   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 
assignStat__anon5a2fc0790111::ErrorManager90   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.
genRuntimeSetBounds(fir::FirOpBuilder & builder,mlir::Location loc,const fir::MutableBoxValue & box,mlir::Value dimIndex,mlir::Value lowerBound,mlir::Value upperBound)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.
genRuntimeInitCharacter(fir::FirOpBuilder & builder,mlir::Location loc,const fir::MutableBoxValue & box,mlir::Value len)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.
genRuntimeAllocate(fir::FirOpBuilder & builder,mlir::Location loc,const fir::MutableBoxValue & box,ErrorManager & errorManager)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.
genRuntimeDeallocate(fir::FirOpBuilder & builder,mlir::Location loc,const fir::MutableBoxValue & box,ErrorManager & errorManager)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 &
unwrapSymbol(const Fortran::parser::AllocateObject & allocObj)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
genMutableBoxValue(Fortran::lower::AbstractConverter & converter,mlir::Location loc,const Fortran::parser::AllocateObject & allocObj)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:
AllocateStmtHelper(Fortran::lower::AbstractConverter & converter,const Fortran::parser::AllocateStmt & stmt,mlir::Location loc)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 
lower()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;
hasCoarraySpec__anon5a2fc0790111::AllocateStmtHelper::Allocation254     bool hasCoarraySpec() const {
255       return std::get<std::optional<Fortran::parser::AllocateCoarraySpec>>(
256                  alloc.t)
257           .has_value();
258     }
getAllocObj__anon5a2fc0790111::AllocateStmtHelper::Allocation259     const Fortran::parser::AllocateObject &getAllocObj() const {
260       return std::get<Fortran::parser::AllocateObject>(alloc.t);
261     }
getSymbol__anon5a2fc0790111::AllocateStmtHelper::Allocation262     const Fortran::semantics::Symbol &getSymbol() const {
263       return unwrapSymbol(getAllocObj());
264     }
getShapeSpecs__anon5a2fc0790111::AllocateStmtHelper::Allocation265     const std::list<Fortran::parser::AllocateShapeSpec> &getShapeSpecs() const {
266       return std::get<std::list<Fortran::parser::AllocateShapeSpec>>(alloc.t);
267     }
268   };
269 
unwrapAllocation(const Fortran::parser::Allocation & alloc)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 
visitAllocateOptions()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 
lowerAllocation(const Allocation & alloc)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 
lowerBoundsAreOnes(const Allocation & alloc)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.
mangleAlloc(const Allocation & 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.
genInlinedAllocation(const Allocation & alloc,const fir::MutableBoxValue & box)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 
genSimpleAllocation(const Allocation & alloc,const fir::MutableBoxValue & box)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.
lowerAllocateLengthParameters()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, "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.
genSetDeferredLengthParameters(const Allocation & alloc,const fir::MutableBoxValue & box)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 
genSourceAllocation(const Allocation &,const fir::MutableBoxValue &)464   void genSourceAllocation(const Allocation &, const fir::MutableBoxValue &) {
465     TODO(loc, "SOURCE allocation");
466   }
genMoldAllocation(const Allocation &,const fir::MutableBoxValue &)467   void genMoldAllocation(const Allocation &, const fir::MutableBoxValue &) {
468     TODO(loc, "MOLD allocation");
469   }
genSetType(const Allocation &,const fir::MutableBoxValue &)470   void genSetType(const Allocation &, const fir::MutableBoxValue &) {
471     TODO(loc, "polymorphic entity allocation");
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.
getIfAllocateStmtTypeSpec() const476   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 
genAllocateStmt(Fortran::lower::AbstractConverter & converter,const Fortran::parser::AllocateStmt & stmt,mlir::Location loc)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 }
504 
505 //===----------------------------------------------------------------------===//
506 // Deallocate statement implementation
507 //===----------------------------------------------------------------------===//
508 
509 // Generate deallocation of a pointer/allocatable.
genDeallocate(fir::FirOpBuilder & builder,mlir::Location loc,const fir::MutableBoxValue & box,ErrorManager & errorManager)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 
genDeallocateStmt(Fortran::lower::AbstractConverter & converter,const Fortran::parser::DeallocateStmt & stmt,mlir::Location loc)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
isNonContiguousArrayPointer(const Fortran::semantics::Symbol & sym)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 ?
mayBeCapturedInInternalProc(const Fortran::semantics::Symbol & sym)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
createMutableProperties(Fortran::lower::AbstractConverter & converter,mlir::Location loc,const Fortran::lower::pft::Variable & var,mlir::ValueRange nonDeferredParams)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 
createMutableBox(Fortran::lower::AbstractConverter & converter,mlir::Location loc,const Fortran::lower::pft::Variable & var,mlir::Value boxAddr,mlir::ValueRange nonDeferredParams)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 
isArraySectionWithoutVectorSubscript(const Fortran::lower::SomeExpr & expr)674 bool Fortran::lower::isArraySectionWithoutVectorSubscript(
675     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 
associateMutableBox(Fortran::lower::AbstractConverter & converter,mlir::Location loc,const fir::MutableBoxValue & box,const Fortran::lower::SomeExpr & source,mlir::ValueRange lbounds,Fortran::lower::StatementContext & stmtCtx)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 
691   // The right hand side is not be evaluated into a temp. Array sections can
692   // typically be represented as a value of type `!fir.box`. However, an
693   // expression that uses vector subscripts cannot be emboxed. In that case,
694   // generate a reference to avoid having to later use a fir.rebox to implement
695   // the pointer association.
696   fir::ExtendedValue rhs = isArraySectionWithoutVectorSubscript(source)
697                                ? converter.genExprBox(loc, source, stmtCtx)
698                                : converter.genExprAddr(loc, source, stmtCtx);
699   fir::factory::associateMutableBox(builder, loc, box, rhs, lbounds);
700 }
701 
isWholeAllocatable(const Fortran::lower::SomeExpr & expr)702 bool Fortran::lower::isWholeAllocatable(const Fortran::lower::SomeExpr &expr) {
703   if (const Fortran::semantics::Symbol *sym =
704           Fortran::evaluate::UnwrapWholeSymbolOrComponentDataRef(expr))
705     return Fortran::semantics::IsAllocatable(*sym);
706   return false;
707 }
708 
isWholePointer(const Fortran::lower::SomeExpr & expr)709 bool Fortran::lower::isWholePointer(const Fortran::lower::SomeExpr &expr) {
710   if (const Fortran::semantics::Symbol *sym =
711           Fortran::evaluate::UnwrapWholeSymbolOrComponentDataRef(expr))
712     return Fortran::semantics::IsPointer(*sym);
713   return false;
714 }
715