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