xref: /llvm-project/flang/include/flang/Lower/PFTBuilder.h (revision 6003be7ef14bd95647e1ea6ec9685c1310f8ce58)

//===-- Lower/PFTBuilder.h -- PFT builder -----------------------*- 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
//
//===----------------------------------------------------------------------===//
//
// Coding style: https://mlir.llvm.org/getting_started/DeveloperGuide/
//
//===----------------------------------------------------------------------===//
//
// PFT (Pre-FIR Tree) interface.
//
//===----------------------------------------------------------------------===//

#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/semantics.h"
#include "flang/Semantics/symbol.h"
#include "llvm/Support/ErrorHandling.h"
#include "llvm/Support/raw_ostream.h"

namespace Fortran::lower::pft {

struct CompilerDirectiveUnit;
struct Evaluation;
struct FunctionLikeUnit;
struct ModuleLikeUnit;
struct Program;

using ContainedUnit = std::variant<CompilerDirectiveUnit, FunctionLikeUnit>;
using ContainedUnitList = std::list<ContainedUnit>;
using EvaluationList = std::list<Evaluation>;

/// Provide a variant like container that can hold references. It can hold
/// constant or mutable references. It is used in the other classes to provide
/// union of const references to parse-tree nodes.
template <bool isConst, typename... A>
class ReferenceVariantBase {
public:
  template <typename B>
  using BaseType = std::conditional_t<isConst, const B, B>;
  template <typename B>
  using Ref = common::Reference<BaseType<B>>;

  ReferenceVariantBase() = delete;
  ReferenceVariantBase(std::variant<Ref<A>...> b) : u(b) {}
  template <typename T>
  ReferenceVariantBase(Ref<T> b) : u(b) {}

  template <typename B>
  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 {
    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 {
    return Fortran::common::visit(
        common::visitors{[&visitor](auto ref) { return visitor(ref.get()); }},
        u);
  }

private:
  std::variant<Ref<A>...> u;
};
template <typename... A>
using ReferenceVariant = ReferenceVariantBase<true, A...>;
template <typename... A>
using MutableReferenceVariant = ReferenceVariantBase<false, A...>;

/// PftNode is used to provide a reference to the unit a parse-tree node
/// belongs to. It is a variant of non-nullable pointers.
using PftNode = MutableReferenceVariant<Program, ModuleLikeUnit,
                                        FunctionLikeUnit, Evaluation>;

/// Classify the parse-tree nodes from ExecutablePartConstruct

using ActionStmts = std::tuple<
    parser::AllocateStmt, parser::AssignmentStmt, parser::BackspaceStmt,
    parser::CallStmt, parser::CloseStmt, parser::ContinueStmt,
    parser::CycleStmt, parser::DeallocateStmt, parser::EndfileStmt,
    parser::EventPostStmt, parser::EventWaitStmt, parser::ExitStmt,
    parser::FailImageStmt, parser::FlushStmt, parser::FormTeamStmt,
    parser::GotoStmt, parser::IfStmt, parser::InquireStmt, parser::LockStmt,
    parser::NotifyWaitStmt, 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::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,
    parser::SelectTypeStmt, parser::TypeGuardStmt, parser::WhereConstructStmt,
    parser::MaskedElsewhereStmt, parser::ElsewhereStmt, parser::EndWhereStmt,
    parser::ForallConstructStmt, parser::EndForallStmt>;

using EndStmts =
    std::tuple<parser::EndProgramStmt, parser::EndFunctionStmt,
               parser::EndSubroutineStmt, parser::EndMpSubprogramStmt>;

using Constructs =
    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::OpenACCRoutineConstruct,
               parser::OpenACCDeclarativeConstruct, parser::OpenMPConstruct,
               parser::OpenMPDeclarativeConstruct, parser::OmpEndLoopDirective,
               parser::CUFKernelDoConstruct>;

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::CaseStmt, 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, parser::CUFKernelDoConstruct>>};

template <typename A>
static constexpr bool isFunctionLike{common::HasMember<
    A, std::tuple<parser::MainProgram, parser::FunctionSubprogram,
                  parser::SubroutineSubprogram,
                  parser::SeparateModuleSubprogram>>};

template <typename A>
struct MakeReferenceVariantHelper {};
template <typename... A>
struct MakeReferenceVariantHelper<std::variant<A...>> {
  using type = ReferenceVariant<A...>;
};
template <typename... A>
struct MakeReferenceVariantHelper<std::tuple<A...>> {
  using type = ReferenceVariant<A...>;
};
template <typename A>
using MakeReferenceVariant = typename MakeReferenceVariantHelper<A>::type;

using EvaluationTuple =
    common::CombineTuples<ActionStmts, OtherStmts, ConstructStmts, EndStmts,
                          Constructs, Directives>;
/// Hide non-nullable pointers to the parse-tree node.
/// Build type std::variant<const A* const, const B* const, ...>
/// from EvaluationTuple type (std::tuple<A, B, ...>).
using EvaluationVariant = MakeReferenceVariant<EvaluationTuple>;

/// Function-like units contain lists of evaluations. These can be simple
/// statements or constructs, where a construct contains its own evaluations.
struct Evaluation : EvaluationVariant {

  /// General ctor
  template <typename A>
  Evaluation(const A &a, const PftNode &parent,
             const parser::CharBlock &position,
             const std::optional<parser::Label> &label)
      : EvaluationVariant{a}, parent{parent}, position{position}, label{label} {
  }

  /// Construct and Directive ctor
  template <typename A>
  Evaluation(const A &a, const PftNode &parent)
      : EvaluationVariant{a}, parent{parent} {
    static_assert(pft::isConstruct<A> || pft::isDirective<A>,
                  "must be a construct or directive");
  }

  /// Evaluation classification predicates.
  constexpr bool isActionStmt() const {
    return visit(common::visitors{
        [](auto &r) { return pft::isActionStmt<std::decay_t<decltype(r)>>; }});
  }
  constexpr bool isOtherStmt() const {
    return visit(common::visitors{
        [](auto &r) { return pft::isOtherStmt<std::decay_t<decltype(r)>>; }});
  }
  constexpr bool isConstructStmt() const {
    return visit(common::visitors{[](auto &r) {
      return pft::isConstructStmt<std::decay_t<decltype(r)>>;
    }});
  }
  constexpr bool isEndStmt() const {
    return visit(common::visitors{
        [](auto &r) { return pft::isEndStmt<std::decay_t<decltype(r)>>; }});
  }
  constexpr bool isConstruct() const {
    return visit(common::visitors{
        [](auto &r) { return pft::isConstruct<std::decay_t<decltype(r)>>; }});
  }
  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)>>;
    }});
  }

  LLVM_DUMP_METHOD void dump() const;

  /// Return the first non-nop successor of an evaluation, possibly exiting
  /// from one or more enclosing constructs.
  Evaluation &nonNopSuccessor() const {
    Evaluation *successor = lexicalSuccessor;
    if (successor && successor->isNopConstructStmt())
      successor = successor->parentConstruct->constructExit;
    assert(successor && "missing successor");
    return *successor;
  }

  /// Return true if this Evaluation has at least one nested evaluation.
  bool hasNestedEvaluations() const {
    return evaluationList && !evaluationList->empty();
  }

  /// Return nested evaluation list.
  EvaluationList &getNestedEvaluations() {
    assert(evaluationList && "no nested evaluations");
    return *evaluationList;
  }

  Evaluation &getFirstNestedEvaluation() {
    assert(hasNestedEvaluations() && "no nested evaluations");
    return evaluationList->front();
  }

  Evaluation &getLastNestedEvaluation() {
    assert(hasNestedEvaluations() && "no nested evaluations");
    return evaluationList->back();
  }

  /// Return the FunctionLikeUnit containing this evaluation (or nullptr).
  FunctionLikeUnit *getOwningProcedure() const;

  bool lowerAsStructured() const;
  bool lowerAsUnstructured() const;
  bool forceAsUnstructured() const;

  // FIR generation looks primarily at PFT ActionStmt and ConstructStmt leaf
  // nodes. Members such as lexicalSuccessor and block are applicable only
  // 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.
  //
  // The block member is set for statements that begin a new block. This
  // block is the target of any branch to the statement. Statements may have
  // additional (unstructured) "local" blocks, but such blocks cannot be the
  // target of any explicit branch. The primary example of an (unstructured)
  // statement that may have multiple associated blocks is NonLabelDoStmt,
  // which may have a loop preheader block for loop initialization code (the
  // block member), and always has a "local" header block that is the target
  // of the loop back edge. If the NonLabelDoStmt is a concurrent loop, it
  // may be associated with an arbitrary number of nested preheader, header,
  // and mask blocks.
  //
  // 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
  // associated compiler directives
  llvm::SmallVector<const parser::CompilerDirective *, 1> dirs;
  Evaluation *parentConstruct{nullptr};  // set for nodes below the top level
  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
  bool activeConstruct{false}; // temporarily set for some constructs
  mlir::Block *block{nullptr}; // isNewBlock block (ActionStmt, ConstructStmt)
  int printIndex{0}; // (ActionStmt, ConstructStmt) evaluation index for dumps
};

using ProgramVariant =
    ReferenceVariant<parser::MainProgram, parser::FunctionSubprogram,
                     parser::SubroutineSubprogram, parser::Module,
                     parser::Submodule, parser::SeparateModuleSubprogram,
                     parser::BlockData, parser::CompilerDirective,
                     parser::OpenACCRoutineConstruct>;
/// A program is a list of program units.
/// These units can be function like, module like, or block data.
struct ProgramUnit : ProgramVariant {
  template <typename A>
  ProgramUnit(const A &p, const PftNode &parent)
      : ProgramVariant{p}, parent{parent} {}
  ProgramUnit(ProgramUnit &&) = default;
  ProgramUnit(const ProgramUnit &) = delete;

  PftNode parent;
};

/// 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.
///
/// EQUIVALENCE can also interact with COMMON and other global variables to
/// imply aliasing between (subparts of) a global and other local variable
/// names.
///
/// Properties can be applied by lowering. For example, a local array that is
/// known to be very large may be transformed into a heap allocated entity by
/// lowering. That decision would be tracked in its Variable instance.
struct Variable {
  /// Most variables are nominal and require the allocation of local/global
  /// 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; }

    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::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 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{};
    /// 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.
  const Fortran::semantics::Symbol &getSymbol() const {
    assert(hasSymbol() && "variable is not nominal");
    return *std::get<Nominal>(var).symbol;
  }

  /// Is this variable a compiler generated global to describe derived types?
  bool isRuntimeTypeInfoData() const;

  /// Return the aggregate store.
  const AggregateStore &getAggregateStore() const {
    assert(isAggregateStore());
    return std::get<AggregateStore>(var);
  }

  /// Return the interval range of an aggregate store.
  const Interval &getInterval() const {
    assert(isAggregateStore());
    return std::get<AggregateStore>(var).interval;
  }

  /// Only nominal variable have front-end symbols.
  bool hasSymbol() const { return std::holds_alternative<Nominal>(var); }

  /// Is this an aggregate store?
  bool isAggregateStore() const {
    return std::holds_alternative<AggregateStore>(var);
  }

  /// Is this variable a global?
  bool isGlobal() const {
    return Fortran::common::visit([](const auto &x) { return x.isGlobal(); },
                                  var);
  }

  /// Is this a module or submodule variable?
  bool isModuleOrSubmoduleVariable() const {
    const semantics::Scope *scope = getOwningScope();
    return scope && scope->kind() == Fortran::semantics::Scope::Kind::Module;
  }

  const Fortran::semantics::Scope *getOwningScope() const {
    return Fortran::common::visit(
        common::visitors{
            [](const Nominal &x) { return &x.symbol->GetUltimate().owner(); },
            [](const AggregateStore &agg) { return &agg.getOwningScope(); }},
        var);
  }

  bool isHeapAlloc() const {
    if (auto *s = std::get_if<Nominal>(&var))
      return s->heapAlloc;
    return false;
  }
  bool isPointer() const {
    if (auto *s = std::get_if<Nominal>(&var))
      return s->pointer;
    return false;
  }
  bool isTarget() const {
    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 (auto *s = std::get_if<Nominal>(&var))
      return s->aliaser;
    return false;
  }
  std::size_t getAliasOffset() const {
    if (auto *s = std::get_if<Nominal>(&var))
      return s->aliasOffset;
    return 0;
  }
  void setAlias(std::size_t offset) {
    if (auto *s = std::get_if<Nominal>(&var)) {
      s->aliaser = true;
      s->aliasOffset = offset;
    } else {
      llvm_unreachable("not a nominal var");
    }
  }

  void setHeapAlloc(bool to = true) {
    if (auto *s = std::get_if<Nominal>(&var))
      s->heapAlloc = to;
    else
      llvm_unreachable("not a nominal var");
  }
  void setPointer(bool to = true) {
    if (auto *s = std::get_if<Nominal>(&var))
      s->pointer = to;
    else
      llvm_unreachable("not a nominal var");
  }
  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 (auto *s = std::get_if<Nominal>(&var))
      return s->depth;
    return 0;
  }

  LLVM_DUMP_METHOD void dump() const;

private:
  std::variant<Nominal, AggregateStore> var;
};

using VariableList = std::vector<Variable>;
using ScopeVariableListMap =
    std::map<const Fortran::semantics::Scope *, VariableList>;

/// Find or create an ordered list of the equivalence sets and variables that
/// appear in \p scope. The result is cached in \p map.
const VariableList &getScopeVariableList(const Fortran::semantics::Scope &scope,
                                         ScopeVariableListMap &map);

/// Create an ordered list of the equivalence sets and variables that appear in
/// \p scope. The result is not cached.
VariableList getScopeVariableList(const Fortran::semantics::Scope &scope);

/// Create an ordered list of the equivalence sets and variables that \p symbol
/// depends on. \p symbol itself will be the last variable in the list.
VariableList getDependentVariableList(const Fortran::semantics::Symbol &);

void dump(VariableList &, std::string s = {}); // `s` is an optional dump label

/// Function-like units may contain evaluations (executable statements),
/// directives, and internal (nested) function-like units.
struct FunctionLikeUnit : public ProgramUnit {
  // wrapper statements for function-like syntactic structures
  using FunctionStatement =
      ReferenceVariant<parser::Statement<parser::ProgramStmt>,
                       parser::Statement<parser::EndProgramStmt>,
                       parser::Statement<parser::FunctionStmt>,
                       parser::Statement<parser::EndFunctionStmt>,
                       parser::Statement<parser::SubroutineStmt>,
                       parser::Statement<parser::EndSubroutineStmt>,
                       parser::Statement<parser::MpSubprogramStmt>,
                       parser::Statement<parser::EndMpSubprogramStmt>>;

  FunctionLikeUnit(
      const parser::MainProgram &f, const PftNode &parent,
      const Fortran::semantics::SemanticsContext &semanticsContext);
  FunctionLikeUnit(
      const parser::FunctionSubprogram &f, const PftNode &parent,
      const Fortran::semantics::SemanticsContext &semanticsContext);
  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;

  bool isMainProgram() const {
    return endStmt.isA<parser::Statement<parser::EndProgramStmt>>();
  }

  /// Get the starting source location for this function like unit
  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 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 main program symbol for named programs
  /// Return the null pointer for anonymous programs
  const semantics::Symbol *getMainProgramSymbol() const {
    if (!isMainProgram()) {
      llvm::report_fatal_error("call only on main program.");
    }
    return entryPointList[activeEntry].first;
  }

  /// Return a pointer to the current entry point Evaluation.
  /// This is null for a primary entry point.
  Evaluation *getEntryEval() const {
    return entryPointList[activeEntry].second;
  }

  //===--------------------------------------------------------------------===//
  // Host associations
  //===--------------------------------------------------------------------===//

  void setHostAssociatedSymbols(
      const llvm::SetVector<const semantics::Symbol *> &symbols) {
    hostAssociations.addSymbolsToBind(symbols, getScope());
  }

  /// 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 that are conveyed through an extra tuple
  /// argument.
  bool parentHasTupleHostAssoc();

  /// Return true iff the parent is a procedure and the parent has a non-empty
  /// set of host associations for variables.
  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; }
  const HostAssociations &getHostAssoc() const { return hostAssociations; };

  LLVM_DUMP_METHOD void dump() const;

  /// Get the function scope.
  const Fortran::semantics::Scope &getScope() const { return *scope; }

  /// Anonymous programs do not have a begin statement.
  std::optional<FunctionStatement> beginStmt;
  FunctionStatement endStmt;
  const semantics::Scope *scope;
  LabelEvalMap labelEvaluationMap;
  SymbolLabelMap assignSymbolLabelMap;
  ContainedUnitList containedUnitList;
  EvaluationList evaluationList;
  /// <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;
  /// 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};
  bool hasIeeeAccess{false};
  bool mayModifyHaltingMode{false};
  bool mayModifyRoundingMode{false};
  bool mayModifyUnderflowMode{false};
  /// Terminal basic block (if any)
  mlir::Block *finalBlock{};
  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;

  /// 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;
  ContainedUnitList containedUnitList;
  EvaluationList evaluationList;
};

/// 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);
  BlockDataUnit(BlockDataUnit &&) = default;
  BlockDataUnit(const BlockDataUnit &) = delete;

  LLVM_DUMP_METHOD void dump() const;

  const Fortran::semantics::Scope &symTab; // symbol table
};

// Top level compiler directives
struct CompilerDirectiveUnit : public ProgramUnit {
  CompilerDirectiveUnit(const parser::CompilerDirective &directive,
                        const PftNode &parent)
      : ProgramUnit{directive, parent} {};
  CompilerDirectiveUnit(CompilerDirectiveUnit &&) = default;
  CompilerDirectiveUnit(const CompilerDirectiveUnit &) = delete;
};

// Top level OpenACC routine directives
struct OpenACCDirectiveUnit : public ProgramUnit {
  OpenACCDirectiveUnit(const parser::OpenACCRoutineConstruct &directive,
                       const PftNode &parent)
      : ProgramUnit{directive, parent}, routine{directive} {};
  OpenACCDirectiveUnit(OpenACCDirectiveUnit &&) = default;
  OpenACCDirectiveUnit(const OpenACCDirectiveUnit &) = delete;
  const parser::OpenACCRoutineConstruct &routine;
};

/// A Program is the top-level root of the PFT.
struct Program {
  using Units = std::variant<FunctionLikeUnit, ModuleLikeUnit, BlockDataUnit,
                             CompilerDirectiveUnit, OpenACCDirectiveUnit>;

  Program(semantics::CommonBlockList &&commonBlocks)
      : commonBlocks{std::move(commonBlocks)} {}
  Program(Program &&) = default;
  Program(const Program &) = delete;

  const std::list<Units> &getUnits() const { return units; }
  std::list<Units> &getUnits() { return units; }
  const semantics::CommonBlockList &getCommonBlocks() const {
    return commonBlocks;
  }
  ScopeVariableListMap &getScopeVariableListMap() {
    return scopeVariableListMap;
  }

  /// LLVM dump method on a Program.
  LLVM_DUMP_METHOD void dump() const;

private:
  std::list<Units> units;
  semantics::CommonBlockList commonBlocks;
  ScopeVariableListMap scopeVariableListMap; // module and submodule scopes
};

/// 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); }});
}

/// Get the "global" scopeVariableListMap, stored in the pft root node.
template <typename A>
ScopeVariableListMap &getScopeVariableListMap(A &node) {
  Program *pftRoot = getAncestor<Program>(node);
  assert(pftRoot && "pft must have a root");
  return pftRoot->getScopeVariableListMap();
}

/// 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);

/// Call the provided \p callBack on all symbols that are referenced inside \p
/// eval region.
void visitAllSymbols(const Evaluation &eval,
                     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