1 //===-- PFTBuilder.cpp ----------------------------------------------------===//
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 #include "flang/Lower/PFTBuilder.h"
10 #include "flang/Lower/IntervalSet.h"
11 #include "flang/Lower/Support/Utils.h"
12 #include "flang/Parser/dump-parse-tree.h"
13 #include "flang/Parser/parse-tree-visitor.h"
14 #include "flang/Semantics/semantics.h"
15 #include "flang/Semantics/tools.h"
16 #include "llvm/ADT/DenseSet.h"
17 #include "llvm/ADT/IntervalMap.h"
18 #include "llvm/Support/CommandLine.h"
19 #include "llvm/Support/Debug.h"
20 
21 #define DEBUG_TYPE "flang-pft"
22 
23 static llvm::cl::opt<bool> clDisableStructuredFir(
24     "no-structured-fir", llvm::cl::desc("disable generation of structured FIR"),
25     llvm::cl::init(false), llvm::cl::Hidden);
26 
27 static llvm::cl::opt<bool> nonRecursiveProcedures(
28     "non-recursive-procedures",
29     llvm::cl::desc("Make procedures non-recursive by default. This was the "
30                    "default for all Fortran standards prior to 2018."),
31     llvm::cl::init(/*2018 standard=*/false));
32 
33 using namespace Fortran;
34 
35 namespace {
36 /// Helpers to unveil parser node inside Fortran::parser::Statement<>,
37 /// Fortran::parser::UnlabeledStatement, and Fortran::common::Indirection<>
38 template <typename A>
39 struct RemoveIndirectionHelper {
40   using Type = A;
41 };
42 template <typename A>
43 struct RemoveIndirectionHelper<common::Indirection<A>> {
44   using Type = A;
45 };
46 
47 template <typename A>
48 struct UnwrapStmt {
49   static constexpr bool isStmt{false};
50 };
51 template <typename A>
52 struct UnwrapStmt<parser::Statement<A>> {
53   static constexpr bool isStmt{true};
54   using Type = typename RemoveIndirectionHelper<A>::Type;
55   constexpr UnwrapStmt(const parser::Statement<A> &a)
56       : unwrapped{removeIndirection(a.statement)}, position{a.source},
57         label{a.label} {}
58   const Type &unwrapped;
59   parser::CharBlock position;
60   std::optional<parser::Label> label;
61 };
62 template <typename A>
63 struct UnwrapStmt<parser::UnlabeledStatement<A>> {
64   static constexpr bool isStmt{true};
65   using Type = typename RemoveIndirectionHelper<A>::Type;
66   constexpr UnwrapStmt(const parser::UnlabeledStatement<A> &a)
67       : unwrapped{removeIndirection(a.statement)}, position{a.source} {}
68   const Type &unwrapped;
69   parser::CharBlock position;
70   std::optional<parser::Label> label;
71 };
72 
73 /// The instantiation of a parse tree visitor (Pre and Post) is extremely
74 /// expensive in terms of compile and link time.  So one goal here is to
75 /// limit the bridge to one such instantiation.
76 class PFTBuilder {
77 public:
78   PFTBuilder(const semantics::SemanticsContext &semanticsContext)
79       : pgm{std::make_unique<lower::pft::Program>(
80             semanticsContext.GetCommonBlocks())},
81         semanticsContext{semanticsContext} {
82     lower::pft::PftNode pftRoot{*pgm.get()};
83     pftParentStack.push_back(pftRoot);
84   }
85 
86   /// Get the result
87   std::unique_ptr<lower::pft::Program> result() { return std::move(pgm); }
88 
89   template <typename A>
90   constexpr bool Pre(const A &a) {
91     if constexpr (lower::pft::isFunctionLike<A>) {
92       return enterFunction(a, semanticsContext);
93     } else if constexpr (lower::pft::isConstruct<A> ||
94                          lower::pft::isDirective<A>) {
95       return enterConstructOrDirective(a);
96     } else if constexpr (UnwrapStmt<A>::isStmt) {
97       using T = typename UnwrapStmt<A>::Type;
98       // Node "a" being visited has one of the following types:
99       // Statement<T>, Statement<Indirection<T>>, UnlabeledStatement<T>,
100       // or UnlabeledStatement<Indirection<T>>
101       auto stmt{UnwrapStmt<A>(a)};
102       if constexpr (lower::pft::isConstructStmt<T> ||
103                     lower::pft::isOtherStmt<T>) {
104         addEvaluation(lower::pft::Evaluation{
105             stmt.unwrapped, pftParentStack.back(), stmt.position, stmt.label});
106         return false;
107       } else if constexpr (std::is_same_v<T, parser::ActionStmt>) {
108         return std::visit(
109             common::visitors{
110                 [&](const common::Indirection<parser::IfStmt> &x) {
111                   convertIfStmt(x.value(), stmt.position, stmt.label);
112                   return false;
113                 },
114                 [&](const auto &x) {
115                   addEvaluation(lower::pft::Evaluation{
116                       removeIndirection(x), pftParentStack.back(),
117                       stmt.position, stmt.label});
118                   return true;
119                 },
120             },
121             stmt.unwrapped.u);
122       }
123     }
124     return true;
125   }
126 
127   /// Convert an IfStmt into an IfConstruct, retaining the IfStmt as the
128   /// first statement of the construct.
129   void convertIfStmt(const parser::IfStmt &ifStmt, parser::CharBlock position,
130                      std::optional<parser::Label> label) {
131     // Generate a skeleton IfConstruct parse node.  Its components are never
132     // referenced.  The actual components are available via the IfConstruct
133     // evaluation's nested evaluationList, with the ifStmt in the position of
134     // the otherwise normal IfThenStmt.  Caution: All other PFT nodes reference
135     // front end generated parse nodes; this is an exceptional case.
136     static const auto ifConstruct = parser::IfConstruct{
137         parser::Statement<parser::IfThenStmt>{
138             std::nullopt,
139             parser::IfThenStmt{
140                 std::optional<parser::Name>{},
141                 parser::ScalarLogicalExpr{parser::LogicalExpr{parser::Expr{
142                     parser::LiteralConstant{parser::LogicalLiteralConstant{
143                         false, std::optional<parser::KindParam>{}}}}}}}},
144         parser::Block{}, std::list<parser::IfConstruct::ElseIfBlock>{},
145         std::optional<parser::IfConstruct::ElseBlock>{},
146         parser::Statement<parser::EndIfStmt>{std::nullopt,
147                                              parser::EndIfStmt{std::nullopt}}};
148     enterConstructOrDirective(ifConstruct);
149     addEvaluation(
150         lower::pft::Evaluation{ifStmt, pftParentStack.back(), position, label});
151     Pre(std::get<parser::UnlabeledStatement<parser::ActionStmt>>(ifStmt.t));
152     static const auto endIfStmt = parser::EndIfStmt{std::nullopt};
153     addEvaluation(
154         lower::pft::Evaluation{endIfStmt, pftParentStack.back(), {}, {}});
155     exitConstructOrDirective();
156   }
157 
158   template <typename A>
159   constexpr void Post(const A &) {
160     if constexpr (lower::pft::isFunctionLike<A>) {
161       exitFunction();
162     } else if constexpr (lower::pft::isConstruct<A> ||
163                          lower::pft::isDirective<A>) {
164       exitConstructOrDirective();
165     }
166   }
167 
168   // Module like
169   bool Pre(const parser::Module &node) { return enterModule(node); }
170   bool Pre(const parser::Submodule &node) { return enterModule(node); }
171 
172   void Post(const parser::Module &) { exitModule(); }
173   void Post(const parser::Submodule &) { exitModule(); }
174 
175   // Block data
176   bool Pre(const parser::BlockData &node) {
177     addUnit(lower::pft::BlockDataUnit{node, pftParentStack.back(),
178                                       semanticsContext});
179     return false;
180   }
181 
182   // Get rid of production wrapper
183   bool Pre(const parser::Statement<parser::ForallAssignmentStmt> &statement) {
184     addEvaluation(std::visit(
185         [&](const auto &x) {
186           return lower::pft::Evaluation{x, pftParentStack.back(),
187                                         statement.source, statement.label};
188         },
189         statement.statement.u));
190     return false;
191   }
192   bool Pre(const parser::WhereBodyConstruct &whereBody) {
193     return std::visit(
194         common::visitors{
195             [&](const parser::Statement<parser::AssignmentStmt> &stmt) {
196               // Not caught as other AssignmentStmt because it is not
197               // wrapped in a parser::ActionStmt.
198               addEvaluation(lower::pft::Evaluation{stmt.statement,
199                                                    pftParentStack.back(),
200                                                    stmt.source, stmt.label});
201               return false;
202             },
203             [&](const auto &) { return true; },
204         },
205         whereBody.u);
206   }
207 
208   // CompilerDirective have special handling in case they are top level
209   // directives (i.e. they do not belong to a ProgramUnit).
210   bool Pre(const parser::CompilerDirective &directive) {
211     assert(pftParentStack.size() > 0 &&
212            "At least the Program must be a parent");
213     if (pftParentStack.back().isA<lower::pft::Program>()) {
214       addUnit(
215           lower::pft::CompilerDirectiveUnit(directive, pftParentStack.back()));
216       return false;
217     }
218     return enterConstructOrDirective(directive);
219   }
220 
221 private:
222   /// Initialize a new module-like unit and make it the builder's focus.
223   template <typename A>
224   bool enterModule(const A &func) {
225     Fortran::lower::pft::ModuleLikeUnit &unit =
226         addUnit(lower::pft::ModuleLikeUnit{func, pftParentStack.back()});
227     functionList = &unit.nestedFunctions;
228     pushEvaluationList(&unit.evaluationList);
229     pftParentStack.emplace_back(unit);
230     return true;
231   }
232 
233   void exitModule() {
234     if (!evaluationListStack.empty())
235       popEvaluationList();
236     pftParentStack.pop_back();
237     resetFunctionState();
238   }
239 
240   /// Add the end statement Evaluation of a sub/program to the PFT.
241   /// There may be intervening internal subprogram definitions between
242   /// prior statements and this end statement.
243   void endFunctionBody() {
244     if (evaluationListStack.empty())
245       return;
246     auto evaluationList = evaluationListStack.back();
247     if (evaluationList->empty() || !evaluationList->back().isEndStmt()) {
248       const auto &endStmt =
249           pftParentStack.back().get<lower::pft::FunctionLikeUnit>().endStmt;
250       endStmt.visit(common::visitors{
251           [&](const parser::Statement<parser::EndProgramStmt> &s) {
252             addEvaluation(lower::pft::Evaluation{
253                 s.statement, pftParentStack.back(), s.source, s.label});
254           },
255           [&](const parser::Statement<parser::EndFunctionStmt> &s) {
256             addEvaluation(lower::pft::Evaluation{
257                 s.statement, pftParentStack.back(), s.source, s.label});
258           },
259           [&](const parser::Statement<parser::EndSubroutineStmt> &s) {
260             addEvaluation(lower::pft::Evaluation{
261                 s.statement, pftParentStack.back(), s.source, s.label});
262           },
263           [&](const parser::Statement<parser::EndMpSubprogramStmt> &s) {
264             addEvaluation(lower::pft::Evaluation{
265                 s.statement, pftParentStack.back(), s.source, s.label});
266           },
267           [&](const auto &s) {
268             llvm::report_fatal_error("missing end statement or unexpected "
269                                      "begin statement reference");
270           },
271       });
272     }
273     lastLexicalEvaluation = nullptr;
274   }
275 
276   /// Pop the ModuleLikeUnit evaluationList when entering the first module
277   /// procedure.
278   void cleanModuleEvaluationList() {
279     if (evaluationListStack.empty())
280       return;
281     if (pftParentStack.back().isA<lower::pft::ModuleLikeUnit>())
282       popEvaluationList();
283   }
284 
285   /// Initialize a new function-like unit and make it the builder's focus.
286   template <typename A>
287   bool enterFunction(const A &func,
288                      const semantics::SemanticsContext &semanticsContext) {
289     cleanModuleEvaluationList();
290     endFunctionBody(); // enclosing host subprogram body, if any
291     Fortran::lower::pft::FunctionLikeUnit &unit =
292         addFunction(lower::pft::FunctionLikeUnit{func, pftParentStack.back(),
293                                                  semanticsContext});
294     labelEvaluationMap = &unit.labelEvaluationMap;
295     assignSymbolLabelMap = &unit.assignSymbolLabelMap;
296     functionList = &unit.nestedFunctions;
297     pushEvaluationList(&unit.evaluationList);
298     pftParentStack.emplace_back(unit);
299     return true;
300   }
301 
302   void exitFunction() {
303     rewriteIfGotos();
304     endFunctionBody();
305     analyzeBranches(nullptr, *evaluationListStack.back()); // add branch links
306     processEntryPoints();
307     popEvaluationList();
308     labelEvaluationMap = nullptr;
309     assignSymbolLabelMap = nullptr;
310     pftParentStack.pop_back();
311     resetFunctionState();
312   }
313 
314   /// Initialize a new construct or directive and make it the builder's focus.
315   template <typename A>
316   bool enterConstructOrDirective(const A &constructOrDirective) {
317     Fortran::lower::pft::Evaluation &eval = addEvaluation(
318         lower::pft::Evaluation{constructOrDirective, pftParentStack.back()});
319     eval.evaluationList.reset(new lower::pft::EvaluationList);
320     pushEvaluationList(eval.evaluationList.get());
321     pftParentStack.emplace_back(eval);
322     constructAndDirectiveStack.emplace_back(&eval);
323     return true;
324   }
325 
326   void exitConstructOrDirective() {
327     rewriteIfGotos();
328     auto *eval = constructAndDirectiveStack.back();
329     if (eval->isExecutableDirective()) {
330       // A construct at the end of an (unstructured) OpenACC or OpenMP
331       // construct region must have an exit target inside the region.
332       Fortran::lower::pft::EvaluationList &evaluationList =
333           *eval->evaluationList;
334       if (!evaluationList.empty() && evaluationList.back().isConstruct()) {
335         static const parser::ContinueStmt exitTarget{};
336         addEvaluation(
337             lower::pft::Evaluation{exitTarget, pftParentStack.back(), {}, {}});
338       }
339     }
340     popEvaluationList();
341     pftParentStack.pop_back();
342     constructAndDirectiveStack.pop_back();
343   }
344 
345   /// Reset function state to that of an enclosing host function.
346   void resetFunctionState() {
347     if (!pftParentStack.empty()) {
348       pftParentStack.back().visit(common::visitors{
349           [&](lower::pft::FunctionLikeUnit &p) {
350             functionList = &p.nestedFunctions;
351             labelEvaluationMap = &p.labelEvaluationMap;
352             assignSymbolLabelMap = &p.assignSymbolLabelMap;
353           },
354           [&](lower::pft::ModuleLikeUnit &p) {
355             functionList = &p.nestedFunctions;
356           },
357           [&](auto &) { functionList = nullptr; },
358       });
359     }
360   }
361 
362   template <typename A>
363   A &addUnit(A &&unit) {
364     pgm->getUnits().emplace_back(std::move(unit));
365     return std::get<A>(pgm->getUnits().back());
366   }
367 
368   template <typename A>
369   A &addFunction(A &&func) {
370     if (functionList) {
371       functionList->emplace_back(std::move(func));
372       return functionList->back();
373     }
374     return addUnit(std::move(func));
375   }
376 
377   // ActionStmt has a couple of non-conforming cases, explicitly handled here.
378   // The other cases use an Indirection, which are discarded in the PFT.
379   lower::pft::Evaluation
380   makeEvaluationAction(const parser::ActionStmt &statement,
381                        parser::CharBlock position,
382                        std::optional<parser::Label> label) {
383     return std::visit(
384         common::visitors{
385             [&](const auto &x) {
386               return lower::pft::Evaluation{
387                   removeIndirection(x), pftParentStack.back(), position, label};
388             },
389         },
390         statement.u);
391   }
392 
393   /// Append an Evaluation to the end of the current list.
394   lower::pft::Evaluation &addEvaluation(lower::pft::Evaluation &&eval) {
395     assert(functionList && "not in a function");
396     assert(!evaluationListStack.empty() && "empty evaluation list stack");
397     if (!constructAndDirectiveStack.empty())
398       eval.parentConstruct = constructAndDirectiveStack.back();
399     auto &entryPointList = eval.getOwningProcedure()->entryPointList;
400     evaluationListStack.back()->emplace_back(std::move(eval));
401     lower::pft::Evaluation *p = &evaluationListStack.back()->back();
402     if (p->isActionStmt() || p->isConstructStmt() || p->isEndStmt() ||
403         p->isExecutableDirective()) {
404       if (lastLexicalEvaluation) {
405         lastLexicalEvaluation->lexicalSuccessor = p;
406         p->printIndex = lastLexicalEvaluation->printIndex + 1;
407       } else {
408         p->printIndex = 1;
409       }
410       lastLexicalEvaluation = p;
411       for (std::size_t entryIndex = entryPointList.size() - 1;
412            entryIndex && !entryPointList[entryIndex].second->lexicalSuccessor;
413            --entryIndex)
414         // Link to the entry's first executable statement.
415         entryPointList[entryIndex].second->lexicalSuccessor = p;
416     } else if (const auto *entryStmt = p->getIf<parser::EntryStmt>()) {
417       const semantics::Symbol *sym =
418           std::get<parser::Name>(entryStmt->t).symbol;
419       assert(sym->has<semantics::SubprogramDetails>() &&
420              "entry must be a subprogram");
421       entryPointList.push_back(std::pair{sym, p});
422     }
423     if (p->label.has_value())
424       labelEvaluationMap->try_emplace(*p->label, p);
425     return evaluationListStack.back()->back();
426   }
427 
428   /// push a new list on the stack of Evaluation lists
429   void pushEvaluationList(lower::pft::EvaluationList *evaluationList) {
430     assert(functionList && "not in a function");
431     assert(evaluationList && evaluationList->empty() &&
432            "evaluation list isn't correct");
433     evaluationListStack.emplace_back(evaluationList);
434   }
435 
436   /// pop the current list and return to the last Evaluation list
437   void popEvaluationList() {
438     assert(functionList && "not in a function");
439     evaluationListStack.pop_back();
440   }
441 
442   /// Rewrite IfConstructs containing a GotoStmt or CycleStmt to eliminate an
443   /// unstructured branch and a trivial basic block.  The pre-branch-analysis
444   /// code:
445   ///
446   ///       <<IfConstruct>>
447   ///         1 If[Then]Stmt: if(cond) goto L
448   ///         2 GotoStmt: goto L
449   ///         3 EndIfStmt
450   ///       <<End IfConstruct>>
451   ///       4 Statement: ...
452   ///       5 Statement: ...
453   ///       6 Statement: L ...
454   ///
455   /// becomes:
456   ///
457   ///       <<IfConstruct>>
458   ///         1 If[Then]Stmt [negate]: if(cond) goto L
459   ///         4 Statement: ...
460   ///         5 Statement: ...
461   ///         3 EndIfStmt
462   ///       <<End IfConstruct>>
463   ///       6 Statement: L ...
464   ///
465   /// The If[Then]Stmt condition is implicitly negated.  It is not modified
466   /// in the PFT.  It must be negated when generating FIR.  The GotoStmt or
467   /// CycleStmt is deleted.
468   ///
469   /// The transformation is only valid for forward branch targets at the same
470   /// construct nesting level as the IfConstruct.  The result must not violate
471   /// construct nesting requirements or contain an EntryStmt.  The result
472   /// is subject to normal un/structured code classification analysis.  The
473   /// result is allowed to violate the F18 Clause 11.1.2.1 prohibition on
474   /// transfer of control into the interior of a construct block, as that does
475   /// not compromise correct code generation.  When two transformation
476   /// candidates overlap, at least one must be disallowed.  In such cases,
477   /// the current heuristic favors simple code generation, which happens to
478   /// favor later candidates over earlier candidates.  That choice is probably
479   /// not significant, but could be changed.
480   ///
481   void rewriteIfGotos() {
482     auto &evaluationList = *evaluationListStack.back();
483     if (!evaluationList.size())
484       return;
485     struct T {
486       lower::pft::EvaluationList::iterator ifConstructIt;
487       parser::Label ifTargetLabel;
488       bool isCycleStmt = false;
489     };
490     llvm::SmallVector<T> ifCandidateStack;
491     const auto *doStmt =
492         evaluationList.begin()->getIf<parser::NonLabelDoStmt>();
493     std::string doName = doStmt ? getConstructName(*doStmt) : std::string{};
494     for (auto it = evaluationList.begin(), end = evaluationList.end();
495          it != end; ++it) {
496       auto &eval = *it;
497       if (eval.isA<parser::EntryStmt>()) {
498         ifCandidateStack.clear();
499         continue;
500       }
501       auto firstStmt = [](lower::pft::Evaluation *e) {
502         return e->isConstruct() ? &*e->evaluationList->begin() : e;
503       };
504       const Fortran::lower::pft::Evaluation &targetEval = *firstStmt(&eval);
505       bool targetEvalIsEndDoStmt = targetEval.isA<parser::EndDoStmt>();
506       auto branchTargetMatch = [&]() {
507         if (const parser::Label targetLabel =
508                 ifCandidateStack.back().ifTargetLabel)
509           if (targetLabel == *targetEval.label)
510             return true; // goto target match
511         if (targetEvalIsEndDoStmt && ifCandidateStack.back().isCycleStmt)
512           return true; // cycle target match
513         return false;
514       };
515       if (targetEval.label || targetEvalIsEndDoStmt) {
516         while (!ifCandidateStack.empty() && branchTargetMatch()) {
517           lower::pft::EvaluationList::iterator ifConstructIt =
518               ifCandidateStack.back().ifConstructIt;
519           lower::pft::EvaluationList::iterator successorIt =
520               std::next(ifConstructIt);
521           if (successorIt != it) {
522             Fortran::lower::pft::EvaluationList &ifBodyList =
523                 *ifConstructIt->evaluationList;
524             lower::pft::EvaluationList::iterator branchStmtIt =
525                 std::next(ifBodyList.begin());
526             assert((branchStmtIt->isA<parser::GotoStmt>() ||
527                     branchStmtIt->isA<parser::CycleStmt>()) &&
528                    "expected goto or cycle statement");
529             ifBodyList.erase(branchStmtIt);
530             lower::pft::Evaluation &ifStmt = *ifBodyList.begin();
531             ifStmt.negateCondition = true;
532             ifStmt.lexicalSuccessor = firstStmt(&*successorIt);
533             lower::pft::EvaluationList::iterator endIfStmtIt =
534                 std::prev(ifBodyList.end());
535             std::prev(it)->lexicalSuccessor = &*endIfStmtIt;
536             endIfStmtIt->lexicalSuccessor = firstStmt(&*it);
537             ifBodyList.splice(endIfStmtIt, evaluationList, successorIt, it);
538             for (; successorIt != endIfStmtIt; ++successorIt)
539               successorIt->parentConstruct = &*ifConstructIt;
540           }
541           ifCandidateStack.pop_back();
542         }
543       }
544       if (eval.isA<parser::IfConstruct>() && eval.evaluationList->size() == 3) {
545         const auto bodyEval = std::next(eval.evaluationList->begin());
546         if (const auto *gotoStmt = bodyEval->getIf<parser::GotoStmt>()) {
547           ifCandidateStack.push_back({it, gotoStmt->v});
548         } else if (doStmt) {
549           if (const auto *cycleStmt = bodyEval->getIf<parser::CycleStmt>()) {
550             std::string cycleName = getConstructName(*cycleStmt);
551             if (cycleName.empty() || cycleName == doName)
552               // This candidate will match doStmt's EndDoStmt.
553               ifCandidateStack.push_back({it, {}, true});
554           }
555         }
556       }
557     }
558   }
559 
560   /// Mark IO statement ERR, EOR, and END specifier branch targets.
561   /// Mark an IO statement with an assigned format as unstructured.
562   template <typename A>
563   void analyzeIoBranches(lower::pft::Evaluation &eval, const A &stmt) {
564     auto analyzeFormatSpec = [&](const parser::Format &format) {
565       if (const auto *expr = std::get_if<parser::Expr>(&format.u)) {
566         if (semantics::ExprHasTypeCategory(*semantics::GetExpr(*expr),
567                                            common::TypeCategory::Integer))
568           eval.isUnstructured = true;
569       }
570     };
571     auto analyzeSpecs{[&](const auto &specList) {
572       for (const auto &spec : specList) {
573         std::visit(
574             Fortran::common::visitors{
575                 [&](const Fortran::parser::Format &format) {
576                   analyzeFormatSpec(format);
577                 },
578                 [&](const auto &label) {
579                   using LabelNodes =
580                       std::tuple<parser::ErrLabel, parser::EorLabel,
581                                  parser::EndLabel>;
582                   if constexpr (common::HasMember<decltype(label), LabelNodes>)
583                     markBranchTarget(eval, label.v);
584                 }},
585             spec.u);
586       }
587     }};
588 
589     using OtherIOStmts =
590         std::tuple<parser::BackspaceStmt, parser::CloseStmt,
591                    parser::EndfileStmt, parser::FlushStmt, parser::OpenStmt,
592                    parser::RewindStmt, parser::WaitStmt>;
593 
594     if constexpr (std::is_same_v<A, parser::ReadStmt> ||
595                   std::is_same_v<A, parser::WriteStmt>) {
596       if (stmt.format)
597         analyzeFormatSpec(*stmt.format);
598       analyzeSpecs(stmt.controls);
599     } else if constexpr (std::is_same_v<A, parser::PrintStmt>) {
600       analyzeFormatSpec(std::get<parser::Format>(stmt.t));
601     } else if constexpr (std::is_same_v<A, parser::InquireStmt>) {
602       if (const auto *specList =
603               std::get_if<std::list<parser::InquireSpec>>(&stmt.u))
604         analyzeSpecs(*specList);
605     } else if constexpr (common::HasMember<A, OtherIOStmts>) {
606       analyzeSpecs(stmt.v);
607     } else {
608       // Always crash if this is instantiated
609       static_assert(!std::is_same_v<A, parser::ReadStmt>,
610                     "Unexpected IO statement");
611     }
612   }
613 
614   /// Set the exit of a construct, possibly from multiple enclosing constructs.
615   void setConstructExit(lower::pft::Evaluation &eval) {
616     eval.constructExit = &eval.evaluationList->back().nonNopSuccessor();
617   }
618 
619   /// Mark the target of a branch as a new block.
620   void markBranchTarget(lower::pft::Evaluation &sourceEvaluation,
621                         lower::pft::Evaluation &targetEvaluation) {
622     sourceEvaluation.isUnstructured = true;
623     if (!sourceEvaluation.controlSuccessor)
624       sourceEvaluation.controlSuccessor = &targetEvaluation;
625     targetEvaluation.isNewBlock = true;
626     // If this is a branch into the body of a construct (usually illegal,
627     // but allowed in some legacy cases), then the targetEvaluation and its
628     // ancestors must be marked as unstructured.
629     lower::pft::Evaluation *sourceConstruct = sourceEvaluation.parentConstruct;
630     lower::pft::Evaluation *targetConstruct = targetEvaluation.parentConstruct;
631     if (targetConstruct &&
632         &targetConstruct->getFirstNestedEvaluation() == &targetEvaluation)
633       // A branch to an initial constructStmt is a branch to the construct.
634       targetConstruct = targetConstruct->parentConstruct;
635     if (targetConstruct) {
636       while (sourceConstruct && sourceConstruct != targetConstruct)
637         sourceConstruct = sourceConstruct->parentConstruct;
638       if (sourceConstruct != targetConstruct) // branch into a construct body
639         for (lower::pft::Evaluation *eval = &targetEvaluation; eval;
640              eval = eval->parentConstruct) {
641           eval->isUnstructured = true;
642           // If the branch is a backward branch into an already analyzed
643           // DO or IF construct, mark the construct exit as a new block.
644           // For a forward branch, the isUnstructured flag will cause this
645           // to be done when the construct is analyzed.
646           if (eval->constructExit && (eval->isA<parser::DoConstruct>() ||
647                                       eval->isA<parser::IfConstruct>()))
648             eval->constructExit->isNewBlock = true;
649         }
650     }
651   }
652   void markBranchTarget(lower::pft::Evaluation &sourceEvaluation,
653                         parser::Label label) {
654     assert(label && "missing branch target label");
655     lower::pft::Evaluation *targetEvaluation{
656         labelEvaluationMap->find(label)->second};
657     assert(targetEvaluation && "missing branch target evaluation");
658     markBranchTarget(sourceEvaluation, *targetEvaluation);
659   }
660 
661   /// Mark the successor of an Evaluation as a new block.
662   void markSuccessorAsNewBlock(lower::pft::Evaluation &eval) {
663     eval.nonNopSuccessor().isNewBlock = true;
664   }
665 
666   template <typename A>
667   inline std::string getConstructName(const A &stmt) {
668     using MaybeConstructNameWrapper =
669         std::tuple<parser::BlockStmt, parser::CycleStmt, parser::ElseStmt,
670                    parser::ElsewhereStmt, parser::EndAssociateStmt,
671                    parser::EndBlockStmt, parser::EndCriticalStmt,
672                    parser::EndDoStmt, parser::EndForallStmt, parser::EndIfStmt,
673                    parser::EndSelectStmt, parser::EndWhereStmt,
674                    parser::ExitStmt>;
675     if constexpr (common::HasMember<A, MaybeConstructNameWrapper>) {
676       if (stmt.v)
677         return stmt.v->ToString();
678     }
679 
680     using MaybeConstructNameInTuple = std::tuple<
681         parser::AssociateStmt, parser::CaseStmt, parser::ChangeTeamStmt,
682         parser::CriticalStmt, parser::ElseIfStmt, parser::EndChangeTeamStmt,
683         parser::ForallConstructStmt, parser::IfThenStmt, parser::LabelDoStmt,
684         parser::MaskedElsewhereStmt, parser::NonLabelDoStmt,
685         parser::SelectCaseStmt, parser::SelectRankCaseStmt,
686         parser::TypeGuardStmt, parser::WhereConstructStmt>;
687     if constexpr (common::HasMember<A, MaybeConstructNameInTuple>) {
688       if (auto name = std::get<std::optional<parser::Name>>(stmt.t))
689         return name->ToString();
690     }
691 
692     // These statements have multiple std::optional<parser::Name> elements.
693     if constexpr (std::is_same_v<A, parser::SelectRankStmt> ||
694                   std::is_same_v<A, parser::SelectTypeStmt>) {
695       if (auto name = std::get<0>(stmt.t))
696         return name->ToString();
697     }
698 
699     return {};
700   }
701 
702   /// \p parentConstruct can be null if this statement is at the highest
703   /// level of a program.
704   template <typename A>
705   void insertConstructName(const A &stmt,
706                            lower::pft::Evaluation *parentConstruct) {
707     std::string name = getConstructName(stmt);
708     if (!name.empty())
709       constructNameMap[name] = parentConstruct;
710   }
711 
712   /// Insert branch links for a list of Evaluations.
713   /// \p parentConstruct can be null if the evaluationList contains the
714   /// top-level statements of a program.
715   void analyzeBranches(lower::pft::Evaluation *parentConstruct,
716                        std::list<lower::pft::Evaluation> &evaluationList) {
717     lower::pft::Evaluation *lastConstructStmtEvaluation{};
718     for (auto &eval : evaluationList) {
719       eval.visit(common::visitors{
720           // Action statements (except IO statements)
721           [&](const parser::CallStmt &s) {
722             // Look for alternate return specifiers.
723             const auto &args =
724                 std::get<std::list<parser::ActualArgSpec>>(s.v.t);
725             for (const auto &arg : args) {
726               const auto &actual = std::get<parser::ActualArg>(arg.t);
727               if (const auto *altReturn =
728                       std::get_if<parser::AltReturnSpec>(&actual.u))
729                 markBranchTarget(eval, altReturn->v);
730             }
731           },
732           [&](const parser::CycleStmt &s) {
733             std::string name = getConstructName(s);
734             lower::pft::Evaluation *construct{name.empty()
735                                                   ? doConstructStack.back()
736                                                   : constructNameMap[name]};
737             assert(construct && "missing CYCLE construct");
738             markBranchTarget(eval, construct->evaluationList->back());
739           },
740           [&](const parser::ExitStmt &s) {
741             std::string name = getConstructName(s);
742             lower::pft::Evaluation *construct{name.empty()
743                                                   ? doConstructStack.back()
744                                                   : constructNameMap[name]};
745             assert(construct && "missing EXIT construct");
746             markBranchTarget(eval, *construct->constructExit);
747           },
748           [&](const parser::FailImageStmt &) {
749             eval.isUnstructured = true;
750             if (eval.lexicalSuccessor->lexicalSuccessor)
751               markSuccessorAsNewBlock(eval);
752           },
753           [&](const parser::GotoStmt &s) { markBranchTarget(eval, s.v); },
754           [&](const parser::IfStmt &) {
755             eval.lexicalSuccessor->isNewBlock = true;
756             lastConstructStmtEvaluation = &eval;
757           },
758           [&](const parser::ReturnStmt &) {
759             eval.isUnstructured = true;
760             if (eval.lexicalSuccessor->lexicalSuccessor)
761               markSuccessorAsNewBlock(eval);
762           },
763           [&](const parser::StopStmt &) {
764             eval.isUnstructured = true;
765             if (eval.lexicalSuccessor->lexicalSuccessor)
766               markSuccessorAsNewBlock(eval);
767           },
768           [&](const parser::ComputedGotoStmt &s) {
769             for (auto &label : std::get<std::list<parser::Label>>(s.t))
770               markBranchTarget(eval, label);
771           },
772           [&](const parser::ArithmeticIfStmt &s) {
773             markBranchTarget(eval, std::get<1>(s.t));
774             markBranchTarget(eval, std::get<2>(s.t));
775             markBranchTarget(eval, std::get<3>(s.t));
776           },
777           [&](const parser::AssignStmt &s) { // legacy label assignment
778             auto &label = std::get<parser::Label>(s.t);
779             const auto *sym = std::get<parser::Name>(s.t).symbol;
780             assert(sym && "missing AssignStmt symbol");
781             lower::pft::Evaluation *target{
782                 labelEvaluationMap->find(label)->second};
783             assert(target && "missing branch target evaluation");
784             if (!target->isA<parser::FormatStmt>())
785               target->isNewBlock = true;
786             auto iter = assignSymbolLabelMap->find(*sym);
787             if (iter == assignSymbolLabelMap->end()) {
788               lower::pft::LabelSet labelSet{};
789               labelSet.insert(label);
790               assignSymbolLabelMap->try_emplace(*sym, labelSet);
791             } else {
792               iter->second.insert(label);
793             }
794           },
795           [&](const parser::AssignedGotoStmt &) {
796             // Although this statement is a branch, it doesn't have any
797             // explicit control successors.  So the code at the end of the
798             // loop won't mark the successor.  Do that here.
799             eval.isUnstructured = true;
800             markSuccessorAsNewBlock(eval);
801           },
802 
803           // The first executable statement after an EntryStmt is a new block.
804           [&](const parser::EntryStmt &) {
805             eval.lexicalSuccessor->isNewBlock = true;
806           },
807 
808           // Construct statements
809           [&](const parser::AssociateStmt &s) {
810             insertConstructName(s, parentConstruct);
811           },
812           [&](const parser::BlockStmt &s) {
813             insertConstructName(s, parentConstruct);
814           },
815           [&](const parser::SelectCaseStmt &s) {
816             insertConstructName(s, parentConstruct);
817             lastConstructStmtEvaluation = &eval;
818           },
819           [&](const parser::CaseStmt &) {
820             eval.isNewBlock = true;
821             lastConstructStmtEvaluation->controlSuccessor = &eval;
822             lastConstructStmtEvaluation = &eval;
823           },
824           [&](const parser::EndSelectStmt &) {
825             eval.nonNopSuccessor().isNewBlock = true;
826             lastConstructStmtEvaluation = nullptr;
827           },
828           [&](const parser::ChangeTeamStmt &s) {
829             insertConstructName(s, parentConstruct);
830           },
831           [&](const parser::CriticalStmt &s) {
832             insertConstructName(s, parentConstruct);
833           },
834           [&](const parser::NonLabelDoStmt &s) {
835             insertConstructName(s, parentConstruct);
836             doConstructStack.push_back(parentConstruct);
837             const auto &loopControl =
838                 std::get<std::optional<parser::LoopControl>>(s.t);
839             if (!loopControl.has_value()) {
840               eval.isUnstructured = true; // infinite loop
841               return;
842             }
843             eval.nonNopSuccessor().isNewBlock = true;
844             eval.controlSuccessor = &evaluationList.back();
845             if (const auto *bounds =
846                     std::get_if<parser::LoopControl::Bounds>(&loopControl->u)) {
847               if (bounds->name.thing.symbol->GetType()->IsNumeric(
848                       common::TypeCategory::Real))
849                 eval.isUnstructured = true; // real-valued loop control
850             } else if (std::get_if<parser::ScalarLogicalExpr>(
851                            &loopControl->u)) {
852               eval.isUnstructured = true; // while loop
853             }
854           },
855           [&](const parser::EndDoStmt &) {
856             lower::pft::Evaluation &doEval = evaluationList.front();
857             eval.controlSuccessor = &doEval;
858             doConstructStack.pop_back();
859             if (parentConstruct->lowerAsStructured())
860               return;
861             // The loop is unstructured, which wasn't known for all cases when
862             // visiting the NonLabelDoStmt.
863             parentConstruct->constructExit->isNewBlock = true;
864             const auto &doStmt = *doEval.getIf<parser::NonLabelDoStmt>();
865             const auto &loopControl =
866                 std::get<std::optional<parser::LoopControl>>(doStmt.t);
867             if (!loopControl.has_value())
868               return; // infinite loop
869             if (const auto *concurrent =
870                     std::get_if<parser::LoopControl::Concurrent>(
871                         &loopControl->u)) {
872               // If there is a mask, the EndDoStmt starts a new block.
873               const auto &header =
874                   std::get<parser::ConcurrentHeader>(concurrent->t);
875               eval.isNewBlock |=
876                   std::get<std::optional<parser::ScalarLogicalExpr>>(header.t)
877                       .has_value();
878             }
879           },
880           [&](const parser::IfThenStmt &s) {
881             insertConstructName(s, parentConstruct);
882             eval.lexicalSuccessor->isNewBlock = true;
883             lastConstructStmtEvaluation = &eval;
884           },
885           [&](const parser::ElseIfStmt &) {
886             eval.isNewBlock = true;
887             eval.lexicalSuccessor->isNewBlock = true;
888             lastConstructStmtEvaluation->controlSuccessor = &eval;
889             lastConstructStmtEvaluation = &eval;
890           },
891           [&](const parser::ElseStmt &) {
892             eval.isNewBlock = true;
893             lastConstructStmtEvaluation->controlSuccessor = &eval;
894             lastConstructStmtEvaluation = nullptr;
895           },
896           [&](const parser::EndIfStmt &) {
897             if (parentConstruct->lowerAsUnstructured())
898               parentConstruct->constructExit->isNewBlock = true;
899             if (lastConstructStmtEvaluation) {
900               lastConstructStmtEvaluation->controlSuccessor =
901                   parentConstruct->constructExit;
902               lastConstructStmtEvaluation = nullptr;
903             }
904           },
905           [&](const parser::SelectRankStmt &s) {
906             insertConstructName(s, parentConstruct);
907           },
908           [&](const parser::SelectRankCaseStmt &) { eval.isNewBlock = true; },
909           [&](const parser::SelectTypeStmt &s) {
910             insertConstructName(s, parentConstruct);
911           },
912           [&](const parser::TypeGuardStmt &) { eval.isNewBlock = true; },
913 
914           // Constructs - set (unstructured) construct exit targets
915           [&](const parser::AssociateConstruct &) { setConstructExit(eval); },
916           [&](const parser::BlockConstruct &) {
917             // EndBlockStmt may have code.
918             eval.constructExit = &eval.evaluationList->back();
919           },
920           [&](const parser::CaseConstruct &) {
921             setConstructExit(eval);
922             eval.isUnstructured = true;
923           },
924           [&](const parser::ChangeTeamConstruct &) {
925             // EndChangeTeamStmt may have code.
926             eval.constructExit = &eval.evaluationList->back();
927           },
928           [&](const parser::CriticalConstruct &) {
929             // EndCriticalStmt may have code.
930             eval.constructExit = &eval.evaluationList->back();
931           },
932           [&](const parser::DoConstruct &) { setConstructExit(eval); },
933           [&](const parser::IfConstruct &) { setConstructExit(eval); },
934           [&](const parser::SelectRankConstruct &) {
935             setConstructExit(eval);
936             eval.isUnstructured = true;
937           },
938           [&](const parser::SelectTypeConstruct &) {
939             setConstructExit(eval);
940             eval.isUnstructured = true;
941           },
942 
943           // Default - Common analysis for IO statements; otherwise nop.
944           [&](const auto &stmt) {
945             using A = std::decay_t<decltype(stmt)>;
946             using IoStmts = std::tuple<
947                 parser::BackspaceStmt, parser::CloseStmt, parser::EndfileStmt,
948                 parser::FlushStmt, parser::InquireStmt, parser::OpenStmt,
949                 parser::PrintStmt, parser::ReadStmt, parser::RewindStmt,
950                 parser::WaitStmt, parser::WriteStmt>;
951             if constexpr (common::HasMember<A, IoStmts>)
952               analyzeIoBranches(eval, stmt);
953           },
954       });
955 
956       // Analyze construct evaluations.
957       if (eval.evaluationList)
958         analyzeBranches(&eval, *eval.evaluationList);
959 
960       // Set the successor of the last statement in an IF or SELECT block.
961       if (!eval.controlSuccessor && eval.lexicalSuccessor &&
962           eval.lexicalSuccessor->isIntermediateConstructStmt()) {
963         eval.controlSuccessor = parentConstruct->constructExit;
964         eval.lexicalSuccessor->isNewBlock = true;
965       }
966 
967       // Propagate isUnstructured flag to enclosing construct.
968       if (parentConstruct && eval.isUnstructured)
969         parentConstruct->isUnstructured = true;
970 
971       // The successor of a branch starts a new block.
972       if (eval.controlSuccessor && eval.isActionStmt() &&
973           eval.lowerAsUnstructured())
974         markSuccessorAsNewBlock(eval);
975     }
976   }
977 
978   /// Do processing specific to subprograms with multiple entry points.
979   void processEntryPoints() {
980     lower::pft::Evaluation *initialEval = &evaluationListStack.back()->front();
981     lower::pft::FunctionLikeUnit *unit = initialEval->getOwningProcedure();
982     int entryCount = unit->entryPointList.size();
983     if (entryCount == 1)
984       return;
985 
986     // The first executable statement in the subprogram is preceded by a
987     // branch to the entry point, so it starts a new block.
988     if (initialEval->hasNestedEvaluations())
989       initialEval = &initialEval->getFirstNestedEvaluation();
990     else if (initialEval->isA<Fortran::parser::EntryStmt>())
991       initialEval = initialEval->lexicalSuccessor;
992     initialEval->isNewBlock = true;
993 
994     // All function entry points share a single result container.
995     // Find one of the largest results.
996     for (int entryIndex = 0; entryIndex < entryCount; ++entryIndex) {
997       unit->setActiveEntry(entryIndex);
998       const auto &details =
999           unit->getSubprogramSymbol().get<semantics::SubprogramDetails>();
1000       if (details.isFunction()) {
1001         const semantics::Symbol *resultSym = &details.result();
1002         assert(resultSym && "missing result symbol");
1003         if (!unit->primaryResult ||
1004             unit->primaryResult->size() < resultSym->size())
1005           unit->primaryResult = resultSym;
1006       }
1007     }
1008     unit->setActiveEntry(0);
1009   }
1010 
1011   std::unique_ptr<lower::pft::Program> pgm;
1012   std::vector<lower::pft::PftNode> pftParentStack;
1013   const semantics::SemanticsContext &semanticsContext;
1014 
1015   /// functionList points to the internal or module procedure function list
1016   /// of a FunctionLikeUnit or a ModuleLikeUnit.  It may be null.
1017   std::list<lower::pft::FunctionLikeUnit> *functionList{};
1018   std::vector<lower::pft::Evaluation *> constructAndDirectiveStack{};
1019   std::vector<lower::pft::Evaluation *> doConstructStack{};
1020   /// evaluationListStack is the current nested construct evaluationList state.
1021   std::vector<lower::pft::EvaluationList *> evaluationListStack{};
1022   llvm::DenseMap<parser::Label, lower::pft::Evaluation *> *labelEvaluationMap{};
1023   lower::pft::SymbolLabelMap *assignSymbolLabelMap{};
1024   std::map<std::string, lower::pft::Evaluation *> constructNameMap{};
1025   lower::pft::Evaluation *lastLexicalEvaluation{};
1026 };
1027 
1028 class PFTDumper {
1029 public:
1030   void dumpPFT(llvm::raw_ostream &outputStream,
1031                const lower::pft::Program &pft) {
1032     for (auto &unit : pft.getUnits()) {
1033       std::visit(common::visitors{
1034                      [&](const lower::pft::BlockDataUnit &unit) {
1035                        outputStream << getNodeIndex(unit) << " ";
1036                        outputStream << "BlockData: ";
1037                        outputStream << "\nEnd BlockData\n\n";
1038                      },
1039                      [&](const lower::pft::FunctionLikeUnit &func) {
1040                        dumpFunctionLikeUnit(outputStream, func);
1041                      },
1042                      [&](const lower::pft::ModuleLikeUnit &unit) {
1043                        dumpModuleLikeUnit(outputStream, unit);
1044                      },
1045                      [&](const lower::pft::CompilerDirectiveUnit &unit) {
1046                        dumpCompilerDirectiveUnit(outputStream, unit);
1047                      },
1048                  },
1049                  unit);
1050     }
1051   }
1052 
1053   llvm::StringRef evaluationName(const lower::pft::Evaluation &eval) {
1054     return eval.visit([](const auto &parseTreeNode) {
1055       return parser::ParseTreeDumper::GetNodeName(parseTreeNode);
1056     });
1057   }
1058 
1059   void dumpEvaluation(llvm::raw_ostream &outputStream,
1060                       const lower::pft::Evaluation &eval,
1061                       const std::string &indentString, int indent = 1) {
1062     llvm::StringRef name = evaluationName(eval);
1063     llvm::StringRef newBlock = eval.isNewBlock ? "^" : "";
1064     llvm::StringRef bang = eval.isUnstructured ? "!" : "";
1065     outputStream << indentString;
1066     if (eval.printIndex)
1067       outputStream << eval.printIndex << ' ';
1068     if (eval.hasNestedEvaluations())
1069       outputStream << "<<" << newBlock << name << bang << ">>";
1070     else
1071       outputStream << newBlock << name << bang;
1072     if (eval.negateCondition)
1073       outputStream << " [negate]";
1074     if (eval.constructExit)
1075       outputStream << " -> " << eval.constructExit->printIndex;
1076     else if (eval.controlSuccessor)
1077       outputStream << " -> " << eval.controlSuccessor->printIndex;
1078     else if (eval.isA<parser::EntryStmt>() && eval.lexicalSuccessor)
1079       outputStream << " -> " << eval.lexicalSuccessor->printIndex;
1080     if (!eval.position.empty())
1081       outputStream << ": " << eval.position.ToString();
1082     else if (auto *dir = eval.getIf<Fortran::parser::CompilerDirective>())
1083       outputStream << ": !" << dir->source.ToString();
1084     outputStream << '\n';
1085     if (eval.hasNestedEvaluations()) {
1086       dumpEvaluationList(outputStream, *eval.evaluationList, indent + 1);
1087       outputStream << indentString << "<<End " << name << bang << ">>\n";
1088     }
1089   }
1090 
1091   void dumpEvaluation(llvm::raw_ostream &ostream,
1092                       const lower::pft::Evaluation &eval) {
1093     dumpEvaluation(ostream, eval, "");
1094   }
1095 
1096   void dumpEvaluationList(llvm::raw_ostream &outputStream,
1097                           const lower::pft::EvaluationList &evaluationList,
1098                           int indent = 1) {
1099     static const auto white = "                                      ++"s;
1100     auto indentString = white.substr(0, indent * 2);
1101     for (const lower::pft::Evaluation &eval : evaluationList)
1102       dumpEvaluation(outputStream, eval, indentString, indent);
1103   }
1104 
1105   void
1106   dumpFunctionLikeUnit(llvm::raw_ostream &outputStream,
1107                        const lower::pft::FunctionLikeUnit &functionLikeUnit) {
1108     outputStream << getNodeIndex(functionLikeUnit) << " ";
1109     llvm::StringRef unitKind;
1110     llvm::StringRef name;
1111     llvm::StringRef header;
1112     if (functionLikeUnit.beginStmt) {
1113       functionLikeUnit.beginStmt->visit(common::visitors{
1114           [&](const parser::Statement<parser::ProgramStmt> &stmt) {
1115             unitKind = "Program";
1116             name = toStringRef(stmt.statement.v.source);
1117           },
1118           [&](const parser::Statement<parser::FunctionStmt> &stmt) {
1119             unitKind = "Function";
1120             name = toStringRef(std::get<parser::Name>(stmt.statement.t).source);
1121             header = toStringRef(stmt.source);
1122           },
1123           [&](const parser::Statement<parser::SubroutineStmt> &stmt) {
1124             unitKind = "Subroutine";
1125             name = toStringRef(std::get<parser::Name>(stmt.statement.t).source);
1126             header = toStringRef(stmt.source);
1127           },
1128           [&](const parser::Statement<parser::MpSubprogramStmt> &stmt) {
1129             unitKind = "MpSubprogram";
1130             name = toStringRef(stmt.statement.v.source);
1131             header = toStringRef(stmt.source);
1132           },
1133           [&](const auto &) { llvm_unreachable("not a valid begin stmt"); },
1134       });
1135     } else {
1136       unitKind = "Program";
1137       name = "<anonymous>";
1138     }
1139     outputStream << unitKind << ' ' << name;
1140     if (!header.empty())
1141       outputStream << ": " << header;
1142     outputStream << '\n';
1143     dumpEvaluationList(outputStream, functionLikeUnit.evaluationList);
1144     if (!functionLikeUnit.nestedFunctions.empty()) {
1145       outputStream << "\nContains\n";
1146       for (const lower::pft::FunctionLikeUnit &func :
1147            functionLikeUnit.nestedFunctions)
1148         dumpFunctionLikeUnit(outputStream, func);
1149       outputStream << "End Contains\n";
1150     }
1151     outputStream << "End " << unitKind << ' ' << name << "\n\n";
1152   }
1153 
1154   void dumpModuleLikeUnit(llvm::raw_ostream &outputStream,
1155                           const lower::pft::ModuleLikeUnit &moduleLikeUnit) {
1156     outputStream << getNodeIndex(moduleLikeUnit) << " ";
1157     outputStream << "ModuleLike:\n";
1158     dumpEvaluationList(outputStream, moduleLikeUnit.evaluationList);
1159     outputStream << "Contains\n";
1160     for (const lower::pft::FunctionLikeUnit &func :
1161          moduleLikeUnit.nestedFunctions)
1162       dumpFunctionLikeUnit(outputStream, func);
1163     outputStream << "End Contains\nEnd ModuleLike\n\n";
1164   }
1165 
1166   // Top level directives
1167   void dumpCompilerDirectiveUnit(
1168       llvm::raw_ostream &outputStream,
1169       const lower::pft::CompilerDirectiveUnit &directive) {
1170     outputStream << getNodeIndex(directive) << " ";
1171     outputStream << "CompilerDirective: !";
1172     outputStream << directive.get<Fortran::parser::CompilerDirective>()
1173                         .source.ToString();
1174     outputStream << "\nEnd CompilerDirective\n\n";
1175   }
1176 
1177   template <typename T>
1178   std::size_t getNodeIndex(const T &node) {
1179     auto addr = static_cast<const void *>(&node);
1180     auto it = nodeIndexes.find(addr);
1181     if (it != nodeIndexes.end())
1182       return it->second;
1183     nodeIndexes.try_emplace(addr, nextIndex);
1184     return nextIndex++;
1185   }
1186   std::size_t getNodeIndex(const lower::pft::Program &) { return 0; }
1187 
1188 private:
1189   llvm::DenseMap<const void *, std::size_t> nodeIndexes;
1190   std::size_t nextIndex{1}; // 0 is the root
1191 };
1192 
1193 } // namespace
1194 
1195 template <typename A, typename T>
1196 static lower::pft::FunctionLikeUnit::FunctionStatement
1197 getFunctionStmt(const T &func) {
1198   lower::pft::FunctionLikeUnit::FunctionStatement result{
1199       std::get<parser::Statement<A>>(func.t)};
1200   return result;
1201 }
1202 
1203 template <typename A, typename T>
1204 static lower::pft::ModuleLikeUnit::ModuleStatement getModuleStmt(const T &mod) {
1205   lower::pft::ModuleLikeUnit::ModuleStatement result{
1206       std::get<parser::Statement<A>>(mod.t)};
1207   return result;
1208 }
1209 
1210 template <typename A>
1211 static const semantics::Symbol *getSymbol(A &beginStmt) {
1212   const auto *symbol = beginStmt.visit(common::visitors{
1213       [](const parser::Statement<parser::ProgramStmt> &stmt)
1214           -> const semantics::Symbol * { return stmt.statement.v.symbol; },
1215       [](const parser::Statement<parser::FunctionStmt> &stmt)
1216           -> const semantics::Symbol * {
1217         return std::get<parser::Name>(stmt.statement.t).symbol;
1218       },
1219       [](const parser::Statement<parser::SubroutineStmt> &stmt)
1220           -> const semantics::Symbol * {
1221         return std::get<parser::Name>(stmt.statement.t).symbol;
1222       },
1223       [](const parser::Statement<parser::MpSubprogramStmt> &stmt)
1224           -> const semantics::Symbol * { return stmt.statement.v.symbol; },
1225       [](const parser::Statement<parser::ModuleStmt> &stmt)
1226           -> const semantics::Symbol * { return stmt.statement.v.symbol; },
1227       [](const parser::Statement<parser::SubmoduleStmt> &stmt)
1228           -> const semantics::Symbol * {
1229         return std::get<parser::Name>(stmt.statement.t).symbol;
1230       },
1231       [](const auto &) -> const semantics::Symbol * {
1232         llvm_unreachable("unknown FunctionLike or ModuleLike beginStmt");
1233         return nullptr;
1234       }});
1235   assert(symbol && "parser::Name must have resolved symbol");
1236   return symbol;
1237 }
1238 
1239 bool Fortran::lower::pft::Evaluation::lowerAsStructured() const {
1240   return !lowerAsUnstructured();
1241 }
1242 
1243 bool Fortran::lower::pft::Evaluation::lowerAsUnstructured() const {
1244   return isUnstructured || clDisableStructuredFir;
1245 }
1246 
1247 lower::pft::FunctionLikeUnit *
1248 Fortran::lower::pft::Evaluation::getOwningProcedure() const {
1249   return parent.visit(common::visitors{
1250       [](lower::pft::FunctionLikeUnit &c) { return &c; },
1251       [&](lower::pft::Evaluation &c) { return c.getOwningProcedure(); },
1252       [](auto &) -> lower::pft::FunctionLikeUnit * { return nullptr; },
1253   });
1254 }
1255 
1256 bool Fortran::lower::definedInCommonBlock(const semantics::Symbol &sym) {
1257   return semantics::FindCommonBlockContaining(sym);
1258 }
1259 
1260 static bool isReEntrant(const Fortran::semantics::Scope &scope) {
1261   if (scope.kind() == Fortran::semantics::Scope::Kind::MainProgram)
1262     return false;
1263   if (scope.kind() == Fortran::semantics::Scope::Kind::Subprogram) {
1264     const Fortran::semantics::Symbol *sym = scope.symbol();
1265     assert(sym && "Subprogram scope must have a symbol");
1266     return sym->attrs().test(semantics::Attr::RECURSIVE) ||
1267            (!sym->attrs().test(semantics::Attr::NON_RECURSIVE) &&
1268             Fortran::lower::defaultRecursiveFunctionSetting());
1269   }
1270   if (scope.kind() == Fortran::semantics::Scope::Kind::Module)
1271     return false;
1272   return true;
1273 }
1274 
1275 /// Is the symbol `sym` a global?
1276 bool Fortran::lower::symbolIsGlobal(const semantics::Symbol &sym) {
1277   if (const auto *details = sym.detailsIf<semantics::ObjectEntityDetails>()) {
1278     if (details->init())
1279       return true;
1280     if (!isReEntrant(sym.owner())) {
1281       // Turn array and character of non re-entrant programs (like the main
1282       // program) into global memory.
1283       if (const Fortran::semantics::DeclTypeSpec *symTy = sym.GetType())
1284         if (symTy->category() == semantics::DeclTypeSpec::Character)
1285           if (auto e = symTy->characterTypeSpec().length().GetExplicit())
1286             return true;
1287       if (!details->shape().empty() || !details->coshape().empty())
1288         return true;
1289     }
1290   }
1291   return semantics::IsSaved(sym) || lower::definedInCommonBlock(sym) ||
1292          semantics::IsNamedConstant(sym);
1293 }
1294 
1295 namespace {
1296 /// This helper class is for sorting the symbols in the symbol table. We want
1297 /// the symbols in an order such that a symbol will be visited after those it
1298 /// depends upon. Otherwise this sort is stable and preserves the order of the
1299 /// symbol table, which is sorted by name.
1300 struct SymbolDependenceDepth {
1301   explicit SymbolDependenceDepth(
1302       std::vector<std::vector<lower::pft::Variable>> &vars)
1303       : vars{vars} {}
1304 
1305   void analyzeAliasesInCurrentScope(const semantics::Scope &scope) {
1306     // FIXME: When this function is called on the scope of an internal
1307     // procedure whose parent contains an EQUIVALENCE set and the internal
1308     // procedure uses variables from that EQUIVALENCE set, we end up creating
1309     // an AggregateStore for those variables unnecessarily.
1310     //
1311     /// If this is a function nested in a module no host associated
1312     /// symbol are added to the function scope for module symbols used in this
1313     /// scope. As a result, alias analysis in parent module scopes must be
1314     /// preformed here.
1315     const semantics::Scope *parentScope = &scope;
1316     while (!parentScope->IsGlobal()) {
1317       parentScope = &parentScope->parent();
1318       if (parentScope->IsModule())
1319         analyzeAliases(*parentScope);
1320     }
1321     for (const auto &iter : scope) {
1322       const semantics::Symbol &ultimate = iter.second.get().GetUltimate();
1323       if (skipSymbol(ultimate))
1324         continue;
1325       analyzeAliases(ultimate.owner());
1326     }
1327     // add all aggregate stores to the front of the work list
1328     adjustSize(1);
1329     // The copy in the loop matters, 'stores' will still be used.
1330     for (auto st : stores)
1331       vars[0].emplace_back(std::move(st));
1332   }
1333 
1334   // Compute the offset of the last byte that resides in the symbol.
1335   inline static std::size_t offsetWidth(const Fortran::semantics::Symbol &sym) {
1336     std::size_t width = sym.offset();
1337     if (std::size_t size = sym.size())
1338       width += size - 1;
1339     return width;
1340   }
1341 
1342   // Analyze the equivalence sets. This analysis need not be performed when the
1343   // scope has no equivalence sets.
1344   void analyzeAliases(const semantics::Scope &scope) {
1345     if (scope.equivalenceSets().empty())
1346       return;
1347     // Don't analyze a scope if it has already been analyzed.
1348     if (analyzedScopes.find(&scope) != analyzedScopes.end())
1349       return;
1350 
1351     analyzedScopes.insert(&scope);
1352     std::list<std::list<semantics::SymbolRef>> aggregates =
1353         Fortran::semantics::GetStorageAssociations(scope);
1354     for (std::list<semantics::SymbolRef> aggregate : aggregates) {
1355       const Fortran::semantics::Symbol *aggregateSym = nullptr;
1356       bool isGlobal = false;
1357       const semantics::Symbol &first = *aggregate.front();
1358       std::size_t start = first.offset();
1359       std::size_t end = first.offset() + first.size();
1360       const Fortran::semantics::Symbol *namingSym = nullptr;
1361       for (semantics::SymbolRef symRef : aggregate) {
1362         const semantics::Symbol &sym = *symRef;
1363         aliasSyms.insert(&sym);
1364         if (sym.test(Fortran::semantics::Symbol::Flag::CompilerCreated)) {
1365           aggregateSym = &sym;
1366         } else {
1367           isGlobal |= lower::symbolIsGlobal(sym);
1368           start = std::min(sym.offset(), start);
1369           end = std::max(sym.offset() + sym.size(), end);
1370           if (!namingSym || (sym.name() < namingSym->name()))
1371             namingSym = &sym;
1372         }
1373       }
1374       assert(namingSym && "must contain at least one user symbol");
1375       if (!aggregateSym) {
1376         stores.emplace_back(
1377             Fortran::lower::pft::Variable::Interval{start, end - start},
1378             *namingSym, isGlobal);
1379       } else {
1380         stores.emplace_back(*aggregateSym, *namingSym, isGlobal);
1381       }
1382     }
1383   }
1384 
1385   // Recursively visit each symbol to determine the height of its dependence on
1386   // other symbols.
1387   int analyze(const semantics::Symbol &sym) {
1388     auto done = seen.insert(&sym);
1389     LLVM_DEBUG(llvm::dbgs() << "analyze symbol: " << sym << '\n');
1390     if (!done.second)
1391       return 0;
1392     const bool isProcedurePointerOrDummy =
1393         semantics::IsProcedurePointer(sym) ||
1394         (semantics::IsProcedure(sym) && IsDummy(sym));
1395     // A procedure argument in a subprogram with multiple entry points might
1396     // need a vars list entry to trigger creation of a symbol map entry in
1397     // some cases.  Non-dummy procedures don't.
1398     if (semantics::IsProcedure(sym) && !isProcedurePointerOrDummy)
1399       return 0;
1400     semantics::Symbol ultimate = sym.GetUltimate();
1401     if (const auto *details =
1402             ultimate.detailsIf<semantics::NamelistDetails>()) {
1403       // handle namelist group symbols
1404       for (const semantics::SymbolRef &s : details->objects())
1405         analyze(s);
1406       return 0;
1407     }
1408     if (!ultimate.has<semantics::ObjectEntityDetails>() &&
1409         !isProcedurePointerOrDummy)
1410       return 0;
1411 
1412     if (sym.has<semantics::DerivedTypeDetails>())
1413       llvm_unreachable("not yet implemented - derived type analysis");
1414 
1415     // Symbol must be something lowering will have to allocate.
1416     int depth = 0;
1417     // Analyze symbols appearing in object entity specification expression. This
1418     // ensures these symbols will be instantiated before the current one.
1419     // This is not done for object entities that are host associated because
1420     // they must be instantiated from the value of the host symbols (the
1421     // specification expressions should not be re-evaluated).
1422     if (const auto *details = sym.detailsIf<semantics::ObjectEntityDetails>()) {
1423       const semantics::DeclTypeSpec *symTy = sym.GetType();
1424       assert(symTy && "symbol must have a type");
1425       // check CHARACTER's length
1426       if (symTy->category() == semantics::DeclTypeSpec::Character)
1427         if (auto e = symTy->characterTypeSpec().length().GetExplicit())
1428           for (const auto &s : evaluate::CollectSymbols(*e))
1429             depth = std::max(analyze(s) + 1, depth);
1430 
1431       auto doExplicit = [&](const auto &bound) {
1432         if (bound.isExplicit()) {
1433           semantics::SomeExpr e{*bound.GetExplicit()};
1434           for (const auto &s : evaluate::CollectSymbols(e))
1435             depth = std::max(analyze(s) + 1, depth);
1436         }
1437       };
1438       // handle any symbols in array bound declarations
1439       for (const semantics::ShapeSpec &subs : details->shape()) {
1440         doExplicit(subs.lbound());
1441         doExplicit(subs.ubound());
1442       }
1443       // handle any symbols in coarray bound declarations
1444       for (const semantics::ShapeSpec &subs : details->coshape()) {
1445         doExplicit(subs.lbound());
1446         doExplicit(subs.ubound());
1447       }
1448       // handle any symbols in initialization expressions
1449       if (auto e = details->init())
1450         for (const auto &s : evaluate::CollectSymbols(*e))
1451           depth = std::max(analyze(s) + 1, depth);
1452     }
1453     adjustSize(depth + 1);
1454     bool global = lower::symbolIsGlobal(sym);
1455     vars[depth].emplace_back(sym, global, depth);
1456     if (semantics::IsAllocatable(sym))
1457       vars[depth].back().setHeapAlloc();
1458     if (semantics::IsPointer(sym))
1459       vars[depth].back().setPointer();
1460     if (ultimate.attrs().test(semantics::Attr::TARGET))
1461       vars[depth].back().setTarget();
1462 
1463     // If there are alias sets, then link the participating variables to their
1464     // aggregate stores when constructing the new variable on the list.
1465     if (lower::pft::Variable::AggregateStore *store = findStoreIfAlias(sym))
1466       vars[depth].back().setAlias(store->getOffset());
1467     return depth;
1468   }
1469 
1470   /// Save the final list of variable allocations as a single vector and free
1471   /// the rest.
1472   void finalize() {
1473     for (int i = 1, end = vars.size(); i < end; ++i)
1474       vars[0].insert(vars[0].end(), vars[i].begin(), vars[i].end());
1475     vars.resize(1);
1476   }
1477 
1478   Fortran::lower::pft::Variable::AggregateStore *
1479   findStoreIfAlias(const Fortran::evaluate::Symbol &sym) {
1480     const semantics::Symbol &ultimate = sym.GetUltimate();
1481     const semantics::Scope &scope = ultimate.owner();
1482     // Expect the total number of EQUIVALENCE sets to be small for a typical
1483     // Fortran program.
1484     if (aliasSyms.find(&ultimate) != aliasSyms.end()) {
1485       LLVM_DEBUG(llvm::dbgs() << "symbol: " << ultimate << '\n');
1486       LLVM_DEBUG(llvm::dbgs() << "scope: " << scope << '\n');
1487       std::size_t off = ultimate.offset();
1488       std::size_t symSize = ultimate.size();
1489       for (lower::pft::Variable::AggregateStore &v : stores) {
1490         if (&v.getOwningScope() == &scope) {
1491           auto intervalOff = std::get<0>(v.interval);
1492           auto intervalSize = std::get<1>(v.interval);
1493           if (off >= intervalOff && off < intervalOff + intervalSize)
1494             return &v;
1495           // Zero sized symbol in zero sized equivalence.
1496           if (off == intervalOff && symSize == 0)
1497             return &v;
1498         }
1499       }
1500       // clang-format off
1501       LLVM_DEBUG(
1502           llvm::dbgs() << "looking for " << off << "\n{\n";
1503           for (lower::pft::Variable::AggregateStore &v : stores) {
1504             llvm::dbgs() << " in scope: " << &v.getOwningScope() << "\n";
1505             llvm::dbgs() << "  i = [" << std::get<0>(v.interval) << ".."
1506                 << std::get<0>(v.interval) + std::get<1>(v.interval)
1507                 << "]\n";
1508           }
1509           llvm::dbgs() << "}\n");
1510       // clang-format on
1511       llvm_unreachable("the store must be present");
1512     }
1513     return nullptr;
1514   }
1515 
1516 private:
1517   /// Skip symbol in alias analysis.
1518   bool skipSymbol(const semantics::Symbol &sym) {
1519     // Common block equivalences are largely managed by the front end.
1520     // Compiler generated symbols ('.' names) cannot be equivalenced.
1521     // FIXME: Equivalence code generation may need to be revisited.
1522     return !sym.has<semantics::ObjectEntityDetails>() ||
1523            lower::definedInCommonBlock(sym) || sym.name()[0] == '.';
1524   }
1525 
1526   // Make sure the table is of appropriate size.
1527   void adjustSize(std::size_t size) {
1528     if (vars.size() < size)
1529       vars.resize(size);
1530   }
1531 
1532   llvm::SmallSet<const semantics::Symbol *, 32> seen;
1533   std::vector<std::vector<lower::pft::Variable>> &vars;
1534   llvm::SmallSet<const semantics::Symbol *, 32> aliasSyms;
1535   /// Set of Scope that have been analyzed for aliases.
1536   llvm::SmallSet<const semantics::Scope *, 4> analyzedScopes;
1537   std::vector<Fortran::lower::pft::Variable::AggregateStore> stores;
1538 };
1539 } // namespace
1540 
1541 static void processSymbolTable(
1542     const semantics::Scope &scope,
1543     std::vector<std::vector<Fortran::lower::pft::Variable>> &varList) {
1544   SymbolDependenceDepth sdd{varList};
1545   sdd.analyzeAliasesInCurrentScope(scope);
1546   for (const auto &iter : scope)
1547     sdd.analyze(iter.second.get());
1548   sdd.finalize();
1549 }
1550 
1551 //===----------------------------------------------------------------------===//
1552 // FunctionLikeUnit implementation
1553 //===----------------------------------------------------------------------===//
1554 
1555 Fortran::lower::pft::FunctionLikeUnit::FunctionLikeUnit(
1556     const parser::MainProgram &func, const lower::pft::PftNode &parent,
1557     const semantics::SemanticsContext &semanticsContext)
1558     : ProgramUnit{func, parent}, endStmt{
1559                                      getFunctionStmt<parser::EndProgramStmt>(
1560                                          func)} {
1561   const auto &programStmt =
1562       std::get<std::optional<parser::Statement<parser::ProgramStmt>>>(func.t);
1563   if (programStmt.has_value()) {
1564     beginStmt = FunctionStatement(programStmt.value());
1565     const semantics::Symbol *symbol = getSymbol(*beginStmt);
1566     entryPointList[0].first = symbol;
1567     processSymbolTable(*symbol->scope(), varList);
1568   } else {
1569     processSymbolTable(
1570         semanticsContext.FindScope(
1571             std::get<parser::Statement<parser::EndProgramStmt>>(func.t).source),
1572         varList);
1573   }
1574 }
1575 
1576 Fortran::lower::pft::FunctionLikeUnit::FunctionLikeUnit(
1577     const parser::FunctionSubprogram &func, const lower::pft::PftNode &parent,
1578     const semantics::SemanticsContext &)
1579     : ProgramUnit{func, parent},
1580       beginStmt{getFunctionStmt<parser::FunctionStmt>(func)},
1581       endStmt{getFunctionStmt<parser::EndFunctionStmt>(func)} {
1582   const semantics::Symbol *symbol = getSymbol(*beginStmt);
1583   entryPointList[0].first = symbol;
1584   processSymbolTable(*symbol->scope(), varList);
1585 }
1586 
1587 Fortran::lower::pft::FunctionLikeUnit::FunctionLikeUnit(
1588     const parser::SubroutineSubprogram &func, const lower::pft::PftNode &parent,
1589     const semantics::SemanticsContext &)
1590     : ProgramUnit{func, parent},
1591       beginStmt{getFunctionStmt<parser::SubroutineStmt>(func)},
1592       endStmt{getFunctionStmt<parser::EndSubroutineStmt>(func)} {
1593   const semantics::Symbol *symbol = getSymbol(*beginStmt);
1594   entryPointList[0].first = symbol;
1595   processSymbolTable(*symbol->scope(), varList);
1596 }
1597 
1598 Fortran::lower::pft::FunctionLikeUnit::FunctionLikeUnit(
1599     const parser::SeparateModuleSubprogram &func,
1600     const lower::pft::PftNode &parent, const semantics::SemanticsContext &)
1601     : ProgramUnit{func, parent},
1602       beginStmt{getFunctionStmt<parser::MpSubprogramStmt>(func)},
1603       endStmt{getFunctionStmt<parser::EndMpSubprogramStmt>(func)} {
1604   const semantics::Symbol *symbol = getSymbol(*beginStmt);
1605   entryPointList[0].first = symbol;
1606   processSymbolTable(*symbol->scope(), varList);
1607 }
1608 
1609 Fortran::lower::HostAssociations &
1610 Fortran::lower::pft::FunctionLikeUnit::parentHostAssoc() {
1611   if (auto *par = parent.getIf<FunctionLikeUnit>())
1612     return par->hostAssociations;
1613   llvm::report_fatal_error("parent is not a function");
1614 }
1615 
1616 bool Fortran::lower::pft::FunctionLikeUnit::parentHasHostAssoc() {
1617   if (auto *par = parent.getIf<FunctionLikeUnit>())
1618     return !par->hostAssociations.empty();
1619   return false;
1620 }
1621 
1622 parser::CharBlock
1623 Fortran::lower::pft::FunctionLikeUnit::getStartingSourceLoc() const {
1624   if (beginStmt)
1625     return stmtSourceLoc(*beginStmt);
1626   if (!evaluationList.empty())
1627     return evaluationList.front().position;
1628   return stmtSourceLoc(endStmt);
1629 }
1630 
1631 //===----------------------------------------------------------------------===//
1632 // ModuleLikeUnit implementation
1633 //===----------------------------------------------------------------------===//
1634 
1635 Fortran::lower::pft::ModuleLikeUnit::ModuleLikeUnit(
1636     const parser::Module &m, const lower::pft::PftNode &parent)
1637     : ProgramUnit{m, parent}, beginStmt{getModuleStmt<parser::ModuleStmt>(m)},
1638       endStmt{getModuleStmt<parser::EndModuleStmt>(m)} {
1639   const semantics::Symbol *symbol = getSymbol(beginStmt);
1640   processSymbolTable(*symbol->scope(), varList);
1641 }
1642 
1643 Fortran::lower::pft::ModuleLikeUnit::ModuleLikeUnit(
1644     const parser::Submodule &m, const lower::pft::PftNode &parent)
1645     : ProgramUnit{m, parent}, beginStmt{getModuleStmt<parser::SubmoduleStmt>(
1646                                   m)},
1647       endStmt{getModuleStmt<parser::EndSubmoduleStmt>(m)} {
1648   const semantics::Symbol *symbol = getSymbol(beginStmt);
1649   processSymbolTable(*symbol->scope(), varList);
1650 }
1651 
1652 parser::CharBlock
1653 Fortran::lower::pft::ModuleLikeUnit::getStartingSourceLoc() const {
1654   return stmtSourceLoc(beginStmt);
1655 }
1656 const Fortran::semantics::Scope &
1657 Fortran::lower::pft::ModuleLikeUnit::getScope() const {
1658   const Fortran::semantics::Symbol *symbol = getSymbol(beginStmt);
1659   assert(symbol && symbol->scope() &&
1660          "Module statement must have a symbol with a scope");
1661   return *symbol->scope();
1662 }
1663 
1664 //===----------------------------------------------------------------------===//
1665 // BlockDataUnit implementation
1666 //===----------------------------------------------------------------------===//
1667 
1668 Fortran::lower::pft::BlockDataUnit::BlockDataUnit(
1669     const parser::BlockData &bd, const lower::pft::PftNode &parent,
1670     const semantics::SemanticsContext &semanticsContext)
1671     : ProgramUnit{bd, parent},
1672       symTab{semanticsContext.FindScope(
1673           std::get<parser::Statement<parser::EndBlockDataStmt>>(bd.t).source)} {
1674 }
1675 
1676 std::unique_ptr<lower::pft::Program>
1677 Fortran::lower::createPFT(const parser::Program &root,
1678                           const semantics::SemanticsContext &semanticsContext) {
1679   PFTBuilder walker(semanticsContext);
1680   Walk(root, walker);
1681   return walker.result();
1682 }
1683 
1684 // FIXME: FlangDriver
1685 // This option should be integrated with the real driver as the default of
1686 // RECURSIVE vs. NON_RECURSIVE may be changed by other command line options,
1687 // etc., etc.
1688 bool Fortran::lower::defaultRecursiveFunctionSetting() {
1689   return !nonRecursiveProcedures;
1690 }
1691 
1692 void Fortran::lower::dumpPFT(llvm::raw_ostream &outputStream,
1693                              const lower::pft::Program &pft) {
1694   PFTDumper{}.dumpPFT(outputStream, pft);
1695 }
1696 
1697 void Fortran::lower::pft::Program::dump() const {
1698   dumpPFT(llvm::errs(), *this);
1699 }
1700 
1701 void Fortran::lower::pft::Evaluation::dump() const {
1702   PFTDumper{}.dumpEvaluation(llvm::errs(), *this);
1703 }
1704 
1705 void Fortran::lower::pft::Variable::dump() const {
1706   if (auto *s = std::get_if<Nominal>(&var)) {
1707     llvm::errs() << "symbol: " << s->symbol->name();
1708     llvm::errs() << " (depth: " << s->depth << ')';
1709     if (s->global)
1710       llvm::errs() << ", global";
1711     if (s->heapAlloc)
1712       llvm::errs() << ", allocatable";
1713     if (s->pointer)
1714       llvm::errs() << ", pointer";
1715     if (s->target)
1716       llvm::errs() << ", target";
1717     if (s->aliaser)
1718       llvm::errs() << ", equivalence(" << s->aliasOffset << ')';
1719   } else if (auto *s = std::get_if<AggregateStore>(&var)) {
1720     llvm::errs() << "interval[" << std::get<0>(s->interval) << ", "
1721                  << std::get<1>(s->interval) << "]:";
1722     llvm::errs() << " name: " << toStringRef(s->getNamingSymbol().name());
1723     if (s->isGlobal())
1724       llvm::errs() << ", global";
1725     if (s->initialValueSymbol)
1726       llvm::errs() << ", initial value: {" << *s->initialValueSymbol << "}";
1727   } else {
1728     llvm_unreachable("not a Variable");
1729   }
1730   llvm::errs() << '\n';
1731 }
1732 
1733 void Fortran::lower::pft::FunctionLikeUnit::dump() const {
1734   PFTDumper{}.dumpFunctionLikeUnit(llvm::errs(), *this);
1735 }
1736 
1737 void Fortran::lower::pft::ModuleLikeUnit::dump() const {
1738   PFTDumper{}.dumpModuleLikeUnit(llvm::errs(), *this);
1739 }
1740 
1741 /// The BlockDataUnit dump is just the associated symbol table.
1742 void Fortran::lower::pft::BlockDataUnit::dump() const {
1743   llvm::errs() << "block data {\n" << symTab << "\n}\n";
1744 }
1745 
1746 std::vector<Fortran::lower::pft::Variable>
1747 Fortran::lower::pft::buildFuncResultDependencyList(
1748     const Fortran::semantics::Symbol &symbol) {
1749   std::vector<std::vector<pft::Variable>> variableList;
1750   SymbolDependenceDepth sdd(variableList);
1751   sdd.analyzeAliasesInCurrentScope(symbol.owner());
1752   sdd.analyze(symbol);
1753   sdd.finalize();
1754   // Remove the pft::variable for the result itself, only its dependencies
1755   // should be returned in the list.
1756   assert(!variableList[0].empty() && "must at least contain the result");
1757   assert(&variableList[0].back().getSymbol() == &symbol &&
1758          "result sym should be last");
1759   variableList[0].pop_back();
1760   return variableList[0];
1761 }
1762 
1763 namespace {
1764 /// Helper class to find all the symbols referenced in a FunctionLikeUnit.
1765 /// It defines a parse tree visitor doing a deep visit in all nodes with
1766 /// symbols (including evaluate::Expr).
1767 struct SymbolVisitor {
1768   template <typename A>
1769   bool Pre(const A &x) {
1770     if constexpr (Fortran::parser::HasTypedExpr<A>::value)
1771       if (const auto *expr = Fortran::semantics::GetExpr(x))
1772         visitExpr(*expr);
1773     return true;
1774   }
1775 
1776   bool Pre(const Fortran::parser::Name &name) {
1777     if (const semantics::Symbol *symbol = name.symbol)
1778       visitSymbol(*symbol);
1779     return false;
1780   }
1781 
1782   void visitExpr(const Fortran::lower::SomeExpr &expr) {
1783     for (const semantics::Symbol &symbol :
1784          Fortran::evaluate::CollectSymbols(expr))
1785       visitSymbol(symbol);
1786   }
1787 
1788   void visitSymbol(const Fortran::semantics::Symbol &symbol) {
1789     callBack(symbol);
1790     // Visit statement function body since it will be inlined in lowering.
1791     if (const auto *subprogramDetails =
1792             symbol.detailsIf<Fortran::semantics::SubprogramDetails>())
1793       if (const auto &maybeExpr = subprogramDetails->stmtFunction())
1794         visitExpr(*maybeExpr);
1795   }
1796 
1797   template <typename A>
1798   constexpr void Post(const A &) {}
1799 
1800   const std::function<void(const Fortran::semantics::Symbol &)> &callBack;
1801 };
1802 } // namespace
1803 
1804 void Fortran::lower::pft::visitAllSymbols(
1805     const Fortran::lower::pft::FunctionLikeUnit &funit,
1806     const std::function<void(const Fortran::semantics::Symbol &)> callBack) {
1807   SymbolVisitor visitor{callBack};
1808   funit.visit([&](const auto &functionParserNode) {
1809     parser::Walk(functionParserNode, visitor);
1810   });
1811 }
1812 
1813 void Fortran::lower::pft::visitAllSymbols(
1814     const Fortran::lower::pft::Evaluation &eval,
1815     const std::function<void(const Fortran::semantics::Symbol &)> callBack) {
1816   SymbolVisitor visitor{callBack};
1817   eval.visit([&](const auto &functionParserNode) {
1818     parser::Walk(functionParserNode, visitor);
1819   });
1820 }
1821