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