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