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