Index: flang/include/flang/Lower/IO.h =================================================================== --- flang/include/flang/Lower/IO.h +++ flang/include/flang/Lower/IO.h @@ -43,7 +43,7 @@ struct Evaluation; using LabelEvalMap = llvm::DenseMap; using SymbolRef = Fortran::common::Reference; -using LabelSet = llvm::SmallSet; +using LabelSet = llvm::SmallSet; using SymbolLabelMap = llvm::DenseMap; } // namespace pft Index: flang/include/flang/Lower/PFTBuilder.h =================================================================== --- flang/include/flang/Lower/PFTBuilder.h +++ flang/include/flang/Lower/PFTBuilder.h @@ -6,6 +6,10 @@ // //===----------------------------------------------------------------------===// // +// Coding style: https://mlir.llvm.org/getting_started/DeveloperGuide/ +// +//===----------------------------------------------------------------------===// +// // PFT (Pre-FIR Tree) interface. // //===----------------------------------------------------------------------===// @@ -15,31 +19,20 @@ #include "flang/Common/reference.h" #include "flang/Common/template.h" +#include "flang/Lower/PFTDefs.h" #include "flang/Parser/parse-tree.h" -#include "llvm/ADT/DenseMap.h" -#include "llvm/ADT/SmallSet.h" +#include "flang/Semantics/attr.h" +#include "flang/Semantics/symbol.h" +#include "llvm/Support/ErrorHandling.h" #include "llvm/Support/raw_ostream.h" -namespace mlir { -class Block; -} - -namespace Fortran { -namespace semantics { -class SemanticsContext; -class Scope; -} // namespace semantics -namespace lower { -namespace pft { +namespace Fortran::lower::pft { struct Evaluation; struct Program; struct ModuleLikeUnit; struct FunctionLikeUnit; -// TODO: A collection of Evaluations can obviously be any of the container -// types; leaving this as a std::list _for now_ because we reserve the right to -// insert PFT nodes in any order in O(1) time. using EvaluationList = std::list; using LabelEvalMap = llvm::DenseMap; @@ -61,7 +54,11 @@ template constexpr BaseType &get() const { - return std::get> > (u).get(); + return std::get>(u).get(); + } + template + constexpr BaseType &getStatement() const { + return std::get>>(u).get().statement; } template constexpr BaseType *getIf() const { @@ -87,10 +84,10 @@ template using MutableReferenceVariant = ReferenceVariantBase; -/// ParentVariant is used to provide a reference to the unit a parse-tree node +/// 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 ParentVariant = MutableReferenceVariant; +using PftNode = MutableReferenceVariant; /// Classify the parse-tree nodes from ExecutablePartConstruct @@ -109,8 +106,8 @@ parser::ComputedGotoStmt, parser::ForallStmt, parser::ArithmeticIfStmt, parser::AssignStmt, parser::AssignedGotoStmt, parser::PauseStmt>; -using OtherStmts = std::tuple; +using OtherStmts = + std::tuple; using ConstructStmts = std::tuple< parser::AssociateStmt, parser::EndAssociateStmt, parser::BlockStmt, @@ -123,6 +120,10 @@ parser::MaskedElsewhereStmt, parser::ElsewhereStmt, parser::EndWhereStmt, parser::ForallConstructStmt, parser::EndForallStmt>; +using EndStmts = + std::tuple; + using Constructs = std::tuple static constexpr bool isConstructStmt{common::HasMember}; +template +static constexpr bool isEndStmt{common::HasMember}; + template static constexpr bool isConstruct{common::HasMember}; @@ -168,10 +172,6 @@ parser::SubroutineSubprogram, parser::SeparateModuleSubprogram>>}; -using LabelSet = llvm::SmallSet; -using SymbolRef = common::Reference; -using SymbolLabelMap = llvm::DenseMap; - template struct MakeReferenceVariantHelper {}; template @@ -186,8 +186,8 @@ using MakeReferenceVariant = typename MakeReferenceVariantHelper::type; using EvaluationTuple = - common::CombineTuples; + common::CombineTuples; /// Hide non-nullable pointers to the parse-tree node. /// Build type std::variant /// from EvaluationTuple type (std::tuple). @@ -199,16 +199,16 @@ /// General ctor template - Evaluation(const A &a, const ParentVariant &parentVariant, + Evaluation(const A &a, const PftNode &parent, const parser::CharBlock &position, const std::optional &label) - : EvaluationVariant{a}, - parentVariant{parentVariant}, position{position}, label{label} {} + : EvaluationVariant{a}, parent{parent}, position{position}, label{label} { + } - /// Construct ctor + /// Construct and Directive ctor template - Evaluation(const A &a, const ParentVariant &parentVariant) - : EvaluationVariant{a}, parentVariant{parentVariant} { + Evaluation(const A &a, const PftNode &parent) + : EvaluationVariant{a}, parent{parent} { static_assert(pft::isConstruct || pft::isDirective, "must be a construct or directive"); } @@ -227,6 +227,10 @@ return pft::isConstructStmt>; }}); } + constexpr bool isEndStmt() const { + return visit(common::visitors{ + [](auto &r) { return pft::isEndStmt>; }}); + } constexpr bool isConstruct() const { return visit(common::visitors{ [](auto &r) { return pft::isConstruct>; }}); @@ -249,6 +253,8 @@ }}); } + 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 { @@ -287,14 +293,13 @@ bool lowerAsStructured() const; bool lowerAsUnstructured() const; - // FIR generation looks primarily at PFT statement (leaf) nodes. So members - // such as lexicalSuccessor and the various block fields are only applicable - // to statement nodes. One exception is that an internal construct node is - // a convenient place for a constructExit link that applies to exits from any - // statement within the construct. The controlSuccessor member is used for - // nonlexical successors, such as linking to a GOTO target. For multiway - // branches, controlSuccessor is set to one of the targets (might as well be - // the first target). Successor and exit links always target statements. + // 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. // // 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 @@ -303,25 +308,21 @@ // FIR operations. An unstructured statement is materialized as mlir // operation sequences that include explicit branches. // - // There are two mlir::Block members. The block member is set for statements - // that begin a new block. If a statement may have more than one associated - // block, this member must be the block that would be the target of a branch - // to the statement. The prime example of a statement that may have multiple - // associated blocks is NonLabelDoStmt, which may have a loop preheader block - // for loop initialization code, and always has a header block that is the - // target of the loop back edge. If the NonLabelDoStmt is a concurrent loop, - // there may be an arbitrary number of nested preheader, header, and mask - // blocks. Any such additional blocks in the localBlocks member are local - // to a construct and cannot be the target of an unstructured branch. For - // NonLabelDoStmt, the block member designates the preheader block, which may - // be absent if loop initialization code may be appended to a predecessor - // block. The primary loop header block is localBlocks[0], with additional - // DO CONCURRENT blocks at localBlocks[1], etc. + // 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 does not affect FIR generation. It may also be helpful for debugging. + // (and debugging) and does not affect FIR generation. - ParentVariant parentVariant; + PftNode parent; parser::CharBlock position{}; std::optional label{}; std::unique_ptr evaluationList; // nested evaluations @@ -331,9 +332,8 @@ Evaluation *constructExit{nullptr}; // set for constructs bool isNewBlock{false}; // evaluation begins a new basic block bool isUnstructured{false}; // evaluation has unstructured control flow - bool skip{false}; // evaluation has been processed in advance - mlir::Block *block{nullptr}; // isNewBlock block - llvm::SmallVector localBlocks{}; // construct local blocks + 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 }; @@ -341,49 +341,201 @@ ReferenceVariant; + parser::BlockData, parser::CompilerDirective>; /// A program is a list of program units. /// These units can be function like, module like, or block data. struct ProgramUnit : ProgramVariant { template - ProgramUnit(const A &p, const ParentVariant &parentVariant) - : ProgramVariant{p}, parentVariant{parentVariant} {} + ProgramUnit(const A &p, const PftNode &parent) + : ProgramVariant{p}, parent{parent} {} ProgramUnit(ProgramUnit &&) = default; ProgramUnit(const ProgramUnit &) = delete; - ParentVariant parentVariant; + 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; } + 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{}; + }; + + using Interval = std::tuple; + + /// 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 &vars, + bool isDeclaration = false) + : interval{std::move(interval)}, scope{&scope}, vars{vars}, + isDecl{isDeclaration} {} + + bool isGlobal() const { return vars.size() > 0; } + bool isDeclaration() const { return isDecl; } + /// Get offset of the aggregate inside its scope. + std::size_t getOffset() const { return std::get<0>(interval); } + + Interval interval{}; + /// scope in which the interval is. + const Fortran::semantics::Scope *scope; + llvm::SmallVector vars{}; + /// Is this a declaration of a storage defined in another scope ? + bool isDecl; + }; + explicit Variable(const Fortran::semantics::Symbol &sym, bool global = false, int depth = 0) - : sym{&sym}, depth{depth}, global{global} {} + : 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(var).symbol; + } + + /// Return the aggregate store. + const AggregateStore &getAggregateStore() const { + assert(isAggregateStore()); + return std::get(var); + } + + /// Return the interval range of an aggregate store. + const Interval &getInterval() const { + assert(isAggregateStore()); + return std::get(var).interval; + } + + /// Only nominal variable have front-end symbols. + bool hasSymbol() const { return std::holds_alternative(var); } + + /// Is this an aggregate store? + bool isAggregateStore() const { + return std::holds_alternative(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); + } + + 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; }}, + var); + } + + bool isHeapAlloc() const { + if (auto *s = std::get_if(&var)) + return s->heapAlloc; + return false; + } + bool isPointer() const { + if (auto *s = std::get_if(&var)) + return s->pointer; + return false; + } + bool isTarget() const { + if (auto *s = std::get_if(&var)) + return s->target; + return false; + } - const Fortran::semantics::Symbol &getSymbol() const { return *sym; } + /// 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(&var)) + return s->aliaser; + return false; + } + std::size_t getAlias() const { + if (auto *s = std::get_if(&var)) + return s->aliasOffset; + return 0; + } + void setAlias(std::size_t offset) { + if (auto *s = std::get_if(&var)) { + s->aliaser = true; + s->aliasOffset = offset; + } else { + llvm_unreachable("not a nominal var"); + } + } - bool isGlobal() const { return global; } - bool isHeapAlloc() const { return heapAlloc; } - bool isPointer() const { return pointer; } - bool isTarget() const { return target; } - int getDepth() const { return depth; } + void setHeapAlloc(bool to = true) { + if (auto *s = std::get_if(&var)) + s->heapAlloc = to; + else + llvm_unreachable("not a nominal var"); + } + void setPointer(bool to = true) { + if (auto *s = std::get_if(&var)) + s->pointer = to; + else + llvm_unreachable("not a nominal var"); + } + void setTarget(bool to = true) { + if (auto *s = std::get_if(&var)) + s->target = to; + else + llvm_unreachable("not a nominal var"); + } - void setHeapAlloc(bool to = true) { heapAlloc = to; } - void setPointer(bool to = true) { pointer = to; } - void setTarget(bool to = true) { target = to; } + /// The depth is recorded for nominal variables as a debugging aid. + int getDepth() const { + if (auto *s = std::get_if(&var)) + return s->depth; + return 0; + } + + LLVM_DUMP_METHOD void dump() const; private: - const Fortran::semantics::Symbol *sym; - int depth; - bool global; - bool heapAlloc{false}; // variable needs deallocation on exit - bool pointer{false}; - bool target{false}; + std::variant var; }; /// Function-like units may contain evaluations (executable statements) and @@ -401,22 +553,30 @@ parser::Statement>; FunctionLikeUnit( - const parser::MainProgram &f, const ParentVariant &parentVariant, + const parser::MainProgram &f, const PftNode &parent, const Fortran::semantics::SemanticsContext &semanticsContext); FunctionLikeUnit( - const parser::FunctionSubprogram &f, const ParentVariant &parentVariant, + const parser::FunctionSubprogram &f, const PftNode &parent, const Fortran::semantics::SemanticsContext &semanticsContext); FunctionLikeUnit( - const parser::SubroutineSubprogram &f, const ParentVariant &parentVariant, + const parser::SubroutineSubprogram &f, const PftNode &parent, const Fortran::semantics::SemanticsContext &semanticsContext); FunctionLikeUnit( - const parser::SeparateModuleSubprogram &f, - const ParentVariant &parentVariant, + const parser::SeparateModuleSubprogram &f, const PftNode &parent, const Fortran::semantics::SemanticsContext &semanticsContext); FunctionLikeUnit(FunctionLikeUnit &&) = default; FunctionLikeUnit(const FunctionLikeUnit &) = delete; - void processSymbolTable(const Fortran::semantics::Scope &); + /// 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 getOrderedSymbolTable() { return varList[0]; } @@ -433,18 +593,36 @@ return stmtSourceLoc(endStmt); } - /// Returns reference to the subprogram symbol of this FunctionLikeUnit. - /// Dies if the FunctionLikeUnit is not a subprogram. + 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 { - assert(symbol && "not inside a procedure"); + auto *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; }}); } + LLVM_DUMP_METHOD void dump() const; + /// Anonymous programs do not have a begin statement std::optional beginStmt; FunctionStatement endStmt; @@ -452,11 +630,20 @@ LabelEvalMap labelEvaluationMap; SymbolLabelMap assignSymbolLabelMap; std::list nestedFunctions; - /// Symbol associated to this FunctionLikeUnit. - /// Null if the FunctionLikeUnit is an anonymous program. - /// The symbol has MainProgramDetails for named programs, otherwise it has - /// SubprogramDetails. - const semantics::Symbol *symbol{nullptr}; + /// 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, 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 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> varList; @@ -471,44 +658,66 @@ parser::Statement, parser::Statement>; - ModuleLikeUnit(const parser::Module &m, const ParentVariant &parentVariant); - ModuleLikeUnit(const parser::Submodule &m, - const ParentVariant &parentVariant); + 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 getOrderedSymbolTable() { return varList[0]; } + ModuleStatement beginStmt; ModuleStatement endStmt; std::list nestedFunctions; + std::vector> varList; }; +/// Block data units contain the variables and data initializers for common +/// blocks, etc. struct BlockDataUnit : public ProgramUnit { - BlockDataUnit(const parser::BlockData &bd, - const ParentVariant &parentVariant); + 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; }; /// A Program is the top-level root of the PFT. struct Program { - using Units = std::variant; + using Units = std::variant; Program() = default; Program(Program &&) = default; Program(const Program &) = delete; + const std::list &getUnits() const { return units; } std::list &getUnits() { return units; } /// LLVM dump method on a Program. - void dump(); + LLVM_DUMP_METHOD void dump() const; private: std::list units; }; -} // namespace pft +} // 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. @@ -522,9 +731,8 @@ const Fortran::semantics::SemanticsContext &semanticsContext); /// Dumper for displaying a PFT. -void dumpPFT(llvm::raw_ostream &outputStream, pft::Program &pft); +void dumpPFT(llvm::raw_ostream &outputStream, const pft::Program &pft); -} // namespace lower -} // namespace Fortran +} // namespace Fortran::lower #endif // FORTRAN_LOWER_PFTBUILDER_H Index: flang/include/flang/Lower/PFTDefs.h =================================================================== --- /dev/null +++ flang/include/flang/Lower/PFTDefs.h @@ -0,0 +1,62 @@ +//===-- Lower/PFTDefs.h -- shared PFT info ----------------------*- 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/ +// +//===----------------------------------------------------------------------===// + +#ifndef FORTRAN_LOWER_PFTDEFS_H +#define FORTRAN_LOWER_PFTDEFS_H + +#include "llvm/ADT/DenseMap.h" +#include "llvm/ADT/SmallSet.h" +#include "llvm/ADT/StringRef.h" + +namespace mlir { +class Block; +} + +namespace Fortran { +namespace semantics { +class Symbol; +class SemanticsContext; +class Scope; +} // namespace semantics + +namespace evaluate { +template +class Expr; +struct SomeType; +} // namespace evaluate + +namespace common { +template +class Reference; +} + +namespace lower { + +bool definedInCommonBlock(const semantics::Symbol &sym); +bool defaultRecursiveFunctionSetting(); + +namespace pft { + +struct Evaluation; + +using SomeExpr = Fortran::evaluate::Expr; +using SymbolRef = Fortran::common::Reference; +using Label = std::uint64_t; +using LabelSet = llvm::SmallSet; +using SymbolLabelMap = llvm::DenseMap; +using LabelEvalMap = llvm::DenseMap; + +} // namespace pft +} // namespace lower +} // namespace Fortran + +#endif // FORTRAN_LOWER_PFTDEFS_H Index: flang/include/flang/Lower/Support/Utils.h =================================================================== --- /dev/null +++ flang/include/flang/Lower/Support/Utils.h @@ -0,0 +1,49 @@ +//===-- Lower/Support/Utils.h -- utilities ----------------------*- 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/ +// +//===----------------------------------------------------------------------===// + +#ifndef FORTRAN_LOWER_SUPPORT_UTILS_H +#define FORTRAN_LOWER_SUPPORT_UTILS_H + +#include "flang/Common/indirection.h" +#include "flang/Parser/char-block.h" +#include "mlir/Dialect/StandardOps/IR/Ops.h" +#include "mlir/IR/BuiltinAttributes.h" +#include "llvm/ADT/StringRef.h" +#include + +//===----------------------------------------------------------------------===// +// Small inline helper functions to deal with repetitive, clumsy conversions. +//===----------------------------------------------------------------------===// + +/// Convert an F18 CharBlock to an LLVM StringRef. +inline llvm::StringRef toStringRef(const Fortran::parser::CharBlock &cb) { + return {cb.begin(), cb.size()}; +} + +namespace fir { +/// Return the integer value of a ConstantOp. +inline std::int64_t toInt(mlir::ConstantOp cop) { + return cop.getValue().cast().getValue().getSExtValue(); +} +} // namespace fir + +/// Template helper to remove Fortran::common::Indirection wrappers. +template +const A &removeIndirection(const A &a) { + return a; +} +template +const A &removeIndirection(const Fortran::common::Indirection &a) { + return a.value(); +} + +#endif // FORTRAN_LOWER_SUPPORT_UTILS_H Index: flang/lib/Lower/IntervalSet.h =================================================================== --- /dev/null +++ flang/lib/Lower/IntervalSet.h @@ -0,0 +1,109 @@ +//===-- 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 +#include + +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; + 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 + auto 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 Index: flang/lib/Lower/PFTBuilder.cpp =================================================================== --- flang/lib/Lower/PFTBuilder.cpp +++ flang/lib/Lower/PFTBuilder.cpp @@ -7,17 +7,28 @@ //===----------------------------------------------------------------------===// #include "flang/Lower/PFTBuilder.h" -#include "flang/Lower/Utils.h" +#include "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" +#define DEBUG_TYPE "flang-pft" + static llvm::cl::opt clDisableStructuredFir( "no-structured-fir", llvm::cl::desc("disable generation of structured FIR"), llvm::cl::init(false), llvm::cl::Hidden); +static llvm::cl::opt nonRecursiveProcedures( + "non-recursive-procedures", + llvm::cl::desc("Make procedures non-recursive by default. This was the " + "default for all Fortran standards prior to 2018."), + llvm::cl::init(/*2018 standard=*/false)); + using namespace Fortran; namespace { @@ -66,8 +77,8 @@ PFTBuilder(const semantics::SemanticsContext &semanticsContext) : pgm{std::make_unique()}, semanticsContext{ semanticsContext} { - lower::pft::ParentVariant parent{*pgm.get()}; - parentVariantStack.push_back(parent); + lower::pft::PftNode pftRoot{*pgm.get()}; + pftParentStack.push_back(pftRoot); } /// Get the result @@ -83,24 +94,65 @@ } else if constexpr (UnwrapStmt::isStmt) { using T = typename UnwrapStmt::Type; // Node "a" being visited has one of the following types: - // Statement, Statement, UnlabeledStatement, + // Statement, Statement>, UnlabeledStatement, // or UnlabeledStatement> auto stmt{UnwrapStmt(a)}; if constexpr (lower::pft::isConstructStmt || lower::pft::isOtherStmt) { - addEvaluation(lower::pft::Evaluation{stmt.unwrapped, - parentVariantStack.back(), - stmt.position, stmt.label}); + addEvaluation(lower::pft::Evaluation{ + stmt.unwrapped, pftParentStack.back(), stmt.position, stmt.label}); return false; } else if constexpr (std::is_same_v) { - addEvaluation( - makeEvaluationAction(stmt.unwrapped, stmt.position, stmt.label)); - return true; + return std::visit( + common::visitors{ + [&](const common::Indirection &x) { + convertIfStmt(x.value(), stmt.position, stmt.label); + return false; + }, + [&](const auto &x) { + addEvaluation(lower::pft::Evaluation{ + removeIndirection(x), pftParentStack.back(), + stmt.position, stmt.label}); + return true; + }, + }, + stmt.unwrapped.u); } } return true; } + /// Convert an IfStmt into an IfConstruct, retaining the IfStmt as the + /// first statement of the construct. + void convertIfStmt(const parser::IfStmt &ifStmt, parser::CharBlock position, + std::optional label) { + // Generate a skeleton IfConstruct parse node. Its components are never + // referenced. The actual components are available via the IfConstruct + // evaluation's nested evaluationList, with the ifStmt in the position of + // the otherwise normal IfThenStmt. Caution: All other PFT nodes reference + // front end generated parse nodes; this is an exceptional case. + static const auto ifConstruct = parser::IfConstruct{ + parser::Statement{ + std::nullopt, + parser::IfThenStmt{ + std::optional{}, + parser::ScalarLogicalExpr{parser::LogicalExpr{parser::Expr{ + parser::LiteralConstant{parser::LogicalLiteralConstant{ + false, std::optional{}}}}}}}}, + parser::Block{}, std::list{}, + std::optional{}, + parser::Statement{std::nullopt, + parser::EndIfStmt{std::nullopt}}}; + enterConstructOrDirective(ifConstruct); + addEvaluation( + lower::pft::Evaluation{ifStmt, pftParentStack.back(), position, label}); + Pre(std::get>(ifStmt.t)); + static const auto endIfStmt = parser::EndIfStmt{std::nullopt}; + addEvaluation( + lower::pft::Evaluation{endIfStmt, pftParentStack.back(), {}, {}}); + exitConstructOrDirective(); + } + template constexpr void Post(const A &) { if constexpr (lower::pft::isFunctionLike) { @@ -120,25 +172,16 @@ // Block data bool Pre(const parser::BlockData &node) { - addUnit(lower::pft::BlockDataUnit{node, parentVariantStack.back()}); + addUnit(lower::pft::BlockDataUnit{node, pftParentStack.back(), + semanticsContext}); return false; } // Get rid of production wrapper - bool Pre(const parser::UnlabeledStatement - &statement) { - addEvaluation(std::visit( - [&](const auto &x) { - return lower::pft::Evaluation{ - x, parentVariantStack.back(), statement.source, {}}; - }, - statement.statement.u)); - return false; - } bool Pre(const parser::Statement &statement) { addEvaluation(std::visit( [&](const auto &x) { - return lower::pft::Evaluation{x, parentVariantStack.back(), + return lower::pft::Evaluation{x, pftParentStack.back(), statement.source, statement.label}; }, statement.statement.u)); @@ -151,7 +194,7 @@ // Not caught as other AssignmentStmt because it is not // wrapped in a parser::ActionStmt. addEvaluation(lower::pft::Evaluation{stmt.statement, - parentVariantStack.back(), + pftParentStack.back(), stmt.source, stmt.label}); return false; }, @@ -160,30 +203,69 @@ whereBody.u); } + // CompilerDirective have special handling in case they are top level + // directives (i.e. they do not belong to a ProgramUnit). + bool Pre(const parser::CompilerDirective &directive) { + assert(pftParentStack.size() > 0 && + "At least the Program must be a parent"); + if (pftParentStack.back().isA()) { + addUnit( + lower::pft::CompilerDirectiveUnit(directive, pftParentStack.back())); + return false; + } + return enterConstructOrDirective(directive); + } + private: /// Initialize a new module-like unit and make it the builder's focus. template bool enterModule(const A &func) { auto &unit = - addUnit(lower::pft::ModuleLikeUnit{func, parentVariantStack.back()}); + addUnit(lower::pft::ModuleLikeUnit{func, pftParentStack.back()}); functionList = &unit.nestedFunctions; - parentVariantStack.emplace_back(unit); + pftParentStack.emplace_back(unit); return true; } void exitModule() { - parentVariantStack.pop_back(); + pftParentStack.pop_back(); resetFunctionState(); } - /// Ensure that a function has a branch target after the last user statement. + /// 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 (lastLexicalEvaluation) { - static const parser::ContinueStmt endTarget{}; - addEvaluation( - lower::pft::Evaluation{endTarget, parentVariantStack.back(), {}, {}}); - lastLexicalEvaluation = nullptr; + if (evaluationListStack.empty()) + return; + auto evaluationList = evaluationListStack.back(); + if (evaluationList->empty() || !evaluationList->back().isEndStmt()) { + const auto &endStmt = + pftParentStack.back().get().endStmt; + endStmt.visit(common::visitors{ + [&](const parser::Statement &s) { + addEvaluation(lower::pft::Evaluation{ + s.statement, pftParentStack.back(), s.source, s.label}); + }, + [&](const parser::Statement &s) { + addEvaluation(lower::pft::Evaluation{ + s.statement, pftParentStack.back(), s.source, s.label}); + }, + [&](const parser::Statement &s) { + addEvaluation(lower::pft::Evaluation{ + s.statement, pftParentStack.back(), s.source, s.label}); + }, + [&](const parser::Statement &s) { + addEvaluation(lower::pft::Evaluation{ + s.statement, pftParentStack.back(), s.source, s.label}); + }, + [&](const auto &s) { + llvm::report_fatal_error("missing end statement or unexpected " + "begin statement reference"); + }, + }); } + lastLexicalEvaluation = nullptr; } /// Initialize a new function-like unit and make it the builder's focus. @@ -192,47 +274,50 @@ const semantics::SemanticsContext &semanticsContext) { endFunctionBody(); // enclosing host subprogram body, if any auto &unit = addFunction(lower::pft::FunctionLikeUnit{ - func, parentVariantStack.back(), semanticsContext}); + func, pftParentStack.back(), semanticsContext}); labelEvaluationMap = &unit.labelEvaluationMap; assignSymbolLabelMap = &unit.assignSymbolLabelMap; functionList = &unit.nestedFunctions; pushEvaluationList(&unit.evaluationList); - parentVariantStack.emplace_back(unit); + pftParentStack.emplace_back(unit); return true; } void exitFunction() { + rewriteIfGotos(); endFunctionBody(); analyzeBranches(nullptr, *evaluationListStack.back()); // add branch links + processEntryPoints(); popEvaluationList(); labelEvaluationMap = nullptr; assignSymbolLabelMap = nullptr; - parentVariantStack.pop_back(); + pftParentStack.pop_back(); resetFunctionState(); } /// Initialize a new construct and make it the builder's focus. template bool enterConstructOrDirective(const A &construct) { - auto &eval = addEvaluation( - lower::pft::Evaluation{construct, parentVariantStack.back()}); + auto &eval = + addEvaluation(lower::pft::Evaluation{construct, pftParentStack.back()}); eval.evaluationList.reset(new lower::pft::EvaluationList); pushEvaluationList(eval.evaluationList.get()); - parentVariantStack.emplace_back(eval); + pftParentStack.emplace_back(eval); constructAndDirectiveStack.emplace_back(&eval); return true; } void exitConstructOrDirective() { + rewriteIfGotos(); popEvaluationList(); - parentVariantStack.pop_back(); + pftParentStack.pop_back(); constructAndDirectiveStack.pop_back(); } /// Reset function state to that of an enclosing host function. void resetFunctionState() { - if (!parentVariantStack.empty()) { - parentVariantStack.back().visit(common::visitors{ + if (!pftParentStack.empty()) { + pftParentStack.back().visit(common::visitors{ [&](lower::pft::FunctionLikeUnit &p) { functionList = &p.nestedFunctions; labelEvaluationMap = &p.labelEvaluationMap; @@ -270,9 +355,8 @@ return std::visit( common::visitors{ [&](const auto &x) { - return lower::pft::Evaluation{removeIndirection(x), - parentVariantStack.back(), position, - label}; + return lower::pft::Evaluation{ + removeIndirection(x), pftParentStack.back(), position, label}; }, }, statement.u); @@ -281,13 +365,13 @@ /// Append an Evaluation to the end of the current list. lower::pft::Evaluation &addEvaluation(lower::pft::Evaluation &&eval) { assert(functionList && "not in a function"); - assert(evaluationListStack.size() > 0); - if (constructAndDirectiveStack.size() > 0) { + 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()) { + if (p->isActionStmt() || p->isConstructStmt() || p->isEndStmt()) { if (lastLexicalEvaluation) { lastLexicalEvaluation->lexicalSuccessor = p; p->printIndex = lastLexicalEvaluation->printIndex + 1; @@ -295,18 +379,28 @@ p->printIndex = 1; } lastLexicalEvaluation = p; + for (auto 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()) { + const auto *sym = std::get(entryStmt->t).symbol; + assert(sym->has() && + "entry must be a subprogram"); + entryPointList.push_back(std::pair{sym, p}); } - if (p->label.has_value()) { + 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 *eval) { + void pushEvaluationList(lower::pft::EvaluationList *evaluationList) { assert(functionList && "not in a function"); - assert(eval && eval->empty() && "evaluation list isn't correct"); - evaluationListStack.emplace_back(eval); + assert(evaluationList && evaluationList->empty() && + "evaluation list isn't correct"); + evaluationListStack.emplace_back(evaluationList); } /// pop the current list and return to the last Evaluation list @@ -315,25 +409,119 @@ evaluationListStack.pop_back(); } + /// Rewrite IfConstructs containing a GotoStmt to eliminate an unstructured + /// branch and a trivial basic block. The pre-branch-analysis code: + /// + /// <> + /// 1 If[Then]Stmt: if(cond) goto L + /// 2 GotoStmt: goto L + /// 3 EndIfStmt + /// <> + /// 4 Statement: ... + /// 5 Statement: ... + /// 6 Statement: L ... + /// + /// becomes: + /// + /// <> + /// 1 If[Then]Stmt [negate]: if(cond) goto L + /// 4 Statement: ... + /// 5 Statement: ... + /// 3 EndIfStmt + /// <> + /// 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. + /// + /// 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 { + lower::pft::EvaluationList::iterator ifConstructIt; + parser::Label ifTargetLabel; + }; + llvm::SmallVector ifExpansionStack; + auto &evaluationList = *evaluationListStack.back(); + for (auto it = evaluationList.begin(), end = evaluationList.end(); + it != end; ++it) { + auto &eval = *it; + if (eval.isA()) { + ifExpansionStack.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); + if (successorIt != it) { + auto &ifBodyList = *ifConstructIt->evaluationList; + auto gotoStmtIt = std::next(ifBodyList.begin()); + assert(gotoStmtIt->isA() && "expected GotoStmt"); + ifBodyList.erase(gotoStmtIt); + auto &ifStmt = *ifBodyList.begin(); + ifStmt.negateCondition = true; + ifStmt.lexicalSuccessor = firstStmt(&*successorIt); + auto 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(); + } + } + if (eval.isA() && eval.evaluationList->size() == 3) { + if (auto *gotoStmt = std::next(eval.evaluationList->begin()) + ->getIf()) + ifExpansionStack.push_back({it, gotoStmt->v}); + } + } + } + /// Mark I/O statement ERR, EOR, and END specifier branch targets. + /// Mark an I/O statement with an assigned format as unstructured. template void analyzeIoBranches(lower::pft::Evaluation &eval, const A &stmt) { - auto processIfLabel{[&](const auto &specs) { - using LabelNodes = - std::tuple; - for (const auto &spec : specs) { - const auto *label = std::visit( - [](const auto &label) -> const parser::Label * { - using B = std::decay_t; - if constexpr (common::HasMember) { - return &label.v; - } - return nullptr; - }, + auto analyzeFormatSpec = [&](const parser::Format &format) { + if (const auto *expr = std::get_if(&format.u)) { + if (semantics::ExprHasTypeCategory(*semantics::GetExpr(*expr), + common::TypeCategory::Integer)) + eval.isUnstructured = true; + } + }; + auto analyzeSpecs{[&](const auto &specList) { + for (const auto &spec : specList) { + std::visit( + Fortran::common::visitors{ + [&](const Fortran::parser::Format &format) { + analyzeFormatSpec(format); + }, + [&](const auto &label) { + using LabelNodes = + std::tuple; + if constexpr (common::HasMember) + markBranchTarget(eval, label.v); + }}, spec.u); - - if (label) - markBranchTarget(eval, *label); } }}; @@ -344,11 +532,17 @@ if constexpr (std::is_same_v || std::is_same_v) { - processIfLabel(stmt.controls); + if (stmt.format) + analyzeFormatSpec(*stmt.format); + analyzeSpecs(stmt.controls); + } else if constexpr (std::is_same_v) { + analyzeFormatSpec(std::get(stmt.t)); } else if constexpr (std::is_same_v) { - processIfLabel(std::get>(stmt.u)); + if (const auto *specList = + std::get_if>(&stmt.u)) + analyzeSpecs(*specList); } else if constexpr (common::HasMember) { - processIfLabel(stmt.v); + analyzeSpecs(stmt.v); } else { // Always crash if this is instantiated static_assert(!std::is_same_v, @@ -365,16 +559,15 @@ void markBranchTarget(lower::pft::Evaluation &sourceEvaluation, lower::pft::Evaluation &targetEvaluation) { sourceEvaluation.isUnstructured = true; - if (!sourceEvaluation.controlSuccessor) { + 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; - if (targetEvaluation.isConstructStmt() && + if (targetConstruct && &targetConstruct->getFirstNestedEvaluation() == &targetEvaluation) // A branch to an initial constructStmt is a branch to the construct. targetConstruct = targetConstruct->parentConstruct; @@ -423,16 +616,15 @@ parser::TypeGuardStmt, parser::WhereConstructStmt>; if constexpr (common::HasMember) { - if (auto name{std::get>(stmt.t)}) + if (auto name = std::get>(stmt.t)) return name->ToString(); } // These statements have several std::optional if constexpr (std::is_same_v || std::is_same_v) { - if (auto name{std::get<0>(stmt.t)}) { + if (auto name = std::get<0>(stmt.t)) return name->ToString(); - } } return {}; } @@ -442,10 +634,9 @@ template void insertConstructName(const A &stmt, lower::pft::Evaluation *parentConstruct) { - std::string name{getConstructName(stmt)}; - if (!name.empty()) { + std::string name = getConstructName(stmt); + if (!name.empty()) constructNameMap[name] = parentConstruct; - } } /// Insert branch links for a list of Evaluations. @@ -453,24 +644,23 @@ /// top-level statements of a program. void analyzeBranches(lower::pft::Evaluation *parentConstruct, std::list &evaluationList) { - lower::pft::Evaluation *lastConstructStmtEvaluation{nullptr}; - lower::pft::Evaluation *lastIfStmtEvaluation{nullptr}; + lower::pft::Evaluation *lastConstructStmtEvaluation{}; for (auto &eval : evaluationList) { eval.visit(common::visitors{ - // Action statements + // Action statements (except I/O statements) [&](const parser::CallStmt &s) { // Look for alternate return specifiers. - const auto &args{std::get>(s.v.t)}; + const auto &args = + std::get>(s.v.t); for (const auto &arg : args) { - const auto &actual{std::get(arg.t)}; - if (const auto *altReturn{ - std::get_if(&actual.u)}) { + const auto &actual = std::get(arg.t); + if (const auto *altReturn = + std::get_if(&actual.u)) markBranchTarget(eval, altReturn->v); - } } }, [&](const parser::CycleStmt &s) { - std::string name{getConstructName(s)}; + std::string name = getConstructName(s); lower::pft::Evaluation *construct{name.empty() ? doConstructStack.back() : constructNameMap[name]}; @@ -478,7 +668,7 @@ markBranchTarget(eval, construct->evaluationList->back()); }, [&](const parser::ExitStmt &s) { - std::string name{getConstructName(s)}; + std::string name = getConstructName(s); lower::pft::Evaluation *construct{name.empty() ? doConstructStack.back() : constructNameMap[name]}; @@ -486,7 +676,10 @@ markBranchTarget(eval, *construct->constructExit); }, [&](const parser::GotoStmt &s) { markBranchTarget(eval, s.v); }, - [&](const parser::IfStmt &) { lastIfStmtEvaluation = &eval; }, + [&](const parser::IfStmt &) { + eval.lexicalSuccessor->isNewBlock = true; + lastConstructStmtEvaluation = &eval; + }, [&](const parser::ReturnStmt &) { eval.isUnstructured = true; if (eval.lexicalSuccessor->lexicalSuccessor) @@ -498,20 +691,13 @@ markSuccessorAsNewBlock(eval); }, [&](const parser::ComputedGotoStmt &s) { - for (auto &label : std::get>(s.t)) { + for (auto &label : std::get>(s.t)) markBranchTarget(eval, label); - } }, [&](const parser::ArithmeticIfStmt &s) { markBranchTarget(eval, std::get<1>(s.t)); markBranchTarget(eval, std::get<2>(s.t)); markBranchTarget(eval, std::get<3>(s.t)); - if (semantics::ExprHasTypeCategory( - *semantics::GetExpr(std::get(s.t)), - common::TypeCategory::Real)) { - // Real expression evaluation uses an additional local block. - eval.localBlocks.emplace_back(nullptr); - } }, [&](const parser::AssignStmt &s) { // legacy label assignment auto &label = std::get(s.t); @@ -520,9 +706,8 @@ lower::pft::Evaluation *target{ labelEvaluationMap->find(label)->second}; assert(target && "missing branch target evaluation"); - if (!target->isA()) { + if (!target->isA()) target->isNewBlock = true; - } auto iter = assignSymbolLabelMap->find(*sym); if (iter == assignSymbolLabelMap->end()) { lower::pft::LabelSet labelSet{}; @@ -569,60 +754,47 @@ [&](const parser::NonLabelDoStmt &s) { insertConstructName(s, parentConstruct); doConstructStack.push_back(parentConstruct); - auto &control{std::get>(s.t)}; - // eval.block is the loop preheader block, which will be set - // elsewhere if the NonLabelDoStmt is itself a target. - // eval.localBlocks[0] is the loop header block. - eval.localBlocks.emplace_back(nullptr); - if (!control.has_value()) { + const auto &loopControl = + std::get>(s.t); + if (!loopControl.has_value()) { eval.isUnstructured = true; // infinite loop return; } eval.nonNopSuccessor().isNewBlock = true; eval.controlSuccessor = &evaluationList.back(); - if (std::holds_alternative(control->u)) { + if (const auto *bounds = + std::get_if(&loopControl->u)) { + if (bounds->name.thing.symbol->GetType()->IsNumeric( + common::TypeCategory::Real)) + eval.isUnstructured = true; // real-valued loop control + } else if (std::get_if( + &loopControl->u)) { eval.isUnstructured = true; // while loop } - // Defer additional processing for an unstructured concurrent loop - // to the EndDoStmt, when the loop is known to be unstructured. }, [&](const parser::EndDoStmt &) { - lower::pft::Evaluation &doEval{evaluationList.front()}; + lower::pft::Evaluation &doEval = evaluationList.front(); eval.controlSuccessor = &doEval; doConstructStack.pop_back(); - if (parentConstruct->lowerAsStructured()) { + if (parentConstruct->lowerAsStructured()) return; - } - // Now that the loop is known to be unstructured, finish concurrent - // loop processing, using NonLabelDoStmt information. + // The loop is unstructured, which wasn't known for all cases when + // visiting the NonLabelDoStmt. parentConstruct->constructExit->isNewBlock = true; - const auto &doStmt{doEval.getIf()}; - assert(doStmt && "missing NonLabelDoStmt"); - auto &control{ - std::get>(doStmt->t)}; - if (!control.has_value()) { + const auto &doStmt = *doEval.getIf(); + const auto &loopControl = + std::get>(doStmt.t); + if (!loopControl.has_value()) return; // infinite loop - } - const auto *concurrent{ - std::get_if(&control->u)}; - if (!concurrent) { - return; - } - // Unstructured concurrent loop. NonLabelDoStmt code accounts - // for one concurrent loop dimension. Reserve preheader, - // header, and latch blocks for the remaining dimensions, and - // one block for a mask expression. - const auto &header{ - std::get(concurrent->t)}; - auto dims{std::get>(header.t) - .size()}; - for (; dims > 1; --dims) { - doEval.localBlocks.emplace_back(nullptr); // preheader - doEval.localBlocks.emplace_back(nullptr); // header - eval.localBlocks.emplace_back(nullptr); // latch - } - if (std::get>(header.t)) { - doEval.localBlocks.emplace_back(nullptr); // mask + if (const auto *concurrent = + std::get_if( + &loopControl->u)) { + // If there is a mask, the EndDoStmt starts a new block. + const auto &header = + std::get(concurrent->t); + eval.isNewBlock |= + std::get>(header.t) + .has_value(); } }, [&](const parser::IfThenStmt &s) { @@ -642,9 +814,8 @@ lastConstructStmtEvaluation = nullptr; }, [&](const parser::EndIfStmt &) { - if (parentConstruct->lowerAsUnstructured()) { + if (parentConstruct->lowerAsUnstructured()) parentConstruct->constructExit->isNewBlock = true; - } if (lastConstructStmtEvaluation) { lastConstructStmtEvaluation->controlSuccessor = parentConstruct->constructExit; @@ -689,37 +860,22 @@ eval.isUnstructured = true; }, + // Default - Common analysis for I/O statements; otherwise nop. [&](const auto &stmt) { using A = std::decay_t; - using IoStmts = std::tuple; - if constexpr (common::HasMember) { + 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) analyzeIoBranches(eval, stmt); - } - - /* do nothing */ }, }); // Analyze construct evaluations. - if (eval.evaluationList) { + if (eval.evaluationList) analyzeBranches(&eval, *eval.evaluationList); - } - - // Insert branch links for an unstructured IF statement. - if (lastIfStmtEvaluation && lastIfStmtEvaluation != &eval) { - // eval is the action substatement of an IfStmt. - if (eval.lowerAsUnstructured()) { - eval.isNewBlock = true; - markSuccessorAsNewBlock(eval); - lastIfStmtEvaluation->isUnstructured = true; - } - lastIfStmtEvaluation->controlSuccessor = &eval.nonNopSuccessor(); - lastIfStmtEvaluation = nullptr; - } // Set the successor of the last statement in an IF or SELECT block. if (!eval.controlSuccessor && eval.lexicalSuccessor && @@ -729,141 +885,184 @@ } // Propagate isUnstructured flag to enclosing construct. - if (parentConstruct && eval.isUnstructured) { + if (parentConstruct && eval.isUnstructured) parentConstruct->isUnstructured = true; - } // The successor of a branch starts a new block. if (eval.controlSuccessor && eval.isActionStmt() && - eval.lowerAsUnstructured()) { + eval.lowerAsUnstructured()) markSuccessorAsNewBlock(eval); + } + } + + /// 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(); + int entryCount = unit->entryPointList.size(); + if (entryCount == 1) + return; + llvm::DenseMap dummyCountMap; + for (int entryIndex = 0; entryIndex < entryCount; ++entryIndex) { + unit->setActiveEntry(entryIndex); + const auto &details = + unit->getSubprogramSymbol().get(); + for (auto *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(); + 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); } std::unique_ptr pgm; - std::vector parentVariantStack; + std::vector 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. - std::list *functionList{nullptr}; + std::list *functionList{}; std::vector constructAndDirectiveStack{}; std::vector doConstructStack{}; /// evaluationListStack is the current nested construct evaluationList state. std::vector evaluationListStack{}; - llvm::DenseMap *labelEvaluationMap{ - nullptr}; - lower::pft::SymbolLabelMap *assignSymbolLabelMap{nullptr}; + llvm::DenseMap *labelEvaluationMap{}; + lower::pft::SymbolLabelMap *assignSymbolLabelMap{}; std::map constructNameMap{}; - lower::pft::Evaluation *lastLexicalEvaluation{nullptr}; + lower::pft::Evaluation *lastLexicalEvaluation{}; }; class PFTDumper { public: - void dumpPFT(llvm::raw_ostream &outputStream, lower::pft::Program &pft) { + void dumpPFT(llvm::raw_ostream &outputStream, + const lower::pft::Program &pft) { for (auto &unit : pft.getUnits()) { std::visit(common::visitors{ - [&](lower::pft::BlockDataUnit &unit) { + [&](const lower::pft::BlockDataUnit &unit) { outputStream << getNodeIndex(unit) << " "; outputStream << "BlockData: "; - outputStream << "\nEndBlockData\n\n"; + outputStream << "\nEnd BlockData\n\n"; }, - [&](lower::pft::FunctionLikeUnit &func) { + [&](const lower::pft::FunctionLikeUnit &func) { dumpFunctionLikeUnit(outputStream, func); }, - [&](lower::pft::ModuleLikeUnit &unit) { + [&](const lower::pft::ModuleLikeUnit &unit) { dumpModuleLikeUnit(outputStream, unit); }, + [&](const lower::pft::CompilerDirectiveUnit &unit) { + dumpCompilerDirectiveUnit(outputStream, unit); + }, }, unit); } } - llvm::StringRef evaluationName(lower::pft::Evaluation &eval) { - return eval.visit(common::visitors{ - [](const auto &parseTreeNode) { - return parser::ParseTreeDumper::GetNodeName(parseTreeNode); - }, + llvm::StringRef evaluationName(const lower::pft::Evaluation &eval) { + return eval.visit([](const auto &parseTreeNode) { + return parser::ParseTreeDumper::GetNodeName(parseTreeNode); }); } - void dumpEvaluationList(llvm::raw_ostream &outputStream, - lower::pft::EvaluationList &evaluationList, - int indent = 1) { - static const std::string white{" ++"}; - std::string indentString{white.substr(0, indent * 2)}; - for (lower::pft::Evaluation &eval : evaluationList) { - 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 << "<>\n"; - continue; - } - outputStream << indentString; - if (eval.printIndex) { - outputStream << eval.printIndex << ' '; - } - if (eval.isNewBlock) { - outputStream << '^'; - } - if (eval.localBlocks.size()) { - outputStream << '*'; - } - outputStream << name << bang; - if (eval.isActionStmt() || eval.isConstructStmt()) { - if (eval.controlSuccessor) { - outputStream << " -> " << eval.controlSuccessor->printIndex; - } - } - if (eval.position.size()) { - outputStream << ": " << eval.position.ToString(); - } + 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 << "<>\n"; + return; } + 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() && eval.lexicalSuccessor) { + outputStream << " -> " << eval.lexicalSuccessor->printIndex; + } + if (!eval.position.empty()) + outputStream << ": " << eval.position.ToString(); + outputStream << '\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) + dumpEvaluation(outputStream, eval, indentString, indent); } - void dumpFunctionLikeUnit(llvm::raw_ostream &outputStream, - lower::pft::FunctionLikeUnit &functionLikeUnit) { + void + dumpFunctionLikeUnit(llvm::raw_ostream &outputStream, + const lower::pft::FunctionLikeUnit &functionLikeUnit) { outputStream << getNodeIndex(functionLikeUnit) << " "; - llvm::StringRef unitKind{}; - std::string name{}; - std::string header{}; + llvm::StringRef unitKind; + llvm::StringRef name; + llvm::StringRef header; if (functionLikeUnit.beginStmt) { functionLikeUnit.beginStmt->visit(common::visitors{ - [&](const parser::Statement &statement) { + [&](const parser::Statement &stmt) { unitKind = "Program"; - name = statement.statement.v.ToString(); + name = toStringRef(stmt.statement.v.source); }, - [&](const parser::Statement &statement) { + [&](const parser::Statement &stmt) { unitKind = "Function"; - name = std::get(statement.statement.t).ToString(); - header = statement.source.ToString(); + name = toStringRef(std::get(stmt.statement.t).source); + header = toStringRef(stmt.source); }, - [&](const parser::Statement &statement) { + [&](const parser::Statement &stmt) { unitKind = "Subroutine"; - name = std::get(statement.statement.t).ToString(); - header = statement.source.ToString(); + name = toStringRef(std::get(stmt.statement.t).source); + header = toStringRef(stmt.source); }, - [&](const parser::Statement &statement) { + [&](const parser::Statement &stmt) { unitKind = "MpSubprogram"; - name = statement.statement.v.ToString(); - header = statement.source.ToString(); + name = toStringRef(stmt.statement.v.source); + header = toStringRef(stmt.source); }, - [&](const auto &) {}, + [&](const auto &) { llvm_unreachable("not a valid begin stmt"); }, }); } else { unitKind = "Program"; name = ""; } outputStream << unitKind << ' ' << name; - if (header.size()) + if (!header.empty()) outputStream << ": " << header; outputStream << '\n'; dumpEvaluationList(outputStream, functionLikeUnit.evaluationList); @@ -871,28 +1070,38 @@ outputStream << "\nContains\n"; for (auto &func : functionLikeUnit.nestedFunctions) dumpFunctionLikeUnit(outputStream, func); - outputStream << "EndContains\n"; + outputStream << "End Contains\n"; } - outputStream << "End" << unitKind << ' ' << name << "\n\n"; + outputStream << "End " << unitKind << ' ' << name << "\n\n"; } void dumpModuleLikeUnit(llvm::raw_ostream &outputStream, - lower::pft::ModuleLikeUnit &moduleLikeUnit) { + const lower::pft::ModuleLikeUnit &moduleLikeUnit) { outputStream << getNodeIndex(moduleLikeUnit) << " "; outputStream << "ModuleLike: "; outputStream << "\nContains\n"; for (auto &func : moduleLikeUnit.nestedFunctions) dumpFunctionLikeUnit(outputStream, func); - outputStream << "EndContains\nEndModuleLike\n\n"; + outputStream << "End Contains\nEnd ModuleLike\n\n"; + } + + // Top level directives + void dumpCompilerDirectiveUnit( + llvm::raw_ostream &outputStream, + const lower::pft::CompilerDirectiveUnit &directive) { + outputStream << getNodeIndex(directive) << " "; + outputStream << "CompilerDirective: !"; + outputStream << directive.get() + .source.ToString(); + outputStream << "\nEnd CompilerDirective\n\n"; } template std::size_t getNodeIndex(const T &node) { - auto addr{static_cast(&node)}; - auto it{nodeIndexes.find(addr)}; - if (it != nodeIndexes.end()) { + auto addr = static_cast(&node); + auto it = nodeIndexes.find(addr); + if (it != nodeIndexes.end()) return it->second; - } nodeIndexes.try_emplace(addr, nextIndex); return nextIndex++; } @@ -919,12 +1128,9 @@ return result; } -static const semantics::Symbol *getSymbol( - std::optional &beginStmt) { - if (!beginStmt) - return nullptr; - - const auto *symbol = beginStmt->visit(common::visitors{ +template +static const semantics::Symbol *getSymbol(A &beginStmt) { + const auto *symbol = beginStmt.visit(common::visitors{ [](const parser::Statement &stmt) -> const semantics::Symbol * { return stmt.statement.v.symbol; }, [](const parser::Statement &stmt) @@ -937,8 +1143,14 @@ }, [](const parser::Statement &stmt) -> const semantics::Symbol * { return stmt.statement.v.symbol; }, + [](const parser::Statement &stmt) + -> const semantics::Symbol * { return stmt.statement.v.symbol; }, + [](const parser::Statement &stmt) + -> const semantics::Symbol * { + return std::get(stmt.statement.t).symbol; + }, [](const auto &) -> const semantics::Symbol * { - llvm_unreachable("unknown FunctionLike beginStmt"); + llvm_unreachable("unknown FunctionLike or ModuleLike beginStmt"); return nullptr; }}); assert(symbol && "parser::Name must have resolved symbol"); @@ -955,13 +1167,25 @@ lower::pft::FunctionLikeUnit * Fortran::lower::pft::Evaluation::getOwningProcedure() const { - return parentVariant.visit(common::visitors{ + return parent.visit(common::visitors{ [](lower::pft::FunctionLikeUnit &c) { return &c; }, [&](lower::pft::Evaluation &c) { return c.getOwningProcedure(); }, [](auto &) -> lower::pft::FunctionLikeUnit * { return nullptr; }, }); } +bool Fortran::lower::definedInCommonBlock(const semantics::Symbol &sym) { + return semantics::FindCommonBlockContaining(sym); +} + +/// Is the symbol `sym` a global? +static bool symbolIsGlobal(const semantics::Symbol &sym) { + if (const auto *details = sym.detailsIf()) + if (details->init()) + return true; + return semantics::IsSaved(sym) || lower::definedInCommonBlock(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 @@ -969,26 +1193,112 @@ /// symbol table, which is sorted by name. struct SymbolDependenceDepth { explicit SymbolDependenceDepth( - std::vector> &vars) - : vars{vars} {} + std::vector> &vars, bool reentrant) + : vars{vars}, reentrant{reentrant} {} + + void analyzeAliasesInCurrentScope(const semantics::Scope &scope) { + for (const auto &iter : scope) { + const auto &ultimate = iter.second.get().GetUltimate(); + if (skipSymbol(ultimate)) + continue; + bool isDeclaration = scope != ultimate.owner(); + analyzeAliases(ultimate.owner(), isDeclaration); + } + // 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) { + vars[0].emplace_back(std::move(st)); + } + } + // 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) { + if (scope.equivalenceSets().empty()) + return; + if (scopeAnlyzedForAliases.find(&scope) != scopeAnlyzedForAliases.end()) + return; + scopeAnlyzedForAliases.insert(&scope); + Fortran::lower::IntervalSet intervals; + llvm::DenseMap> + aliasSets; + llvm::DenseMap 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}); + } + } + + // 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); + } + } + } + } // 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; } - if (sym.has() || - sym.has() || - sym.has() || - sym.has()) { - // FIXME: do we want to do anything with any of these? + auto ultimate = sym.GetUltimate(); + if (!ultimate.has() && + !ultimate.has()) return 0; - } + + if (sym.has()) + llvm_unreachable("not yet implemented - derived type analysis"); // Symbol must be something lowering will have to allocate. bool global = semantics::IsSaved(sym); @@ -998,9 +1308,12 @@ // check CHARACTER's length if (symTy->category() == semantics::DeclTypeSpec::Character) - if (auto e = symTy->characterTypeSpec().length().GetExplicit()) + if (auto e = symTy->characterTypeSpec().length().GetExplicit()) { + // turn variable into a global if this unit is not reentrant + global = global || !reentrant; for (const auto &s : evaluate::CollectSymbols(*e)) depth = std::max(analyze(s) + 1, depth); + } if (const auto *details = sym.detailsIf()) { auto doExplicit = [&](const auto &bound) { @@ -1011,11 +1324,15 @@ } }; // handle any symbols in array bound declarations + if (!details->shape().empty()) + global = global || !reentrant; for (const auto &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()) { doExplicit(subs.lbound()); doExplicit(subs.ubound()); @@ -1030,23 +1347,69 @@ } adjustSize(depth + 1); vars[depth].emplace_back(sym, global, depth); - if (Fortran::semantics::IsAllocatable(sym)) + if (semantics::IsAllocatable(sym)) vars[depth].back().setHeapAlloc(); - if (Fortran::semantics::IsPointer(sym)) + if (semantics::IsPointer(sym)) vars[depth].back().setPointer(); - if (sym.attrs().test(Fortran::semantics::Attr::TARGET)) + 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)) { + vars[depth].back().setAlias(store->getOffset()); + } return depth; } - // Save the final list of symbols as a single vector and free the rest. + /// 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(); + // 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)) + 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"; + 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) { + return !sym.has() || + lower::definedInCommonBlock(sym); + } + // Make sure the table is of appropriate size. void adjustSize(std::size_t size) { if (vars.size() < size) @@ -1055,93 +1418,102 @@ llvm::SmallSet seen; std::vector> &vars; + llvm::SmallSet aliasSyms; + llvm::SmallSet scopeAnlyzedForAliases; + std::vector stores; + bool reentrant; }; } // namespace -void Fortran::lower::pft::FunctionLikeUnit::processSymbolTable( - const semantics::Scope &scope) { - // TODO: handle equivalence and common blocks - if (!scope.equivalenceSets().empty()) { - llvm::errs() << "TODO: equivalence not yet handled in lowering.\n" - << "note: equivalence used in " - << (scope.GetName() && !scope.GetName()->empty() - ? scope.GetName()->ToString() - : "unnamed program"s) - << "\n"; - exit(1); - } - SymbolDependenceDepth sdd{varList}; +static void processSymbolTable( + const semantics::Scope &scope, + std::vector> &varList, + bool reentrant) { + SymbolDependenceDepth sdd{varList, reentrant}; + sdd.analyzeAliasesInCurrentScope(scope); for (const auto &iter : scope) sdd.analyze(iter.second.get()); sdd.finalize(); } Fortran::lower::pft::FunctionLikeUnit::FunctionLikeUnit( - const parser::MainProgram &func, const lower::pft::ParentVariant &parent, + const parser::MainProgram &func, const lower::pft::PftNode &parent, const semantics::SemanticsContext &semanticsContext) : ProgramUnit{func, parent}, endStmt{ getFunctionStmt( func)} { - const auto &ps{ - std::get>>(func.t)}; - if (ps.has_value()) { - FunctionStatement begin{ps.value()}; - beginStmt = begin; - symbol = getSymbol(beginStmt); - processSymbolTable(*symbol->scope()); + const auto &programStmt = + std::get>>(func.t); + if (programStmt.has_value()) { + beginStmt = FunctionStatement(programStmt.value()); + auto symbol = getSymbol(*beginStmt); + entryPointList[0].first = symbol; + processSymbolTable(*symbol->scope(), varList, isRecursive()); } else { - processSymbolTable(semanticsContext.FindScope( - std::get>(func.t).source)); + processSymbolTable( + semanticsContext.FindScope( + std::get>(func.t).source), + varList, isRecursive()); } } Fortran::lower::pft::FunctionLikeUnit::FunctionLikeUnit( - const parser::FunctionSubprogram &func, - const lower::pft::ParentVariant &parent, + const parser::FunctionSubprogram &func, const lower::pft::PftNode &parent, const semantics::SemanticsContext &) : ProgramUnit{func, parent}, beginStmt{getFunctionStmt(func)}, - endStmt{getFunctionStmt(func)}, symbol{getSymbol( - beginStmt)} { - processSymbolTable(*symbol->scope()); + endStmt{getFunctionStmt(func)} { + auto symbol = getSymbol(*beginStmt); + entryPointList[0].first = symbol; + processSymbolTable(*symbol->scope(), varList, isRecursive()); } Fortran::lower::pft::FunctionLikeUnit::FunctionLikeUnit( - const parser::SubroutineSubprogram &func, - const lower::pft::ParentVariant &parent, + const parser::SubroutineSubprogram &func, const lower::pft::PftNode &parent, const semantics::SemanticsContext &) : ProgramUnit{func, parent}, beginStmt{getFunctionStmt(func)}, - endStmt{getFunctionStmt(func)}, - symbol{getSymbol(beginStmt)} { - processSymbolTable(*symbol->scope()); + endStmt{getFunctionStmt(func)} { + auto symbol = getSymbol(*beginStmt); + entryPointList[0].first = symbol; + processSymbolTable(*symbol->scope(), varList, isRecursive()); } Fortran::lower::pft::FunctionLikeUnit::FunctionLikeUnit( const parser::SeparateModuleSubprogram &func, - const lower::pft::ParentVariant &parent, - const semantics::SemanticsContext &) + const lower::pft::PftNode &parent, const semantics::SemanticsContext &) : ProgramUnit{func, parent}, beginStmt{getFunctionStmt(func)}, - endStmt{getFunctionStmt(func)}, - symbol{getSymbol(beginStmt)} { - processSymbolTable(*symbol->scope()); + endStmt{getFunctionStmt(func)} { + auto symbol = getSymbol(*beginStmt); + entryPointList[0].first = symbol; + processSymbolTable(*symbol->scope(), varList, isRecursive()); } Fortran::lower::pft::ModuleLikeUnit::ModuleLikeUnit( - const parser::Module &m, const lower::pft::ParentVariant &parent) + const parser::Module &m, const lower::pft::PftNode &parent) : ProgramUnit{m, parent}, beginStmt{getModuleStmt(m)}, - endStmt{getModuleStmt(m)} {} + endStmt{getModuleStmt(m)} { + auto symbol = getSymbol(beginStmt); + processSymbolTable(*symbol->scope(), varList, /*reentrant=*/false); +} Fortran::lower::pft::ModuleLikeUnit::ModuleLikeUnit( - const parser::Submodule &m, const lower::pft::ParentVariant &parent) + const parser::Submodule &m, const lower::pft::PftNode &parent) : ProgramUnit{m, parent}, beginStmt{getModuleStmt( m)}, - endStmt{getModuleStmt(m)} {} + endStmt{getModuleStmt(m)} { + auto symbol = getSymbol(beginStmt); + processSymbolTable(*symbol->scope(), varList, /*reentrant=*/false); +} Fortran::lower::pft::BlockDataUnit::BlockDataUnit( - const parser::BlockData &bd, const lower::pft::ParentVariant &parent) - : ProgramUnit{bd, parent} {} + const parser::BlockData &bd, const lower::pft::PftNode &parent, + const semantics::SemanticsContext &semanticsContext) + : ProgramUnit{bd, parent}, + symTab{semanticsContext.FindScope( + std::get>(bd.t).source)} { +} std::unique_ptr Fortran::lower::createPFT(const parser::Program &root, @@ -1151,9 +1523,67 @@ return walker.result(); } +// FIXME: FlangDriver +// This option should be integrated with the real driver as the default of +// RECURSIVE vs. NON_RECURSIVE may be changed by other command line options, +// etc., etc. +bool Fortran::lower::defaultRecursiveFunctionSetting() { + return !nonRecursiveProcedures; +} + void Fortran::lower::dumpPFT(llvm::raw_ostream &outputStream, - lower::pft::Program &pft) { + const lower::pft::Program &pft) { PFTDumper{}.dumpPFT(outputStream, pft); } -void Fortran::lower::pft::Program::dump() { dumpPFT(llvm::errs(), *this); } +void Fortran::lower::pft::Program::dump() const { + dumpPFT(llvm::errs(), *this); +} + +void Fortran::lower::pft::Evaluation::dump() const { + PFTDumper{}.dumpEvaluation(llvm::errs(), *this); +} + +void Fortran::lower::pft::Variable::dump() const { + if (auto *s = std::get_if(&var)) { + llvm::errs() << "symbol: " << s->symbol->name(); + llvm::errs() << " (depth: " << s->depth << ')'; + if (s->global) + llvm::errs() << ", global"; + if (s->heapAlloc) + llvm::errs() << ", allocatable"; + 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(&var)) { + llvm::errs() << "interval[" << std::get<0>(s->interval) << ", " + << std::get<1>(s->interval) << "]:"; + 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() << '}'; + } + } 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"; +} Index: flang/test/Lower/pre-fir-tree01.f90 =================================================================== --- flang/test/Lower/pre-fir-tree01.f90 +++ flang/test/Lower/pre-fir-tree01.f90 @@ -20,8 +20,9 @@ ! CHECK: EndDoStmt end do ! CHECK: <> +! CHECK: EndSubroutineStmt end subroutine -! CHECK: EndSubroutine foo +! CHECK: End Subroutine foo ! CHECK: BlockData block data @@ -29,7 +30,7 @@ integer, dimension(n) :: a, b, c common /arrays/ a, b, c end -! CHECK: EndBlockData +! CHECK: End BlockData ! CHECK: ModuleLike module test_mod @@ -44,49 +45,57 @@ contains ! CHECK: Subroutine foo subroutine foo() + ! CHECK: EndSubroutineStmt contains ! CHECK: Subroutine subfoo subroutine subfoo() - end subroutine - ! CHECK: EndSubroutine subfoo + ! CHECK: EndSubroutineStmt + 9 end subroutine + ! CHECK: End Subroutine subfoo ! CHECK: Function subfoo2 function subfoo2() - end function - ! CHECK: EndFunction subfoo2 + ! CHECK: EndFunctionStmt + 9 end function + ! CHECK: End Function subfoo2 end subroutine - ! CHECK: EndSubroutine foo + ! CHECK: End Subroutine foo ! CHECK: Function foo2 function foo2(i, j) integer i, j, foo2 ! CHECK: AssignmentStmt foo2 = i + j + ! CHECK: EndFunctionStmt contains ! CHECK: Subroutine subfoo subroutine subfoo() + ! CHECK: EndSubroutineStmt end subroutine - ! CHECK: EndSubroutine subfoo + ! CHECK: End Subroutine subfoo end function - ! CHECK: EndFunction foo2 + ! CHECK: End Function foo2 end module -! CHECK: EndModuleLike +! CHECK: End ModuleLike ! CHECK: ModuleLike submodule (test_mod) test_mod_impl contains ! CHECK: Subroutine foo subroutine foo() + ! CHECK: EndSubroutineStmt contains ! CHECK: Subroutine subfoo subroutine subfoo() + ! CHECK: EndSubroutineStmt end subroutine - ! CHECK: EndSubroutine subfoo + ! CHECK: End Subroutine subfoo ! CHECK: Function subfoo2 function subfoo2() + ! CHECK: EndFunctionStmt end function - ! CHECK: EndFunction subfoo2 + ! CHECK: End Function subfoo2 end subroutine - ! CHECK: EndSubroutine foo + ! CHECK: End Subroutine foo ! CHECK: MpSubprogram dump module procedure dump ! CHECK: FormatStmt @@ -105,19 +114,34 @@ ! CHECK: <> end procedure end submodule -! CHECK: EndModuleLike +! CHECK: End ModuleLike ! CHECK: BlockData block data named_block integer i, j, k common /indexes/ i, j, k end -! CHECK: EndBlockData +! CHECK: End BlockData ! CHECK: Function bar function bar() +! CHECK: EndFunctionStmt end function -! CHECK: EndFunction bar +! 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: <> + ! CHECK: <> +end subroutine +! CHECK: EndSubroutine ! CHECK: Program ! check specification parts are not part of the PFT. @@ -127,4 +151,4 @@ ! CHECK: AllocateStmt allocate(x(foo2(10, 30))) end -! CHECK: EndProgram +! CHECK: End Program Index: flang/test/Lower/pre-fir-tree02.f90 =================================================================== --- flang/test/Lower/pre-fir-tree02.f90 +++ flang/test/Lower/pre-fir-tree02.f90 @@ -146,12 +146,15 @@ ! CHECK: ModuleLike module test - type :: a_type - integer :: x - end type - type, extends(a_type) :: b_type - integer :: y - end type + !! When derived type processing is implemented, remove all instances of: + !! - !![disable] + !! - COM: + !![disable]type :: a_type + !![disable] integer :: x + !![disable]end type + !![disable]type, extends(a_type) :: b_type + !![disable] integer :: y + !![disable]end type contains ! CHECK: Function foo function foo(x) @@ -191,12 +194,12 @@ type is (integer) ! CHECK: AssignmentStmt bar = 0 - ! CHECK: TypeGuardStmt - class is (a_type) - ! CHECK: AssignmentStmt - bar = 1 - ! CHECK: ReturnStmt - return + !![disable]! COM: CHECK: TypeGuardStmt + !![disable]class is (a_type) + !![disable] ! COM: CHECK: AssignmentStmt + !![disable] bar = 1 + !![disable] ! COM: CHECK: ReturnStmt + !![disable] return ! CHECK: TypeGuardStmt class default ! CHECK: AssignmentStmt @@ -329,6 +332,5 @@ subroutine sub4() integer :: i print*, "test" - ! CHECK: DataStmt data i /1/ end subroutine Index: flang/test/Lower/pre-fir-tree04.f90 =================================================================== --- flang/test/Lower/pre-fir-tree04.f90 +++ flang/test/Lower/pre-fir-tree04.f90 @@ -1,4 +1,4 @@ -! RUN: %f18 -fdebug-pre-fir-tree -fsyntax-only %s | FileCheck %s +! RUN: %flang_fc1 -fsyntax-only -fdebug-pre-fir-tree %s | FileCheck %s ! Test Pre-FIR Tree captures all the coarray related statements Index: flang/test/Lower/pre-fir-tree05.f90 =================================================================== --- flang/test/Lower/pre-fir-tree05.f90 +++ flang/test/Lower/pre-fir-tree05.f90 @@ -27,9 +27,9 @@ !$acc end parallel ! CHECK-NEXT: <> ! CHECK-NEXT: <> - ! CHECK-NEXT: ContinueStmt + ! CHECK-NEXT: EndSubroutineStmt end subroutine -! CHECK-NEXT: EndSubroutine foo +! CHECK-NEXT: End Subroutine foo ! CHECK: Subroutine foo subroutine foo2() @@ -43,7 +43,7 @@ end do !$acc end parallel loop ! CHECK-NEXT: <> - ! CHECK-NEXT: ContinueStmt + ! CHECK-NEXT: EndSubroutineStmt end subroutine -! CHECK-NEXT: EndSubroutine foo2 +! CHECK-NEXT: End Subroutine foo2