[flang] Update PFTBuilder

[clementval]

Summary

This patch update the PFTBuilder to be able to lower
the construct present in semantics.

This is a building block for other lowering patches that will be posted soon.

This patch is part of the upstreaming effort from fir-dev branch.

[PeteSteinfeld]

All builds and tests correctly and looks good.

[peixin]

The lowering for OpenMP/OpenACC declarative constructs is upstreamed in this patch. However, there is no regression test for them. In addition, I found a bug when I look at lowering OpenMP Threadprivate directive. D120459 and D120460 address those two problems. D120460 is based on D120459. They are split for ease of review. @clementval Could you please help review them?

flang/include/flang/Lower/HostAssociations.h

+//===-- Lower/HostAssociations.h --------------------------------*- C++ -*-===//
+//
+// Part of the LLVM Project, under the Apache License v2.0 with LLVM Exceptions.
+// See https://llvm.org/LICENSE.txt for license information.
+// SPDX-License-Identifier: Apache-2.0 WITH LLVM-exception
+//
+//===----------------------------------------------------------------------===//
+
+#ifndef FORTRAN_LOWER_HOSTASSOCIATIONS_H
+#define FORTRAN_LOWER_HOSTASSOCIATIONS_H
+
+#include "mlir/IR/Location.h"
+#include "mlir/IR/Types.h"
+#include "mlir/IR/Value.h"
+#include "llvm/ADT/SetVector.h"
+
+namespace Fortran {
+namespace semantics {
+class Symbol;
+}
+
+namespace lower {
+class AbstractConverter;
+class SymMap;
+
+/// Internal procedures in Fortran may access variables declared in the host
+/// procedure directly. We bundle these variables together in a tuple and pass
+/// them as an extra argument.
+class HostAssociations {
+public:
+  /// Returns true iff there are no host associations.
+  bool empty() const { return symbols.empty(); }
+
+  /// Adds a set of Symbols that will be the host associated bindings for this
+  /// host procedure.
+  void addSymbolsToBind(
+      const llvm::SetVector<const Fortran::semantics::Symbol *> &s) {
+    assert(empty() && "symbol set must be initially empty");
+    symbols = s;
+  }
+
+  /// Code gen the FIR for the local bindings for the host associated symbols
+  /// for the host (parent) procedure using `builder`.
+  void hostProcedureBindings(AbstractConverter &converter, SymMap &symMap);
+
+  /// Code gen the FIR for the local bindings for the host associated symbols
+  /// for an internal (child) procedure using `builder`.
+  void internalProcedureBindings(AbstractConverter &converter, SymMap &symMap);
+
+  /// Return the type of the extra argument to add to each internal procedure.
+  mlir::Type getArgumentType(AbstractConverter &convert);
+
+  /// Is \p symbol host associated ?
+  bool isAssociated(const Fortran::semantics::Symbol &symbol) const {
+    return symbols.contains(&symbol);
+  }
+
+private:
+  /// Canonical vector of host associated symbols.
+  llvm::SetVector<const Fortran::semantics::Symbol *> symbols;
+
+  /// The type of the extra argument to be added to each internal procedure.
+  mlir::Type argType;
+};
+} // namespace lower
+} // namespace Fortran
+
+#endif // FORTRAN_LOWER_HOSTASSOCIATIONS_H

flang/include/flang/Lower/IntervalSet.h

+//===-- IntervalSet.h -------------------------------------------*- C++ -*-===//
+//
+// Part of the LLVM Project, under the Apache License v2.0 with LLVM Exceptions.
+// See https://llvm.org/LICENSE.txt for license information.
+// SPDX-License-Identifier: Apache-2.0 WITH LLVM-exception
+//
+//===----------------------------------------------------------------------===//
+
+#ifndef FORTRAN_LOWER_INTERVALSET_H
+#define FORTRAN_LOWER_INTERVALSET_H
+
+#include <cassert>
+#include <map>
+
+namespace Fortran::lower {
+
+//===----------------------------------------------------------------------===//
+// Interval set
+//===----------------------------------------------------------------------===//
+
+/// Interval set to keep track of intervals, merging them when they overlap one
+/// another. Used to refine the pseudo-offset ranges of the front-end symbols
+/// into groups of aliasing variables.
+struct IntervalSet {
+  using MAP = std::map<std::size_t, std::size_t>;
+  using Iterator = MAP::const_iterator;
+
+  // Handles the merging of overlapping intervals correctly, efficiently.
+  void merge(std::size_t lo, std::size_t up) {
+    assert(lo <= up);
+    if (empty()) {
+      m.insert({lo, up});
+      return;
+    }
+    auto i = m.lower_bound(lo);
+    // i->first >= lo
+    if (i == begin()) {
+      if (up < i->first) {
+        // [lo..up] < i->first
+        m.insert({lo, up});
+        return;
+      }
+      // up >= i->first
+      if (i->second > up)
+        up = i->second;
+      fuse(lo, up, i);
+      return;
+    }
+    auto i1 = i;
+    if (i == end() || i->first > lo)
+      i = std::prev(i);
+    // i->first <= lo
+    if (i->second >= up) {
+      // i->first <= lo && up <= i->second, keep i
+      return;
+    }
+    // i->second < up
+    if (i->second < lo) {
+      if (i1 == end() || i1->first > up) {
+        // i < [lo..up] < i1
+        m.insert({lo, up});
+        return;
+      }
+      // i < [lo..up], i1->first <= up  -->  [lo..up] union [i1..?]
+      i = i1;
+    } else {
+      // i->first <= lo, lo <= i->second  -->  [i->first..up] union [i..?]
+      lo = i->first;
+    }
+    fuse(lo, up, i);
+  }
+
+  Iterator find(std::size_t pt) const {
+    auto i = m.lower_bound(pt);
+    if (i != end() && i->first == pt)
+      return i;
+    if (i == begin())
+      return end();
+    i = std::prev(i);
+    if (i->second < pt)
+      return end();
+    return i;
+  }
+
+  Iterator begin() const { return m.begin(); }
+  Iterator end() const { return m.end(); }
+  bool empty() const { return m.empty(); }
+  std::size_t size() const { return m.size(); }
+
+private:
+  // Find and fuse overlapping sets.
+  void fuse(std::size_t lo, std::size_t up, Iterator i) {
+    auto j = m.upper_bound(up);
+    // up < j->first
+    std::size_t cu = std::prev(j)->second;
+    // cu < j->first
+    if (cu > up)
+      up = cu;
+    m.erase(i, j);
+    // merge [i .. j) with [i->first, max(up, cu)]
+    m.insert({lo, up});
+  }
+
+  MAP m{};
+};
+
+} // namespace Fortran::lower
+
+#endif // FORTRAN_LOWER_INTERVALSET_H

flang/include/flang/Lower/PFTBuilder.h

 //
 //===----------------------------------------------------------------------===//
 
 #ifndef FORTRAN_LOWER_PFTBUILDER_H
 #define FORTRAN_LOWER_PFTBUILDER_H
 
 #include "flang/Common/reference.h"
 #include "flang/Common/template.h"
+#include "flang/Lower/HostAssociations.h"
 #include "flang/Lower/PFTDefs.h"
 #include "flang/Parser/parse-tree.h"
 #include "flang/Semantics/attr.h"
+#include "flang/Semantics/scope.h"
 #include "flang/Semantics/symbol.h"
 #include "llvm/Support/ErrorHandling.h"
 #include "llvm/Support/raw_ostream.h"
 
 namespace Fortran::lower::pft {
 
 struct Evaluation;
 struct Program;
constexpr BaseType<B> &get() const {
     return std::get<Ref<B>>(u).get();
   }
   template <typename B>
   constexpr BaseType<B> &getStatement() const {
     return std::get<Ref<parser::Statement<B>>>(u).get().statement;
   }
   template <typename B>
   constexpr BaseType<B> *getIf() const {
-    auto *ptr = std::get_if<Ref<B>>(&u);
+    const Ref<B> *ptr = std::get_if<Ref<B>>(&u);
     return ptr ? &ptr->get() : nullptr;
   }
   template <typename B>
   constexpr bool isA() const {
     return std::holds_alternative<Ref<B>>(u);
   }
   template <typename VISITOR>
   constexpr auto visit(VISITOR &&visitor) const {
using ActionStmts = std::tuple<
     parser::NullifyStmt, parser::OpenStmt, parser::PointerAssignmentStmt,
     parser::PrintStmt, parser::ReadStmt, parser::ReturnStmt, parser::RewindStmt,
     parser::StopStmt, parser::SyncAllStmt, parser::SyncImagesStmt,
     parser::SyncMemoryStmt, parser::SyncTeamStmt, parser::UnlockStmt,
     parser::WaitStmt, parser::WhereStmt, parser::WriteStmt,
     parser::ComputedGotoStmt, parser::ForallStmt, parser::ArithmeticIfStmt,
     parser::AssignStmt, parser::AssignedGotoStmt, parser::PauseStmt>;
 
-using OtherStmts =
-    std::tuple<parser::FormatStmt, parser::EntryStmt, parser::NamelistStmt>;
+using OtherStmts = std::tuple<parser::EntryStmt, parser::FormatStmt>;
 
 using ConstructStmts = std::tuple<
     parser::AssociateStmt, parser::EndAssociateStmt, parser::BlockStmt,
     parser::EndBlockStmt, parser::SelectCaseStmt, parser::CaseStmt,
     parser::EndSelectStmt, parser::ChangeTeamStmt, parser::EndChangeTeamStmt,
     parser::CriticalStmt, parser::EndCriticalStmt, parser::NonLabelDoStmt,
     parser::EndDoStmt, parser::IfThenStmt, parser::ElseIfStmt, parser::ElseStmt,
     parser::EndIfStmt, parser::SelectRankStmt, parser::SelectRankCaseStmt,
std::tuple<parser::AssociateConstruct, parser::BlockConstruct,
                parser::CaseConstruct, parser::ChangeTeamConstruct,
                parser::CriticalConstruct, parser::DoConstruct,
                parser::IfConstruct, parser::SelectRankConstruct,
                parser::SelectTypeConstruct, parser::WhereConstruct,
                parser::ForallConstruct>;
 
 using Directives =
     std::tuple<parser::CompilerDirective, parser::OpenACCConstruct,
-               parser::OpenMPConstruct, parser::OmpEndLoopDirective>;
+               parser::OpenACCDeclarativeConstruct, parser::OpenMPConstruct,
+               parser::OpenMPDeclarativeConstruct, parser::OmpEndLoopDirective>;
+
+using DeclConstructs = std::tuple<parser::OpenMPDeclarativeConstruct,
+                                  parser::OpenACCDeclarativeConstruct>;
 
 template <typename A>
 static constexpr bool isActionStmt{common::HasMember<A, ActionStmts>};
 
 template <typename A>
 static constexpr bool isOtherStmt{common::HasMember<A, OtherStmts>};
 
 template <typename A>
 static constexpr bool isConstructStmt{common::HasMember<A, ConstructStmts>};
 
 template <typename A>
 static constexpr bool isEndStmt{common::HasMember<A, EndStmts>};
 
 template <typename A>
 static constexpr bool isConstruct{common::HasMember<A, Constructs>};
 
 template <typename A>
 static constexpr bool isDirective{common::HasMember<A, Directives>};
 
 template <typename A>
+static constexpr bool isDeclConstruct{common::HasMember<A, DeclConstructs>};
+
+template <typename A>
 static constexpr bool isIntermediateConstructStmt{common::HasMember<
     A, std::tuple<parser::CaseStmt, parser::ElseIfStmt, parser::ElseStmt,
                   parser::SelectRankCaseStmt, parser::TypeGuardStmt>>};
 
 template <typename A>
 static constexpr bool isNopConstructStmt{common::HasMember<
-    A, std::tuple<parser::EndAssociateStmt, parser::CaseStmt,
-                  parser::EndSelectStmt, parser::ElseIfStmt, parser::ElseStmt,
-                  parser::EndIfStmt, parser::SelectRankCaseStmt,
-                  parser::TypeGuardStmt>>};
+    A, std::tuple<parser::CaseStmt, parser::EndSelectStmt, parser::ElseIfStmt,
+                  parser::ElseStmt, parser::EndIfStmt,
+                  parser::SelectRankCaseStmt, parser::TypeGuardStmt>>};
+
+template <typename A>
+static constexpr bool isExecutableDirective{common::HasMember<
+    A, std::tuple<parser::CompilerDirective, parser::OpenACCConstruct,
+                  parser::OpenMPConstruct>>};
 
 template <typename A>
 static constexpr bool isFunctionLike{common::HasMember<
     A, std::tuple<parser::MainProgram, parser::FunctionSubprogram,
                   parser::SubroutineSubprogram,
                   parser::SeparateModuleSubprogram>>};
 
 template <typename A>
constexpr bool isDirective() const {
     return visit(common::visitors{
         [](auto &r) { return pft::isDirective<std::decay_t<decltype(r)>>; }});
   }
   constexpr bool isNopConstructStmt() const {
     return visit(common::visitors{[](auto &r) {
       return pft::isNopConstructStmt<std::decay_t<decltype(r)>>;
     }});
   }
+  constexpr bool isExecutableDirective() const {
+    return visit(common::visitors{[](auto &r) {
+      return pft::isExecutableDirective<std::decay_t<decltype(r)>>;
+    }});
+  }
 
   /// Return the predicate:  "This is a non-initial, non-terminal construct
   /// statement."  For an IfConstruct, this is ElseIfStmt and ElseStmt.
   constexpr bool isIntermediateConstructStmt() const {
     return visit(common::visitors{[](auto &r) {
       return pft::isIntermediateConstructStmt<std::decay_t<decltype(r)>>;
     }});
   }
struct Evaluation : EvaluationVariant {
   /// Return the FunctionLikeUnit containing this evaluation (or nullptr).
   FunctionLikeUnit *getOwningProcedure() const;
 
   bool lowerAsStructured() const;
   bool lowerAsUnstructured() const;
 
   // FIR generation looks primarily at PFT ActionStmt and ConstructStmt leaf
   // nodes.  Members such as lexicalSuccessor and block are applicable only
-  // to these nodes.  The controlSuccessor member is used for nonlexical
-  // successors, such as linking to a GOTO target.  For multiway branches,
-  // it is set to the first target.  Successor and exit links always target
-  // statements.  An internal Construct node has a constructExit link that
-  // applies to exits from anywhere within the construct.
+  // to these nodes, plus some directives.  The controlSuccessor member is
+  // used for nonlexical successors, such as linking to a GOTO target.  For
+  // multiway branches, it is set to the first target.  Successor and exit
+  // links always target statements or directives.  An internal Construct
+  // node has a constructExit link that applies to exits from anywhere within
+  // the construct.
   //
   // An unstructured construct is one that contains some form of goto.  This
   // is indicated by the isUnstructured member flag, which may be set on a
   // statement and propagated to enclosing constructs.  This distinction allows
   // a structured IF or DO statement to be materialized with custom structured
   // FIR operations.  An unstructured statement is materialized as mlir
   // operation sequences that include explicit branches.
   //
struct Evaluation : EvaluationVariant {
   // The printIndex member is only set for statements.  It is used for dumps
   // (and debugging) and does not affect FIR generation.
 
   PftNode parent;
   parser::CharBlock position{};
   std::optional<parser::Label> label{};
   std::unique_ptr<EvaluationList> evaluationList; // nested evaluations
   Evaluation *parentConstruct{nullptr};  // set for nodes below the top level
-  Evaluation *lexicalSuccessor{nullptr}; // set for ActionStmt, ConstructStmt
-  Evaluation *controlSuccessor{nullptr}; // set for some statements
+  Evaluation *lexicalSuccessor{nullptr}; // set for leaf nodes, some directives
+  Evaluation *controlSuccessor{nullptr}; // set for some leaf nodes
   Evaluation *constructExit{nullptr};    // set for constructs
   bool isNewBlock{false};                // evaluation begins a new basic block
   bool isUnstructured{false};  // evaluation has unstructured control flow
   bool negateCondition{false}; // If[Then]Stmt condition must be negated
   mlir::Block *block{nullptr}; // isNewBlock block (ActionStmt, ConstructStmt)
   int printIndex{0}; // (ActionStmt, ConstructStmt) evaluation index for dumps
 };
 
struct ProgramUnit : ProgramVariant {
   ProgramUnit(const A &p, const PftNode &parent)
       : ProgramVariant{p}, parent{parent} {}
   ProgramUnit(ProgramUnit &&) = default;
   ProgramUnit(const ProgramUnit &) = delete;
 
   PftNode parent;
 };
 
-/// Helper to get location from FunctionLikeUnit/ModuleLikeUnit begin/end
-/// statements.
-template <typename T>
-static parser::CharBlock stmtSourceLoc(const T &stmt) {
-  return stmt.visit(common::visitors{[](const auto &x) { return x.source; }});
-}
-
 /// A variable captures an object to be created per the declaration part of a
 /// function like unit.
 ///
 /// Fortran EQUIVALENCE statements are a mechanism that introduces aliasing
 /// between named variables. The set of overlapping aliases will materialize a
 /// generic store object with a designated offset and size. Participant
 /// symbols will simply be pointers into the aggregate store.
 ///
struct Variable {
   /// storage space. A nominal variable may also be an alias for some other
   /// (subpart) of storage.
   struct Nominal {
     Nominal(const semantics::Symbol *symbol, int depth, bool global)
         : symbol{symbol}, depth{depth}, global{global} {}
     const semantics::Symbol *symbol{};
 
     bool isGlobal() const { return global; }
-    bool isDeclaration() const {
-      return !symbol || symbol != &symbol->GetUltimate();
-    }
 
     int depth{};
     bool global{};
     bool heapAlloc{}; // variable needs deallocation on exit
     bool pointer{};
     bool target{};
     bool aliaser{}; // participates in EQUIVALENCE union
     std::size_t aliasOffset{};
   };
 
+  /// <offset, size> pair
   using Interval = std::tuple<std::size_t, std::size_t>;
 
   /// An interval of storage is a contiguous block of memory to be allocated or
   /// mapped onto another variable. Aliasing variables will be pointers into
   /// interval stores and may overlap each other.
   struct AggregateStore {
-    AggregateStore(Interval &&interval, const Fortran::semantics::Scope &scope,
-                   bool isDeclaration = false)
-        : interval{std::move(interval)}, scope{&scope}, isDecl{isDeclaration} {}
-    AggregateStore(Interval &&interval, const Fortran::semantics::Scope &scope,
-                   const llvm::SmallVector<const semantics::Symbol *, 8> &vars,
-                   bool isDeclaration = false)
-        : interval{std::move(interval)}, scope{&scope}, vars{vars},
-          isDecl{isDeclaration} {}
+    AggregateStore(Interval &&interval,
+                   const Fortran::semantics::Symbol &namingSym,
+                   bool isGlobal = false)
+        : interval{std::move(interval)}, namingSymbol{&namingSym},
+          isGlobalAggregate{isGlobal} {}
+    AggregateStore(const semantics::Symbol &initialValueSym,
+                   const semantics::Symbol &namingSym, bool isGlobal = false)
+        : interval{initialValueSym.offset(), initialValueSym.size()},
+          namingSymbol{&namingSym}, initialValueSymbol{&initialValueSym},
+          isGlobalAggregate{isGlobal} {};
 
-    bool isGlobal() const { return vars.size() > 0; }
-    bool isDeclaration() const { return isDecl; }
+    bool isGlobal() const { return isGlobalAggregate; }
     /// Get offset of the aggregate inside its scope.
     std::size_t getOffset() const { return std::get<0>(interval); }
-
+    /// Returns symbols holding the aggregate initial value if any.
+    const semantics::Symbol *getInitialValueSymbol() const {
+      return initialValueSymbol;
+    }
+    /// Returns the symbol that gives its name to the aggregate.
+    const semantics::Symbol &getNamingSymbol() const { return *namingSymbol; }
+    /// Scope to which the aggregates belongs to.
+    const semantics::Scope &getOwningScope() const {
+      return getNamingSymbol().owner();
+    }
+    /// <offset, size> of the aggregate in its scope.
     Interval interval{};
-    /// scope in which the interval is.
-    const Fortran::semantics::Scope *scope;
-    llvm::SmallVector<const semantics::Symbol *, 8> vars{};
-    /// Is this a declaration of a storage defined in another scope ?
-    bool isDecl;
+    /// Symbol that gives its name to the aggregate. Always set by constructor.
+    const semantics::Symbol *namingSymbol;
+    /// Compiler generated symbol with the aggregate initial value if any.
+    const semantics::Symbol *initialValueSymbol = nullptr;
+    /// Is this a global aggregate ?
+    bool isGlobalAggregate;
   };
 
   explicit Variable(const Fortran::semantics::Symbol &sym, bool global = false,
                     int depth = 0)
       : var{Nominal(&sym, depth, global)} {}
   explicit Variable(AggregateStore &&istore) : var{std::move(istore)} {}
 
   /// Return the front-end symbol for a nominal variable.
bool isAggregateStore() const {
     return std::holds_alternative<AggregateStore>(var);
   }
 
   /// Is this variable a global?
   bool isGlobal() const {
     return std::visit([](const auto &x) { return x.isGlobal(); }, var);
   }
 
-  /// Is this a declaration of a variable owned by another scope ?
-  bool isDeclaration() const {
-    return std::visit([](const auto &x) { return x.isDeclaration(); }, var);
+  /// Is this a module variable ?
+  bool isModuleVariable() const {
+    const semantics::Scope *scope = getOwningScope();
+    return scope && scope->IsModule();
   }
 
   const Fortran::semantics::Scope *getOwningScope() const {
     return std::visit(
         common::visitors{
             [](const Nominal &x) { return &x.symbol->GetUltimate().owner(); },
-            [](const AggregateStore &agg) { return agg.scope; }},
+            [](const AggregateStore &agg) { return &agg.getOwningScope(); }},
         var);
   }
 
   bool isHeapAlloc() const {
-    if (const auto *s = std::get_if<Nominal>(&var))
+    if (auto *s = std::get_if<Nominal>(&var))
       return s->heapAlloc;
     return false;
   }
   bool isPointer() const {
-    if (const auto *s = std::get_if<Nominal>(&var))
+    if (auto *s = std::get_if<Nominal>(&var))
       return s->pointer;
     return false;
   }
   bool isTarget() const {
-    if (const auto *s = std::get_if<Nominal>(&var))
+    if (auto *s = std::get_if<Nominal>(&var))
       return s->target;
     return false;
   }
 
   /// An alias(er) is a variable that is part of a EQUIVALENCE that is allocated
   /// locally on the stack.
   bool isAlias() const {
-    if (const auto *s = std::get_if<Nominal>(&var))
+    if (auto *s = std::get_if<Nominal>(&var))
       return s->aliaser;
     return false;
   }
   std::size_t getAlias() const {
     if (auto *s = std::get_if<Nominal>(&var))
       return s->aliasOffset;
     return 0;
   }
void setTarget(bool to = true) {
     if (auto *s = std::get_if<Nominal>(&var))
       s->target = to;
     else
       llvm_unreachable("not a nominal var");
   }
 
   /// The depth is recorded for nominal variables as a debugging aid.
   int getDepth() const {
-    if (const auto *s = std::get_if<Nominal>(&var))
+    if (auto *s = std::get_if<Nominal>(&var))
       return s->depth;
     return 0;
   }
 
   LLVM_DUMP_METHOD void dump() const;
 
 private:
   std::variant<Nominal, AggregateStore> var;
FunctionLikeUnit(
       const parser::SubroutineSubprogram &f, const PftNode &parent,
       const Fortran::semantics::SemanticsContext &semanticsContext);
   FunctionLikeUnit(
       const parser::SeparateModuleSubprogram &f, const PftNode &parent,
       const Fortran::semantics::SemanticsContext &semanticsContext);
   FunctionLikeUnit(FunctionLikeUnit &&) = default;
   FunctionLikeUnit(const FunctionLikeUnit &) = delete;
 
-  /// Return true iff this function like unit is Fortran recursive (actually
-  /// meaning it's reentrant).
-  bool isRecursive() const {
-    if (isMainProgram())
-      return false;
-    const auto &sym = getSubprogramSymbol();
-    return sym.attrs().test(semantics::Attr::RECURSIVE) ||
-           (!sym.attrs().test(semantics::Attr::NON_RECURSIVE) &&
-            defaultRecursiveFunctionSetting());
-  }
-
   std::vector<Variable> getOrderedSymbolTable() { return varList[0]; }
 
   bool isMainProgram() const {
     return endStmt.isA<parser::Statement<parser::EndProgramStmt>>();
   }
 
   /// Get the starting source location for this function like unit
-  parser::CharBlock getStartingSourceLoc() {
-    if (beginStmt)
-      return stmtSourceLoc(*beginStmt);
-    if (!evaluationList.empty())
-      return evaluationList.front().position;
-    return stmtSourceLoc(endStmt);
-  }
+  parser::CharBlock getStartingSourceLoc() const;
 
   void setActiveEntry(int entryIndex) {
     assert(entryIndex >= 0 && entryIndex < (int)entryPointList.size() &&
            "invalid entry point index");
     activeEntry = entryIndex;
   }
 
   /// Return a reference to the subprogram symbol of this FunctionLikeUnit.
   /// This should not be called if the FunctionLikeUnit is the main program
   /// since anonymous main programs do not have a symbol.
   const semantics::Symbol &getSubprogramSymbol() const {
-    const auto *symbol = entryPointList[activeEntry].first;
+    const semantics::Symbol *symbol = entryPointList[activeEntry].first;
     if (!symbol)
       llvm::report_fatal_error(
           "not inside a procedure; do not call on main program.");
     return *symbol;
   }
 
   /// Return a pointer to the current entry point Evaluation.
   /// This is null for a primary entry point.
   Evaluation *getEntryEval() const {
     return entryPointList[activeEntry].second;
   }
 
-  /// Helper to get location from FunctionLikeUnit begin/end statements.
-  static parser::CharBlock stmtSourceLoc(const FunctionStatement &stmt) {
-    return stmt.visit(common::visitors{[](const auto &x) { return x.source; }});
-  }
+  //===--------------------------------------------------------------------===//
+  // Host associations
+  //===--------------------------------------------------------------------===//
+
+  void setHostAssociatedSymbols(
+      const llvm::SetVector<const semantics::Symbol *> &symbols) {
+    hostAssociations.addSymbolsToBind(symbols);
+  }
+
+  /// Return the host associations, if any, from the parent (host) procedure.
+  /// Crashes if the parent is not a procedure.
+  HostAssociations &parentHostAssoc();
+
+  /// Return true iff the parent is a procedure and the parent has a non-empty
+  /// set of host associations.
+  bool parentHasHostAssoc();
+
+  /// Return the host associations for this function like unit. The list of host
+  /// associations are kept in the host procedure.
+  HostAssociations &getHostAssoc() { return hostAssociations; }
 
   LLVM_DUMP_METHOD void dump() const;
 
   /// Anonymous programs do not have a begin statement
   std::optional<FunctionStatement> beginStmt;
   FunctionStatement endStmt;
   EvaluationList evaluationList;
   LabelEvalMap labelEvaluationMap;
   SymbolLabelMap assignSymbolLabelMap;
   std::list<FunctionLikeUnit> nestedFunctions;
   /// <Symbol, Evaluation> pairs for each entry point.  The pair at index 0
   /// is the primary entry point; remaining pairs are alternate entry points.
   /// The primary entry point symbol is Null for an anonymous program.
   /// A named program symbol has MainProgramDetails.  Other symbols have
   /// SubprogramDetails.  Evaluations are filled in for alternate entries.
   llvm::SmallVector<std::pair<const semantics::Symbol *, Evaluation *>, 1>
       entryPointList{std::pair{nullptr, nullptr}};
   /// Current index into entryPointList.  Index 0 is the primary entry point.
   int activeEntry = 0;
   /// Dummy arguments that are not universal across entry points.
-  llvm::SmallVector<const semantics::Symbol *, 3> nonUniversalDummyArguments;
+  llvm::SmallVector<const semantics::Symbol *, 1> nonUniversalDummyArguments;
   /// Primary result for function subprograms with alternate entries.  This
   /// is one of the largest result values, not necessarily the first one.
   const semantics::Symbol *primaryResult{nullptr};
   /// Terminal basic block (if any)
   mlir::Block *finalBlock{};
   std::vector<std::vector<Variable>> varList;
+  HostAssociations hostAssociations;
 };
 
 /// Module-like units contain a list of function-like units.
 struct ModuleLikeUnit : public ProgramUnit {
   // wrapper statements for module-like syntactic structures
   using ModuleStatement =
       ReferenceVariant<parser::Statement<parser::ModuleStmt>,
                        parser::Statement<parser::EndModuleStmt>,
                        parser::Statement<parser::SubmoduleStmt>,
                        parser::Statement<parser::EndSubmoduleStmt>>;
 
   ModuleLikeUnit(const parser::Module &m, const PftNode &parent);
   ModuleLikeUnit(const parser::Submodule &m, const PftNode &parent);
   ~ModuleLikeUnit() = default;
   ModuleLikeUnit(ModuleLikeUnit &&) = default;
   ModuleLikeUnit(const ModuleLikeUnit &) = delete;
 
   LLVM_DUMP_METHOD void dump() const;
 
   std::vector<Variable> getOrderedSymbolTable() { return varList[0]; }
 
+  /// Get the starting source location for this module like unit.
+  parser::CharBlock getStartingSourceLoc() const;
+
+  /// Get the module scope.
+  const Fortran::semantics::Scope &getScope() const;
+
   ModuleStatement beginStmt;
   ModuleStatement endStmt;
   std::list<FunctionLikeUnit> nestedFunctions;
+  EvaluationList evaluationList;
   std::vector<std::vector<Variable>> varList;
 };
 
 /// Block data units contain the variables and data initializers for common
 /// blocks, etc.
 struct BlockDataUnit : public ProgramUnit {
   BlockDataUnit(const parser::BlockData &bd, const PftNode &parent,
                 const Fortran::semantics::SemanticsContext &semanticsContext);
struct Program {
 
   /// LLVM dump method on a Program.
   LLVM_DUMP_METHOD void dump() const;
 
 private:
   std::list<Units> units;
 };
 
+/// Return the list of variables that appears in the specification expressions
+/// of a function result.
+std::vector<pft::Variable>
+buildFuncResultDependencyList(const Fortran::semantics::Symbol &);
+
+/// Helper to get location from FunctionLikeUnit/ModuleLikeUnit begin/end
+/// statements.
+template <typename T>
+static parser::CharBlock stmtSourceLoc(const T &stmt) {
+  return stmt.visit(common::visitors{[](const auto &x) { return x.source; }});
+}
+
+/// Get the first PFT ancestor node that has type ParentType.
+template <typename ParentType, typename A>
+ParentType *getAncestor(A &node) {
+  if (auto *seekedParent = node.parent.template getIf<ParentType>())
+    return seekedParent;
+  return node.parent.visit(common::visitors{
+      [](Program &p) -> ParentType * { return nullptr; },
+      [](auto &p) -> ParentType * { return getAncestor<ParentType>(p); }});
+}
+
+/// Call the provided \p callBack on all symbols that are referenced inside \p
+/// funit.
+void visitAllSymbols(const FunctionLikeUnit &funit,
+                     std::function<void(const semantics::Symbol &)> callBack);
+
 } // namespace Fortran::lower::pft
 
 namespace Fortran::lower {
 /// Create a PFT (Pre-FIR Tree) from the parse tree.
 ///
 /// A PFT is a light weight tree over the parse tree that is used to create FIR.
 /// The PFT captures pointers back into the parse tree, so the parse tree must
 /// not be changed between the construction of the PFT and its last use.  The
 /// PFT captures a structured view of a program.  A program is a list of units.
 /// A function like unit contains a list of evaluations.  An evaluation is
 /// either a statement, or a construct with a nested list of evaluations.
 std::unique_ptr<pft::Program>
 createPFT(const parser::Program &root,
           const Fortran::semantics::SemanticsContext &semanticsContext);
 
 /// Dumper for displaying a PFT.
 void dumpPFT(llvm::raw_ostream &outputStream, const pft::Program &pft);
-
 } // namespace Fortran::lower
 
 #endif // FORTRAN_LOWER_PFTBUILDER_H

flang/include/flang/Lower/PFTDefs.h

 namespace common {
 template <typename A>
 class Reference;
 }
 
 namespace lower {
 
 bool definedInCommonBlock(const semantics::Symbol &sym);
+bool symbolIsGlobal(const semantics::Symbol &sym);
 bool defaultRecursiveFunctionSetting();
 
 namespace pft {
 
 struct Evaluation;
 
 using SomeExpr = Fortran::evaluate::Expr<Fortran::evaluate::SomeType>;
 using SymbolRef = Fortran::common::Reference<const Fortran::semantics::Symbol>;

flang/lib/Lower/PFTBuilder.cpp

-//===-- PFTBuilder.cc -----------------------------------------------------===//
+//===-- PFTBuilder.cpp ----------------------------------------------------===//
 //
 // Part of the LLVM Project, under the Apache License v2.0 with LLVM Exceptions.
 // See https://llvm.org/LICENSE.txt for license information.
 // SPDX-License-Identifier: Apache-2.0 WITH LLVM-exception
 //
 //===----------------------------------------------------------------------===//
 
 #include "flang/Lower/PFTBuilder.h"
-#include "IntervalSet.h"
+#include "flang/Lower/IntervalSet.h"
 #include "flang/Lower/Support/Utils.h"
 #include "flang/Parser/dump-parse-tree.h"
 #include "flang/Parser/parse-tree-visitor.h"
 #include "flang/Semantics/semantics.h"
 #include "flang/Semantics/tools.h"
 #include "llvm/ADT/DenseSet.h"
 #include "llvm/ADT/IntervalMap.h"
 #include "llvm/Support/CommandLine.h"
public:
   }
 
   template <typename A>
   constexpr void Post(const A &) {
     if constexpr (lower::pft::isFunctionLike<A>) {
       exitFunction();
     } else if constexpr (lower::pft::isConstruct<A> ||
                          lower::pft::isDirective<A>) {
+      if constexpr (lower::pft::isDeclConstruct<A>)
+        return;
       exitConstructOrDirective();
     }
   }
 
   // Module like
   bool Pre(const parser::Module &node) { return enterModule(node); }
   bool Pre(const parser::Submodule &node) { return enterModule(node); }
 
bool Pre(const parser::CompilerDirective &directive) {
     }
     return enterConstructOrDirective(directive);
   }
 
 private:
   /// Initialize a new module-like unit and make it the builder's focus.
   template <typename A>
   bool enterModule(const A &func) {
-    auto &unit =
+    Fortran::lower::pft::ModuleLikeUnit &unit =
         addUnit(lower::pft::ModuleLikeUnit{func, pftParentStack.back()});
     functionList = &unit.nestedFunctions;
+    pushEvaluationList(&unit.evaluationList);
     pftParentStack.emplace_back(unit);
     return true;
   }
 
   void exitModule() {
+    if (!evaluationListStack.empty())
+      popEvaluationList();
     pftParentStack.pop_back();
     resetFunctionState();
   }
 
   /// Add the end statement Evaluation of a sub/program to the PFT.
   /// There may be intervening internal subprogram definitions between
   /// prior statements and this end statement.
   void endFunctionBody() {
     if (evaluationListStack.empty())
       return;
     auto evaluationList = evaluationListStack.back();
+    if (evaluationList->empty() &&
+        pftParentStack.back().getIf<lower::pft::ModuleLikeUnit>()) {
+      popEvaluationList();
+      return;
+    }
     if (evaluationList->empty() || !evaluationList->back().isEndStmt()) {
       const auto &endStmt =
           pftParentStack.back().get<lower::pft::FunctionLikeUnit>().endStmt;
       endStmt.visit(common::visitors{
           [&](const parser::Statement<parser::EndProgramStmt> &s) {
             addEvaluation(lower::pft::Evaluation{
                 s.statement, pftParentStack.back(), s.source, s.label});
           },
void endFunctionBody() {
     lastLexicalEvaluation = nullptr;
   }
 
   /// Initialize a new function-like unit and make it the builder's focus.
   template <typename A>
   bool enterFunction(const A &func,
                      const semantics::SemanticsContext &semanticsContext) {
     endFunctionBody(); // enclosing host subprogram body, if any
-    auto &unit = addFunction(lower::pft::FunctionLikeUnit{
-        func, pftParentStack.back(), semanticsContext});
+    Fortran::lower::pft::FunctionLikeUnit &unit =
+        addFunction(lower::pft::FunctionLikeUnit{func, pftParentStack.back(),
+                                                 semanticsContext});
     labelEvaluationMap = &unit.labelEvaluationMap;
     assignSymbolLabelMap = &unit.assignSymbolLabelMap;
     functionList = &unit.nestedFunctions;
     pushEvaluationList(&unit.evaluationList);
     pftParentStack.emplace_back(unit);
     return true;
   }
 
   void exitFunction() {
     rewriteIfGotos();
     endFunctionBody();
     analyzeBranches(nullptr, *evaluationListStack.back()); // add branch links
     processEntryPoints();
     popEvaluationList();
     labelEvaluationMap = nullptr;
     assignSymbolLabelMap = nullptr;
     pftParentStack.pop_back();
     resetFunctionState();
   }
 
-  /// Initialize a new construct and make it the builder's focus.
+  /// Initialize a new construct or directive and make it the builder's focus.
   template <typename A>
-  bool enterConstructOrDirective(const A &construct) {
-    auto &eval =
-        addEvaluation(lower::pft::Evaluation{construct, pftParentStack.back()});
+  bool enterConstructOrDirective(const A &constructOrDirective) {
+    Fortran::lower::pft::Evaluation &eval = addEvaluation(
+        lower::pft::Evaluation{constructOrDirective, pftParentStack.back()});
     eval.evaluationList.reset(new lower::pft::EvaluationList);
     pushEvaluationList(eval.evaluationList.get());
     pftParentStack.emplace_back(eval);
     constructAndDirectiveStack.emplace_back(&eval);
+    if constexpr (lower::pft::isDeclConstruct<A>) {
+      popEvaluationList();
+      pftParentStack.pop_back();
+      constructAndDirectiveStack.pop_back();
+      popEvaluationList();
+    }
     return true;
   }
 
   void exitConstructOrDirective() {
     rewriteIfGotos();
+    auto *eval = constructAndDirectiveStack.back();
+    if (eval->isExecutableDirective()) {
+      // A construct at the end of an (unstructured) OpenACC or OpenMP
+      // construct region must have an exit target inside the region.
+      Fortran::lower::pft::EvaluationList &evaluationList =
+          *eval->evaluationList;
+      if (!evaluationList.empty() && evaluationList.back().isConstruct()) {
+        static const parser::ContinueStmt exitTarget{};
+        addEvaluation(
+            lower::pft::Evaluation{exitTarget, pftParentStack.back(), {}, {}});
+      }
+    }
     popEvaluationList();
     pftParentStack.pop_back();
     constructAndDirectiveStack.pop_back();
   }
 
   /// Reset function state to that of an enclosing host function.
   void resetFunctionState() {
     if (!pftParentStack.empty()) {
private:
   lower::pft::Evaluation &addEvaluation(lower::pft::Evaluation &&eval) {
     assert(functionList && "not in a function");
     assert(!evaluationListStack.empty() && "empty evaluation list stack");
     if (!constructAndDirectiveStack.empty())
       eval.parentConstruct = constructAndDirectiveStack.back();
     auto &entryPointList = eval.getOwningProcedure()->entryPointList;
     evaluationListStack.back()->emplace_back(std::move(eval));
     lower::pft::Evaluation *p = &evaluationListStack.back()->back();
-    if (p->isActionStmt() || p->isConstructStmt() || p->isEndStmt()) {
+    if (p->isActionStmt() || p->isConstructStmt() || p->isEndStmt() ||
+        p->isExecutableDirective()) {
       if (lastLexicalEvaluation) {
         lastLexicalEvaluation->lexicalSuccessor = p;
         p->printIndex = lastLexicalEvaluation->printIndex + 1;
       } else {
         p->printIndex = 1;
       }
       lastLexicalEvaluation = p;
-      for (auto entryIndex = entryPointList.size() - 1;
+      for (std::size_t entryIndex = entryPointList.size() - 1;
            entryIndex && !entryPointList[entryIndex].second->lexicalSuccessor;
            --entryIndex)
         // Link to the entry's first executable statement.
         entryPointList[entryIndex].second->lexicalSuccessor = p;
     } else if (const auto *entryStmt = p->getIf<parser::EntryStmt>()) {
-      const auto *sym = std::get<parser::Name>(entryStmt->t).symbol;
+      const semantics::Symbol *sym =
+          std::get<parser::Name>(entryStmt->t).symbol;
       assert(sym->has<semantics::SubprogramDetails>() &&
              "entry must be a subprogram");
       entryPointList.push_back(std::pair{sym, p});
     }
     if (p->label.has_value())
       labelEvaluationMap->try_emplace(*p->label, p);
     return evaluationListStack.back()->back();
   }
 
   /// push a new list on the stack of Evaluation lists
   void pushEvaluationList(lower::pft::EvaluationList *evaluationList) {
     assert(functionList && "not in a function");
     assert(evaluationList && evaluationList->empty() &&
            "evaluation list isn't correct");
     evaluationListStack.emplace_back(evaluationList);
   }
 
   /// pop the current list and return to the last Evaluation list
   void popEvaluationList() {
     assert(functionList && "not in a function");
     evaluationListStack.pop_back();
   }
 
-  /// Rewrite IfConstructs containing a GotoStmt to eliminate an unstructured
-  /// branch and a trivial basic block.  The pre-branch-analysis code:
+  /// Rewrite IfConstructs containing a GotoStmt or CycleStmt to eliminate an
+  /// unstructured branch and a trivial basic block.  The pre-branch-analysis
+  /// code:
   ///
   ///       <<IfConstruct>>
   ///         1 If[Then]Stmt: if(cond) goto L
   ///         2 GotoStmt: goto L
   ///         3 EndIfStmt
   ///       <<End IfConstruct>>
   ///       4 Statement: ...
   ///       5 Statement: ...
   ///       6 Statement: L ...
   ///
   /// becomes:
   ///
   ///       <<IfConstruct>>
   ///         1 If[Then]Stmt [negate]: if(cond) goto L
   ///         4 Statement: ...
   ///         5 Statement: ...
   ///         3 EndIfStmt
   ///       <<End IfConstruct>>
   ///       6 Statement: L ...
   ///
   /// The If[Then]Stmt condition is implicitly negated.  It is not modified
-  /// in the PFT.  It must be negated when generating FIR.  The GotoStmt is
-  /// deleted.
+  /// in the PFT.  It must be negated when generating FIR.  The GotoStmt or
+  /// CycleStmt is deleted.
   ///
   /// The transformation is only valid for forward branch targets at the same
   /// construct nesting level as the IfConstruct.  The result must not violate
   /// construct nesting requirements or contain an EntryStmt.  The result
   /// is subject to normal un/structured code classification analysis.  The
   /// result is allowed to violate the F18 Clause 11.1.2.1 prohibition on
   /// transfer of control into the interior of a construct block, as that does
   /// not compromise correct code generation.  When two transformation
   /// candidates overlap, at least one must be disallowed.  In such cases,
   /// the current heuristic favors simple code generation, which happens to
   /// favor later candidates over earlier candidates.  That choice is probably
   /// not significant, but could be changed.
   ///
   void rewriteIfGotos() {
-    using T = struct {
+    auto &evaluationList = *evaluationListStack.back();
+    if (!evaluationList.size())
+      return;
+    struct T {
       lower::pft::EvaluationList::iterator ifConstructIt;
       parser::Label ifTargetLabel;
+      bool isCycleStmt = false;
     };
-    llvm::SmallVector<T, 8> ifExpansionStack;
-    auto &evaluationList = *evaluationListStack.back();
+    llvm::SmallVector<T> ifCandidateStack;
+    const auto *doStmt =
+        evaluationList.begin()->getIf<parser::NonLabelDoStmt>();
+    std::string doName = doStmt ? getConstructName(*doStmt) : std::string{};
     for (auto it = evaluationList.begin(), end = evaluationList.end();
          it != end; ++it) {
       auto &eval = *it;
       if (eval.isA<parser::EntryStmt>()) {
-        ifExpansionStack.clear();
+        ifCandidateStack.clear();
         continue;
       }
       auto firstStmt = [](lower::pft::Evaluation *e) {
         return e->isConstruct() ? &*e->evaluationList->begin() : e;
       };
-      auto &targetEval = *firstStmt(&eval);
-      if (targetEval.label) {
-        while (!ifExpansionStack.empty() &&
-               ifExpansionStack.back().ifTargetLabel == *targetEval.label) {
-          auto ifConstructIt = ifExpansionStack.back().ifConstructIt;
-          auto successorIt = std::next(ifConstructIt);
+      const Fortran::lower::pft::Evaluation &targetEval = *firstStmt(&eval);
+      bool targetEvalIsEndDoStmt = targetEval.isA<parser::EndDoStmt>();
+      auto branchTargetMatch = [&]() {
+        if (const parser::Label targetLabel =
+                ifCandidateStack.back().ifTargetLabel)
+          if (targetLabel == *targetEval.label)
+            return true; // goto target match
+        if (targetEvalIsEndDoStmt && ifCandidateStack.back().isCycleStmt)
+          return true; // cycle target match
+        return false;
+      };
+      if (targetEval.label || targetEvalIsEndDoStmt) {
+        while (!ifCandidateStack.empty() && branchTargetMatch()) {
+          lower::pft::EvaluationList::iterator ifConstructIt =
+              ifCandidateStack.back().ifConstructIt;
+          lower::pft::EvaluationList::iterator successorIt =
+              std::next(ifConstructIt);
           if (successorIt != it) {
-            auto &ifBodyList = *ifConstructIt->evaluationList;
-            auto gotoStmtIt = std::next(ifBodyList.begin());
-            assert(gotoStmtIt->isA<parser::GotoStmt>() && "expected GotoStmt");
-            ifBodyList.erase(gotoStmtIt);
-            auto &ifStmt = *ifBodyList.begin();
+            Fortran::lower::pft::EvaluationList &ifBodyList =
+                *ifConstructIt->evaluationList;
+            lower::pft::EvaluationList::iterator branchStmtIt =
+                std::next(ifBodyList.begin());
+            assert((branchStmtIt->isA<parser::GotoStmt>() ||
+                    branchStmtIt->isA<parser::CycleStmt>()) &&
+                   "expected goto or cycle statement");
+            ifBodyList.erase(branchStmtIt);
+            lower::pft::Evaluation &ifStmt = *ifBodyList.begin();
             ifStmt.negateCondition = true;
             ifStmt.lexicalSuccessor = firstStmt(&*successorIt);
-            auto endIfStmtIt = std::prev(ifBodyList.end());
+            lower::pft::EvaluationList::iterator endIfStmtIt =
+                std::prev(ifBodyList.end());
             std::prev(it)->lexicalSuccessor = &*endIfStmtIt;
             endIfStmtIt->lexicalSuccessor = firstStmt(&*it);
             ifBodyList.splice(endIfStmtIt, evaluationList, successorIt, it);
             for (; successorIt != endIfStmtIt; ++successorIt)
               successorIt->parentConstruct = &*ifConstructIt;
           }
-          ifExpansionStack.pop_back();
+          ifCandidateStack.pop_back();
         }
       }
       if (eval.isA<parser::IfConstruct>() && eval.evaluationList->size() == 3) {
-        if (auto *gotoStmt = std::next(eval.evaluationList->begin())
-                                 ->getIf<parser::GotoStmt>())
-          ifExpansionStack.push_back({it, gotoStmt->v});
+        const auto bodyEval = std::next(eval.evaluationList->begin());
+        if (const auto *gotoStmt = bodyEval->getIf<parser::GotoStmt>()) {
+          ifCandidateStack.push_back({it, gotoStmt->v});
+        } else if (doStmt) {
+          if (const auto *cycleStmt = bodyEval->getIf<parser::CycleStmt>()) {
+            std::string cycleName = getConstructName(*cycleStmt);
+            if (cycleName.empty() || cycleName == doName)
+              // This candidate will match doStmt's EndDoStmt.
+              ifCandidateStack.push_back({it, {}, true});
+          }
+        }
       }
     }
   }
 
-  /// Mark I/O statement ERR, EOR, and END specifier branch targets.
-  /// Mark an I/O statement with an assigned format as unstructured.
+  /// Mark IO statement ERR, EOR, and END specifier branch targets.
+  /// Mark an IO statement with an assigned format as unstructured.
   template <typename A>
   void analyzeIoBranches(lower::pft::Evaluation &eval, const A &stmt) {
     auto analyzeFormatSpec = [&](const parser::Format &format) {
       if (const auto *expr = std::get_if<parser::Expr>(&format.u)) {
         if (semantics::ExprHasTypeCategory(*semantics::GetExpr(*expr),
                                            common::TypeCategory::Integer))
           eval.isUnstructured = true;
       }
void markBranchTarget(lower::pft::Evaluation &sourceEvaluation,
                         lower::pft::Evaluation &targetEvaluation) {
     sourceEvaluation.isUnstructured = true;
     if (!sourceEvaluation.controlSuccessor)
       sourceEvaluation.controlSuccessor = &targetEvaluation;
     targetEvaluation.isNewBlock = true;
     // If this is a branch into the body of a construct (usually illegal,
     // but allowed in some legacy cases), then the targetEvaluation and its
     // ancestors must be marked as unstructured.
-    auto *sourceConstruct = sourceEvaluation.parentConstruct;
-    auto *targetConstruct = targetEvaluation.parentConstruct;
+    lower::pft::Evaluation *sourceConstruct = sourceEvaluation.parentConstruct;
+    lower::pft::Evaluation *targetConstruct = targetEvaluation.parentConstruct;
     if (targetConstruct &&
         &targetConstruct->getFirstNestedEvaluation() == &targetEvaluation)
       // A branch to an initial constructStmt is a branch to the construct.
       targetConstruct = targetConstruct->parentConstruct;
     if (targetConstruct) {
       while (sourceConstruct && sourceConstruct != targetConstruct)
         sourceConstruct = sourceConstruct->parentConstruct;
-      if (sourceConstruct != targetConstruct)
-        for (auto *eval = &targetEvaluation; eval; eval = eval->parentConstruct)
+      if (sourceConstruct != targetConstruct) // branch into a construct body
+        for (lower::pft::Evaluation *eval = &targetEvaluation; eval;
+             eval = eval->parentConstruct) {
           eval->isUnstructured = true;
+          // If the branch is a backward branch into an already analyzed
+          // DO or IF construct, mark the construct exit as a new block.
+          // For a forward branch, the isUnstructured flag will cause this
+          // to be done when the construct is analyzed.
+          if (eval->constructExit && (eval->isA<parser::DoConstruct>() ||
+                                      eval->isA<parser::IfConstruct>()))
+            eval->constructExit->isNewBlock = true;
+        }
     }
   }
   void markBranchTarget(lower::pft::Evaluation &sourceEvaluation,
                         parser::Label label) {
     assert(label && "missing branch target label");
     lower::pft::Evaluation *targetEvaluation{
         labelEvaluationMap->find(label)->second};
     assert(targetEvaluation && "missing branch target evaluation");
inline std::string getConstructName(const A &stmt) {
 
     using MaybeConstructNameInTuple = std::tuple<
         parser::AssociateStmt, parser::CaseStmt, parser::ChangeTeamStmt,
         parser::CriticalStmt, parser::ElseIfStmt, parser::EndChangeTeamStmt,
         parser::ForallConstructStmt, parser::IfThenStmt, parser::LabelDoStmt,
         parser::MaskedElsewhereStmt, parser::NonLabelDoStmt,
         parser::SelectCaseStmt, parser::SelectRankCaseStmt,
         parser::TypeGuardStmt, parser::WhereConstructStmt>;
-
     if constexpr (common::HasMember<A, MaybeConstructNameInTuple>) {
       if (auto name = std::get<std::optional<parser::Name>>(stmt.t))
         return name->ToString();
     }
 
-    // These statements have several std::optional<parser::Name>
+    // These statements have multiple std::optional<parser::Name> elements.
     if constexpr (std::is_same_v<A, parser::SelectRankStmt> ||
                   std::is_same_v<A, parser::SelectTypeStmt>) {
       if (auto name = std::get<0>(stmt.t))
         return name->ToString();
     }
+
     return {};
   }
 
   /// \p parentConstruct can be null if this statement is at the highest
   /// level of a program.
   template <typename A>
   void insertConstructName(const A &stmt,
                            lower::pft::Evaluation *parentConstruct) {
     std::string name = getConstructName(stmt);
     if (!name.empty())
       constructNameMap[name] = parentConstruct;
   }
 
   /// Insert branch links for a list of Evaluations.
   /// \p parentConstruct can be null if the evaluationList contains the
   /// top-level statements of a program.
   void analyzeBranches(lower::pft::Evaluation *parentConstruct,
                        std::list<lower::pft::Evaluation> &evaluationList) {
     lower::pft::Evaluation *lastConstructStmtEvaluation{};
     for (auto &eval : evaluationList) {
       eval.visit(common::visitors{
-          // Action statements (except I/O statements)
+          // Action statements (except IO statements)
           [&](const parser::CallStmt &s) {
             // Look for alternate return specifiers.
             const auto &args =
                 std::get<std::list<parser::ActualArgSpec>>(s.v.t);
             for (const auto &arg : args) {
               const auto &actual = std::get<parser::ActualArg>(arg.t);
               if (const auto *altReturn =
                       std::get_if<parser::AltReturnSpec>(&actual.u))
for (auto &eval : evaluationList) {
           [&](const parser::AssignedGotoStmt &) {
             // Although this statement is a branch, it doesn't have any
             // explicit control successors.  So the code at the end of the
             // loop won't mark the successor.  Do that here.
             eval.isUnstructured = true;
             markSuccessorAsNewBlock(eval);
           },
 
+          // The first executable statement after an EntryStmt is a new block.
+          [&](const parser::EntryStmt &) {
+            eval.lexicalSuccessor->isNewBlock = true;
+          },
+
           // Construct statements
           [&](const parser::AssociateStmt &s) {
             insertConstructName(s, parentConstruct);
           },
           [&](const parser::BlockStmt &s) {
             insertConstructName(s, parentConstruct);
           },
           [&](const parser::SelectCaseStmt &s) {
for (auto &eval : evaluationList) {
             setConstructExit(eval);
             eval.isUnstructured = true;
           },
           [&](const parser::SelectTypeConstruct &) {
             setConstructExit(eval);
             eval.isUnstructured = true;
           },
 
-          // Default - Common analysis for I/O statements; otherwise nop.
+          // Default - Common analysis for IO statements; otherwise nop.
           [&](const auto &stmt) {
             using A = std::decay_t<decltype(stmt)>;
             using IoStmts = std::tuple<
                 parser::BackspaceStmt, parser::CloseStmt, parser::EndfileStmt,
                 parser::FlushStmt, parser::InquireStmt, parser::OpenStmt,
                 parser::PrintStmt, parser::ReadStmt, parser::RewindStmt,
                 parser::WaitStmt, parser::WriteStmt>;
             if constexpr (common::HasMember<A, IoStmts>)
void analyzeBranches(lower::pft::Evaluation *parentConstruct,
     }
   }
 
   /// For multiple entry subprograms, build a list of the dummy arguments that
   /// appear in some, but not all entry points.  For those that are functions,
   /// also find one of the largest function results, since a single result
   /// container holds the result for all entries.
   void processEntryPoints() {
-    auto *unit = evaluationListStack.back()->front().getOwningProcedure();
+    lower::pft::Evaluation *initialEval = &evaluationListStack.back()->front();
+    lower::pft::FunctionLikeUnit *unit = initialEval->getOwningProcedure();
     int entryCount = unit->entryPointList.size();
     if (entryCount == 1)
       return;
     llvm::DenseMap<semantics::Symbol *, int> dummyCountMap;
     for (int entryIndex = 0; entryIndex < entryCount; ++entryIndex) {
       unit->setActiveEntry(entryIndex);
       const auto &details =
           unit->getSubprogramSymbol().get<semantics::SubprogramDetails>();
-      for (auto *arg : details.dummyArgs()) {
+      for (semantics::Symbol *arg : details.dummyArgs()) {
         if (!arg)
           continue; // alternate return specifier (no actual argument)
         const auto iter = dummyCountMap.find(arg);
         if (iter == dummyCountMap.end())
           dummyCountMap.try_emplace(arg, 1);
         else
           ++iter->second;
       }
       if (details.isFunction()) {
-        const auto *resultSym = &details.result();
+        const semantics::Symbol *resultSym = &details.result();
         assert(resultSym && "missing result symbol");
         if (!unit->primaryResult ||
             unit->primaryResult->size() < resultSym->size())
           unit->primaryResult = resultSym;
       }
     }
     unit->setActiveEntry(0);
     for (auto arg : dummyCountMap)
       if (arg.second < entryCount)
         unit->nonUniversalDummyArguments.push_back(arg.first);
+    // The first executable statement in the subprogram is preceded by a
+    // branch to the entry point, so it starts a new block.
+    if (initialEval->hasNestedEvaluations())
+      initialEval = &initialEval->getFirstNestedEvaluation();
+    else if (initialEval->isA<Fortran::parser::EntryStmt>())
+      initialEval = initialEval->lexicalSuccessor;
+    initialEval->isNewBlock = true;
   }
 
   std::unique_ptr<lower::pft::Program> pgm;
   std::vector<lower::pft::PftNode> pftParentStack;
   const semantics::SemanticsContext &semanticsContext;
 
   /// functionList points to the internal or module procedure function list
   /// of a FunctionLikeUnit or a ModuleLikeUnit.  It may be null.
return eval.visit([](const auto &parseTreeNode) {
       return parser::ParseTreeDumper::GetNodeName(parseTreeNode);
     });
   }
 
   void dumpEvaluation(llvm::raw_ostream &outputStream,
                       const lower::pft::Evaluation &eval,
                       const std::string &indentString, int indent = 1) {
     llvm::StringRef name = evaluationName(eval);
-    std::string bang = eval.isUnstructured ? "!" : "";
-    if (eval.isConstruct() || eval.isDirective()) {
-      outputStream << indentString << "<<" << name << bang << ">>";
-      if (eval.constructExit)
-        outputStream << " -> " << eval.constructExit->printIndex;
-      outputStream << '\n';
-      dumpEvaluationList(outputStream, *eval.evaluationList, indent + 1);
-      outputStream << indentString << "<<End " << name << bang << ">>\n";
-      return;
-    }
+    llvm::StringRef newBlock = eval.isNewBlock ? "^" : "";
+    llvm::StringRef bang = eval.isUnstructured ? "!" : "";
     outputStream << indentString;
     if (eval.printIndex)
       outputStream << eval.printIndex << ' ';
-    if (eval.isNewBlock)
-      outputStream << '^';
-    outputStream << name << bang;
-    if (eval.isActionStmt() || eval.isConstructStmt()) {
-      if (eval.negateCondition)
-        outputStream << " [negate]";
-      if (eval.controlSuccessor)
-        outputStream << " -> " << eval.controlSuccessor->printIndex;
-    } else if (eval.isA<parser::EntryStmt>() && eval.lexicalSuccessor) {
+    if (eval.hasNestedEvaluations())
+      outputStream << "<<" << newBlock << name << bang << ">>";
+    else
+      outputStream << newBlock << name << bang;
+    if (eval.constructExit)
+      outputStream << " -> " << eval.constructExit->printIndex;
+    else if (eval.controlSuccessor)
+    else if (eval.isA<parser::EntryStmt>() && eval.lexicalSuccessor)
       outputStream << " -> " << eval.lexicalSuccessor->printIndex;
-    }
     if (!eval.position.empty())
       outputStream << ": " << eval.position.ToString();
+    else if (auto *dir = eval.getIf<Fortran::parser::CompilerDirective>())
+      outputStream << ": !" << dir->source.ToString();
     outputStream << '\n';
+    if (eval.hasNestedEvaluations()) {
+      dumpEvaluationList(outputStream, *eval.evaluationList, indent + 1);
+      outputStream << indentString << "<<End " << name << bang << ">>\n";
+    }
   }
 
   void dumpEvaluation(llvm::raw_ostream &ostream,
                       const lower::pft::Evaluation &eval) {
     dumpEvaluation(ostream, eval, "");
   }
 
   void dumpEvaluationList(llvm::raw_ostream &outputStream,
                           const lower::pft::EvaluationList &evaluationList,
                           int indent = 1) {
     static const auto white = "                                      ++"s;
     auto indentString = white.substr(0, indent * 2);
-    for (const auto &eval : evaluationList)
+    for (const lower::pft::Evaluation &eval : evaluationList)
       dumpEvaluation(outputStream, eval, indentString, indent);
   }
 
   void
   dumpFunctionLikeUnit(llvm::raw_ostream &outputStream,
                        const lower::pft::FunctionLikeUnit &functionLikeUnit) {
     outputStream << getNodeIndex(functionLikeUnit) << " ";
     llvm::StringRef unitKind;
dumpFunctionLikeUnit(llvm::raw_ostream &outputStream,
     }
     outputStream << unitKind << ' ' << name;
     if (!header.empty())
       outputStream << ": " << header;
     outputStream << '\n';
     dumpEvaluationList(outputStream, functionLikeUnit.evaluationList);
     if (!functionLikeUnit.nestedFunctions.empty()) {
       outputStream << "\nContains\n";
-      for (auto &func : functionLikeUnit.nestedFunctions)
+      for (const lower::pft::FunctionLikeUnit &func :
+           functionLikeUnit.nestedFunctions)
         dumpFunctionLikeUnit(outputStream, func);
       outputStream << "End Contains\n";
     }
     outputStream << "End " << unitKind << ' ' << name << "\n\n";
   }
 
   void dumpModuleLikeUnit(llvm::raw_ostream &outputStream,
                           const lower::pft::ModuleLikeUnit &moduleLikeUnit) {
     outputStream << getNodeIndex(moduleLikeUnit) << " ";
     outputStream << "ModuleLike: ";
     outputStream << "\nContains\n";
-    for (auto &func : moduleLikeUnit.nestedFunctions)
+    for (const lower::pft::FunctionLikeUnit &func :
+         moduleLikeUnit.nestedFunctions)
       dumpFunctionLikeUnit(outputStream, func);
     outputStream << "End Contains\nEnd ModuleLike\n\n";
   }
 
   // Top level directives
   void dumpCompilerDirectiveUnit(
       llvm::raw_ostream &outputStream,
       const lower::pft::CompilerDirectiveUnit &directive) {

 
 template <typename A, typename T>
 static lower::pft::FunctionLikeUnit::FunctionStatement
 getFunctionStmt(const T &func) {
   lower::pft::FunctionLikeUnit::FunctionStatement result{
       std::get<parser::Statement<A>>(func.t)};
   return result;
 }
+
 template <typename A, typename T>
 static lower::pft::ModuleLikeUnit::ModuleStatement getModuleStmt(const T &mod) {
   lower::pft::ModuleLikeUnit::ModuleStatement result{
       std::get<parser::Statement<A>>(mod.t)};
   return result;
 }
 
 template <typename A>
return parent.visit(common::visitors{
       [](auto &) -> lower::pft::FunctionLikeUnit * { return nullptr; },
   });
 }
 
 bool Fortran::lower::definedInCommonBlock(const semantics::Symbol &sym) {
   return semantics::FindCommonBlockContaining(sym);
 }
 
+static bool isReEntrant(const Fortran::semantics::Scope &scope) {
+  if (scope.kind() == Fortran::semantics::Scope::Kind::MainProgram)
+    return false;
+  if (scope.kind() == Fortran::semantics::Scope::Kind::Subprogram) {
+    const Fortran::semantics::Symbol *sym = scope.symbol();
+    assert(sym && "Subprogram scope must have a symbol");
+    return sym->attrs().test(semantics::Attr::RECURSIVE) ||
+           (!sym->attrs().test(semantics::Attr::NON_RECURSIVE) &&
+            Fortran::lower::defaultRecursiveFunctionSetting());
+  }
+  if (scope.kind() == Fortran::semantics::Scope::Kind::Module)
+    return false;
+  return true;
+}
+
 /// Is the symbol `sym` a global?
-static bool symbolIsGlobal(const semantics::Symbol &sym) {
-  if (const auto *details = sym.detailsIf<semantics::ObjectEntityDetails>())
+bool Fortran::lower::symbolIsGlobal(const semantics::Symbol &sym) {
+  if (const auto *details = sym.detailsIf<semantics::ObjectEntityDetails>()) {
     if (details->init())
       return true;
-  return semantics::IsSaved(sym) || lower::definedInCommonBlock(sym);
+    if (!isReEntrant(sym.owner())) {
+      // Turn array and character of non re-entrant programs (like the main
+      // program) into global memory.
+      if (const Fortran::semantics::DeclTypeSpec *symTy = sym.GetType())
+        if (symTy->category() == semantics::DeclTypeSpec::Character)
+          if (auto e = symTy->characterTypeSpec().length().GetExplicit())
+            return true;
+      if (!details->shape().empty() || !details->coshape().empty())
+        return true;
+    }
+  }
+  return semantics::IsSaved(sym) || lower::definedInCommonBlock(sym) ||
+         semantics::IsNamedConstant(sym);
 }
 
 namespace {
 /// This helper class is for sorting the symbols in the symbol table. We want
 /// the symbols in an order such that a symbol will be visited after those it
 /// depends upon. Otherwise this sort is stable and preserves the order of the
 /// symbol table, which is sorted by name.
 struct SymbolDependenceDepth {
   explicit SymbolDependenceDepth(
-      std::vector<std::vector<lower::pft::Variable>> &vars, bool reentrant)
-      : vars{vars}, reentrant{reentrant} {}
+      std::vector<std::vector<lower::pft::Variable>> &vars)
+      : vars{vars} {}
 
   void analyzeAliasesInCurrentScope(const semantics::Scope &scope) {
+    // FIXME: When this function is called on the scope of an internal
+    // procedure whose parent contains an EQUIVALENCE set and the internal
+    // procedure uses variables from that EQUIVALENCE set, we end up creating
+    // an AggregateStore for those variables unnecessarily.
+    //
+    /// If this is a function nested in a module no host associated
+    /// symbol are added to the function scope for module symbols used in this
+    /// scope. As a result, alias analysis in parent module scopes must be
+    /// preformed here.
+    const semantics::Scope *parentScope = &scope;
+    while (!parentScope->IsGlobal()) {
+      parentScope = &parentScope->parent();
+      if (parentScope->IsModule())
+        analyzeAliases(*parentScope);
+    }
     for (const auto &iter : scope) {
-      const auto &ultimate = iter.second.get().GetUltimate();
+      const semantics::Symbol &ultimate = iter.second.get().GetUltimate();
       if (skipSymbol(ultimate))
         continue;
-      bool isDeclaration = scope != ultimate.owner();
-      analyzeAliases(ultimate.owner(), isDeclaration);
+      analyzeAliases(ultimate.owner());
     }
     // add all aggregate stores to the front of the work list
     adjustSize(1);
     // The copy in the loop matters, 'stores' will still be used.
-    for (auto st : stores) {
+    for (auto st : stores)
       vars[0].emplace_back(std::move(st));
-    }
+
+  // Compute the offset of the last byte that resides in the symbol.
+  inline static std::size_t offsetWidth(const Fortran::semantics::Symbol &sym) {
+    std::size_t width = sym.offset();
+    if (std::size_t size = sym.size())
+      width += size - 1;
+    return width;
   }
+
   // Analyze the equivalence sets. This analysis need not be performed when the
   // scope has no equivalence sets.
-  void analyzeAliases(const semantics::Scope &scope, bool isDeclaration) {
+  void analyzeAliases(const semantics::Scope &scope) {
     if (scope.equivalenceSets().empty())
       return;
-    if (scopeAnlyzedForAliases.find(&scope) != scopeAnlyzedForAliases.end())
+    // Don't analyze a scope if it has already been analyzed.
+    if (analyzedScopes.find(&scope) != analyzedScopes.end())
       return;
-    scopeAnlyzedForAliases.insert(&scope);
-    Fortran::lower::IntervalSet intervals;
-    llvm::DenseMap<std::size_t, llvm::SmallVector<const semantics::Symbol *, 8>>
-        aliasSets;
-    llvm::DenseMap<std::size_t, const semantics::Symbol *> setIsGlobal;
-
-    // 1. Construct the intervals. Determine each entity's interval, merging
-    // overlapping intervals into aggregates.
-    for (const auto &pair : scope) {
-      const auto &sym = pair.second.get();
-      if (skipSymbol(sym))
-        continue;
-      LLVM_DEBUG(llvm::dbgs() << "symbol: " << sym << '\n');
-      intervals.merge(sym.offset(), sym.offset() + sym.size() - 1);
-    }
 
-    // 2. Compute alias sets. Adds each entity to a set for the interval it
-    // appears to be mapped into.
-    for (const auto &pair : scope) {
-      const auto &sym = pair.second.get();
-      if (skipSymbol(sym))
-        continue;
-      auto iter = intervals.find(sym.offset());
-      if (iter != intervals.end()) {
-        LLVM_DEBUG(llvm::dbgs()
-                   << "symbol: " << toStringRef(sym.name()) << " on ["
-                   << iter->first << ".." << iter->second << "]\n");
-        aliasSets[iter->first].push_back(&sym);
-        if (symbolIsGlobal(sym))
-          setIsGlobal.insert({iter->first, &sym});
+    analyzedScopes.insert(&scope);
+    std::list<std::list<semantics::SymbolRef>> aggregates =
+        Fortran::semantics::GetStorageAssociations(scope);
+    for (std::list<semantics::SymbolRef> aggregate : aggregates) {
+      const Fortran::semantics::Symbol *aggregateSym = nullptr;
+      bool isGlobal = false;
+      const semantics::Symbol &first = *aggregate.front();
+      std::size_t start = first.offset();
+      std::size_t end = first.offset() + first.size();
+      const Fortran::semantics::Symbol *namingSym = nullptr;
+      for (semantics::SymbolRef symRef : aggregate) {
+        const semantics::Symbol &sym = *symRef;
+        aliasSyms.insert(&sym);
+        if (sym.test(Fortran::semantics::Symbol::Flag::CompilerCreated)) {
+          aggregateSym = &sym;
+        } else {
+          isGlobal |= lower::symbolIsGlobal(sym);
+          start = std::min(sym.offset(), start);
+          end = std::max(sym.offset() + sym.size(), end);
+          if (!namingSym || (sym.name() < namingSym->name()))
+            namingSym = &sym;
         }
       }
-
-    // 3. For each alias set with more than 1 member, add an Interval to the
-    // stores. The Interval will be lowered into a single memory allocation,
-    // with the co-located, overlapping variables mapped into that memory range.
-    for (const auto &pair : aliasSets) {
-      if (pair.second.size() > 1) {
-        // Set contains more than 1 aliasing variable.
-        // 1. Mark the symbols as aliasing for lowering.
-        for (auto *sym : pair.second)
-          aliasSyms.insert(sym);
-        auto gvarIter = setIsGlobal.find(pair.first);
-        auto iter = intervals.find(pair.first);
-        auto ibgn = iter->first;
-        auto ilen = iter->second - ibgn + 1;
-        // 2. Add an Interval to the list of stores allocated for this unit.
-        lower::pft::Variable::Interval interval(ibgn, ilen);
-        if (gvarIter != setIsGlobal.end()) {
-          LLVM_DEBUG(llvm::dbgs()
-                     << "interval [" << ibgn << ".." << ibgn + ilen
-                     << ") added as global " << *gvarIter->second << '\n');
-          stores.emplace_back(std::move(interval), scope, pair.second,
-                              isDeclaration);
-        } else {
-          LLVM_DEBUG(llvm::dbgs() << "interval [" << ibgn << ".." << ibgn + ilen
-                                  << ") added\n");
-          stores.emplace_back(std::move(interval), scope, isDeclaration);
-        }
+      assert(namingSym && "must contain at least one user symbol");
+      if (!aggregateSym) {
+        stores.emplace_back(
+            Fortran::lower::pft::Variable::Interval{start, end - start},
+            *namingSym, isGlobal);
+        stores.emplace_back(*aggregateSym, *namingSym, isGlobal);
       }
     }
   }
 
   // Recursively visit each symbol to determine the height of its dependence on
   // other symbols.
   int analyze(const semantics::Symbol &sym) {
     auto done = seen.insert(&sym);
     LLVM_DEBUG(llvm::dbgs() << "analyze symbol: " << sym << '\n');
     if (!done.second)
       return 0;
     if (semantics::IsProcedure(sym)) {
       // TODO: add declaration?
       return 0;
     }
-    auto ultimate = sym.GetUltimate();
+    semantics::Symbol ultimate = sym.GetUltimate();
+    if (const auto *details =
+            ultimate.detailsIf<semantics::NamelistDetails>()) {
+      // handle namelist group symbols
+      for (const semantics::SymbolRef &s : details->objects())
+        analyze(s);
+      return 0;
+    }
     if (!ultimate.has<semantics::ObjectEntityDetails>() &&
         !ultimate.has<semantics::ProcEntityDetails>())
       return 0;
 
     if (sym.has<semantics::DerivedTypeDetails>())
       llvm_unreachable("not yet implemented - derived type analysis");
 
     // Symbol must be something lowering will have to allocate.
-    bool global = semantics::IsSaved(sym);
     int depth = 0;
-    const auto *symTy = sym.GetType();
+    const semantics::DeclTypeSpec *symTy = sym.GetType();
     assert(symTy && "symbol must have a type");
 
+    // Analyze symbols appearing in object entity specification expression. This
+    // ensures these symbols will be instantiated before the current one.
+    // This is not done for object entities that are host associated because
+    // they must be instantiated from the value of the host symbols (the
+    // specification expressions should not be re-evaluated).
+    if (const auto *details = sym.detailsIf<semantics::ObjectEntityDetails>()) {
       // check CHARACTER's length
       if (symTy->category() == semantics::DeclTypeSpec::Character)
-      if (auto e = symTy->characterTypeSpec().length().GetExplicit()) {
-        // turn variable into a global if this unit is not reentrant
-        global = global || !reentrant;
+        if (auto e = symTy->characterTypeSpec().length().GetExplicit())
           for (const auto &s : evaluate::CollectSymbols(*e))
             depth = std::max(analyze(s) + 1, depth);
-      }
 
-    if (const auto *details = sym.detailsIf<semantics::ObjectEntityDetails>()) {
       auto doExplicit = [&](const auto &bound) {
         if (bound.isExplicit()) {
           semantics::SomeExpr e{*bound.GetExplicit()};
           for (const auto &s : evaluate::CollectSymbols(e))
             depth = std::max(analyze(s) + 1, depth);
         }
       };
       // handle any symbols in array bound declarations
-      if (!details->shape().empty())
-        global = global || !reentrant;
-      for (const auto &subs : details->shape()) {
+      for (const semantics::ShapeSpec &subs : details->shape()) {
         doExplicit(subs.lbound());
         doExplicit(subs.ubound());
       }
       // handle any symbols in coarray bound declarations
-      if (!details->coshape().empty())
-        global = global || !reentrant;
-      for (const auto &subs : details->coshape()) {
+      for (const semantics::ShapeSpec &subs : details->coshape()) {
         doExplicit(subs.lbound());
         doExplicit(subs.ubound());
       }
       // handle any symbols in initialization expressions
-      if (auto e = details->init()) {
-        // A PARAMETER may not be marked as implicitly SAVE, so set the flag.
-        global = true;
+      if (auto e = details->init())
         for (const auto &s : evaluate::CollectSymbols(*e))
           depth = std::max(analyze(s) + 1, depth);
-      }
-    }
     adjustSize(depth + 1);
+    bool global = lower::symbolIsGlobal(sym);
     vars[depth].emplace_back(sym, global, depth);
     if (semantics::IsAllocatable(sym))
       vars[depth].back().setHeapAlloc();
     if (semantics::IsPointer(sym))
       vars[depth].back().setPointer();
     if (ultimate.attrs().test(semantics::Attr::TARGET))
       vars[depth].back().setTarget();
 
     // If there are alias sets, then link the participating variables to their
     // aggregate stores when constructing the new variable on the list.
-    if (auto *store = findStoreIfAlias(sym)) {
+    if (lower::pft::Variable::AggregateStore *store = findStoreIfAlias(sym)) {
       vars[depth].back().setAlias(store->getOffset());
     }
     return depth;
   }
 
   /// Save the final list of variable allocations as a single vector and free
   /// the rest.
   void finalize() {
     for (int i = 1, end = vars.size(); i < end; ++i)
       vars[0].insert(vars[0].end(), vars[i].begin(), vars[i].end());
     vars.resize(1);
   }
 
   Fortran::lower::pft::Variable::AggregateStore *
   findStoreIfAlias(const Fortran::evaluate::Symbol &sym) {
-    const auto &ultimate = sym.GetUltimate();
-    const auto &scope = ultimate.owner();
+    const semantics::Symbol &ultimate = sym.GetUltimate();
+    const semantics::Scope &scope = ultimate.owner();
     // Expect the total number of EQUIVALENCE sets to be small for a typical
     // Fortran program.
     if (aliasSyms.find(&ultimate) != aliasSyms.end()) {
       LLVM_DEBUG(llvm::dbgs() << "symbol: " << ultimate << '\n');
       LLVM_DEBUG(llvm::dbgs() << "scope: " << scope << '\n');
-      auto off = ultimate.offset();
-      for (auto &v : stores) {
-        if (v.scope == &scope) {
-          auto bot = std::get<0>(v.interval);
-          if (off >= bot && off < bot + std::get<1>(v.interval))
+      std::size_t off = ultimate.offset();
+      std::size_t symSize = ultimate.size();
+      for (lower::pft::Variable::AggregateStore &v : stores) {
+        if (&v.getOwningScope() == &scope) {
+          auto intervalOff = std::get<0>(v.interval);
+          auto intervalSize = std::get<1>(v.interval);
+          if (off >= intervalOff && off < intervalOff + intervalSize)
+            return &v;
+          // Zero sized symbol in zero sized equivalence.
+          if (off == intervalOff && symSize == 0)
             return &v;
         }
       }
       // clang-format off
       LLVM_DEBUG(
           llvm::dbgs() << "looking for " << off << "\n{\n";
-          for (auto v : stores) {
-            llvm::dbgs() << " in scope: " << v.scope << "\n";
+          for (lower::pft::Variable::AggregateStore &v : stores) {
+            llvm::dbgs() << " in scope: " << &v.getOwningScope() << "\n";
             llvm::dbgs() << "  i = [" << std::get<0>(v.interval) << ".."
                 << std::get<0>(v.interval) + std::get<1>(v.interval)
                 << "]\n";
           }
           llvm::dbgs() << "}\n");
       // clang-format on
       llvm_unreachable("the store must be present");
     }
     return nullptr;
   }
 
 private:
   /// Skip symbol in alias analysis.
   bool skipSymbol(const semantics::Symbol &sym) {
+    // Common block equivalences are largely managed by the front end.
+    // Compiler generated symbols ('.' names) cannot be equivalenced.
+    // FIXME: Equivalence code generation may need to be revisited.
     return !sym.has<semantics::ObjectEntityDetails>() ||
-           lower::definedInCommonBlock(sym);
+           lower::definedInCommonBlock(sym) || sym.name()[0] == '.';
   }
 
   // Make sure the table is of appropriate size.
   void adjustSize(std::size_t size) {
     if (vars.size() < size)
       vars.resize(size);
   }
 
   llvm::SmallSet<const semantics::Symbol *, 32> seen;
   std::vector<std::vector<lower::pft::Variable>> &vars;
   llvm::SmallSet<const semantics::Symbol *, 32> aliasSyms;
-  llvm::SmallSet<const semantics::Scope *, 4> scopeAnlyzedForAliases;
+  /// Set of Scope that have been analyzed for aliases.
+  llvm::SmallSet<const semantics::Scope *, 4> analyzedScopes;
   std::vector<Fortran::lower::pft::Variable::AggregateStore> stores;
-  bool reentrant;
 };
 } // namespace
 
 static void processSymbolTable(
     const semantics::Scope &scope,
-    std::vector<std::vector<Fortran::lower::pft::Variable>> &varList,
-    bool reentrant) {
-  SymbolDependenceDepth sdd{varList, reentrant};
+    std::vector<std::vector<Fortran::lower::pft::Variable>> &varList) {
+  SymbolDependenceDepth sdd{varList};
   sdd.analyzeAliasesInCurrentScope(scope);
   for (const auto &iter : scope)
     sdd.analyze(iter.second.get());
   sdd.finalize();
 }
 
+//===----------------------------------------------------------------------===//
+// FunctionLikeUnit implementation
+//===----------------------------------------------------------------------===//
+
 Fortran::lower::pft::FunctionLikeUnit::FunctionLikeUnit(
     const parser::MainProgram &func, const lower::pft::PftNode &parent,
     const semantics::SemanticsContext &semanticsContext)
     : ProgramUnit{func, parent}, endStmt{
                                      getFunctionStmt<parser::EndProgramStmt>(
                                          func)} {
   const auto &programStmt =
       std::get<std::optional<parser::Statement<parser::ProgramStmt>>>(func.t);
   if (programStmt.has_value()) {
     beginStmt = FunctionStatement(programStmt.value());
-    const auto *symbol = getSymbol(*beginStmt);
+    const semantics::Symbol *symbol = getSymbol(*beginStmt);
     entryPointList[0].first = symbol;
-    processSymbolTable(*symbol->scope(), varList, isRecursive());
+    processSymbolTable(*symbol->scope(), varList);
   } else {
     processSymbolTable(
         semanticsContext.FindScope(
             std::get<parser::Statement<parser::EndProgramStmt>>(func.t).source),
-        varList, isRecursive());
+        varList);
   }
 }
 
 Fortran::lower::pft::FunctionLikeUnit::FunctionLikeUnit(
     const parser::FunctionSubprogram &func, const lower::pft::PftNode &parent,
     const semantics::SemanticsContext &)
     : ProgramUnit{func, parent},
       beginStmt{getFunctionStmt<parser::FunctionStmt>(func)},
       endStmt{getFunctionStmt<parser::EndFunctionStmt>(func)} {
-  const auto *symbol = getSymbol(*beginStmt);
+  const semantics::Symbol *symbol = getSymbol(*beginStmt);
   entryPointList[0].first = symbol;
-  processSymbolTable(*symbol->scope(), varList, isRecursive());
+  processSymbolTable(*symbol->scope(), varList);
 }
 
 Fortran::lower::pft::FunctionLikeUnit::FunctionLikeUnit(
     const parser::SubroutineSubprogram &func, const lower::pft::PftNode &parent,
     const semantics::SemanticsContext &)
     : ProgramUnit{func, parent},
       beginStmt{getFunctionStmt<parser::SubroutineStmt>(func)},
       endStmt{getFunctionStmt<parser::EndSubroutineStmt>(func)} {
-  const auto *symbol = getSymbol(*beginStmt);
+  const semantics::Symbol *symbol = getSymbol(*beginStmt);
   entryPointList[0].first = symbol;
-  processSymbolTable(*symbol->scope(), varList, isRecursive());
+  processSymbolTable(*symbol->scope(), varList);
 }
 
 Fortran::lower::pft::FunctionLikeUnit::FunctionLikeUnit(
     const parser::SeparateModuleSubprogram &func,
     const lower::pft::PftNode &parent, const semantics::SemanticsContext &)
     : ProgramUnit{func, parent},
       beginStmt{getFunctionStmt<parser::MpSubprogramStmt>(func)},
       endStmt{getFunctionStmt<parser::EndMpSubprogramStmt>(func)} {
-  const auto *symbol = getSymbol(*beginStmt);
+  const semantics::Symbol *symbol = getSymbol(*beginStmt);
   entryPointList[0].first = symbol;
-  processSymbolTable(*symbol->scope(), varList, isRecursive());
+  processSymbolTable(*symbol->scope(), varList);
+}
+
+Fortran::lower::HostAssociations &
+Fortran::lower::pft::FunctionLikeUnit::parentHostAssoc() {
+  if (auto *par = parent.getIf<FunctionLikeUnit>())
+    return par->hostAssociations;
+  llvm::report_fatal_error("parent is not a function");
+}
+
+bool Fortran::lower::pft::FunctionLikeUnit::parentHasHostAssoc() {
+  if (auto *par = parent.getIf<FunctionLikeUnit>())
+    return !par->hostAssociations.empty();
+  return false;
+}
+
+parser::CharBlock
+Fortran::lower::pft::FunctionLikeUnit::getStartingSourceLoc() const {
+  if (beginStmt)
+    return stmtSourceLoc(*beginStmt);
+  if (!evaluationList.empty())
+    return evaluationList.front().position;
+  return stmtSourceLoc(endStmt);
 }
 
+//===----------------------------------------------------------------------===//
+// ModuleLikeUnit implementation
+//===----------------------------------------------------------------------===//
+
 Fortran::lower::pft::ModuleLikeUnit::ModuleLikeUnit(
     const parser::Module &m, const lower::pft::PftNode &parent)
     : ProgramUnit{m, parent}, beginStmt{getModuleStmt<parser::ModuleStmt>(m)},
       endStmt{getModuleStmt<parser::EndModuleStmt>(m)} {
-  const auto *symbol = getSymbol(beginStmt);
-  processSymbolTable(*symbol->scope(), varList, /*reentrant=*/false);
+  const semantics::Symbol *symbol = getSymbol(beginStmt);
+  processSymbolTable(*symbol->scope(), varList);
 }
 
 Fortran::lower::pft::ModuleLikeUnit::ModuleLikeUnit(
     const parser::Submodule &m, const lower::pft::PftNode &parent)
     : ProgramUnit{m, parent}, beginStmt{getModuleStmt<parser::SubmoduleStmt>(
                                   m)},
       endStmt{getModuleStmt<parser::EndSubmoduleStmt>(m)} {
-  const auto *symbol = getSymbol(beginStmt);
-  processSymbolTable(*symbol->scope(), varList, /*reentrant=*/false);
+  const semantics::Symbol *symbol = getSymbol(beginStmt);
+  processSymbolTable(*symbol->scope(), varList);
 }
 
+parser::CharBlock
+Fortran::lower::pft::ModuleLikeUnit::getStartingSourceLoc() const {
+  return stmtSourceLoc(beginStmt);
+}
+const Fortran::semantics::Scope &
+Fortran::lower::pft::ModuleLikeUnit::getScope() const {
+  const Fortran::semantics::Symbol *symbol = getSymbol(beginStmt);
+  assert(symbol && symbol->scope() &&
+         "Module statement must have a symbol with a scope");
+  return *symbol->scope();
+}
+
+//===----------------------------------------------------------------------===//
+// BlockDataUnit implementation
+//===----------------------------------------------------------------------===//
+
 Fortran::lower::pft::BlockDataUnit::BlockDataUnit(
     const parser::BlockData &bd, const lower::pft::PftNode &parent,
     const semantics::SemanticsContext &semanticsContext)
     : ProgramUnit{bd, parent},
       symTab{semanticsContext.FindScope(
           std::get<parser::Statement<parser::EndBlockDataStmt>>(bd.t).source)} {
 }
 
if (s->pointer)
       llvm::errs() << ", pointer";
     if (s->target)
       llvm::errs() << ", target";
     if (s->aliaser)
       llvm::errs() << ", equivalence(" << s->aliasOffset << ')';
   } else if (auto *s = std::get_if<AggregateStore>(&var)) {
     llvm::errs() << "interval[" << std::get<0>(s->interval) << ", "
                  << std::get<1>(s->interval) << "]:";
+    llvm::errs() << " name: " << toStringRef(s->getNamingSymbol().name());
     if (s->isGlobal())
       llvm::errs() << ", global";
-    if (s->vars.size()) {
-      llvm::errs() << ", vars: {";
-      llvm::interleaveComma(s->vars, llvm::errs(),
-                            [](auto *y) { llvm::errs() << *y; });
-      llvm::errs() << '}';
-    }
+    if (s->initialValueSymbol)
+      llvm::errs() << ", initial value: {" << *s->initialValueSymbol << "}";
   } else {
     llvm_unreachable("not a Variable");
   }
   llvm::errs() << '\n';
 }
 
 void Fortran::lower::pft::FunctionLikeUnit::dump() const {
   PFTDumper{}.dumpFunctionLikeUnit(llvm::errs(), *this);
 }
 
 void Fortran::lower::pft::ModuleLikeUnit::dump() const {
   PFTDumper{}.dumpModuleLikeUnit(llvm::errs(), *this);
 }
 
 /// The BlockDataUnit dump is just the associated symbol table.
 void Fortran::lower::pft::BlockDataUnit::dump() const {
   llvm::errs() << "block data {\n" << symTab << "\n}\n";
 }
+
+std::vector<Fortran::lower::pft::Variable>
+Fortran::lower::pft::buildFuncResultDependencyList(
+    const Fortran::semantics::Symbol &symbol) {
+  std::vector<std::vector<pft::Variable>> variableList;
+  SymbolDependenceDepth sdd(variableList);
+  sdd.analyzeAliasesInCurrentScope(symbol.owner());
+  sdd.analyze(symbol);
+  sdd.finalize();
+  // Remove the pft::variable for the result itself, only its dependencies
+  // should be returned in the list.
+  assert(!variableList[0].empty() && "must at least contain the result");
+  assert(&variableList[0].back().getSymbol() == &symbol &&
+         "result sym should be last");
+  variableList[0].pop_back();
+  return variableList[0];
+}
+
+namespace {
+/// Helper class to find all the symbols referenced in a FunctionLikeUnit.
+/// It defines a parse tree visitor doing a deep visit in all nodes with
+/// symbols (including evaluate::Expr).
+struct SymbolVisitor {
+  template <typename A>
+  bool Pre(const A &x) {
+    if constexpr (Fortran::parser::HasTypedExpr<A>::value)
+      if (const auto *expr = Fortran::semantics::GetExpr(x))
+        visitExpr(*expr);
+    return true;
+  }
+
+  bool Pre(const Fortran::parser::Name &name) {
+    if (const semantics::Symbol *symbol = name.symbol)
+      visitSymbol(*symbol);
+    return false;
+  }
+
+  void visitExpr(const Fortran::lower::SomeExpr &expr) {
+    for (const semantics::Symbol &symbol :
+         Fortran::evaluate::CollectSymbols(expr))
+      visitSymbol(symbol);
+  }
+
+  void visitSymbol(const Fortran::semantics::Symbol &symbol) {
+    callBack(symbol);
+    // Visit statement function body since it will be inlined in lowering.
+    if (const auto *subprogramDetails =
+            symbol.detailsIf<Fortran::semantics::SubprogramDetails>())
+      if (const auto &maybeExpr = subprogramDetails->stmtFunction())
+        visitExpr(*maybeExpr);
+  }
+
+  template <typename A>
+  constexpr void Post(const A &) {}
+
+  const std::function<void(const Fortran::semantics::Symbol &)> &callBack;
+};
+} // namespace
+
+void Fortran::lower::pft::visitAllSymbols(
+    const Fortran::lower::pft::FunctionLikeUnit &funit,
+    const std::function<void(const Fortran::semantics::Symbol &)> callBack) {
+  SymbolVisitor visitor{callBack};
+  funit.visit([&](const auto &functionParserNode) {
+    parser::Walk(functionParserNode, visitor);
+  });
+}

flang/test/Lower/pre-fir-tree01.f90

-! RUN: %flang_fc1 -fdebug-pre-fir-tree %s | FileCheck %s
+! RUN: bbc -pft-test -o %t %s | FileCheck %s
 
 ! Test structure of the Pre-FIR tree
 
 ! CHECK: Subroutine foo
 subroutine foo()
   ! CHECK: <<DoConstruct>>
   ! CHECK: NonLabelDoStmt
   do i=1,5

 function bar()
 ! CHECK: EndFunctionStmt
 end function
 ! CHECK: End Function bar
 
 ! Test top level directives
 !DIR$ INTEGER=64
 ! CHECK: CompilerDirective:
-! CHECK: End CompilerDirective
 
 ! Test nested directive
 ! CHECK: Subroutine test_directive
 subroutine test_directive()
   !DIR$ INTEGER=64
-  ! CHECK: <<CompilerDirective>>
-  ! CHECK: <<End CompilerDirective>>
+  ! CHECK: CompilerDirective:
 end subroutine
 ! CHECK: EndSubroutine
 
 ! CHECK: Program <anonymous>
   ! check specification parts are not part of the PFT.
   ! CHECK-NOT: node
   use test_mod
   real, allocatable :: x(:)
   ! CHECK: AllocateStmt
   allocate(x(foo2(10, 30)))
 end
 ! CHECK: End Program

flang/test/Lower/pre-fir-tree02.f90

-! RUN: %flang_fc1 -fdebug-pre-fir-tree %s | FileCheck %s
+! RUN: bbc -pft-test -o %t %s | FileCheck %s
 
 ! Test Pre-FIR Tree captures all the intended nodes from the parse-tree
 ! Coarray and OpenMP related nodes are tested in other files.
 
 ! CHECK: Program test_prog
 program test_prog
   ! Check specification part is not part of the tree.
   interface
function bar(x)
     ! CHECK: EndSelectStmt
     end select
     ! CHECK: <<End SelectTypeConstruct!>>
   end function
 
   ! CHECK: Subroutine sub
   subroutine sub(a)
     real(4):: a
-    ! CompilerDirective
-    ! CHECK: <<CompilerDirective>>
+    ! CompilerDirective:
     !DIR$ IGNORE_TKR a
   end subroutine
 
 
 end module
 
 ! CHECK: Subroutine altreturn
 subroutine altreturn(i, j, *, *)
if (file_is_opened) then
     ! CHECK: OpenStmt
     open(10, FILE=filename)
   end if
   ! CHECK: <<End IfConstruct>>
   ! CHECK: ReadStmt
   read(10, *) length
   ! CHECK: RewindStmt
   rewind 10
-  ! CHECK: NamelistStmt
+  ! CHECK-NOT: NamelistStmt
   namelist /nlist/ a, b, c
   ! CHECK: WriteStmt
   write(10, NML=nlist)
   ! CHECK: BackspaceStmt
   backspace(10)
   ! CHECK: FormatStmt
 1 format (1PE12.4)
   ! CHECK: WriteStmt

flang/test/Lower/pre-fir-tree05.f90

do j=1,5
       ! CHECK-NEXT: PrintStmt
       print *, "hello", i, j
     ! CHECK-NEXT: EndDoStmt
     ! CHECK-NEXT: <<End DoConstruct>>
     end do
   ! CHECK-NEXT: EndDoStmt
   ! CHECK-NEXT: <<End DoConstruct>>
   end do
+  ! CHECK-NEXT: ContinueStmt
   !$acc end parallel
-  ! CHECK-NEXT: <<End OpenACCConstruct>>
+  ! CHECK-NEXT:      <<End OpenACCConstruct>>
   ! CHECK-NEXT: <<End OpenACCConstruct>>
   ! CHECK-NEXT: EndSubroutineStmt
 end subroutine
 ! CHECK-NEXT: End Subroutine foo
 
-! CHECK: Subroutine foo
+! CHECK: Subroutine foo2
 subroutine foo2()
   ! CHECK-NEXT: <<OpenACCConstruct>>
   !$acc parallel loop
   ! CHECK-NEXT: <<DoConstruct>>
   ! CHECK-NEXT: NonLabelDoStmt
   do i=1,5
   ! CHECK-NEXT: EndDoStmt
   ! CHECK-NEXT: <<End DoConstruct>>
   end do
+  ! CHECK-NEXT: ContinueStmt
   !$acc end parallel loop
   ! CHECK-NEXT: <<End OpenACCConstruct>>
   ! CHECK-NEXT: EndSubroutineStmt
 end subroutine
 ! CHECK-NEXT: End Subroutine foo2
-