diff --git a/flang/include/flang/Lower/HostAssociations.h b/flang/include/flang/Lower/HostAssociations.h new file mode 100644 --- /dev/null +++ b/flang/include/flang/Lower/HostAssociations.h @@ -0,0 +1,68 @@ +//===-- Lower/HostAssociations.h --------------------------------*- C++ -*-===// +// +// Part of the LLVM Project, under the Apache License v2.0 with LLVM Exceptions. +// See https://llvm.org/LICENSE.txt for license information. +// SPDX-License-Identifier: Apache-2.0 WITH LLVM-exception +// +//===----------------------------------------------------------------------===// + +#ifndef FORTRAN_LOWER_HOSTASSOCIATIONS_H +#define FORTRAN_LOWER_HOSTASSOCIATIONS_H + +#include "mlir/IR/Location.h" +#include "mlir/IR/Types.h" +#include "mlir/IR/Value.h" +#include "llvm/ADT/SetVector.h" + +namespace Fortran { +namespace semantics { +class Symbol; +} + +namespace lower { +class AbstractConverter; +class SymMap; + +/// Internal procedures in Fortran may access variables declared in the host +/// procedure directly. We bundle these variables together in a tuple and pass +/// them as an extra argument. +class HostAssociations { +public: + /// Returns true iff there are no host associations. + bool empty() const { return symbols.empty(); } + + /// Adds a set of Symbols that will be the host associated bindings for this + /// host procedure. + void addSymbolsToBind( + const llvm::SetVector &s) { + assert(empty() && "symbol set must be initially empty"); + symbols = s; + } + + /// Code gen the FIR for the local bindings for the host associated symbols + /// for the host (parent) procedure using `builder`. + void hostProcedureBindings(AbstractConverter &converter, SymMap &symMap); + + /// Code gen the FIR for the local bindings for the host associated symbols + /// for an internal (child) procedure using `builder`. + void internalProcedureBindings(AbstractConverter &converter, SymMap &symMap); + + /// Return the type of the extra argument to add to each internal procedure. + mlir::Type getArgumentType(AbstractConverter &convert); + + /// Is \p symbol host associated ? + bool isAssociated(const Fortran::semantics::Symbol &symbol) const { + return symbols.contains(&symbol); + } + +private: + /// Canonical vector of host associated symbols. + llvm::SetVector symbols; + + /// The type of the extra argument to be added to each internal procedure. + mlir::Type argType; +}; +} // namespace lower +} // namespace Fortran + +#endif // FORTRAN_LOWER_HOSTASSOCIATIONS_H diff --git a/flang/include/flang/Lower/IntervalSet.h b/flang/include/flang/Lower/IntervalSet.h new file mode 100644 --- /dev/null +++ b/flang/include/flang/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 + std::size_t cu = std::prev(j)->second; + // cu < j->first + if (cu > up) + up = cu; + m.erase(i, j); + // merge [i .. j) with [i->first, max(up, cu)] + m.insert({lo, up}); + } + + MAP m{}; +}; + +} // namespace Fortran::lower + +#endif // FORTRAN_LOWER_INTERVALSET_H diff --git a/flang/include/flang/Lower/PFTBuilder.h b/flang/include/flang/Lower/PFTBuilder.h --- a/flang/include/flang/Lower/PFTBuilder.h +++ b/flang/include/flang/Lower/PFTBuilder.h @@ -19,9 +19,11 @@ #include "flang/Common/reference.h" #include "flang/Common/template.h" +#include "flang/Lower/HostAssociations.h" #include "flang/Lower/PFTDefs.h" #include "flang/Parser/parse-tree.h" #include "flang/Semantics/attr.h" +#include "flang/Semantics/scope.h" #include "flang/Semantics/symbol.h" #include "llvm/Support/ErrorHandling.h" #include "llvm/Support/raw_ostream.h" @@ -62,7 +64,7 @@ } template constexpr BaseType *getIf() const { - auto *ptr = std::get_if>(&u); + const Ref *ptr = std::get_if>(&u); return ptr ? &ptr->get() : nullptr; } template @@ -106,8 +108,7 @@ 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, @@ -134,7 +135,11 @@ using Directives = std::tuple; + parser::OpenACCDeclarativeConstruct, parser::OpenMPConstruct, + parser::OpenMPDeclarativeConstruct, parser::OmpEndLoopDirective>; + +using DeclConstructs = std::tuple; template static constexpr bool isActionStmt{common::HasMember}; @@ -154,6 +159,9 @@ template static constexpr bool isDirective{common::HasMember}; +template +static constexpr bool isDeclConstruct{common::HasMember}; + template static constexpr bool isIntermediateConstructStmt{common::HasMember< A, std::tuple static constexpr bool isNopConstructStmt{common::HasMember< - A, std::tuple>}; + A, std::tuple>}; + +template +static constexpr bool isExecutableDirective{common::HasMember< + A, std::tuple>}; template static constexpr bool isFunctionLike{common::HasMember< @@ -244,6 +256,11 @@ return pft::isNopConstructStmt>; }}); } + constexpr bool isExecutableDirective() const { + return visit(common::visitors{[](auto &r) { + return pft::isExecutableDirective>; + }}); + } /// Return the predicate: "This is a non-initial, non-terminal construct /// statement." For an IfConstruct, this is ElseIfStmt and ElseStmt. @@ -295,11 +312,12 @@ // FIR generation looks primarily at PFT ActionStmt and ConstructStmt leaf // nodes. Members such as lexicalSuccessor and block are applicable only - // to these nodes. The controlSuccessor member is used for nonlexical - // successors, such as linking to a GOTO target. For multiway branches, - // it is set to the first target. Successor and exit links always target - // statements. An internal Construct node has a constructExit link that - // applies to exits from anywhere within the construct. + // to these nodes, plus some directives. The controlSuccessor member is + // used for nonlexical successors, such as linking to a GOTO target. For + // multiway branches, it is set to the first target. Successor and exit + // links always target statements or directives. An internal Construct + // node has a constructExit link that applies to exits from anywhere within + // the construct. // // An unstructured construct is one that contains some form of goto. This // is indicated by the isUnstructured member flag, which may be set on a @@ -327,8 +345,8 @@ std::optional label{}; std::unique_ptr evaluationList; // nested evaluations Evaluation *parentConstruct{nullptr}; // set for nodes below the top level - Evaluation *lexicalSuccessor{nullptr}; // set for ActionStmt, ConstructStmt - Evaluation *controlSuccessor{nullptr}; // set for some statements + Evaluation *lexicalSuccessor{nullptr}; // set for leaf nodes, some directives + Evaluation *controlSuccessor{nullptr}; // set for some leaf nodes Evaluation *constructExit{nullptr}; // set for constructs bool isNewBlock{false}; // evaluation begins a new basic block bool isUnstructured{false}; // evaluation has unstructured control flow @@ -354,13 +372,6 @@ PftNode parent; }; -/// Helper to get location from FunctionLikeUnit/ModuleLikeUnit begin/end -/// statements. -template -static parser::CharBlock stmtSourceLoc(const T &stmt) { - return stmt.visit(common::visitors{[](const auto &x) { return x.source; }}); -} - /// A variable captures an object to be created per the declaration part of a /// function like unit. /// @@ -386,9 +397,6 @@ const semantics::Symbol *symbol{}; bool isGlobal() const { return global; } - bool isDeclaration() const { - return !symbol || symbol != &symbol->GetUltimate(); - } int depth{}; bool global{}; @@ -399,32 +407,45 @@ std::size_t aliasOffset{}; }; + /// pair 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; } + 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(); + } + /// of the aggregate in its scope. 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; + /// 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, @@ -463,31 +484,32 @@ return std::visit([](const auto &x) { return x.isGlobal(); }, var); } - /// Is this a declaration of a variable owned by another scope ? - bool isDeclaration() const { - return std::visit([](const auto &x) { return x.isDeclaration(); }, var); + /// Is this a module variable ? + bool isModuleVariable() const { + const semantics::Scope *scope = getOwningScope(); + return scope && scope->IsModule(); } const Fortran::semantics::Scope *getOwningScope() const { return std::visit( common::visitors{ [](const Nominal &x) { return &x.symbol->GetUltimate().owner(); }, - [](const AggregateStore &agg) { return agg.scope; }}, + [](const AggregateStore &agg) { return &agg.getOwningScope(); }}, var); } bool isHeapAlloc() const { - if (const auto *s = std::get_if(&var)) + if (auto *s = std::get_if(&var)) return s->heapAlloc; return false; } bool isPointer() const { - if (const auto *s = std::get_if(&var)) + if (auto *s = std::get_if(&var)) return s->pointer; return false; } bool isTarget() const { - if (const auto *s = std::get_if(&var)) + if (auto *s = std::get_if(&var)) return s->target; return false; } @@ -495,7 +517,7 @@ /// An alias(er) is a variable that is part of a EQUIVALENCE that is allocated /// locally on the stack. bool isAlias() const { - if (const auto *s = std::get_if(&var)) + if (auto *s = std::get_if(&var)) return s->aliaser; return false; } @@ -534,7 +556,7 @@ /// The depth is recorded for nominal variables as a debugging aid. int getDepth() const { - if (const auto *s = std::get_if(&var)) + if (auto *s = std::get_if(&var)) return s->depth; return 0; } @@ -574,17 +596,6 @@ FunctionLikeUnit(FunctionLikeUnit &&) = default; FunctionLikeUnit(const FunctionLikeUnit &) = delete; - /// Return true iff this function like unit is Fortran recursive (actually - /// meaning it's reentrant). - bool isRecursive() const { - if (isMainProgram()) - return false; - const auto &sym = getSubprogramSymbol(); - return sym.attrs().test(semantics::Attr::RECURSIVE) || - (!sym.attrs().test(semantics::Attr::NON_RECURSIVE) && - defaultRecursiveFunctionSetting()); - } - std::vector getOrderedSymbolTable() { return varList[0]; } bool isMainProgram() const { @@ -592,13 +603,7 @@ } /// Get the starting source location for this function like unit - parser::CharBlock getStartingSourceLoc() { - if (beginStmt) - return stmtSourceLoc(*beginStmt); - if (!evaluationList.empty()) - return evaluationList.front().position; - return stmtSourceLoc(endStmt); - } + parser::CharBlock getStartingSourceLoc() const; void setActiveEntry(int entryIndex) { assert(entryIndex >= 0 && entryIndex < (int)entryPointList.size() && @@ -610,7 +615,7 @@ /// This should not be called if the FunctionLikeUnit is the main program /// since anonymous main programs do not have a symbol. const semantics::Symbol &getSubprogramSymbol() const { - const auto *symbol = entryPointList[activeEntry].first; + const semantics::Symbol *symbol = entryPointList[activeEntry].first; if (!symbol) llvm::report_fatal_error( "not inside a procedure; do not call on main program."); @@ -623,11 +628,27 @@ return entryPointList[activeEntry].second; } - /// Helper to get location from FunctionLikeUnit begin/end statements. - static parser::CharBlock stmtSourceLoc(const FunctionStatement &stmt) { - return stmt.visit(common::visitors{[](const auto &x) { return x.source; }}); + //===--------------------------------------------------------------------===// + // Host associations + //===--------------------------------------------------------------------===// + + void setHostAssociatedSymbols( + const llvm::SetVector &symbols) { + hostAssociations.addSymbolsToBind(symbols); } + /// Return the host associations, if any, from the parent (host) procedure. + /// Crashes if the parent is not a procedure. + HostAssociations &parentHostAssoc(); + + /// Return true iff the parent is a procedure and the parent has a non-empty + /// set of host associations. + bool parentHasHostAssoc(); + + /// Return the host associations for this function like unit. The list of host + /// associations are kept in the host procedure. + HostAssociations &getHostAssoc() { return hostAssociations; } + LLVM_DUMP_METHOD void dump() const; /// Anonymous programs do not have a begin statement @@ -647,13 +668,14 @@ /// 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; + 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; + HostAssociations hostAssociations; }; /// Module-like units contain a list of function-like units. @@ -675,9 +697,16 @@ std::vector getOrderedSymbolTable() { return varList[0]; } + /// Get the starting source location for this module like unit. + parser::CharBlock getStartingSourceLoc() const; + + /// Get the module scope. + const Fortran::semantics::Scope &getScope() const; + ModuleStatement beginStmt; ModuleStatement endStmt; std::list nestedFunctions; + EvaluationList evaluationList; std::vector> varList; }; @@ -722,6 +751,33 @@ std::list units; }; +/// Return the list of variables that appears in the specification expressions +/// of a function result. +std::vector +buildFuncResultDependencyList(const Fortran::semantics::Symbol &); + +/// Helper to get location from FunctionLikeUnit/ModuleLikeUnit begin/end +/// statements. +template +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 +ParentType *getAncestor(A &node) { + if (auto *seekedParent = node.parent.template getIf()) + return seekedParent; + return node.parent.visit(common::visitors{ + [](Program &p) -> ParentType * { return nullptr; }, + [](auto &p) -> ParentType * { return getAncestor(p); }}); +} + +/// Call the provided \p callBack on all symbols that are referenced inside \p +/// funit. +void visitAllSymbols(const FunctionLikeUnit &funit, + std::function callBack); + } // namespace Fortran::lower::pft namespace Fortran::lower { @@ -739,7 +795,6 @@ /// Dumper for displaying a PFT. void dumpPFT(llvm::raw_ostream &outputStream, const pft::Program &pft); - } // namespace Fortran::lower #endif // FORTRAN_LOWER_PFTBUILDER_H diff --git a/flang/include/flang/Lower/PFTDefs.h b/flang/include/flang/Lower/PFTDefs.h --- a/flang/include/flang/Lower/PFTDefs.h +++ b/flang/include/flang/Lower/PFTDefs.h @@ -42,6 +42,7 @@ namespace lower { bool definedInCommonBlock(const semantics::Symbol &sym); +bool symbolIsGlobal(const semantics::Symbol &sym); bool defaultRecursiveFunctionSetting(); namespace pft { diff --git a/flang/lib/Lower/PFTBuilder.cpp b/flang/lib/Lower/PFTBuilder.cpp --- a/flang/lib/Lower/PFTBuilder.cpp +++ b/flang/lib/Lower/PFTBuilder.cpp @@ -1,4 +1,4 @@ -//===-- PFTBuilder.cc -----------------------------------------------------===// +//===-- PFTBuilder.cpp ----------------------------------------------------===// // // Part of the LLVM Project, under the Apache License v2.0 with LLVM Exceptions. // See https://llvm.org/LICENSE.txt for license information. @@ -7,7 +7,7 @@ //===----------------------------------------------------------------------===// #include "flang/Lower/PFTBuilder.h" -#include "IntervalSet.h" +#include "flang/Lower/IntervalSet.h" #include "flang/Lower/Support/Utils.h" #include "flang/Parser/dump-parse-tree.h" #include "flang/Parser/parse-tree-visitor.h" @@ -160,6 +160,8 @@ exitFunction(); } else if constexpr (lower::pft::isConstruct || lower::pft::isDirective) { + if constexpr (lower::pft::isDeclConstruct) + return; exitConstructOrDirective(); } } @@ -221,14 +223,17 @@ /// Initialize a new module-like unit and make it the builder's focus. template bool enterModule(const A &func) { - auto &unit = + Fortran::lower::pft::ModuleLikeUnit &unit = addUnit(lower::pft::ModuleLikeUnit{func, pftParentStack.back()}); functionList = &unit.nestedFunctions; + pushEvaluationList(&unit.evaluationList); pftParentStack.emplace_back(unit); return true; } void exitModule() { + if (!evaluationListStack.empty()) + popEvaluationList(); pftParentStack.pop_back(); resetFunctionState(); } @@ -240,6 +245,11 @@ if (evaluationListStack.empty()) return; auto evaluationList = evaluationListStack.back(); + if (evaluationList->empty() && + pftParentStack.back().getIf()) { + popEvaluationList(); + return; + } if (evaluationList->empty() || !evaluationList->back().isEndStmt()) { const auto &endStmt = pftParentStack.back().get().endStmt; @@ -274,8 +284,9 @@ bool enterFunction(const A &func, const semantics::SemanticsContext &semanticsContext) { endFunctionBody(); // enclosing host subprogram body, if any - auto &unit = addFunction(lower::pft::FunctionLikeUnit{ - func, pftParentStack.back(), semanticsContext}); + Fortran::lower::pft::FunctionLikeUnit &unit = + addFunction(lower::pft::FunctionLikeUnit{func, pftParentStack.back(), + semanticsContext}); labelEvaluationMap = &unit.labelEvaluationMap; assignSymbolLabelMap = &unit.assignSymbolLabelMap; functionList = &unit.nestedFunctions; @@ -296,20 +307,38 @@ resetFunctionState(); } - /// Initialize a new construct and make it the builder's focus. + /// Initialize a new construct or directive and make it the builder's focus. template - bool enterConstructOrDirective(const A &construct) { - auto &eval = - addEvaluation(lower::pft::Evaluation{construct, pftParentStack.back()}); + bool enterConstructOrDirective(const A &constructOrDirective) { + Fortran::lower::pft::Evaluation &eval = addEvaluation( + lower::pft::Evaluation{constructOrDirective, pftParentStack.back()}); eval.evaluationList.reset(new lower::pft::EvaluationList); pushEvaluationList(eval.evaluationList.get()); pftParentStack.emplace_back(eval); constructAndDirectiveStack.emplace_back(&eval); + if constexpr (lower::pft::isDeclConstruct) { + popEvaluationList(); + pftParentStack.pop_back(); + constructAndDirectiveStack.pop_back(); + popEvaluationList(); + } return true; } void exitConstructOrDirective() { rewriteIfGotos(); + auto *eval = constructAndDirectiveStack.back(); + if (eval->isExecutableDirective()) { + // A construct at the end of an (unstructured) OpenACC or OpenMP + // construct region must have an exit target inside the region. + Fortran::lower::pft::EvaluationList &evaluationList = + *eval->evaluationList; + if (!evaluationList.empty() && evaluationList.back().isConstruct()) { + static const parser::ContinueStmt exitTarget{}; + addEvaluation( + lower::pft::Evaluation{exitTarget, pftParentStack.back(), {}, {}}); + } + } popEvaluationList(); pftParentStack.pop_back(); constructAndDirectiveStack.pop_back(); @@ -372,7 +401,8 @@ auto &entryPointList = eval.getOwningProcedure()->entryPointList; evaluationListStack.back()->emplace_back(std::move(eval)); lower::pft::Evaluation *p = &evaluationListStack.back()->back(); - if (p->isActionStmt() || p->isConstructStmt() || p->isEndStmt()) { + if (p->isActionStmt() || p->isConstructStmt() || p->isEndStmt() || + p->isExecutableDirective()) { if (lastLexicalEvaluation) { lastLexicalEvaluation->lexicalSuccessor = p; p->printIndex = lastLexicalEvaluation->printIndex + 1; @@ -380,13 +410,14 @@ p->printIndex = 1; } lastLexicalEvaluation = p; - for (auto entryIndex = entryPointList.size() - 1; + for (std::size_t entryIndex = entryPointList.size() - 1; entryIndex && !entryPointList[entryIndex].second->lexicalSuccessor; --entryIndex) // Link to the entry's first executable statement. entryPointList[entryIndex].second->lexicalSuccessor = p; } else if (const auto *entryStmt = p->getIf()) { - const auto *sym = std::get(entryStmt->t).symbol; + const semantics::Symbol *sym = + std::get(entryStmt->t).symbol; assert(sym->has() && "entry must be a subprogram"); entryPointList.push_back(std::pair{sym, p}); @@ -410,8 +441,9 @@ evaluationListStack.pop_back(); } - /// Rewrite IfConstructs containing a GotoStmt to eliminate an unstructured - /// branch and a trivial basic block. The pre-branch-analysis code: + /// Rewrite IfConstructs containing a GotoStmt or CycleStmt to eliminate an + /// unstructured branch and a trivial basic block. The pre-branch-analysis + /// code: /// /// <> /// 1 If[Then]Stmt: if(cond) goto L @@ -433,8 +465,8 @@ /// 6 Statement: L ... /// /// The If[Then]Stmt condition is implicitly negated. It is not modified - /// in the PFT. It must be negated when generating FIR. The GotoStmt is - /// deleted. + /// in the PFT. It must be negated when generating FIR. The GotoStmt or + /// CycleStmt is deleted. /// /// The transformation is only valid for forward branch targets at the same /// construct nesting level as the IfConstruct. The result must not violate @@ -449,56 +481,86 @@ /// not significant, but could be changed. /// void rewriteIfGotos() { - using T = struct { + auto &evaluationList = *evaluationListStack.back(); + if (!evaluationList.size()) + return; + struct T { lower::pft::EvaluationList::iterator ifConstructIt; parser::Label ifTargetLabel; + bool isCycleStmt = false; }; - llvm::SmallVector ifExpansionStack; - auto &evaluationList = *evaluationListStack.back(); + llvm::SmallVector ifCandidateStack; + const auto *doStmt = + evaluationList.begin()->getIf(); + std::string doName = doStmt ? getConstructName(*doStmt) : std::string{}; for (auto it = evaluationList.begin(), end = evaluationList.end(); it != end; ++it) { auto &eval = *it; if (eval.isA()) { - ifExpansionStack.clear(); + ifCandidateStack.clear(); continue; } auto firstStmt = [](lower::pft::Evaluation *e) { return e->isConstruct() ? &*e->evaluationList->begin() : e; }; - auto &targetEval = *firstStmt(&eval); - if (targetEval.label) { - while (!ifExpansionStack.empty() && - ifExpansionStack.back().ifTargetLabel == *targetEval.label) { - auto ifConstructIt = ifExpansionStack.back().ifConstructIt; - auto successorIt = std::next(ifConstructIt); + const Fortran::lower::pft::Evaluation &targetEval = *firstStmt(&eval); + bool targetEvalIsEndDoStmt = targetEval.isA(); + auto branchTargetMatch = [&]() { + if (const parser::Label targetLabel = + ifCandidateStack.back().ifTargetLabel) + if (targetLabel == *targetEval.label) + return true; // goto target match + if (targetEvalIsEndDoStmt && ifCandidateStack.back().isCycleStmt) + return true; // cycle target match + return false; + }; + if (targetEval.label || targetEvalIsEndDoStmt) { + while (!ifCandidateStack.empty() && branchTargetMatch()) { + lower::pft::EvaluationList::iterator ifConstructIt = + ifCandidateStack.back().ifConstructIt; + lower::pft::EvaluationList::iterator successorIt = + std::next(ifConstructIt); if (successorIt != it) { - auto &ifBodyList = *ifConstructIt->evaluationList; - auto gotoStmtIt = std::next(ifBodyList.begin()); - assert(gotoStmtIt->isA() && "expected GotoStmt"); - ifBodyList.erase(gotoStmtIt); - auto &ifStmt = *ifBodyList.begin(); + Fortran::lower::pft::EvaluationList &ifBodyList = + *ifConstructIt->evaluationList; + lower::pft::EvaluationList::iterator branchStmtIt = + std::next(ifBodyList.begin()); + assert((branchStmtIt->isA() || + branchStmtIt->isA()) && + "expected goto or cycle statement"); + ifBodyList.erase(branchStmtIt); + lower::pft::Evaluation &ifStmt = *ifBodyList.begin(); ifStmt.negateCondition = true; ifStmt.lexicalSuccessor = firstStmt(&*successorIt); - auto endIfStmtIt = std::prev(ifBodyList.end()); + lower::pft::EvaluationList::iterator endIfStmtIt = + std::prev(ifBodyList.end()); std::prev(it)->lexicalSuccessor = &*endIfStmtIt; endIfStmtIt->lexicalSuccessor = firstStmt(&*it); ifBodyList.splice(endIfStmtIt, evaluationList, successorIt, it); for (; successorIt != endIfStmtIt; ++successorIt) successorIt->parentConstruct = &*ifConstructIt; } - ifExpansionStack.pop_back(); + ifCandidateStack.pop_back(); } } if (eval.isA() && eval.evaluationList->size() == 3) { - if (auto *gotoStmt = std::next(eval.evaluationList->begin()) - ->getIf()) - ifExpansionStack.push_back({it, gotoStmt->v}); + const auto bodyEval = std::next(eval.evaluationList->begin()); + if (const auto *gotoStmt = bodyEval->getIf()) { + ifCandidateStack.push_back({it, gotoStmt->v}); + } else if (doStmt) { + if (const auto *cycleStmt = bodyEval->getIf()) { + std::string cycleName = getConstructName(*cycleStmt); + if (cycleName.empty() || cycleName == doName) + // This candidate will match doStmt's EndDoStmt. + ifCandidateStack.push_back({it, {}, true}); + } + } } } } - /// Mark I/O statement ERR, EOR, and END specifier branch targets. - /// Mark an I/O statement with an assigned format as unstructured. + /// Mark IO statement ERR, EOR, and END specifier branch targets. + /// Mark an IO statement with an assigned format as unstructured. template void analyzeIoBranches(lower::pft::Evaluation &eval, const A &stmt) { auto analyzeFormatSpec = [&](const parser::Format &format) { @@ -566,8 +628,8 @@ // If this is a branch into the body of a construct (usually illegal, // but allowed in some legacy cases), then the targetEvaluation and its // ancestors must be marked as unstructured. - auto *sourceConstruct = sourceEvaluation.parentConstruct; - auto *targetConstruct = targetEvaluation.parentConstruct; + lower::pft::Evaluation *sourceConstruct = sourceEvaluation.parentConstruct; + lower::pft::Evaluation *targetConstruct = targetEvaluation.parentConstruct; if (targetConstruct && &targetConstruct->getFirstNestedEvaluation() == &targetEvaluation) // A branch to an initial constructStmt is a branch to the construct. @@ -575,9 +637,18 @@ if (targetConstruct) { while (sourceConstruct && sourceConstruct != targetConstruct) sourceConstruct = sourceConstruct->parentConstruct; - if (sourceConstruct != targetConstruct) - for (auto *eval = &targetEvaluation; eval; eval = eval->parentConstruct) + if (sourceConstruct != targetConstruct) // branch into a construct body + for (lower::pft::Evaluation *eval = &targetEvaluation; eval; + eval = eval->parentConstruct) { eval->isUnstructured = true; + // If the branch is a backward branch into an already analyzed + // DO or IF construct, mark the construct exit as a new block. + // For a forward branch, the isUnstructured flag will cause this + // to be done when the construct is analyzed. + if (eval->constructExit && (eval->isA() || + eval->isA())) + eval->constructExit->isNewBlock = true; + } } } void markBranchTarget(lower::pft::Evaluation &sourceEvaluation, @@ -615,18 +686,18 @@ parser::MaskedElsewhereStmt, parser::NonLabelDoStmt, parser::SelectCaseStmt, parser::SelectRankCaseStmt, parser::TypeGuardStmt, parser::WhereConstructStmt>; - if constexpr (common::HasMember) { if (auto name = std::get>(stmt.t)) return name->ToString(); } - // These statements have several std::optional + // These statements have multiple std::optional elements. if constexpr (std::is_same_v || std::is_same_v) { if (auto name = std::get<0>(stmt.t)) return name->ToString(); } + return {}; } @@ -648,7 +719,7 @@ lower::pft::Evaluation *lastConstructStmtEvaluation{}; for (auto &eval : evaluationList) { eval.visit(common::visitors{ - // Action statements (except I/O statements) + // Action statements (except IO statements) [&](const parser::CallStmt &s) { // Look for alternate return specifiers. const auto &args = @@ -726,6 +797,11 @@ markSuccessorAsNewBlock(eval); }, + // The first executable statement after an EntryStmt is a new block. + [&](const parser::EntryStmt &) { + eval.lexicalSuccessor->isNewBlock = true; + }, + // Construct statements [&](const parser::AssociateStmt &s) { insertConstructName(s, parentConstruct); @@ -861,7 +937,7 @@ eval.isUnstructured = true; }, - // Default - Common analysis for I/O statements; otherwise nop. + // Default - Common analysis for IO statements; otherwise nop. [&](const auto &stmt) { using A = std::decay_t; using IoStmts = std::tuple< @@ -901,7 +977,8 @@ /// also find one of the largest function results, since a single result /// container holds the result for all entries. void processEntryPoints() { - auto *unit = evaluationListStack.back()->front().getOwningProcedure(); + lower::pft::Evaluation *initialEval = &evaluationListStack.back()->front(); + lower::pft::FunctionLikeUnit *unit = initialEval->getOwningProcedure(); int entryCount = unit->entryPointList.size(); if (entryCount == 1) return; @@ -910,7 +987,7 @@ unit->setActiveEntry(entryIndex); const auto &details = unit->getSubprogramSymbol().get(); - for (auto *arg : details.dummyArgs()) { + for (semantics::Symbol *arg : details.dummyArgs()) { if (!arg) continue; // alternate return specifier (no actual argument) const auto iter = dummyCountMap.find(arg); @@ -920,7 +997,7 @@ ++iter->second; } if (details.isFunction()) { - const auto *resultSym = &details.result(); + const semantics::Symbol *resultSym = &details.result(); assert(resultSym && "missing result symbol"); if (!unit->primaryResult || unit->primaryResult->size() < resultSym->size()) @@ -931,6 +1008,13 @@ for (auto arg : dummyCountMap) if (arg.second < entryCount) unit->nonUniversalDummyArguments.push_back(arg.first); + // The first executable statement in the subprogram is preceded by a + // branch to the entry point, so it starts a new block. + if (initialEval->hasNestedEvaluations()) + initialEval = &initialEval->getFirstNestedEvaluation(); + else if (initialEval->isA()) + initialEval = initialEval->lexicalSuccessor; + initialEval->isNewBlock = true; } std::unique_ptr pgm; @@ -985,33 +1069,32 @@ 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; - } + llvm::StringRef newBlock = eval.isNewBlock ? "^" : ""; + llvm::StringRef bang = eval.isUnstructured ? "!" : ""; outputStream << indentString; if (eval.printIndex) outputStream << eval.printIndex << ' '; - if (eval.isNewBlock) - outputStream << '^'; - outputStream << name << bang; - if (eval.isActionStmt() || eval.isConstructStmt()) { - if (eval.negateCondition) - outputStream << " [negate]"; - if (eval.controlSuccessor) - outputStream << " -> " << eval.controlSuccessor->printIndex; - } else if (eval.isA() && eval.lexicalSuccessor) { + if (eval.hasNestedEvaluations()) + outputStream << "<<" << newBlock << name << bang << ">>"; + else + outputStream << newBlock << name << bang; + if (eval.negateCondition) + outputStream << " [negate]"; + if (eval.constructExit) + outputStream << " -> " << eval.constructExit->printIndex; + else 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(); + else if (auto *dir = eval.getIf()) + outputStream << ": !" << dir->source.ToString(); outputStream << '\n'; + if (eval.hasNestedEvaluations()) { + dumpEvaluationList(outputStream, *eval.evaluationList, indent + 1); + outputStream << indentString << "<>\n"; + } } void dumpEvaluation(llvm::raw_ostream &ostream, @@ -1024,7 +1107,7 @@ int indent = 1) { static const auto white = " ++"s; auto indentString = white.substr(0, indent * 2); - for (const auto &eval : evaluationList) + for (const lower::pft::Evaluation &eval : evaluationList) dumpEvaluation(outputStream, eval, indentString, indent); } @@ -1069,7 +1152,8 @@ dumpEvaluationList(outputStream, functionLikeUnit.evaluationList); if (!functionLikeUnit.nestedFunctions.empty()) { outputStream << "\nContains\n"; - for (auto &func : functionLikeUnit.nestedFunctions) + for (const lower::pft::FunctionLikeUnit &func : + functionLikeUnit.nestedFunctions) dumpFunctionLikeUnit(outputStream, func); outputStream << "End Contains\n"; } @@ -1081,7 +1165,8 @@ outputStream << getNodeIndex(moduleLikeUnit) << " "; outputStream << "ModuleLike: "; outputStream << "\nContains\n"; - for (auto &func : moduleLikeUnit.nestedFunctions) + for (const lower::pft::FunctionLikeUnit &func : + moduleLikeUnit.nestedFunctions) dumpFunctionLikeUnit(outputStream, func); outputStream << "End Contains\nEnd ModuleLike\n\n"; } @@ -1122,6 +1207,7 @@ std::get>(func.t)}; return result; } + template static lower::pft::ModuleLikeUnit::ModuleStatement getModuleStmt(const T &mod) { lower::pft::ModuleLikeUnit::ModuleStatement result{ @@ -1179,12 +1265,39 @@ return semantics::FindCommonBlockContaining(sym); } +static bool isReEntrant(const Fortran::semantics::Scope &scope) { + if (scope.kind() == Fortran::semantics::Scope::Kind::MainProgram) + return false; + if (scope.kind() == Fortran::semantics::Scope::Kind::Subprogram) { + const Fortran::semantics::Symbol *sym = scope.symbol(); + assert(sym && "Subprogram scope must have a symbol"); + return sym->attrs().test(semantics::Attr::RECURSIVE) || + (!sym->attrs().test(semantics::Attr::NON_RECURSIVE) && + Fortran::lower::defaultRecursiveFunctionSetting()); + } + if (scope.kind() == Fortran::semantics::Scope::Kind::Module) + return false; + return true; +} + /// Is the symbol `sym` a global? -static bool symbolIsGlobal(const semantics::Symbol &sym) { - if (const auto *details = sym.detailsIf()) +bool Fortran::lower::symbolIsGlobal(const semantics::Symbol &sym) { + if (const auto *details = sym.detailsIf()) { if (details->init()) return true; - return semantics::IsSaved(sym) || lower::definedInCommonBlock(sym); + if (!isReEntrant(sym.owner())) { + // Turn array and character of non re-entrant programs (like the main + // program) into global memory. + if (const Fortran::semantics::DeclTypeSpec *symTy = sym.GetType()) + if (symTy->category() == semantics::DeclTypeSpec::Character) + if (auto e = symTy->characterTypeSpec().length().GetExplicit()) + return true; + if (!details->shape().empty() || !details->coshape().empty()) + return true; + } + } + return semantics::IsSaved(sym) || lower::definedInCommonBlock(sym) || + semantics::IsNamedConstant(sym); } namespace { @@ -1194,91 +1307,86 @@ /// symbol table, which is sorted by name. struct SymbolDependenceDepth { explicit SymbolDependenceDepth( - std::vector> &vars, bool reentrant) - : vars{vars}, reentrant{reentrant} {} + std::vector> &vars) + : vars{vars} {} void analyzeAliasesInCurrentScope(const semantics::Scope &scope) { + // FIXME: When this function is called on the scope of an internal + // procedure whose parent contains an EQUIVALENCE set and the internal + // procedure uses variables from that EQUIVALENCE set, we end up creating + // an AggregateStore for those variables unnecessarily. + // + /// If this is a function nested in a module no host associated + /// symbol are added to the function scope for module symbols used in this + /// scope. As a result, alias analysis in parent module scopes must be + /// preformed here. + const semantics::Scope *parentScope = &scope; + while (!parentScope->IsGlobal()) { + parentScope = &parentScope->parent(); + if (parentScope->IsModule()) + analyzeAliases(*parentScope); + } for (const auto &iter : scope) { - const auto &ultimate = iter.second.get().GetUltimate(); + const semantics::Symbol &ultimate = iter.second.get().GetUltimate(); if (skipSymbol(ultimate)) continue; - bool isDeclaration = scope != ultimate.owner(); - analyzeAliases(ultimate.owner(), isDeclaration); + analyzeAliases(ultimate.owner()); } // add all aggregate stores to the front of the work list adjustSize(1); // The copy in the loop matters, 'stores' will still be used. - for (auto st : stores) { + for (auto st : stores) vars[0].emplace_back(std::move(st)); - } } + + // Compute the offset of the last byte that resides in the symbol. + inline static std::size_t offsetWidth(const Fortran::semantics::Symbol &sym) { + std::size_t width = sym.offset(); + if (std::size_t size = sym.size()) + width += size - 1; + return width; + } + // Analyze the equivalence sets. This analysis need not be performed when the // scope has no equivalence sets. - void analyzeAliases(const semantics::Scope &scope, bool isDeclaration) { + void analyzeAliases(const semantics::Scope &scope) { if (scope.equivalenceSets().empty()) return; - if (scopeAnlyzedForAliases.find(&scope) != scopeAnlyzedForAliases.end()) + // Don't analyze a scope if it has already been analyzed. + if (analyzedScopes.find(&scope) != analyzedScopes.end()) return; - scopeAnlyzedForAliases.insert(&scope); - Fortran::lower::IntervalSet intervals; - llvm::DenseMap> - 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); + analyzedScopes.insert(&scope); + std::list> aggregates = + Fortran::semantics::GetStorageAssociations(scope); + for (std::list aggregate : aggregates) { + const Fortran::semantics::Symbol *aggregateSym = nullptr; + bool isGlobal = false; + const semantics::Symbol &first = *aggregate.front(); + std::size_t start = first.offset(); + std::size_t end = first.offset() + first.size(); + const Fortran::semantics::Symbol *namingSym = nullptr; + for (semantics::SymbolRef symRef : aggregate) { + const semantics::Symbol &sym = *symRef; + aliasSyms.insert(&sym); + if (sym.test(Fortran::semantics::Symbol::Flag::CompilerCreated)) { + aggregateSym = &sym; } else { - LLVM_DEBUG(llvm::dbgs() << "interval [" << ibgn << ".." << ibgn + ilen - << ") added\n"); - stores.emplace_back(std::move(interval), scope, isDeclaration); + isGlobal |= lower::symbolIsGlobal(sym); + start = std::min(sym.offset(), start); + end = std::max(sym.offset() + sym.size(), end); + if (!namingSym || (sym.name() < namingSym->name())) + namingSym = &sym; } } + assert(namingSym && "must contain at least one user symbol"); + if (!aggregateSym) { + stores.emplace_back( + Fortran::lower::pft::Variable::Interval{start, end - start}, + *namingSym, isGlobal); + } else { + stores.emplace_back(*aggregateSym, *namingSym, isGlobal); + } } } @@ -1293,7 +1401,14 @@ // TODO: add declaration? return 0; } - auto ultimate = sym.GetUltimate(); + semantics::Symbol ultimate = sym.GetUltimate(); + if (const auto *details = + ultimate.detailsIf()) { + // handle namelist group symbols + for (const semantics::SymbolRef &s : details->objects()) + analyze(s); + return 0; + } if (!ultimate.has() && !ultimate.has()) return 0; @@ -1302,21 +1417,22 @@ llvm_unreachable("not yet implemented - derived type analysis"); // Symbol must be something lowering will have to allocate. - bool global = semantics::IsSaved(sym); int depth = 0; - const auto *symTy = sym.GetType(); + const semantics::DeclTypeSpec *symTy = sym.GetType(); assert(symTy && "symbol must have a type"); - // check CHARACTER's length - if (symTy->category() == semantics::DeclTypeSpec::Character) - if (auto e = symTy->characterTypeSpec().length().GetExplicit()) { - // turn variable into a global if this unit is not reentrant - global = global || !reentrant; - for (const auto &s : evaluate::CollectSymbols(*e)) - depth = std::max(analyze(s) + 1, depth); - } - + // Analyze symbols appearing in object entity specification expression. This + // ensures these symbols will be instantiated before the current one. + // This is not done for object entities that are host associated because + // they must be instantiated from the value of the host symbols (the + // specification expressions should not be re-evaluated). if (const auto *details = sym.detailsIf()) { + // check CHARACTER's length + if (symTy->category() == semantics::DeclTypeSpec::Character) + if (auto e = symTy->characterTypeSpec().length().GetExplicit()) + for (const auto &s : evaluate::CollectSymbols(*e)) + depth = std::max(analyze(s) + 1, depth); + auto doExplicit = [&](const auto &bound) { if (bound.isExplicit()) { semantics::SomeExpr e{*bound.GetExplicit()}; @@ -1325,28 +1441,22 @@ } }; // handle any symbols in array bound declarations - if (!details->shape().empty()) - global = global || !reentrant; - for (const auto &subs : details->shape()) { + for (const semantics::ShapeSpec &subs : details->shape()) { doExplicit(subs.lbound()); doExplicit(subs.ubound()); } // handle any symbols in coarray bound declarations - if (!details->coshape().empty()) - global = global || !reentrant; - for (const auto &subs : details->coshape()) { + for (const semantics::ShapeSpec &subs : details->coshape()) { doExplicit(subs.lbound()); doExplicit(subs.ubound()); } // handle any symbols in initialization expressions - if (auto e = details->init()) { - // A PARAMETER may not be marked as implicitly SAVE, so set the flag. - global = true; + if (auto e = details->init()) for (const auto &s : evaluate::CollectSymbols(*e)) depth = std::max(analyze(s) + 1, depth); - } } adjustSize(depth + 1); + bool global = lower::symbolIsGlobal(sym); vars[depth].emplace_back(sym, global, depth); if (semantics::IsAllocatable(sym)) vars[depth].back().setHeapAlloc(); @@ -1357,7 +1467,7 @@ // If there are alias sets, then link the participating variables to their // aggregate stores when constructing the new variable on the list. - if (auto *store = findStoreIfAlias(sym)) { + if (lower::pft::Variable::AggregateStore *store = findStoreIfAlias(sym)) { vars[depth].back().setAlias(store->getOffset()); } return depth; @@ -1373,26 +1483,31 @@ Fortran::lower::pft::Variable::AggregateStore * findStoreIfAlias(const Fortran::evaluate::Symbol &sym) { - const auto &ultimate = sym.GetUltimate(); - const auto &scope = ultimate.owner(); + const semantics::Symbol &ultimate = sym.GetUltimate(); + const semantics::Scope &scope = ultimate.owner(); // Expect the total number of EQUIVALENCE sets to be small for a typical // Fortran program. if (aliasSyms.find(&ultimate) != aliasSyms.end()) { LLVM_DEBUG(llvm::dbgs() << "symbol: " << ultimate << '\n'); LLVM_DEBUG(llvm::dbgs() << "scope: " << scope << '\n'); - auto off = ultimate.offset(); - for (auto &v : stores) { - if (v.scope == &scope) { - auto bot = std::get<0>(v.interval); - if (off >= bot && off < bot + std::get<1>(v.interval)) + std::size_t off = ultimate.offset(); + std::size_t symSize = ultimate.size(); + for (lower::pft::Variable::AggregateStore &v : stores) { + if (&v.getOwningScope() == &scope) { + auto intervalOff = std::get<0>(v.interval); + auto intervalSize = std::get<1>(v.interval); + if (off >= intervalOff && off < intervalOff + intervalSize) + return &v; + // Zero sized symbol in zero sized equivalence. + if (off == intervalOff && symSize == 0) return &v; } } // clang-format off LLVM_DEBUG( llvm::dbgs() << "looking for " << off << "\n{\n"; - for (auto v : stores) { - llvm::dbgs() << " in scope: " << v.scope << "\n"; + for (lower::pft::Variable::AggregateStore &v : stores) { + llvm::dbgs() << " in scope: " << &v.getOwningScope() << "\n"; llvm::dbgs() << " i = [" << std::get<0>(v.interval) << ".." << std::get<0>(v.interval) + std::get<1>(v.interval) << "]\n"; @@ -1407,8 +1522,11 @@ private: /// Skip symbol in alias analysis. bool skipSymbol(const semantics::Symbol &sym) { + // Common block equivalences are largely managed by the front end. + // Compiler generated symbols ('.' names) cannot be equivalenced. + // FIXME: Equivalence code generation may need to be revisited. return !sym.has() || - lower::definedInCommonBlock(sym); + lower::definedInCommonBlock(sym) || sym.name()[0] == '.'; } // Make sure the table is of appropriate size. @@ -1420,23 +1538,26 @@ llvm::SmallSet seen; std::vector> &vars; llvm::SmallSet aliasSyms; - llvm::SmallSet scopeAnlyzedForAliases; + /// Set of Scope that have been analyzed for aliases. + llvm::SmallSet analyzedScopes; std::vector stores; - bool reentrant; }; } // namespace static void processSymbolTable( const semantics::Scope &scope, - std::vector> &varList, - bool reentrant) { - SymbolDependenceDepth sdd{varList, reentrant}; + std::vector> &varList) { + SymbolDependenceDepth sdd{varList}; sdd.analyzeAliasesInCurrentScope(scope); for (const auto &iter : scope) sdd.analyze(iter.second.get()); sdd.finalize(); } +//===----------------------------------------------------------------------===// +// FunctionLikeUnit implementation +//===----------------------------------------------------------------------===// + Fortran::lower::pft::FunctionLikeUnit::FunctionLikeUnit( const parser::MainProgram &func, const lower::pft::PftNode &parent, const semantics::SemanticsContext &semanticsContext) @@ -1447,14 +1568,14 @@ std::get>>(func.t); if (programStmt.has_value()) { beginStmt = FunctionStatement(programStmt.value()); - const auto *symbol = getSymbol(*beginStmt); + const semantics::Symbol *symbol = getSymbol(*beginStmt); entryPointList[0].first = symbol; - processSymbolTable(*symbol->scope(), varList, isRecursive()); + processSymbolTable(*symbol->scope(), varList); } else { processSymbolTable( semanticsContext.FindScope( std::get>(func.t).source), - varList, isRecursive()); + varList); } } @@ -1464,9 +1585,9 @@ : ProgramUnit{func, parent}, beginStmt{getFunctionStmt(func)}, endStmt{getFunctionStmt(func)} { - const auto *symbol = getSymbol(*beginStmt); + const semantics::Symbol *symbol = getSymbol(*beginStmt); entryPointList[0].first = symbol; - processSymbolTable(*symbol->scope(), varList, isRecursive()); + processSymbolTable(*symbol->scope(), varList); } Fortran::lower::pft::FunctionLikeUnit::FunctionLikeUnit( @@ -1475,9 +1596,9 @@ : ProgramUnit{func, parent}, beginStmt{getFunctionStmt(func)}, endStmt{getFunctionStmt(func)} { - const auto *symbol = getSymbol(*beginStmt); + const semantics::Symbol *symbol = getSymbol(*beginStmt); entryPointList[0].first = symbol; - processSymbolTable(*symbol->scope(), varList, isRecursive()); + processSymbolTable(*symbol->scope(), varList); } Fortran::lower::pft::FunctionLikeUnit::FunctionLikeUnit( @@ -1486,17 +1607,43 @@ : ProgramUnit{func, parent}, beginStmt{getFunctionStmt(func)}, endStmt{getFunctionStmt(func)} { - const auto *symbol = getSymbol(*beginStmt); + const semantics::Symbol *symbol = getSymbol(*beginStmt); entryPointList[0].first = symbol; - processSymbolTable(*symbol->scope(), varList, isRecursive()); + processSymbolTable(*symbol->scope(), varList); +} + +Fortran::lower::HostAssociations & +Fortran::lower::pft::FunctionLikeUnit::parentHostAssoc() { + if (auto *par = parent.getIf()) + return par->hostAssociations; + llvm::report_fatal_error("parent is not a function"); } +bool Fortran::lower::pft::FunctionLikeUnit::parentHasHostAssoc() { + if (auto *par = parent.getIf()) + return !par->hostAssociations.empty(); + return false; +} + +parser::CharBlock +Fortran::lower::pft::FunctionLikeUnit::getStartingSourceLoc() const { + if (beginStmt) + return stmtSourceLoc(*beginStmt); + if (!evaluationList.empty()) + return evaluationList.front().position; + return stmtSourceLoc(endStmt); +} + +//===----------------------------------------------------------------------===// +// ModuleLikeUnit implementation +//===----------------------------------------------------------------------===// + Fortran::lower::pft::ModuleLikeUnit::ModuleLikeUnit( const parser::Module &m, const lower::pft::PftNode &parent) : ProgramUnit{m, parent}, beginStmt{getModuleStmt(m)}, endStmt{getModuleStmt(m)} { - const auto *symbol = getSymbol(beginStmt); - processSymbolTable(*symbol->scope(), varList, /*reentrant=*/false); + const semantics::Symbol *symbol = getSymbol(beginStmt); + processSymbolTable(*symbol->scope(), varList); } Fortran::lower::pft::ModuleLikeUnit::ModuleLikeUnit( @@ -1504,9 +1651,25 @@ : ProgramUnit{m, parent}, beginStmt{getModuleStmt( m)}, endStmt{getModuleStmt(m)} { - const auto *symbol = getSymbol(beginStmt); - processSymbolTable(*symbol->scope(), varList, /*reentrant=*/false); + const semantics::Symbol *symbol = getSymbol(beginStmt); + processSymbolTable(*symbol->scope(), varList); +} + +parser::CharBlock +Fortran::lower::pft::ModuleLikeUnit::getStartingSourceLoc() const { + return stmtSourceLoc(beginStmt); } +const Fortran::semantics::Scope & +Fortran::lower::pft::ModuleLikeUnit::getScope() const { + const Fortran::semantics::Symbol *symbol = getSymbol(beginStmt); + assert(symbol && symbol->scope() && + "Module statement must have a symbol with a scope"); + return *symbol->scope(); +} + +//===----------------------------------------------------------------------===// +// BlockDataUnit implementation +//===----------------------------------------------------------------------===// Fortran::lower::pft::BlockDataUnit::BlockDataUnit( const parser::BlockData &bd, const lower::pft::PftNode &parent, @@ -1562,14 +1725,11 @@ } else if (auto *s = std::get_if(&var)) { llvm::errs() << "interval[" << std::get<0>(s->interval) << ", " << std::get<1>(s->interval) << "]:"; + llvm::errs() << " name: " << toStringRef(s->getNamingSymbol().name()); if (s->isGlobal()) llvm::errs() << ", global"; - if (s->vars.size()) { - llvm::errs() << ", vars: {"; - llvm::interleaveComma(s->vars, llvm::errs(), - [](auto *y) { llvm::errs() << *y; }); - llvm::errs() << '}'; - } + if (s->initialValueSymbol) + llvm::errs() << ", initial value: {" << *s->initialValueSymbol << "}"; } else { llvm_unreachable("not a Variable"); } @@ -1588,3 +1748,70 @@ void Fortran::lower::pft::BlockDataUnit::dump() const { llvm::errs() << "block data {\n" << symTab << "\n}\n"; } + +std::vector +Fortran::lower::pft::buildFuncResultDependencyList( + const Fortran::semantics::Symbol &symbol) { + std::vector> variableList; + SymbolDependenceDepth sdd(variableList); + sdd.analyzeAliasesInCurrentScope(symbol.owner()); + sdd.analyze(symbol); + sdd.finalize(); + // Remove the pft::variable for the result itself, only its dependencies + // should be returned in the list. + assert(!variableList[0].empty() && "must at least contain the result"); + assert(&variableList[0].back().getSymbol() == &symbol && + "result sym should be last"); + variableList[0].pop_back(); + return variableList[0]; +} + +namespace { +/// Helper class to find all the symbols referenced in a FunctionLikeUnit. +/// It defines a parse tree visitor doing a deep visit in all nodes with +/// symbols (including evaluate::Expr). +struct SymbolVisitor { + template + bool Pre(const A &x) { + if constexpr (Fortran::parser::HasTypedExpr::value) + if (const auto *expr = Fortran::semantics::GetExpr(x)) + visitExpr(*expr); + return true; + } + + bool Pre(const Fortran::parser::Name &name) { + if (const semantics::Symbol *symbol = name.symbol) + visitSymbol(*symbol); + return false; + } + + void visitExpr(const Fortran::lower::SomeExpr &expr) { + for (const semantics::Symbol &symbol : + Fortran::evaluate::CollectSymbols(expr)) + visitSymbol(symbol); + } + + void visitSymbol(const Fortran::semantics::Symbol &symbol) { + callBack(symbol); + // Visit statement function body since it will be inlined in lowering. + if (const auto *subprogramDetails = + symbol.detailsIf()) + if (const auto &maybeExpr = subprogramDetails->stmtFunction()) + visitExpr(*maybeExpr); + } + + template + constexpr void Post(const A &) {} + + const std::function &callBack; +}; +} // namespace + +void Fortran::lower::pft::visitAllSymbols( + const Fortran::lower::pft::FunctionLikeUnit &funit, + const std::function callBack) { + SymbolVisitor visitor{callBack}; + funit.visit([&](const auto &functionParserNode) { + parser::Walk(functionParserNode, visitor); + }); +} diff --git a/flang/test/Lower/pre-fir-tree01.f90 b/flang/test/Lower/pre-fir-tree01.f90 --- a/flang/test/Lower/pre-fir-tree01.f90 +++ b/flang/test/Lower/pre-fir-tree01.f90 @@ -1,4 +1,4 @@ -! RUN: %flang_fc1 -fdebug-pre-fir-tree %s | FileCheck %s +! RUN: bbc -pft-test -o %t %s | FileCheck %s ! Test structure of the Pre-FIR tree @@ -132,14 +132,12 @@ ! 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: <> + ! CHECK: CompilerDirective: end subroutine ! CHECK: EndSubroutine diff --git a/flang/test/Lower/pre-fir-tree02.f90 b/flang/test/Lower/pre-fir-tree02.f90 --- a/flang/test/Lower/pre-fir-tree02.f90 +++ b/flang/test/Lower/pre-fir-tree02.f90 @@ -1,4 +1,4 @@ -! RUN: %flang_fc1 -fdebug-pre-fir-tree %s | FileCheck %s +! RUN: bbc -pft-test -o %t %s | FileCheck %s ! Test Pre-FIR Tree captures all the intended nodes from the parse-tree ! Coarray and OpenMP related nodes are tested in other files. @@ -212,8 +212,7 @@ ! CHECK: Subroutine sub subroutine sub(a) real(4):: a - ! CompilerDirective - ! CHECK: <> + ! CompilerDirective: !DIR$ IGNORE_TKR a end subroutine @@ -254,7 +253,7 @@ read(10, *) length ! CHECK: RewindStmt rewind 10 - ! CHECK: NamelistStmt + ! CHECK-NOT: NamelistStmt namelist /nlist/ a, b, c ! CHECK: WriteStmt write(10, NML=nlist) diff --git a/flang/test/Lower/pre-fir-tree05.f90 b/flang/test/Lower/pre-fir-tree05.f90 --- a/flang/test/Lower/pre-fir-tree05.f90 +++ b/flang/test/Lower/pre-fir-tree05.f90 @@ -24,14 +24,15 @@ ! CHECK-NEXT: EndDoStmt ! CHECK-NEXT: <> end do + ! CHECK-NEXT: ContinueStmt !$acc end parallel - ! CHECK-NEXT: <> + ! CHECK-NEXT: <> ! CHECK-NEXT: <> ! CHECK-NEXT: EndSubroutineStmt end subroutine ! CHECK-NEXT: End Subroutine foo -! CHECK: Subroutine foo +! CHECK: Subroutine foo2 subroutine foo2() ! CHECK-NEXT: <> !$acc parallel loop @@ -41,9 +42,9 @@ ! CHECK-NEXT: EndDoStmt ! CHECK-NEXT: <> end do + ! CHECK-NEXT: ContinueStmt !$acc end parallel loop ! CHECK-NEXT: <> ! CHECK-NEXT: EndSubroutineStmt end subroutine ! CHECK-NEXT: End Subroutine foo2 -