1 //===-- Bridge.cpp -- bridge to lower to MLIR -----------------------------===//
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/Bridge.h"
14 #include "flang/Evaluate/tools.h"
15 #include "flang/Lower/Allocatable.h"
16 #include "flang/Lower/CallInterface.h"
17 #include "flang/Lower/ConvertExpr.h"
18 #include "flang/Lower/ConvertType.h"
19 #include "flang/Lower/ConvertVariable.h"
20 #include "flang/Lower/IO.h"
21 #include "flang/Lower/IterationSpace.h"
22 #include "flang/Lower/Mangler.h"
23 #include "flang/Lower/PFTBuilder.h"
24 #include "flang/Lower/Runtime.h"
25 #include "flang/Lower/StatementContext.h"
26 #include "flang/Lower/SymbolMap.h"
27 #include "flang/Lower/Todo.h"
28 #include "flang/Optimizer/Builder/BoxValue.h"
29 #include "flang/Optimizer/Builder/Character.h"
30 #include "flang/Optimizer/Builder/MutableBox.h"
31 #include "flang/Optimizer/Support/FIRContext.h"
32 #include "flang/Optimizer/Support/InternalNames.h"
33 #include "flang/Runtime/iostat.h"
34 #include "flang/Semantics/tools.h"
35 #include "mlir/Dialect/ControlFlow/IR/ControlFlowOps.h"
36 #include "mlir/IR/PatternMatch.h"
37 #include "mlir/Transforms/RegionUtils.h"
38 #include "llvm/Support/CommandLine.h"
39 #include "llvm/Support/Debug.h"
40 
41 #define DEBUG_TYPE "flang-lower-bridge"
42 
43 static llvm::cl::opt<bool> dumpBeforeFir(
44     "fdebug-dump-pre-fir", llvm::cl::init(false),
45     llvm::cl::desc("dump the Pre-FIR tree prior to FIR generation"));
46 
47 //===----------------------------------------------------------------------===//
48 // FirConverter
49 //===----------------------------------------------------------------------===//
50 
51 namespace {
52 
53 /// Traverse the pre-FIR tree (PFT) to generate the FIR dialect of MLIR.
54 class FirConverter : public Fortran::lower::AbstractConverter {
55 public:
56   explicit FirConverter(Fortran::lower::LoweringBridge &bridge)
57       : bridge{bridge}, foldingContext{bridge.createFoldingContext()} {}
58   virtual ~FirConverter() = default;
59 
60   /// Convert the PFT to FIR.
61   void run(Fortran::lower::pft::Program &pft) {
62     // Primary translation pass.
63     //  - Declare all functions that have definitions so that definition
64     //    signatures prevail over call site signatures.
65     //  - Define module variables and OpenMP/OpenACC declarative construct so
66     //    that they are available before lowering any function that may use
67     //    them.
68     for (Fortran::lower::pft::Program::Units &u : pft.getUnits()) {
69       std::visit(Fortran::common::visitors{
70                      [&](Fortran::lower::pft::FunctionLikeUnit &f) {
71                        declareFunction(f);
72                      },
73                      [&](Fortran::lower::pft::ModuleLikeUnit &m) {
74                        lowerModuleDeclScope(m);
75                        for (Fortran::lower::pft::FunctionLikeUnit &f :
76                             m.nestedFunctions)
77                          declareFunction(f);
78                      },
79                      [&](Fortran::lower::pft::BlockDataUnit &b) {},
80                      [&](Fortran::lower::pft::CompilerDirectiveUnit &d) {
81                        setCurrentPosition(
82                            d.get<Fortran::parser::CompilerDirective>().source);
83                        mlir::emitWarning(toLocation(),
84                                          "ignoring all compiler directives");
85                      },
86                  },
87                  u);
88     }
89 
90     // Primary translation pass.
91     for (Fortran::lower::pft::Program::Units &u : pft.getUnits()) {
92       std::visit(
93           Fortran::common::visitors{
94               [&](Fortran::lower::pft::FunctionLikeUnit &f) { lowerFunc(f); },
95               [&](Fortran::lower::pft::ModuleLikeUnit &m) { lowerMod(m); },
96               [&](Fortran::lower::pft::BlockDataUnit &b) {},
97               [&](Fortran::lower::pft::CompilerDirectiveUnit &d) {},
98           },
99           u);
100     }
101   }
102 
103   /// Declare a function.
104   void declareFunction(Fortran::lower::pft::FunctionLikeUnit &funit) {
105     setCurrentPosition(funit.getStartingSourceLoc());
106     for (int entryIndex = 0, last = funit.entryPointList.size();
107          entryIndex < last; ++entryIndex) {
108       funit.setActiveEntry(entryIndex);
109       // Calling CalleeInterface ctor will build a declaration mlir::FuncOp with
110       // no other side effects.
111       // TODO: when doing some compiler profiling on real apps, it may be worth
112       // to check it's better to save the CalleeInterface instead of recomputing
113       // it later when lowering the body. CalleeInterface ctor should be linear
114       // with the number of arguments, so it is not awful to do it that way for
115       // now, but the linear coefficient might be non negligible. Until
116       // measured, stick to the solution that impacts the code less.
117       Fortran::lower::CalleeInterface{funit, *this};
118     }
119     funit.setActiveEntry(0);
120 
121     // Compute the set of host associated entities from the nested functions.
122     llvm::SetVector<const Fortran::semantics::Symbol *> escapeHost;
123     for (Fortran::lower::pft::FunctionLikeUnit &f : funit.nestedFunctions)
124       collectHostAssociatedVariables(f, escapeHost);
125     funit.setHostAssociatedSymbols(escapeHost);
126 
127     // Declare internal procedures
128     for (Fortran::lower::pft::FunctionLikeUnit &f : funit.nestedFunctions)
129       declareFunction(f);
130   }
131 
132   /// Collects the canonical list of all host associated symbols. These bindings
133   /// must be aggregated into a tuple which can then be added to each of the
134   /// internal procedure declarations and passed at each call site.
135   void collectHostAssociatedVariables(
136       Fortran::lower::pft::FunctionLikeUnit &funit,
137       llvm::SetVector<const Fortran::semantics::Symbol *> &escapees) {
138     const Fortran::semantics::Scope *internalScope =
139         funit.getSubprogramSymbol().scope();
140     assert(internalScope && "internal procedures symbol must create a scope");
141     auto addToListIfEscapee = [&](const Fortran::semantics::Symbol &sym) {
142       const Fortran::semantics::Symbol &ultimate = sym.GetUltimate();
143       const auto *namelistDetails =
144           ultimate.detailsIf<Fortran::semantics::NamelistDetails>();
145       if (ultimate.has<Fortran::semantics::ObjectEntityDetails>() ||
146           Fortran::semantics::IsProcedurePointer(ultimate) ||
147           Fortran::semantics::IsDummy(sym) || namelistDetails) {
148         const Fortran::semantics::Scope &ultimateScope = ultimate.owner();
149         if (ultimateScope.kind() ==
150                 Fortran::semantics::Scope::Kind::MainProgram ||
151             ultimateScope.kind() == Fortran::semantics::Scope::Kind::Subprogram)
152           if (ultimateScope != *internalScope &&
153               ultimateScope.Contains(*internalScope)) {
154             if (namelistDetails) {
155               // So far, namelist symbols are processed on the fly in IO and
156               // the related namelist data structure is not added to the symbol
157               // map, so it cannot be passed to the internal procedures.
158               // Instead, all the symbols of the host namelist used in the
159               // internal procedure must be considered as host associated so
160               // that IO lowering can find them when needed.
161               for (const auto &namelistObject : namelistDetails->objects())
162                 escapees.insert(&*namelistObject);
163             } else {
164               escapees.insert(&ultimate);
165             }
166           }
167       }
168     };
169     Fortran::lower::pft::visitAllSymbols(funit, addToListIfEscapee);
170   }
171 
172   //===--------------------------------------------------------------------===//
173   // AbstractConverter overrides
174   //===--------------------------------------------------------------------===//
175 
176   mlir::Value getSymbolAddress(Fortran::lower::SymbolRef sym) override final {
177     return lookupSymbol(sym).getAddr();
178   }
179 
180   bool lookupLabelSet(Fortran::lower::SymbolRef sym,
181                       Fortran::lower::pft::LabelSet &labelSet) override final {
182     Fortran::lower::pft::FunctionLikeUnit &owningProc =
183         *getEval().getOwningProcedure();
184     auto iter = owningProc.assignSymbolLabelMap.find(sym);
185     if (iter == owningProc.assignSymbolLabelMap.end())
186       return false;
187     labelSet = iter->second;
188     return true;
189   }
190 
191   Fortran::lower::pft::Evaluation *
192   lookupLabel(Fortran::lower::pft::Label label) override final {
193     Fortran::lower::pft::FunctionLikeUnit &owningProc =
194         *getEval().getOwningProcedure();
195     auto iter = owningProc.labelEvaluationMap.find(label);
196     if (iter == owningProc.labelEvaluationMap.end())
197       return nullptr;
198     return iter->second;
199   }
200 
201   fir::ExtendedValue genExprAddr(const Fortran::lower::SomeExpr &expr,
202                                  Fortran::lower::StatementContext &context,
203                                  mlir::Location *loc = nullptr) override final {
204     return createSomeExtendedAddress(loc ? *loc : toLocation(), *this, expr,
205                                      localSymbols, context);
206   }
207   fir::ExtendedValue
208   genExprValue(const Fortran::lower::SomeExpr &expr,
209                Fortran::lower::StatementContext &context,
210                mlir::Location *loc = nullptr) override final {
211     return createSomeExtendedExpression(loc ? *loc : toLocation(), *this, expr,
212                                         localSymbols, context);
213   }
214   fir::MutableBoxValue
215   genExprMutableBox(mlir::Location loc,
216                     const Fortran::lower::SomeExpr &expr) override final {
217     return Fortran::lower::createMutableBox(loc, *this, expr, localSymbols);
218   }
219   fir::ExtendedValue genExprBox(const Fortran::lower::SomeExpr &expr,
220                                 Fortran::lower::StatementContext &context,
221                                 mlir::Location loc) override final {
222     if (expr.Rank() > 0 && Fortran::evaluate::IsVariable(expr) &&
223         !Fortran::evaluate::HasVectorSubscript(expr))
224       return Fortran::lower::createSomeArrayBox(*this, expr, localSymbols,
225                                                 context);
226     return fir::BoxValue(
227         builder->createBox(loc, genExprAddr(expr, context, &loc)));
228   }
229 
230   Fortran::evaluate::FoldingContext &getFoldingContext() override final {
231     return foldingContext;
232   }
233 
234   mlir::Type genType(const Fortran::evaluate::DataRef &) override final {
235     TODO_NOLOC("Not implemented genType DataRef. Needed for more complex "
236                "expression lowering");
237   }
238   mlir::Type genType(const Fortran::lower::SomeExpr &expr) override final {
239     return Fortran::lower::translateSomeExprToFIRType(*this, expr);
240   }
241   mlir::Type genType(Fortran::lower::SymbolRef sym) override final {
242     return Fortran::lower::translateSymbolToFIRType(*this, sym);
243   }
244   mlir::Type genType(Fortran::common::TypeCategory tc) override final {
245     TODO_NOLOC("Not implemented genType TypeCategory. Needed for more complex "
246                "expression lowering");
247   }
248   mlir::Type
249   genType(Fortran::common::TypeCategory tc, int kind,
250           llvm::ArrayRef<std::int64_t> lenParameters) override final {
251     return Fortran::lower::getFIRType(&getMLIRContext(), tc, kind,
252                                       lenParameters);
253   }
254   mlir::Type genType(const Fortran::lower::pft::Variable &var) override final {
255     return Fortran::lower::translateVariableToFIRType(*this, var);
256   }
257 
258   void setCurrentPosition(const Fortran::parser::CharBlock &position) {
259     if (position != Fortran::parser::CharBlock{})
260       currentPosition = position;
261   }
262 
263   //===--------------------------------------------------------------------===//
264   // Utility methods
265   //===--------------------------------------------------------------------===//
266 
267   /// Convert a parser CharBlock to a Location
268   mlir::Location toLocation(const Fortran::parser::CharBlock &cb) {
269     return genLocation(cb);
270   }
271 
272   mlir::Location toLocation() { return toLocation(currentPosition); }
273   void setCurrentEval(Fortran::lower::pft::Evaluation &eval) {
274     evalPtr = &eval;
275   }
276   Fortran::lower::pft::Evaluation &getEval() {
277     assert(evalPtr && "current evaluation not set");
278     return *evalPtr;
279   }
280 
281   mlir::Location getCurrentLocation() override final { return toLocation(); }
282 
283   /// Generate a dummy location.
284   mlir::Location genUnknownLocation() override final {
285     // Note: builder may not be instantiated yet
286     return mlir::UnknownLoc::get(&getMLIRContext());
287   }
288 
289   /// Generate a `Location` from the `CharBlock`.
290   mlir::Location
291   genLocation(const Fortran::parser::CharBlock &block) override final {
292     if (const Fortran::parser::AllCookedSources *cooked =
293             bridge.getCookedSource()) {
294       if (std::optional<std::pair<Fortran::parser::SourcePosition,
295                                   Fortran::parser::SourcePosition>>
296               loc = cooked->GetSourcePositionRange(block)) {
297         // loc is a pair (begin, end); use the beginning position
298         Fortran::parser::SourcePosition &filePos = loc->first;
299         return mlir::FileLineColLoc::get(&getMLIRContext(), filePos.file.path(),
300                                          filePos.line, filePos.column);
301       }
302     }
303     return genUnknownLocation();
304   }
305 
306   fir::FirOpBuilder &getFirOpBuilder() override final { return *builder; }
307 
308   mlir::ModuleOp &getModuleOp() override final { return bridge.getModule(); }
309 
310   mlir::MLIRContext &getMLIRContext() override final {
311     return bridge.getMLIRContext();
312   }
313   std::string
314   mangleName(const Fortran::semantics::Symbol &symbol) override final {
315     return Fortran::lower::mangle::mangleName(symbol);
316   }
317 
318   const fir::KindMapping &getKindMap() override final {
319     return bridge.getKindMap();
320   }
321 
322   /// Return the predicate: "current block does not have a terminator branch".
323   bool blockIsUnterminated() {
324     mlir::Block *currentBlock = builder->getBlock();
325     return currentBlock->empty() ||
326            !currentBlock->back().hasTrait<mlir::OpTrait::IsTerminator>();
327   }
328 
329   /// Unconditionally switch code insertion to a new block.
330   void startBlock(mlir::Block *newBlock) {
331     assert(newBlock && "missing block");
332     // Default termination for the current block is a fallthrough branch to
333     // the new block.
334     if (blockIsUnterminated())
335       genFIRBranch(newBlock);
336     // Some blocks may be re/started more than once, and might not be empty.
337     // If the new block already has (only) a terminator, set the insertion
338     // point to the start of the block.  Otherwise set it to the end.
339     // Note that setting the insertion point causes the subsequent function
340     // call to check the existence of terminator in the newBlock.
341     builder->setInsertionPointToStart(newBlock);
342     if (blockIsUnterminated())
343       builder->setInsertionPointToEnd(newBlock);
344   }
345 
346   /// Conditionally switch code insertion to a new block.
347   void maybeStartBlock(mlir::Block *newBlock) {
348     if (newBlock)
349       startBlock(newBlock);
350   }
351 
352   /// Emit return and cleanup after the function has been translated.
353   void endNewFunction(Fortran::lower::pft::FunctionLikeUnit &funit) {
354     setCurrentPosition(Fortran::lower::pft::stmtSourceLoc(funit.endStmt));
355     if (funit.isMainProgram())
356       genExitRoutine();
357     else
358       genFIRProcedureExit(funit, funit.getSubprogramSymbol());
359     funit.finalBlock = nullptr;
360     LLVM_DEBUG(llvm::dbgs() << "*** Lowering result:\n\n"
361                             << *builder->getFunction() << '\n');
362     // FIXME: Simplification should happen in a normal pass, not here.
363     mlir::IRRewriter rewriter(*builder);
364     (void)mlir::simplifyRegions(rewriter,
365                                 {builder->getRegion()}); // remove dead code
366     delete builder;
367     builder = nullptr;
368     hostAssocTuple = mlir::Value{};
369     localSymbols.clear();
370   }
371 
372   /// Map mlir function block arguments to the corresponding Fortran dummy
373   /// variables. When the result is passed as a hidden argument, the Fortran
374   /// result is also mapped. The symbol map is used to hold this mapping.
375   void mapDummiesAndResults(Fortran::lower::pft::FunctionLikeUnit &funit,
376                             const Fortran::lower::CalleeInterface &callee) {
377     assert(builder && "require a builder object at this point");
378     using PassBy = Fortran::lower::CalleeInterface::PassEntityBy;
379     auto mapPassedEntity = [&](const auto arg) -> void {
380       if (arg.passBy == PassBy::AddressAndLength) {
381         // TODO: now that fir call has some attributes regarding character
382         // return, PassBy::AddressAndLength should be retired.
383         mlir::Location loc = toLocation();
384         fir::factory::CharacterExprHelper charHelp{*builder, loc};
385         mlir::Value box =
386             charHelp.createEmboxChar(arg.firArgument, arg.firLength);
387         addSymbol(arg.entity->get(), box);
388       } else {
389         if (arg.entity.has_value()) {
390           addSymbol(arg.entity->get(), arg.firArgument);
391         } else {
392           assert(funit.parentHasHostAssoc());
393           funit.parentHostAssoc().internalProcedureBindings(*this,
394                                                             localSymbols);
395         }
396       }
397     };
398     for (const Fortran::lower::CalleeInterface::PassedEntity &arg :
399          callee.getPassedArguments())
400       mapPassedEntity(arg);
401 
402     // Allocate local skeleton instances of dummies from other entry points.
403     // Most of these locals will not survive into final generated code, but
404     // some will.  It is illegal to reference them at run time if they do.
405     for (const Fortran::semantics::Symbol *arg :
406          funit.nonUniversalDummyArguments) {
407       if (lookupSymbol(*arg))
408         continue;
409       mlir::Type type = genType(*arg);
410       // TODO: Account for VALUE arguments (and possibly other variants).
411       type = builder->getRefType(type);
412       addSymbol(*arg, builder->create<fir::UndefOp>(toLocation(), type));
413     }
414     if (std::optional<Fortran::lower::CalleeInterface::PassedEntity>
415             passedResult = callee.getPassedResult()) {
416       mapPassedEntity(*passedResult);
417       // FIXME: need to make sure things are OK here. addSymbol may not be OK
418       if (funit.primaryResult &&
419           passedResult->entity->get() != *funit.primaryResult)
420         addSymbol(*funit.primaryResult,
421                   getSymbolAddress(passedResult->entity->get()));
422     }
423   }
424 
425   /// Instantiate variable \p var and add it to the symbol map.
426   /// See ConvertVariable.cpp.
427   void instantiateVar(const Fortran::lower::pft::Variable &var,
428                       Fortran::lower::AggregateStoreMap &storeMap) {
429     Fortran::lower::instantiateVariable(*this, var, localSymbols, storeMap);
430   }
431 
432   /// Prepare to translate a new function
433   void startNewFunction(Fortran::lower::pft::FunctionLikeUnit &funit) {
434     assert(!builder && "expected nullptr");
435     Fortran::lower::CalleeInterface callee(funit, *this);
436     mlir::FuncOp func = callee.addEntryBlockAndMapArguments();
437     func.setVisibility(mlir::SymbolTable::Visibility::Public);
438     builder = new fir::FirOpBuilder(func, bridge.getKindMap());
439     assert(builder && "FirOpBuilder did not instantiate");
440     builder->setInsertionPointToStart(&func.front());
441 
442     mapDummiesAndResults(funit, callee);
443 
444     // Note: not storing Variable references because getOrderedSymbolTable
445     // below returns a temporary.
446     llvm::SmallVector<Fortran::lower::pft::Variable> deferredFuncResultList;
447 
448     // Backup actual argument for entry character results
449     // with different lengths. It needs to be added to the non
450     // primary results symbol before mapSymbolAttributes is called.
451     Fortran::lower::SymbolBox resultArg;
452     if (std::optional<Fortran::lower::CalleeInterface::PassedEntity>
453             passedResult = callee.getPassedResult())
454       resultArg = lookupSymbol(passedResult->entity->get());
455 
456     Fortran::lower::AggregateStoreMap storeMap;
457     // The front-end is currently not adding module variables referenced
458     // in a module procedure as host associated. As a result we need to
459     // instantiate all module variables here if this is a module procedure.
460     // It is likely that the front-end behavior should change here.
461     // This also applies to internal procedures inside module procedures.
462     if (auto *module = Fortran::lower::pft::getAncestor<
463             Fortran::lower::pft::ModuleLikeUnit>(funit))
464       for (const Fortran::lower::pft::Variable &var :
465            module->getOrderedSymbolTable())
466         instantiateVar(var, storeMap);
467 
468     mlir::Value primaryFuncResultStorage;
469     for (const Fortran::lower::pft::Variable &var :
470          funit.getOrderedSymbolTable()) {
471       // Always instantiate aggregate storage blocks.
472       if (var.isAggregateStore()) {
473         instantiateVar(var, storeMap);
474         continue;
475       }
476       const Fortran::semantics::Symbol &sym = var.getSymbol();
477       if (funit.parentHasHostAssoc()) {
478         // Never instantitate host associated variables, as they are already
479         // instantiated from an argument tuple. Instead, just bind the symbol to
480         // the reference to the host variable, which must be in the map.
481         const Fortran::semantics::Symbol &ultimate = sym.GetUltimate();
482         if (funit.parentHostAssoc().isAssociated(ultimate)) {
483           Fortran::lower::SymbolBox hostBox =
484               localSymbols.lookupSymbol(ultimate);
485           assert(hostBox && "host association is not in map");
486           localSymbols.addSymbol(sym, hostBox.toExtendedValue());
487           continue;
488         }
489       }
490       if (!sym.IsFuncResult() || !funit.primaryResult) {
491         instantiateVar(var, storeMap);
492       } else if (&sym == funit.primaryResult) {
493         instantiateVar(var, storeMap);
494         primaryFuncResultStorage = getSymbolAddress(sym);
495       } else {
496         deferredFuncResultList.push_back(var);
497       }
498     }
499 
500     // If this is a host procedure with host associations, then create the tuple
501     // of pointers for passing to the internal procedures.
502     if (!funit.getHostAssoc().empty())
503       funit.getHostAssoc().hostProcedureBindings(*this, localSymbols);
504 
505     /// TODO: should use same mechanism as equivalence?
506     /// One blocking point is character entry returns that need special handling
507     /// since they are not locally allocated but come as argument. CHARACTER(*)
508     /// is not something that fit wells with equivalence lowering.
509     for (const Fortran::lower::pft::Variable &altResult :
510          deferredFuncResultList) {
511       if (std::optional<Fortran::lower::CalleeInterface::PassedEntity>
512               passedResult = callee.getPassedResult())
513         addSymbol(altResult.getSymbol(), resultArg.getAddr());
514       Fortran::lower::StatementContext stmtCtx;
515       Fortran::lower::mapSymbolAttributes(*this, altResult, localSymbols,
516                                           stmtCtx, primaryFuncResultStorage);
517     }
518 
519     // Create most function blocks in advance.
520     createEmptyGlobalBlocks(funit.evaluationList);
521 
522     // Reinstate entry block as the current insertion point.
523     builder->setInsertionPointToEnd(&func.front());
524 
525     if (callee.hasAlternateReturns()) {
526       // Create a local temp to hold the alternate return index.
527       // Give it an integer index type and the subroutine name (for dumps).
528       // Attach it to the subroutine symbol in the localSymbols map.
529       // Initialize it to zero, the "fallthrough" alternate return value.
530       const Fortran::semantics::Symbol &symbol = funit.getSubprogramSymbol();
531       mlir::Location loc = toLocation();
532       mlir::Type idxTy = builder->getIndexType();
533       mlir::Value altResult =
534           builder->createTemporary(loc, idxTy, toStringRef(symbol.name()));
535       addSymbol(symbol, altResult);
536       mlir::Value zero = builder->createIntegerConstant(loc, idxTy, 0);
537       builder->create<fir::StoreOp>(loc, zero, altResult);
538     }
539 
540     if (Fortran::lower::pft::Evaluation *alternateEntryEval =
541             funit.getEntryEval())
542       genFIRBranch(alternateEntryEval->lexicalSuccessor->block);
543   }
544 
545   /// Create global blocks for the current function.  This eliminates the
546   /// distinction between forward and backward targets when generating
547   /// branches.  A block is "global" if it can be the target of a GOTO or
548   /// other source code branch.  A block that can only be targeted by a
549   /// compiler generated branch is "local".  For example, a DO loop preheader
550   /// block containing loop initialization code is global.  A loop header
551   /// block, which is the target of the loop back edge, is local.  Blocks
552   /// belong to a region.  Any block within a nested region must be replaced
553   /// with a block belonging to that region.  Branches may not cross region
554   /// boundaries.
555   void createEmptyGlobalBlocks(
556       std::list<Fortran::lower::pft::Evaluation> &evaluationList) {
557     mlir::Region *region = &builder->getRegion();
558     for (Fortran::lower::pft::Evaluation &eval : evaluationList) {
559       if (eval.isNewBlock)
560         eval.block = builder->createBlock(region);
561       if (eval.isConstruct() || eval.isDirective()) {
562         if (eval.lowerAsUnstructured()) {
563           createEmptyGlobalBlocks(eval.getNestedEvaluations());
564         } else if (eval.hasNestedEvaluations()) {
565           // A structured construct that is a target starts a new block.
566           Fortran::lower::pft::Evaluation &constructStmt =
567               eval.getFirstNestedEvaluation();
568           if (constructStmt.isNewBlock)
569             constructStmt.block = builder->createBlock(region);
570         }
571       }
572     }
573   }
574 
575   /// Lower a procedure (nest).
576   void lowerFunc(Fortran::lower::pft::FunctionLikeUnit &funit) {
577     if (!funit.isMainProgram()) {
578       const Fortran::semantics::Symbol &procSymbol =
579           funit.getSubprogramSymbol();
580       if (procSymbol.owner().IsSubmodule()) {
581         TODO(toLocation(), "support submodules");
582         return;
583       }
584     }
585     setCurrentPosition(funit.getStartingSourceLoc());
586     for (int entryIndex = 0, last = funit.entryPointList.size();
587          entryIndex < last; ++entryIndex) {
588       funit.setActiveEntry(entryIndex);
589       startNewFunction(funit); // the entry point for lowering this procedure
590       for (Fortran::lower::pft::Evaluation &eval : funit.evaluationList)
591         genFIR(eval);
592       endNewFunction(funit);
593     }
594     funit.setActiveEntry(0);
595     for (Fortran::lower::pft::FunctionLikeUnit &f : funit.nestedFunctions)
596       lowerFunc(f); // internal procedure
597   }
598 
599   /// Lower module variable definitions to fir::globalOp and OpenMP/OpenACC
600   /// declarative construct.
601   void lowerModuleDeclScope(Fortran::lower::pft::ModuleLikeUnit &mod) {
602     // FIXME: get rid of the bogus function context and instantiate the
603     // globals directly into the module.
604     MLIRContext *context = &getMLIRContext();
605     setCurrentPosition(mod.getStartingSourceLoc());
606     mlir::FuncOp func = fir::FirOpBuilder::createFunction(
607         mlir::UnknownLoc::get(context), getModuleOp(),
608         fir::NameUniquer::doGenerated("ModuleSham"),
609         mlir::FunctionType::get(context, llvm::None, llvm::None));
610     func.addEntryBlock();
611     builder = new fir::FirOpBuilder(func, bridge.getKindMap());
612     for (const Fortran::lower::pft::Variable &var :
613          mod.getOrderedSymbolTable()) {
614       // Only define the variables owned by this module.
615       const Fortran::semantics::Scope *owningScope = var.getOwningScope();
616       if (!owningScope || mod.getScope() == *owningScope)
617         Fortran::lower::defineModuleVariable(*this, var);
618     }
619     for (auto &eval : mod.evaluationList)
620       genFIR(eval);
621     if (mlir::Region *region = func.getCallableRegion())
622       region->dropAllReferences();
623     func.erase();
624     delete builder;
625     builder = nullptr;
626   }
627 
628   /// Lower functions contained in a module.
629   void lowerMod(Fortran::lower::pft::ModuleLikeUnit &mod) {
630     for (Fortran::lower::pft::FunctionLikeUnit &f : mod.nestedFunctions)
631       lowerFunc(f);
632   }
633 
634   mlir::Value hostAssocTupleValue() override final { return hostAssocTuple; }
635 
636   /// Record a binding for the ssa-value of the tuple for this function.
637   void bindHostAssocTuple(mlir::Value val) override final {
638     assert(!hostAssocTuple && val);
639     hostAssocTuple = val;
640   }
641 
642 private:
643   FirConverter() = delete;
644   FirConverter(const FirConverter &) = delete;
645   FirConverter &operator=(const FirConverter &) = delete;
646 
647   //===--------------------------------------------------------------------===//
648   // Helper member functions
649   //===--------------------------------------------------------------------===//
650 
651   mlir::Value createFIRExpr(mlir::Location loc,
652                             const Fortran::lower::SomeExpr *expr,
653                             Fortran::lower::StatementContext &stmtCtx) {
654     return fir::getBase(genExprValue(*expr, stmtCtx, &loc));
655   }
656 
657   /// Find the symbol in the local map or return null.
658   Fortran::lower::SymbolBox
659   lookupSymbol(const Fortran::semantics::Symbol &sym) {
660     if (Fortran::lower::SymbolBox v = localSymbols.lookupSymbol(sym))
661       return v;
662     return {};
663   }
664 
665   /// Add the symbol to the local map and return `true`. If the symbol is
666   /// already in the map and \p forced is `false`, the map is not updated.
667   /// Instead the value `false` is returned.
668   bool addSymbol(const Fortran::semantics::SymbolRef sym, mlir::Value val,
669                  bool forced = false) {
670     if (!forced && lookupSymbol(sym))
671       return false;
672     localSymbols.addSymbol(sym, val, forced);
673     return true;
674   }
675 
676   bool isNumericScalarCategory(Fortran::common::TypeCategory cat) {
677     return cat == Fortran::common::TypeCategory::Integer ||
678            cat == Fortran::common::TypeCategory::Real ||
679            cat == Fortran::common::TypeCategory::Complex ||
680            cat == Fortran::common::TypeCategory::Logical;
681   }
682   bool isCharacterCategory(Fortran::common::TypeCategory cat) {
683     return cat == Fortran::common::TypeCategory::Character;
684   }
685   bool isDerivedCategory(Fortran::common::TypeCategory cat) {
686     return cat == Fortran::common::TypeCategory::Derived;
687   }
688 
689   mlir::Block *blockOfLabel(Fortran::lower::pft::Evaluation &eval,
690                             Fortran::parser::Label label) {
691     const Fortran::lower::pft::LabelEvalMap &labelEvaluationMap =
692         eval.getOwningProcedure()->labelEvaluationMap;
693     const auto iter = labelEvaluationMap.find(label);
694     assert(iter != labelEvaluationMap.end() && "label missing from map");
695     mlir::Block *block = iter->second->block;
696     assert(block && "missing labeled evaluation block");
697     return block;
698   }
699 
700   void genFIRBranch(mlir::Block *targetBlock) {
701     assert(targetBlock && "missing unconditional target block");
702     builder->create<cf::BranchOp>(toLocation(), targetBlock);
703   }
704 
705   void genFIRConditionalBranch(mlir::Value cond, mlir::Block *trueTarget,
706                                mlir::Block *falseTarget) {
707     assert(trueTarget && "missing conditional branch true block");
708     assert(falseTarget && "missing conditional branch false block");
709     mlir::Location loc = toLocation();
710     mlir::Value bcc = builder->createConvert(loc, builder->getI1Type(), cond);
711     builder->create<mlir::cf::CondBranchOp>(loc, bcc, trueTarget, llvm::None,
712                                             falseTarget, llvm::None);
713   }
714   void genFIRConditionalBranch(mlir::Value cond,
715                                Fortran::lower::pft::Evaluation *trueTarget,
716                                Fortran::lower::pft::Evaluation *falseTarget) {
717     genFIRConditionalBranch(cond, trueTarget->block, falseTarget->block);
718   }
719   void genFIRConditionalBranch(const Fortran::parser::ScalarLogicalExpr &expr,
720                                mlir::Block *trueTarget,
721                                mlir::Block *falseTarget) {
722     Fortran::lower::StatementContext stmtCtx;
723     mlir::Value cond =
724         createFIRExpr(toLocation(), Fortran::semantics::GetExpr(expr), stmtCtx);
725     stmtCtx.finalize();
726     genFIRConditionalBranch(cond, trueTarget, falseTarget);
727   }
728   void genFIRConditionalBranch(const Fortran::parser::ScalarLogicalExpr &expr,
729                                Fortran::lower::pft::Evaluation *trueTarget,
730                                Fortran::lower::pft::Evaluation *falseTarget) {
731     Fortran::lower::StatementContext stmtCtx;
732     mlir::Value cond =
733         createFIRExpr(toLocation(), Fortran::semantics::GetExpr(expr), stmtCtx);
734     stmtCtx.finalize();
735     genFIRConditionalBranch(cond, trueTarget->block, falseTarget->block);
736   }
737 
738   //===--------------------------------------------------------------------===//
739   // Termination of symbolically referenced execution units
740   //===--------------------------------------------------------------------===//
741 
742   /// END of program
743   ///
744   /// Generate the cleanup block before the program exits
745   void genExitRoutine() {
746     if (blockIsUnterminated())
747       builder->create<mlir::func::ReturnOp>(toLocation());
748   }
749   void genFIR(const Fortran::parser::EndProgramStmt &) { genExitRoutine(); }
750 
751   /// END of procedure-like constructs
752   ///
753   /// Generate the cleanup block before the procedure exits
754   void genReturnSymbol(const Fortran::semantics::Symbol &functionSymbol) {
755     const Fortran::semantics::Symbol &resultSym =
756         functionSymbol.get<Fortran::semantics::SubprogramDetails>().result();
757     Fortran::lower::SymbolBox resultSymBox = lookupSymbol(resultSym);
758     mlir::Location loc = toLocation();
759     if (!resultSymBox) {
760       mlir::emitError(loc, "failed lowering function return");
761       return;
762     }
763     mlir::Value resultVal = resultSymBox.match(
764         [&](const fir::CharBoxValue &x) -> mlir::Value {
765           return fir::factory::CharacterExprHelper{*builder, loc}
766               .createEmboxChar(x.getBuffer(), x.getLen());
767         },
768         [&](const auto &) -> mlir::Value {
769           mlir::Value resultRef = resultSymBox.getAddr();
770           mlir::Type resultType = genType(resultSym);
771           mlir::Type resultRefType = builder->getRefType(resultType);
772           // A function with multiple entry points returning different types
773           // tags all result variables with one of the largest types to allow
774           // them to share the same storage.  Convert this to the actual type.
775           if (resultRef.getType() != resultRefType)
776             TODO(loc, "Convert to actual type");
777           return builder->create<fir::LoadOp>(loc, resultRef);
778         });
779     builder->create<mlir::func::ReturnOp>(loc, resultVal);
780   }
781 
782   void genFIRProcedureExit(Fortran::lower::pft::FunctionLikeUnit &funit,
783                            const Fortran::semantics::Symbol &symbol) {
784     if (mlir::Block *finalBlock = funit.finalBlock) {
785       // The current block must end with a terminator.
786       if (blockIsUnterminated())
787         builder->create<mlir::cf::BranchOp>(toLocation(), finalBlock);
788       // Set insertion point to final block.
789       builder->setInsertionPoint(finalBlock, finalBlock->end());
790     }
791     if (Fortran::semantics::IsFunction(symbol)) {
792       genReturnSymbol(symbol);
793     } else {
794       genExitRoutine();
795     }
796   }
797 
798   //
799   // Statements that have control-flow semantics
800   //
801 
802   /// Generate an If[Then]Stmt condition or its negation.
803   template <typename A>
804   mlir::Value genIfCondition(const A *stmt, bool negate = false) {
805     mlir::Location loc = toLocation();
806     Fortran::lower::StatementContext stmtCtx;
807     mlir::Value condExpr = createFIRExpr(
808         loc,
809         Fortran::semantics::GetExpr(
810             std::get<Fortran::parser::ScalarLogicalExpr>(stmt->t)),
811         stmtCtx);
812     stmtCtx.finalize();
813     mlir::Value cond =
814         builder->createConvert(loc, builder->getI1Type(), condExpr);
815     if (negate)
816       cond = builder->create<mlir::arith::XOrIOp>(
817           loc, cond, builder->createIntegerConstant(loc, cond.getType(), 1));
818     return cond;
819   }
820 
821   [[maybe_unused]] static bool
822   isFuncResultDesignator(const Fortran::lower::SomeExpr &expr) {
823     const Fortran::semantics::Symbol *sym =
824         Fortran::evaluate::GetFirstSymbol(expr);
825     return sym && sym->IsFuncResult();
826   }
827 
828   static bool isWholeAllocatable(const Fortran::lower::SomeExpr &expr) {
829     const Fortran::semantics::Symbol *sym =
830         Fortran::evaluate::UnwrapWholeSymbolOrComponentDataRef(expr);
831     return sym && Fortran::semantics::IsAllocatable(*sym);
832   }
833 
834   void genAssignment(const Fortran::evaluate::Assignment &assign) {
835     Fortran::lower::StatementContext stmtCtx;
836     mlir::Location loc = toLocation();
837     std::visit(
838         Fortran::common::visitors{
839             // [1] Plain old assignment.
840             [&](const Fortran::evaluate::Assignment::Intrinsic &) {
841               const Fortran::semantics::Symbol *sym =
842                   Fortran::evaluate::GetLastSymbol(assign.lhs);
843 
844               if (!sym)
845                 TODO(loc, "assignment to pointer result of function reference");
846 
847               std::optional<Fortran::evaluate::DynamicType> lhsType =
848                   assign.lhs.GetType();
849               assert(lhsType && "lhs cannot be typeless");
850               // Assignment to polymorphic allocatables may require changing the
851               // variable dynamic type (See Fortran 2018 10.2.1.3 p3).
852               if (lhsType->IsPolymorphic() && isWholeAllocatable(assign.lhs))
853                 TODO(loc, "assignment to polymorphic allocatable");
854 
855               // Note: No ad-hoc handling for pointers is required here. The
856               // target will be assigned as per 2018 10.2.1.3 p2. genExprAddr
857               // on a pointer returns the target address and not the address of
858               // the pointer variable.
859 
860               if (assign.lhs.Rank() > 0) {
861                 // Array assignment
862                 // See Fortran 2018 10.2.1.3 p5, p6, and p7
863                 genArrayAssignment(assign, stmtCtx);
864                 return;
865               }
866 
867               // Scalar assignment
868               const bool isNumericScalar =
869                   isNumericScalarCategory(lhsType->category());
870               fir::ExtendedValue rhs = isNumericScalar
871                                            ? genExprValue(assign.rhs, stmtCtx)
872                                            : genExprAddr(assign.rhs, stmtCtx);
873               bool lhsIsWholeAllocatable = isWholeAllocatable(assign.lhs);
874               llvm::Optional<fir::factory::MutableBoxReallocation> lhsRealloc;
875               llvm::Optional<fir::MutableBoxValue> lhsMutableBox;
876               auto lhs = [&]() -> fir::ExtendedValue {
877                 if (lhsIsWholeAllocatable) {
878                   lhsMutableBox = genExprMutableBox(loc, assign.lhs);
879                   llvm::SmallVector<mlir::Value> lengthParams;
880                   if (const fir::CharBoxValue *charBox = rhs.getCharBox())
881                     lengthParams.push_back(charBox->getLen());
882                   else if (fir::isDerivedWithLengthParameters(rhs))
883                     TODO(loc, "assignment to derived type allocatable with "
884                               "length parameters");
885                   lhsRealloc = fir::factory::genReallocIfNeeded(
886                       *builder, loc, *lhsMutableBox,
887                       /*shape=*/llvm::None, lengthParams);
888                   return lhsRealloc->newValue;
889                 }
890                 return genExprAddr(assign.lhs, stmtCtx);
891               }();
892 
893               if (isNumericScalar) {
894                 // Fortran 2018 10.2.1.3 p8 and p9
895                 // Conversions should have been inserted by semantic analysis,
896                 // but they can be incorrect between the rhs and lhs. Correct
897                 // that here.
898                 mlir::Value addr = fir::getBase(lhs);
899                 mlir::Value val = fir::getBase(rhs);
900                 // A function with multiple entry points returning different
901                 // types tags all result variables with one of the largest
902                 // types to allow them to share the same storage.  Assignment
903                 // to a result variable of one of the other types requires
904                 // conversion to the actual type.
905                 mlir::Type toTy = genType(assign.lhs);
906                 mlir::Value cast =
907                     builder->convertWithSemantics(loc, toTy, val);
908                 if (fir::dyn_cast_ptrEleTy(addr.getType()) != toTy) {
909                   assert(isFuncResultDesignator(assign.lhs) && "type mismatch");
910                   addr = builder->createConvert(
911                       toLocation(), builder->getRefType(toTy), addr);
912                 }
913                 builder->create<fir::StoreOp>(loc, cast, addr);
914               } else if (isCharacterCategory(lhsType->category())) {
915                 // Fortran 2018 10.2.1.3 p10 and p11
916                 fir::factory::CharacterExprHelper{*builder, loc}.createAssign(
917                     lhs, rhs);
918               } else if (isDerivedCategory(lhsType->category())) {
919                 TODO(toLocation(), "Derived type assignment");
920               } else {
921                 llvm_unreachable("unknown category");
922               }
923               if (lhsIsWholeAllocatable)
924                 fir::factory::finalizeRealloc(
925                     *builder, loc, lhsMutableBox.getValue(),
926                     /*lbounds=*/llvm::None, /*takeLboundsIfRealloc=*/false,
927                     lhsRealloc.getValue());
928             },
929 
930             // [2] User defined assignment. If the context is a scalar
931             // expression then call the procedure.
932             [&](const Fortran::evaluate::ProcedureRef &procRef) {
933               TODO(toLocation(), "User defined assignment");
934             },
935 
936             // [3] Pointer assignment with possibly empty bounds-spec. R1035: a
937             // bounds-spec is a lower bound value.
938             [&](const Fortran::evaluate::Assignment::BoundsSpec &lbExprs) {
939               TODO(toLocation(),
940                    "Pointer assignment with possibly empty bounds-spec");
941             },
942 
943             // [4] Pointer assignment with bounds-remapping. R1036: a
944             // bounds-remapping is a pair, lower bound and upper bound.
945             [&](const Fortran::evaluate::Assignment::BoundsRemapping
946                     &boundExprs) {
947               TODO(toLocation(), "Pointer assignment with bounds-remapping");
948             },
949         },
950         assign.u);
951   }
952 
953   /// Lowering of CALL statement
954   void genFIR(const Fortran::parser::CallStmt &stmt) {
955     Fortran::lower::StatementContext stmtCtx;
956     setCurrentPosition(stmt.v.source);
957     assert(stmt.typedCall && "Call was not analyzed");
958     // Call statement lowering shares code with function call lowering.
959     mlir::Value res = Fortran::lower::createSubroutineCall(
960         *this, *stmt.typedCall, localSymbols, stmtCtx);
961     if (!res)
962       return; // "Normal" subroutine call.
963   }
964 
965   void genFIR(const Fortran::parser::ComputedGotoStmt &stmt) {
966     TODO(toLocation(), "ComputedGotoStmt lowering");
967   }
968 
969   void genFIR(const Fortran::parser::ArithmeticIfStmt &stmt) {
970     TODO(toLocation(), "ArithmeticIfStmt lowering");
971   }
972 
973   void genFIR(const Fortran::parser::AssignedGotoStmt &stmt) {
974     TODO(toLocation(), "AssignedGotoStmt lowering");
975   }
976 
977   void genFIR(const Fortran::parser::DoConstruct &doConstruct) {
978     TODO(toLocation(), "DoConstruct lowering");
979   }
980 
981   void genFIR(const Fortran::parser::IfConstruct &) {
982     mlir::Location loc = toLocation();
983     Fortran::lower::pft::Evaluation &eval = getEval();
984     if (eval.lowerAsStructured()) {
985       // Structured fir.if nest.
986       fir::IfOp topIfOp, currentIfOp;
987       for (Fortran::lower::pft::Evaluation &e : eval.getNestedEvaluations()) {
988         auto genIfOp = [&](mlir::Value cond) {
989           auto ifOp = builder->create<fir::IfOp>(loc, cond, /*withElse=*/true);
990           builder->setInsertionPointToStart(&ifOp.getThenRegion().front());
991           return ifOp;
992         };
993         if (auto *s = e.getIf<Fortran::parser::IfThenStmt>()) {
994           topIfOp = currentIfOp = genIfOp(genIfCondition(s, e.negateCondition));
995         } else if (auto *s = e.getIf<Fortran::parser::IfStmt>()) {
996           topIfOp = currentIfOp = genIfOp(genIfCondition(s, e.negateCondition));
997         } else if (auto *s = e.getIf<Fortran::parser::ElseIfStmt>()) {
998           builder->setInsertionPointToStart(
999               &currentIfOp.getElseRegion().front());
1000           currentIfOp = genIfOp(genIfCondition(s));
1001         } else if (e.isA<Fortran::parser::ElseStmt>()) {
1002           builder->setInsertionPointToStart(
1003               &currentIfOp.getElseRegion().front());
1004         } else if (e.isA<Fortran::parser::EndIfStmt>()) {
1005           builder->setInsertionPointAfter(topIfOp);
1006         } else {
1007           genFIR(e, /*unstructuredContext=*/false);
1008         }
1009       }
1010       return;
1011     }
1012 
1013     // Unstructured branch sequence.
1014     for (Fortran::lower::pft::Evaluation &e : eval.getNestedEvaluations()) {
1015       auto genIfBranch = [&](mlir::Value cond) {
1016         if (e.lexicalSuccessor == e.controlSuccessor) // empty block -> exit
1017           genFIRConditionalBranch(cond, e.parentConstruct->constructExit,
1018                                   e.controlSuccessor);
1019         else // non-empty block
1020           genFIRConditionalBranch(cond, e.lexicalSuccessor, e.controlSuccessor);
1021       };
1022       if (auto *s = e.getIf<Fortran::parser::IfThenStmt>()) {
1023         maybeStartBlock(e.block);
1024         genIfBranch(genIfCondition(s, e.negateCondition));
1025       } else if (auto *s = e.getIf<Fortran::parser::IfStmt>()) {
1026         maybeStartBlock(e.block);
1027         genIfBranch(genIfCondition(s, e.negateCondition));
1028       } else if (auto *s = e.getIf<Fortran::parser::ElseIfStmt>()) {
1029         startBlock(e.block);
1030         genIfBranch(genIfCondition(s));
1031       } else {
1032         genFIR(e);
1033       }
1034     }
1035   }
1036 
1037   void genFIR(const Fortran::parser::CaseConstruct &) {
1038     TODO(toLocation(), "CaseConstruct lowering");
1039   }
1040 
1041   void genFIR(const Fortran::parser::ConcurrentHeader &header) {
1042     TODO(toLocation(), "ConcurrentHeader lowering");
1043   }
1044 
1045   void genFIR(const Fortran::parser::ForallAssignmentStmt &stmt) {
1046     TODO(toLocation(), "ForallAssignmentStmt lowering");
1047   }
1048 
1049   void genFIR(const Fortran::parser::EndForallStmt &) {
1050     TODO(toLocation(), "EndForallStmt lowering");
1051   }
1052 
1053   void genFIR(const Fortran::parser::ForallStmt &) {
1054     TODO(toLocation(), "ForallStmt lowering");
1055   }
1056 
1057   void genFIR(const Fortran::parser::ForallConstruct &) {
1058     TODO(toLocation(), "ForallConstruct lowering");
1059   }
1060 
1061   void genFIR(const Fortran::parser::ForallConstructStmt &) {
1062     TODO(toLocation(), "ForallConstructStmt lowering");
1063   }
1064 
1065   void genFIR(const Fortran::parser::CompilerDirective &) {
1066     TODO(toLocation(), "CompilerDirective lowering");
1067   }
1068 
1069   void genFIR(const Fortran::parser::OpenACCConstruct &) {
1070     TODO(toLocation(), "OpenACCConstruct lowering");
1071   }
1072 
1073   void genFIR(const Fortran::parser::OpenACCDeclarativeConstruct &) {
1074     TODO(toLocation(), "OpenACCDeclarativeConstruct lowering");
1075   }
1076 
1077   void genFIR(const Fortran::parser::OpenMPConstruct &) {
1078     TODO(toLocation(), "OpenMPConstruct lowering");
1079   }
1080 
1081   void genFIR(const Fortran::parser::OpenMPDeclarativeConstruct &) {
1082     TODO(toLocation(), "OpenMPDeclarativeConstruct lowering");
1083   }
1084 
1085   void genFIR(const Fortran::parser::SelectCaseStmt &) {
1086     TODO(toLocation(), "SelectCaseStmt lowering");
1087   }
1088 
1089   void genFIR(const Fortran::parser::AssociateConstruct &) {
1090     TODO(toLocation(), "AssociateConstruct lowering");
1091   }
1092 
1093   void genFIR(const Fortran::parser::BlockConstruct &blockConstruct) {
1094     TODO(toLocation(), "BlockConstruct lowering");
1095   }
1096 
1097   void genFIR(const Fortran::parser::BlockStmt &) {
1098     TODO(toLocation(), "BlockStmt lowering");
1099   }
1100 
1101   void genFIR(const Fortran::parser::EndBlockStmt &) {
1102     TODO(toLocation(), "EndBlockStmt lowering");
1103   }
1104 
1105   void genFIR(const Fortran::parser::ChangeTeamConstruct &construct) {
1106     TODO(toLocation(), "ChangeTeamConstruct lowering");
1107   }
1108 
1109   void genFIR(const Fortran::parser::ChangeTeamStmt &stmt) {
1110     TODO(toLocation(), "ChangeTeamStmt lowering");
1111   }
1112 
1113   void genFIR(const Fortran::parser::EndChangeTeamStmt &stmt) {
1114     TODO(toLocation(), "EndChangeTeamStmt lowering");
1115   }
1116 
1117   void genFIR(const Fortran::parser::CriticalConstruct &criticalConstruct) {
1118     TODO(toLocation(), "CriticalConstruct lowering");
1119   }
1120 
1121   void genFIR(const Fortran::parser::CriticalStmt &) {
1122     TODO(toLocation(), "CriticalStmt lowering");
1123   }
1124 
1125   void genFIR(const Fortran::parser::EndCriticalStmt &) {
1126     TODO(toLocation(), "EndCriticalStmt lowering");
1127   }
1128 
1129   void genFIR(const Fortran::parser::SelectRankConstruct &selectRankConstruct) {
1130     TODO(toLocation(), "SelectRankConstruct lowering");
1131   }
1132 
1133   void genFIR(const Fortran::parser::SelectRankStmt &) {
1134     TODO(toLocation(), "SelectRankStmt lowering");
1135   }
1136 
1137   void genFIR(const Fortran::parser::SelectRankCaseStmt &) {
1138     TODO(toLocation(), "SelectRankCaseStmt lowering");
1139   }
1140 
1141   void genFIR(const Fortran::parser::SelectTypeConstruct &selectTypeConstruct) {
1142     TODO(toLocation(), "SelectTypeConstruct lowering");
1143   }
1144 
1145   void genFIR(const Fortran::parser::SelectTypeStmt &) {
1146     TODO(toLocation(), "SelectTypeStmt lowering");
1147   }
1148 
1149   void genFIR(const Fortran::parser::TypeGuardStmt &) {
1150     TODO(toLocation(), "TypeGuardStmt lowering");
1151   }
1152 
1153   //===--------------------------------------------------------------------===//
1154   // IO statements (see io.h)
1155   //===--------------------------------------------------------------------===//
1156 
1157   void genFIR(const Fortran::parser::BackspaceStmt &stmt) {
1158     mlir::Value iostat = genBackspaceStatement(*this, stmt);
1159     genIoConditionBranches(getEval(), stmt.v, iostat);
1160   }
1161 
1162   void genFIR(const Fortran::parser::CloseStmt &stmt) {
1163     mlir::Value iostat = genCloseStatement(*this, stmt);
1164     genIoConditionBranches(getEval(), stmt.v, iostat);
1165   }
1166 
1167   void genFIR(const Fortran::parser::EndfileStmt &stmt) {
1168     mlir::Value iostat = genEndfileStatement(*this, stmt);
1169     genIoConditionBranches(getEval(), stmt.v, iostat);
1170   }
1171 
1172   void genFIR(const Fortran::parser::FlushStmt &stmt) {
1173     mlir::Value iostat = genFlushStatement(*this, stmt);
1174     genIoConditionBranches(getEval(), stmt.v, iostat);
1175   }
1176 
1177   void genFIR(const Fortran::parser::InquireStmt &stmt) {
1178     mlir::Value iostat = genInquireStatement(*this, stmt);
1179     if (const auto *specs =
1180             std::get_if<std::list<Fortran::parser::InquireSpec>>(&stmt.u))
1181       genIoConditionBranches(getEval(), *specs, iostat);
1182   }
1183 
1184   void genFIR(const Fortran::parser::OpenStmt &stmt) {
1185     mlir::Value iostat = genOpenStatement(*this, stmt);
1186     genIoConditionBranches(getEval(), stmt.v, iostat);
1187   }
1188 
1189   void genFIR(const Fortran::parser::PrintStmt &stmt) {
1190     genPrintStatement(*this, stmt);
1191   }
1192 
1193   void genFIR(const Fortran::parser::ReadStmt &stmt) {
1194     mlir::Value iostat = genReadStatement(*this, stmt);
1195     genIoConditionBranches(getEval(), stmt.controls, iostat);
1196   }
1197 
1198   void genFIR(const Fortran::parser::RewindStmt &stmt) {
1199     mlir::Value iostat = genRewindStatement(*this, stmt);
1200     genIoConditionBranches(getEval(), stmt.v, iostat);
1201   }
1202 
1203   void genFIR(const Fortran::parser::WaitStmt &stmt) {
1204     mlir::Value iostat = genWaitStatement(*this, stmt);
1205     genIoConditionBranches(getEval(), stmt.v, iostat);
1206   }
1207 
1208   void genFIR(const Fortran::parser::WriteStmt &stmt) {
1209     mlir::Value iostat = genWriteStatement(*this, stmt);
1210     genIoConditionBranches(getEval(), stmt.controls, iostat);
1211   }
1212 
1213   template <typename A>
1214   void genIoConditionBranches(Fortran::lower::pft::Evaluation &eval,
1215                               const A &specList, mlir::Value iostat) {
1216     if (!iostat)
1217       return;
1218 
1219     mlir::Block *endBlock = nullptr;
1220     mlir::Block *eorBlock = nullptr;
1221     mlir::Block *errBlock = nullptr;
1222     for (const auto &spec : specList) {
1223       std::visit(Fortran::common::visitors{
1224                      [&](const Fortran::parser::EndLabel &label) {
1225                        endBlock = blockOfLabel(eval, label.v);
1226                      },
1227                      [&](const Fortran::parser::EorLabel &label) {
1228                        eorBlock = blockOfLabel(eval, label.v);
1229                      },
1230                      [&](const Fortran::parser::ErrLabel &label) {
1231                        errBlock = blockOfLabel(eval, label.v);
1232                      },
1233                      [](const auto &) {}},
1234                  spec.u);
1235     }
1236     if (!endBlock && !eorBlock && !errBlock)
1237       return;
1238 
1239     mlir::Location loc = toLocation();
1240     mlir::Type indexType = builder->getIndexType();
1241     mlir::Value selector = builder->createConvert(loc, indexType, iostat);
1242     llvm::SmallVector<int64_t> indexList;
1243     llvm::SmallVector<mlir::Block *> blockList;
1244     if (eorBlock) {
1245       indexList.push_back(Fortran::runtime::io::IostatEor);
1246       blockList.push_back(eorBlock);
1247     }
1248     if (endBlock) {
1249       indexList.push_back(Fortran::runtime::io::IostatEnd);
1250       blockList.push_back(endBlock);
1251     }
1252     if (errBlock) {
1253       indexList.push_back(0);
1254       blockList.push_back(eval.nonNopSuccessor().block);
1255       // ERR label statement is the default successor.
1256       blockList.push_back(errBlock);
1257     } else {
1258       // Fallthrough successor statement is the default successor.
1259       blockList.push_back(eval.nonNopSuccessor().block);
1260     }
1261     builder->create<fir::SelectOp>(loc, selector, indexList, blockList);
1262   }
1263 
1264   //===--------------------------------------------------------------------===//
1265   // Memory allocation and deallocation
1266   //===--------------------------------------------------------------------===//
1267 
1268   void genFIR(const Fortran::parser::AllocateStmt &stmt) {
1269     Fortran::lower::genAllocateStmt(*this, stmt, toLocation());
1270   }
1271 
1272   void genFIR(const Fortran::parser::DeallocateStmt &stmt) {
1273     Fortran::lower::genDeallocateStmt(*this, stmt, toLocation());
1274   }
1275 
1276   void genFIR(const Fortran::parser::NullifyStmt &stmt) {
1277     TODO(toLocation(), "NullifyStmt lowering");
1278   }
1279 
1280   //===--------------------------------------------------------------------===//
1281 
1282   void genFIR(const Fortran::parser::EventPostStmt &stmt) {
1283     TODO(toLocation(), "EventPostStmt lowering");
1284   }
1285 
1286   void genFIR(const Fortran::parser::EventWaitStmt &stmt) {
1287     TODO(toLocation(), "EventWaitStmt lowering");
1288   }
1289 
1290   void genFIR(const Fortran::parser::FormTeamStmt &stmt) {
1291     TODO(toLocation(), "FormTeamStmt lowering");
1292   }
1293 
1294   void genFIR(const Fortran::parser::LockStmt &stmt) {
1295     TODO(toLocation(), "LockStmt lowering");
1296   }
1297 
1298   /// Generate an array assignment.
1299   /// This is an assignment expression with rank > 0. The assignment may or may
1300   /// not be in a WHERE and/or FORALL context.
1301   void genArrayAssignment(const Fortran::evaluate::Assignment &assign,
1302                           Fortran::lower::StatementContext &stmtCtx) {
1303     if (isWholeAllocatable(assign.lhs)) {
1304       // Assignment to allocatables may require the lhs to be
1305       // deallocated/reallocated. See Fortran 2018 10.2.1.3 p3
1306       Fortran::lower::createAllocatableArrayAssignment(
1307           *this, assign.lhs, assign.rhs, explicitIterSpace, implicitIterSpace,
1308           localSymbols, stmtCtx);
1309       return;
1310     }
1311 
1312     // No masks and the iteration space is implied by the array, so create a
1313     // simple array assignment.
1314     Fortran::lower::createSomeArrayAssignment(*this, assign.lhs, assign.rhs,
1315                                               localSymbols, stmtCtx);
1316   }
1317 
1318   void genFIR(const Fortran::parser::WhereConstruct &c) {
1319     TODO(toLocation(), "WhereConstruct lowering");
1320   }
1321 
1322   void genFIR(const Fortran::parser::WhereBodyConstruct &body) {
1323     TODO(toLocation(), "WhereBodyConstruct lowering");
1324   }
1325 
1326   void genFIR(const Fortran::parser::WhereConstructStmt &stmt) {
1327     TODO(toLocation(), "WhereConstructStmt lowering");
1328   }
1329 
1330   void genFIR(const Fortran::parser::WhereConstruct::MaskedElsewhere &ew) {
1331     TODO(toLocation(), "MaskedElsewhere lowering");
1332   }
1333 
1334   void genFIR(const Fortran::parser::MaskedElsewhereStmt &stmt) {
1335     TODO(toLocation(), "MaskedElsewhereStmt lowering");
1336   }
1337 
1338   void genFIR(const Fortran::parser::WhereConstruct::Elsewhere &ew) {
1339     TODO(toLocation(), "Elsewhere lowering");
1340   }
1341 
1342   void genFIR(const Fortran::parser::ElsewhereStmt &stmt) {
1343     TODO(toLocation(), "ElsewhereStmt lowering");
1344   }
1345 
1346   void genFIR(const Fortran::parser::EndWhereStmt &) {
1347     TODO(toLocation(), "EndWhereStmt lowering");
1348   }
1349 
1350   void genFIR(const Fortran::parser::WhereStmt &stmt) {
1351     TODO(toLocation(), "WhereStmt lowering");
1352   }
1353 
1354   void genFIR(const Fortran::parser::PointerAssignmentStmt &stmt) {
1355     TODO(toLocation(), "PointerAssignmentStmt lowering");
1356   }
1357 
1358   void genFIR(const Fortran::parser::AssignmentStmt &stmt) {
1359     genAssignment(*stmt.typedAssignment->v);
1360   }
1361 
1362   void genFIR(const Fortran::parser::SyncAllStmt &stmt) {
1363     TODO(toLocation(), "SyncAllStmt lowering");
1364   }
1365 
1366   void genFIR(const Fortran::parser::SyncImagesStmt &stmt) {
1367     TODO(toLocation(), "SyncImagesStmt lowering");
1368   }
1369 
1370   void genFIR(const Fortran::parser::SyncMemoryStmt &stmt) {
1371     TODO(toLocation(), "SyncMemoryStmt lowering");
1372   }
1373 
1374   void genFIR(const Fortran::parser::SyncTeamStmt &stmt) {
1375     TODO(toLocation(), "SyncTeamStmt lowering");
1376   }
1377 
1378   void genFIR(const Fortran::parser::UnlockStmt &stmt) {
1379     TODO(toLocation(), "UnlockStmt lowering");
1380   }
1381 
1382   void genFIR(const Fortran::parser::AssignStmt &stmt) {
1383     TODO(toLocation(), "AssignStmt lowering");
1384   }
1385 
1386   void genFIR(const Fortran::parser::FormatStmt &) {
1387     TODO(toLocation(), "FormatStmt lowering");
1388   }
1389 
1390   void genFIR(const Fortran::parser::PauseStmt &stmt) {
1391     genPauseStatement(*this, stmt);
1392   }
1393 
1394   void genFIR(const Fortran::parser::FailImageStmt &stmt) {
1395     TODO(toLocation(), "FailImageStmt lowering");
1396   }
1397 
1398   // call STOP, ERROR STOP in runtime
1399   void genFIR(const Fortran::parser::StopStmt &stmt) {
1400     genStopStatement(*this, stmt);
1401   }
1402 
1403   void genFIR(const Fortran::parser::ReturnStmt &stmt) {
1404     Fortran::lower::pft::FunctionLikeUnit *funit =
1405         getEval().getOwningProcedure();
1406     assert(funit && "not inside main program, function or subroutine");
1407     if (funit->isMainProgram()) {
1408       genExitRoutine();
1409       return;
1410     }
1411     mlir::Location loc = toLocation();
1412     if (stmt.v) {
1413       TODO(loc, "Alternate return statement");
1414     }
1415     // Branch to the last block of the SUBROUTINE, which has the actual return.
1416     if (!funit->finalBlock) {
1417       mlir::OpBuilder::InsertPoint insPt = builder->saveInsertionPoint();
1418       funit->finalBlock = builder->createBlock(&builder->getRegion());
1419       builder->restoreInsertionPoint(insPt);
1420     }
1421     builder->create<mlir::cf::BranchOp>(loc, funit->finalBlock);
1422   }
1423 
1424   void genFIR(const Fortran::parser::CycleStmt &) {
1425     TODO(toLocation(), "CycleStmt lowering");
1426   }
1427 
1428   void genFIR(const Fortran::parser::ExitStmt &) {
1429     TODO(toLocation(), "ExitStmt lowering");
1430   }
1431 
1432   void genFIR(const Fortran::parser::GotoStmt &) {
1433     genFIRBranch(getEval().controlSuccessor->block);
1434   }
1435 
1436   void genFIR(const Fortran::parser::AssociateStmt &) {
1437     TODO(toLocation(), "AssociateStmt lowering");
1438   }
1439 
1440   void genFIR(const Fortran::parser::CaseStmt &) {
1441     TODO(toLocation(), "CaseStmt lowering");
1442   }
1443 
1444   void genFIR(const Fortran::parser::ElseIfStmt &) {
1445     TODO(toLocation(), "ElseIfStmt lowering");
1446   }
1447 
1448   void genFIR(const Fortran::parser::ElseStmt &) {
1449     TODO(toLocation(), "ElseStmt lowering");
1450   }
1451 
1452   void genFIR(const Fortran::parser::EndAssociateStmt &) {
1453     TODO(toLocation(), "EndAssociateStmt lowering");
1454   }
1455 
1456   void genFIR(const Fortran::parser::EndDoStmt &) {
1457     TODO(toLocation(), "EndDoStmt lowering");
1458   }
1459 
1460   void genFIR(const Fortran::parser::EndIfStmt &) {
1461     TODO(toLocation(), "EndIfStmt lowering");
1462   }
1463 
1464   void genFIR(const Fortran::parser::EndMpSubprogramStmt &) {
1465     TODO(toLocation(), "EndMpSubprogramStmt lowering");
1466   }
1467 
1468   void genFIR(const Fortran::parser::EndSelectStmt &) {
1469     TODO(toLocation(), "EndSelectStmt lowering");
1470   }
1471 
1472   // Nop statements - No code, or code is generated at the construct level.
1473   void genFIR(const Fortran::parser::ContinueStmt &) {}      // nop
1474   void genFIR(const Fortran::parser::EndFunctionStmt &) {}   // nop
1475   void genFIR(const Fortran::parser::EndSubroutineStmt &) {} // nop
1476 
1477   void genFIR(const Fortran::parser::EntryStmt &) {
1478     TODO(toLocation(), "EntryStmt lowering");
1479   }
1480 
1481   void genFIR(const Fortran::parser::IfStmt &) {
1482     TODO(toLocation(), "IfStmt lowering");
1483   }
1484 
1485   void genFIR(const Fortran::parser::IfThenStmt &) {
1486     TODO(toLocation(), "IfThenStmt lowering");
1487   }
1488 
1489   void genFIR(const Fortran::parser::NonLabelDoStmt &) {
1490     TODO(toLocation(), "NonLabelDoStmt lowering");
1491   }
1492 
1493   void genFIR(const Fortran::parser::OmpEndLoopDirective &) {
1494     TODO(toLocation(), "OmpEndLoopDirective lowering");
1495   }
1496 
1497   void genFIR(const Fortran::parser::NamelistStmt &) {
1498     TODO(toLocation(), "NamelistStmt lowering");
1499   }
1500 
1501   void genFIR(Fortran::lower::pft::Evaluation &eval,
1502               bool unstructuredContext = true) {
1503     if (unstructuredContext) {
1504       // When transitioning from unstructured to structured code,
1505       // the structured code could be a target that starts a new block.
1506       maybeStartBlock(eval.isConstruct() && eval.lowerAsStructured()
1507                           ? eval.getFirstNestedEvaluation().block
1508                           : eval.block);
1509     }
1510 
1511     setCurrentEval(eval);
1512     setCurrentPosition(eval.position);
1513     eval.visit([&](const auto &stmt) { genFIR(stmt); });
1514   }
1515 
1516   //===--------------------------------------------------------------------===//
1517 
1518   Fortran::lower::LoweringBridge &bridge;
1519   Fortran::evaluate::FoldingContext foldingContext;
1520   fir::FirOpBuilder *builder = nullptr;
1521   Fortran::lower::pft::Evaluation *evalPtr = nullptr;
1522   Fortran::lower::SymMap localSymbols;
1523   Fortran::parser::CharBlock currentPosition;
1524 
1525   /// Tuple of host assoicated variables.
1526   mlir::Value hostAssocTuple;
1527   Fortran::lower::ImplicitIterSpace implicitIterSpace;
1528   Fortran::lower::ExplicitIterSpace explicitIterSpace;
1529 };
1530 
1531 } // namespace
1532 
1533 Fortran::evaluate::FoldingContext
1534 Fortran::lower::LoweringBridge::createFoldingContext() const {
1535   return {getDefaultKinds(), getIntrinsicTable()};
1536 }
1537 
1538 void Fortran::lower::LoweringBridge::lower(
1539     const Fortran::parser::Program &prg,
1540     const Fortran::semantics::SemanticsContext &semanticsContext) {
1541   std::unique_ptr<Fortran::lower::pft::Program> pft =
1542       Fortran::lower::createPFT(prg, semanticsContext);
1543   if (dumpBeforeFir)
1544     Fortran::lower::dumpPFT(llvm::errs(), *pft);
1545   FirConverter converter{*this};
1546   converter.run(*pft);
1547 }
1548 
1549 Fortran::lower::LoweringBridge::LoweringBridge(
1550     mlir::MLIRContext &context,
1551     const Fortran::common::IntrinsicTypeDefaultKinds &defaultKinds,
1552     const Fortran::evaluate::IntrinsicProcTable &intrinsics,
1553     const Fortran::parser::AllCookedSources &cooked, llvm::StringRef triple,
1554     fir::KindMapping &kindMap)
1555     : defaultKinds{defaultKinds}, intrinsics{intrinsics}, cooked{&cooked},
1556       context{context}, kindMap{kindMap} {
1557   // Register the diagnostic handler.
1558   context.getDiagEngine().registerHandler([](mlir::Diagnostic &diag) {
1559     llvm::raw_ostream &os = llvm::errs();
1560     switch (diag.getSeverity()) {
1561     case mlir::DiagnosticSeverity::Error:
1562       os << "error: ";
1563       break;
1564     case mlir::DiagnosticSeverity::Remark:
1565       os << "info: ";
1566       break;
1567     case mlir::DiagnosticSeverity::Warning:
1568       os << "warning: ";
1569       break;
1570     default:
1571       break;
1572     }
1573     if (!diag.getLocation().isa<UnknownLoc>())
1574       os << diag.getLocation() << ": ";
1575     os << diag << '\n';
1576     os.flush();
1577     return mlir::success();
1578   });
1579 
1580   // Create the module and attach the attributes.
1581   module = std::make_unique<mlir::ModuleOp>(
1582       mlir::ModuleOp::create(mlir::UnknownLoc::get(&context)));
1583   assert(module.get() && "module was not created");
1584   fir::setTargetTriple(*module.get(), triple);
1585   fir::setKindMapping(*module.get(), kindMap);
1586 }
1587