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