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