2104 lines · cpp
1//===-- PFTBuilder.cpp ----------------------------------------------------===//2//3// Part of the LLVM Project, under the Apache License v2.0 with LLVM Exceptions.4// See https://llvm.org/LICENSE.txt for license information.5// SPDX-License-Identifier: Apache-2.0 WITH LLVM-exception6//7//===----------------------------------------------------------------------===//8 9#include "flang/Lower/PFTBuilder.h"10#include "flang/Lower/IntervalSet.h"11#include "flang/Lower/Support/Utils.h"12#include "flang/Parser/dump-parse-tree.h"13#include "flang/Parser/parse-tree-visitor.h"14#include "flang/Semantics/semantics.h"15#include "flang/Semantics/tools.h"16#include "llvm/ADT/DenseSet.h"17#include "llvm/ADT/IntervalMap.h"18#include "llvm/Support/CommandLine.h"19#include "llvm/Support/Debug.h"20 21#define DEBUG_TYPE "flang-pft"22 23static llvm::cl::opt<bool> clDisableStructuredFir(24 "no-structured-fir", llvm::cl::desc("disable generation of structured FIR"),25 llvm::cl::init(false), llvm::cl::Hidden);26 27using namespace Fortran;28 29namespace {30/// Helpers to unveil parser node inside Fortran::parser::Statement<>,31/// Fortran::parser::UnlabeledStatement, and Fortran::common::Indirection<>32template <typename A>33struct RemoveIndirectionHelper {34 using Type = A;35};36template <typename A>37struct RemoveIndirectionHelper<common::Indirection<A>> {38 using Type = A;39};40 41template <typename A>42struct UnwrapStmt {43 static constexpr bool isStmt{false};44};45template <typename A>46struct UnwrapStmt<parser::Statement<A>> {47 static constexpr bool isStmt{true};48 using Type = typename RemoveIndirectionHelper<A>::Type;49 constexpr UnwrapStmt(const parser::Statement<A> &a)50 : unwrapped{removeIndirection(a.statement)}, position{a.source},51 label{a.label} {}52 const Type &unwrapped;53 parser::CharBlock position;54 std::optional<parser::Label> label;55};56template <typename A>57struct UnwrapStmt<parser::UnlabeledStatement<A>> {58 static constexpr bool isStmt{true};59 using Type = typename RemoveIndirectionHelper<A>::Type;60 constexpr UnwrapStmt(const parser::UnlabeledStatement<A> &a)61 : unwrapped{removeIndirection(a.statement)}, position{a.source} {}62 const Type &unwrapped;63 parser::CharBlock position;64 std::optional<parser::Label> label;65};66 67#ifndef NDEBUG68void dumpScope(const semantics::Scope *scope, int depth = -1);69#endif70 71/// The instantiation of a parse tree visitor (Pre and Post) is extremely72/// expensive in terms of compile and link time. So one goal here is to73/// limit the bridge to one such instantiation.74class PFTBuilder {75public:76 PFTBuilder(const semantics::SemanticsContext &semanticsContext)77 : pgm{std::make_unique<lower::pft::Program>(78 semanticsContext.GetCommonBlocks())},79 semanticsContext{semanticsContext} {80 lower::pft::PftNode pftRoot{*pgm.get()};81 pftParentStack.push_back(pftRoot);82 }83 84 /// Get the result85 std::unique_ptr<lower::pft::Program> result() { return std::move(pgm); }86 87 template <typename A>88 constexpr bool Pre(const A &a) {89 if constexpr (lower::pft::isFunctionLike<A>) {90 return enterFunction(a, semanticsContext);91 } else if constexpr (lower::pft::isConstruct<A> ||92 lower::pft::isDirective<A>) {93 return enterConstructOrDirective(a);94 } else if constexpr (UnwrapStmt<A>::isStmt) {95 using T = typename UnwrapStmt<A>::Type;96 // Node "a" being visited has one of the following types:97 // Statement<T>, Statement<Indirection<T>>, UnlabeledStatement<T>,98 // or UnlabeledStatement<Indirection<T>>99 auto stmt{UnwrapStmt<A>(a)};100 if constexpr (lower::pft::isConstructStmt<T> ||101 lower::pft::isOtherStmt<T>) {102 addEvaluation(lower::pft::Evaluation{103 stmt.unwrapped, pftParentStack.back(), stmt.position, stmt.label});104 return false;105 } else if constexpr (std::is_same_v<T, parser::ActionStmt>) {106 return Fortran::common::visit(107 common::visitors{108 [&](const common::Indirection<parser::CallStmt> &x) {109 addEvaluation(lower::pft::Evaluation{110 removeIndirection(x), pftParentStack.back(),111 stmt.position, stmt.label});112 checkForFPEnvironmentCalls(x.value());113 return true;114 },115 [&](const common::Indirection<parser::IfStmt> &x) {116 convertIfStmt(x.value(), stmt.position, stmt.label);117 return false;118 },119 [&](const auto &x) {120 addEvaluation(lower::pft::Evaluation{121 removeIndirection(x), pftParentStack.back(),122 stmt.position, stmt.label});123 return true;124 },125 },126 stmt.unwrapped.u);127 }128 }129 return true;130 }131 132 /// Check for calls that could modify the floating point environment.133 /// See F18 Clauses134 /// - 17.1p3 (Overview of IEEE arithmetic support)135 /// - 17.3p3 (The exceptions)136 /// - 17.4p5 (The rounding modes)137 /// - 17.6p1 (Halting)138 void checkForFPEnvironmentCalls(const parser::CallStmt &callStmt) {139 const auto *callName = std::get_if<parser::Name>(140 &std::get<parser::ProcedureDesignator>(callStmt.call.t).u);141 if (!callName)142 return;143 const Fortran::semantics::Symbol &procSym = callName->symbol->GetUltimate();144 if (!procSym.owner().IsModule())145 return;146 const Fortran::semantics::Symbol &modSym = *procSym.owner().symbol();147 if (!modSym.attrs().test(Fortran::semantics::Attr::INTRINSIC))148 return;149 // Modules IEEE_FEATURES, IEEE_EXCEPTIONS, and IEEE_ARITHMETIC get common150 // declarations from several __fortran_... support module files.151 llvm::StringRef modName = toStringRef(modSym.name());152 if (!modName.starts_with("ieee_") && !modName.starts_with("__fortran_"))153 return;154 llvm::StringRef procName = toStringRef(procSym.name());155 if (!procName.starts_with("ieee_"))156 return;157 lower::pft::FunctionLikeUnit *proc =158 evaluationListStack.back()->back().getOwningProcedure();159 proc->hasIeeeAccess = true;160 if (!procName.starts_with("ieee_set_"))161 return;162 if (procName.starts_with("ieee_set_modes_") ||163 procName.starts_with("ieee_set_status_"))164 proc->mayModifyHaltingMode = proc->mayModifyRoundingMode =165 proc->mayModifyUnderflowMode = true;166 else if (procName.starts_with("ieee_set_halting_mode_"))167 proc->mayModifyHaltingMode = true;168 else if (procName.starts_with("ieee_set_rounding_mode_"))169 proc->mayModifyRoundingMode = true;170 else if (procName.starts_with("ieee_set_underflow_mode_"))171 proc->mayModifyUnderflowMode = true;172 }173 174 /// Convert an IfStmt into an IfConstruct, retaining the IfStmt as the175 /// first statement of the construct.176 void convertIfStmt(const parser::IfStmt &ifStmt, parser::CharBlock position,177 std::optional<parser::Label> label) {178 // Generate a skeleton IfConstruct parse node. Its components are never179 // referenced. The actual components are available via the IfConstruct180 // evaluation's nested evaluationList, with the ifStmt in the position of181 // the otherwise normal IfThenStmt. Caution: All other PFT nodes reference182 // front end generated parse nodes; this is an exceptional case.183 static const auto ifConstruct = parser::IfConstruct{184 parser::Statement<parser::IfThenStmt>{185 std::nullopt,186 parser::IfThenStmt{187 std::optional<parser::Name>{},188 parser::ScalarLogicalExpr{parser::LogicalExpr{parser::Expr{189 parser::LiteralConstant{parser::LogicalLiteralConstant{190 false, std::optional<parser::KindParam>{}}}}}}}},191 parser::Block{}, std::list<parser::IfConstruct::ElseIfBlock>{},192 std::optional<parser::IfConstruct::ElseBlock>{},193 parser::Statement<parser::EndIfStmt>{std::nullopt,194 parser::EndIfStmt{std::nullopt}}};195 enterConstructOrDirective(ifConstruct);196 addEvaluation(197 lower::pft::Evaluation{ifStmt, pftParentStack.back(), position, label});198 Pre(std::get<parser::UnlabeledStatement<parser::ActionStmt>>(ifStmt.t));199 static const auto endIfStmt = parser::EndIfStmt{std::nullopt};200 addEvaluation(201 lower::pft::Evaluation{endIfStmt, pftParentStack.back(), {}, {}});202 exitConstructOrDirective();203 }204 205 template <typename A>206 constexpr void Post(const A &) {207 if constexpr (lower::pft::isFunctionLike<A>) {208 exitFunction();209 } else if constexpr (lower::pft::isConstruct<A> ||210 lower::pft::isDirective<A>) {211 exitConstructOrDirective();212 }213 }214 215 bool Pre(const parser::SpecificationPart &) {216 ++specificationPartLevel;217 return true;218 }219 void Post(const parser::SpecificationPart &) { --specificationPartLevel; }220 221 bool Pre(const parser::ContainsStmt &) {222 if (!specificationPartLevel) {223 assert(containsStmtStack.size() && "empty contains stack");224 containsStmtStack.back() = true;225 }226 return false;227 }228 229 // Module like230 bool Pre(const parser::Module &node) { return enterModule(node); }231 bool Pre(const parser::Submodule &node) { return enterModule(node); }232 233 void Post(const parser::Module &) { exitModule(); }234 void Post(const parser::Submodule &) { exitModule(); }235 236 // Block data237 bool Pre(const parser::BlockData &node) {238 addUnit(lower::pft::BlockDataUnit{node, pftParentStack.back(),239 semanticsContext});240 return false;241 }242 243 // Get rid of production wrapper244 bool Pre(const parser::Statement<parser::ForallAssignmentStmt> &statement) {245 addEvaluation(Fortran::common::visit(246 [&](const auto &x) {247 return lower::pft::Evaluation{x, pftParentStack.back(),248 statement.source, statement.label};249 },250 statement.statement.u));251 return false;252 }253 bool Pre(const parser::WhereBodyConstruct &whereBody) {254 return Fortran::common::visit(255 common::visitors{256 [&](const parser::Statement<parser::AssignmentStmt> &stmt) {257 // Not caught as other AssignmentStmt because it is not258 // wrapped in a parser::ActionStmt.259 addEvaluation(lower::pft::Evaluation{stmt.statement,260 pftParentStack.back(),261 stmt.source, stmt.label});262 return false;263 },264 [&](const auto &) { return true; },265 },266 whereBody.u);267 }268 269 // A CompilerDirective may appear outside any program unit, after a module270 // or function contains statement, or inside a module or function.271 bool Pre(const parser::CompilerDirective &directive) {272 assert(pftParentStack.size() > 0 && "no program");273 lower::pft::PftNode &node = pftParentStack.back();274 if (node.isA<lower::pft::Program>()) {275 addUnit(lower::pft::CompilerDirectiveUnit(directive, node));276 return false;277 } else if ((node.isA<lower::pft::ModuleLikeUnit>() ||278 node.isA<lower::pft::FunctionLikeUnit>())) {279 assert(containsStmtStack.size() && "empty contains stack");280 if (containsStmtStack.back()) {281 addContainedUnit(lower::pft::CompilerDirectiveUnit{directive, node});282 return false;283 }284 }285 return enterConstructOrDirective(directive);286 }287 288 bool Pre(const parser::OpenACCRoutineConstruct &directive) {289 assert(pftParentStack.size() > 0 &&290 "At least the Program must be a parent");291 if (pftParentStack.back().isA<lower::pft::Program>()) {292 addUnit(293 lower::pft::OpenACCDirectiveUnit(directive, pftParentStack.back()));294 return false;295 }296 return enterConstructOrDirective(directive);297 }298 299private:300 /// Initialize a new module-like unit and make it the builder's focus.301 template <typename A>302 bool enterModule(const A &mod) {303 lower::pft::ModuleLikeUnit &unit =304 addUnit(lower::pft::ModuleLikeUnit{mod, pftParentStack.back()});305 containsStmtStack.push_back(false);306 containedUnitList = &unit.containedUnitList;307 pushEvaluationList(&unit.evaluationList);308 pftParentStack.emplace_back(unit);309 LLVM_DEBUG(dumpScope(&unit.getScope()));310 return true;311 }312 313 void exitModule() {314 containsStmtStack.pop_back();315 if (!evaluationListStack.empty())316 popEvaluationList();317 pftParentStack.pop_back();318 resetFunctionState();319 }320 321 /// Add the end statement Evaluation of a sub/program to the PFT.322 /// There may be intervening internal subprogram definitions between323 /// prior statements and this end statement.324 void endFunctionBody() {325 if (evaluationListStack.empty())326 return;327 auto evaluationList = evaluationListStack.back();328 if (evaluationList->empty() || !evaluationList->back().isEndStmt()) {329 const auto &endStmt =330 pftParentStack.back().get<lower::pft::FunctionLikeUnit>().endStmt;331 endStmt.visit(common::visitors{332 [&](const parser::Statement<parser::EndProgramStmt> &s) {333 addEvaluation(lower::pft::Evaluation{334 s.statement, pftParentStack.back(), s.source, s.label});335 },336 [&](const parser::Statement<parser::EndFunctionStmt> &s) {337 addEvaluation(lower::pft::Evaluation{338 s.statement, pftParentStack.back(), s.source, s.label});339 },340 [&](const parser::Statement<parser::EndSubroutineStmt> &s) {341 addEvaluation(lower::pft::Evaluation{342 s.statement, pftParentStack.back(), s.source, s.label});343 },344 [&](const parser::Statement<parser::EndMpSubprogramStmt> &s) {345 addEvaluation(lower::pft::Evaluation{346 s.statement, pftParentStack.back(), s.source, s.label});347 },348 [&](const auto &s) {349 llvm::report_fatal_error("missing end statement or unexpected "350 "begin statement reference");351 },352 });353 }354 lastLexicalEvaluation = nullptr;355 }356 357 /// Pop the ModuleLikeUnit evaluationList when entering the first module358 /// procedure.359 void cleanModuleEvaluationList() {360 if (evaluationListStack.empty())361 return;362 if (pftParentStack.back().isA<lower::pft::ModuleLikeUnit>())363 popEvaluationList();364 }365 366 /// Initialize a new function-like unit and make it the builder's focus.367 template <typename A>368 bool enterFunction(const A &func,369 const semantics::SemanticsContext &semanticsContext) {370 cleanModuleEvaluationList();371 endFunctionBody(); // enclosing host subprogram body, if any372 lower::pft::FunctionLikeUnit &unit =373 addContainedUnit(lower::pft::FunctionLikeUnit{374 func, pftParentStack.back(), semanticsContext});375 labelEvaluationMap = &unit.labelEvaluationMap;376 assignSymbolLabelMap = &unit.assignSymbolLabelMap;377 containsStmtStack.push_back(false);378 containedUnitList = &unit.containedUnitList;379 pushEvaluationList(&unit.evaluationList);380 pftParentStack.emplace_back(unit);381 LLVM_DEBUG(dumpScope(&unit.getScope()));382 return true;383 }384 385 void exitFunction() {386 rewriteIfGotos();387 endFunctionBody();388 analyzeBranches(nullptr, *evaluationListStack.back()); // add branch links389 processEntryPoints();390 containsStmtStack.pop_back();391 popEvaluationList();392 labelEvaluationMap = nullptr;393 assignSymbolLabelMap = nullptr;394 pftParentStack.pop_back();395 resetFunctionState();396 }397 398 /// Initialize a new construct or directive and make it the builder's focus.399 template <typename A>400 bool enterConstructOrDirective(const A &constructOrDirective) {401 lower::pft::Evaluation &eval = addEvaluation(402 lower::pft::Evaluation{constructOrDirective, pftParentStack.back()});403 eval.evaluationList.reset(new lower::pft::EvaluationList);404 pushEvaluationList(eval.evaluationList.get());405 pftParentStack.emplace_back(eval);406 constructAndDirectiveStack.emplace_back(&eval);407 return true;408 }409 410 void exitConstructOrDirective() {411 auto isOpenMPLoopConstruct = [](lower::pft::Evaluation *eval) {412 if (const auto *ompConstruct = eval->getIf<parser::OpenMPConstruct>())413 if (std::holds_alternative<parser::OpenMPLoopConstruct>(414 ompConstruct->u))415 return true;416 return false;417 };418 419 rewriteIfGotos();420 auto *eval = constructAndDirectiveStack.back();421 if (eval->isExecutableDirective() && !isOpenMPLoopConstruct(eval)) {422 // A construct at the end of an (unstructured) OpenACC or OpenMP423 // construct region must have an exit target inside the region.424 // This is not applicable to the OpenMP loop construct since the425 // end of the loop is an available target inside the region.426 lower::pft::EvaluationList &evaluationList = *eval->evaluationList;427 if (!evaluationList.empty() && evaluationList.back().isConstruct()) {428 static const parser::ContinueStmt exitTarget{};429 addEvaluation(430 lower::pft::Evaluation{exitTarget, pftParentStack.back(), {}, {}});431 }432 }433 popEvaluationList();434 pftParentStack.pop_back();435 constructAndDirectiveStack.pop_back();436 }437 438 /// Reset function state to that of an enclosing host function.439 void resetFunctionState() {440 if (!pftParentStack.empty()) {441 pftParentStack.back().visit(common::visitors{442 [&](lower::pft::ModuleLikeUnit &p) {443 containedUnitList = &p.containedUnitList;444 },445 [&](lower::pft::FunctionLikeUnit &p) {446 containedUnitList = &p.containedUnitList;447 labelEvaluationMap = &p.labelEvaluationMap;448 assignSymbolLabelMap = &p.assignSymbolLabelMap;449 },450 [&](auto &) { containedUnitList = nullptr; },451 });452 }453 }454 455 template <typename A>456 A &addUnit(A &&unit) {457 pgm->getUnits().emplace_back(std::move(unit));458 return std::get<A>(pgm->getUnits().back());459 }460 461 template <typename A>462 A &addContainedUnit(A &&unit) {463 if (!containedUnitList)464 return addUnit(std::move(unit));465 containedUnitList->emplace_back(std::move(unit));466 return std::get<A>(containedUnitList->back());467 }468 469 // ActionStmt has a couple of non-conforming cases, explicitly handled here.470 // The other cases use an Indirection, which are discarded in the PFT.471 lower::pft::Evaluation472 makeEvaluationAction(const parser::ActionStmt &statement,473 parser::CharBlock position,474 std::optional<parser::Label> label) {475 return Fortran::common::visit(476 common::visitors{477 [&](const auto &x) {478 return lower::pft::Evaluation{479 removeIndirection(x), pftParentStack.back(), position, label};480 },481 },482 statement.u);483 }484 485 /// Append an Evaluation to the end of the current list.486 lower::pft::Evaluation &addEvaluation(lower::pft::Evaluation &&eval) {487 assert(!evaluationListStack.empty() && "empty evaluation list stack");488 if (!constructAndDirectiveStack.empty())489 eval.parentConstruct = constructAndDirectiveStack.back();490 lower::pft::FunctionLikeUnit *owningProcedure = eval.getOwningProcedure();491 evaluationListStack.back()->emplace_back(std::move(eval));492 lower::pft::Evaluation *p = &evaluationListStack.back()->back();493 if (p->isActionStmt() || p->isConstructStmt() || p->isEndStmt() ||494 p->isExecutableDirective()) {495 if (lastLexicalEvaluation) {496 lastLexicalEvaluation->lexicalSuccessor = p;497 p->printIndex = lastLexicalEvaluation->printIndex + 1;498 } else {499 p->printIndex = 1;500 }501 lastLexicalEvaluation = p;502 if (owningProcedure) {503 auto &entryPointList = owningProcedure->entryPointList;504 for (std::size_t entryIndex = entryPointList.size() - 1;505 entryIndex && !entryPointList[entryIndex].second->lexicalSuccessor;506 --entryIndex)507 // Link to the entry's first executable statement.508 entryPointList[entryIndex].second->lexicalSuccessor = p;509 }510 } else if (const auto *entryStmt = p->getIf<parser::EntryStmt>()) {511 const semantics::Symbol *sym =512 std::get<parser::Name>(entryStmt->t).symbol;513 if (auto *details = sym->detailsIf<semantics::GenericDetails>())514 sym = details->specific();515 assert(sym->has<semantics::SubprogramDetails>() &&516 "entry must be a subprogram");517 owningProcedure->entryPointList.push_back(std::pair{sym, p});518 }519 if (p->label.has_value())520 labelEvaluationMap->try_emplace(*p->label, p);521 return evaluationListStack.back()->back();522 }523 524 /// push a new list on the stack of Evaluation lists525 void pushEvaluationList(lower::pft::EvaluationList *evaluationList) {526 assert(evaluationList && evaluationList->empty() &&527 "invalid evaluation list");528 evaluationListStack.emplace_back(evaluationList);529 }530 531 /// pop the current list and return to the last Evaluation list532 void popEvaluationList() {533 assert(!evaluationListStack.empty() &&534 "trying to pop an empty evaluationListStack");535 evaluationListStack.pop_back();536 }537 538 /// Rewrite IfConstructs containing a GotoStmt or CycleStmt to eliminate an539 /// unstructured branch and a trivial basic block. The pre-branch-analysis540 /// code:541 ///542 /// <<IfConstruct>>543 /// 1 If[Then]Stmt: if(cond) goto L544 /// 2 GotoStmt: goto L545 /// 3 EndIfStmt546 /// <<End IfConstruct>>547 /// 4 Statement: ...548 /// 5 Statement: ...549 /// 6 Statement: L ...550 ///551 /// becomes:552 ///553 /// <<IfConstruct>>554 /// 1 If[Then]Stmt [negate]: if(cond) goto L555 /// 4 Statement: ...556 /// 5 Statement: ...557 /// 3 EndIfStmt558 /// <<End IfConstruct>>559 /// 6 Statement: L ...560 ///561 /// The If[Then]Stmt condition is implicitly negated. It is not modified562 /// in the PFT. It must be negated when generating FIR. The GotoStmt or563 /// CycleStmt is deleted.564 ///565 /// The transformation is only valid for forward branch targets at the same566 /// construct nesting level as the IfConstruct. The result must not violate567 /// construct nesting requirements or contain an EntryStmt. The result568 /// is subject to normal un/structured code classification analysis. Except569 /// for a branch to the EndIfStmt, the result is allowed to violate the F18570 /// Clause 11.1.2.1 prohibition on transfer of control into the interior of571 /// a construct block, as that does not compromise correct code generation.572 /// When two transformation candidates overlap, at least one must be573 /// disallowed. In such cases, the current heuristic favors simple code574 /// generation, which happens to favor later candidates over earlier575 /// candidates. That choice is probably not significant, but could be576 /// changed.577 void rewriteIfGotos() {578 auto &evaluationList = *evaluationListStack.back();579 if (!evaluationList.size())580 return;581 struct T {582 lower::pft::EvaluationList::iterator ifConstructIt;583 parser::Label ifTargetLabel;584 bool isCycleStmt = false;585 };586 llvm::SmallVector<T> ifCandidateStack;587 const auto *doStmt =588 evaluationList.begin()->getIf<parser::NonLabelDoStmt>();589 std::string doName = doStmt ? getConstructName(*doStmt) : std::string{};590 for (auto it = evaluationList.begin(), end = evaluationList.end();591 it != end; ++it) {592 auto &eval = *it;593 if (eval.isA<parser::EntryStmt>() || eval.isIntermediateConstructStmt()) {594 ifCandidateStack.clear();595 continue;596 }597 auto firstStmt = [](lower::pft::Evaluation *e) {598 return e->isConstruct() ? &*e->evaluationList->begin() : e;599 };600 const Fortran::lower::pft::Evaluation &targetEval = *firstStmt(&eval);601 bool targetEvalIsEndDoStmt = targetEval.isA<parser::EndDoStmt>();602 auto branchTargetMatch = [&]() {603 if (const parser::Label targetLabel =604 ifCandidateStack.back().ifTargetLabel)605 if (targetEval.label && targetLabel == *targetEval.label)606 return true; // goto target match607 if (targetEvalIsEndDoStmt && ifCandidateStack.back().isCycleStmt)608 return true; // cycle target match609 return false;610 };611 if (targetEval.label || targetEvalIsEndDoStmt) {612 while (!ifCandidateStack.empty() && branchTargetMatch()) {613 lower::pft::EvaluationList::iterator ifConstructIt =614 ifCandidateStack.back().ifConstructIt;615 lower::pft::EvaluationList::iterator successorIt =616 std::next(ifConstructIt);617 if (successorIt != it) {618 Fortran::lower::pft::EvaluationList &ifBodyList =619 *ifConstructIt->evaluationList;620 lower::pft::EvaluationList::iterator branchStmtIt =621 std::next(ifBodyList.begin());622 assert((branchStmtIt->isA<parser::GotoStmt>() ||623 branchStmtIt->isA<parser::CycleStmt>()) &&624 "expected goto or cycle statement");625 ifBodyList.erase(branchStmtIt);626 lower::pft::Evaluation &ifStmt = *ifBodyList.begin();627 ifStmt.negateCondition = true;628 ifStmt.lexicalSuccessor = firstStmt(&*successorIt);629 lower::pft::EvaluationList::iterator endIfStmtIt =630 std::prev(ifBodyList.end());631 std::prev(it)->lexicalSuccessor = &*endIfStmtIt;632 endIfStmtIt->lexicalSuccessor = firstStmt(&*it);633 ifBodyList.splice(endIfStmtIt, evaluationList, successorIt, it);634 for (; successorIt != endIfStmtIt; ++successorIt)635 successorIt->parentConstruct = &*ifConstructIt;636 }637 ifCandidateStack.pop_back();638 }639 }640 if (eval.isA<parser::IfConstruct>() && eval.evaluationList->size() == 3) {641 const auto bodyEval = std::next(eval.evaluationList->begin());642 if (const auto *gotoStmt = bodyEval->getIf<parser::GotoStmt>()) {643 if (!bodyEval->lexicalSuccessor->label)644 ifCandidateStack.push_back({it, gotoStmt->v});645 } else if (doStmt) {646 if (const auto *cycleStmt = bodyEval->getIf<parser::CycleStmt>()) {647 std::string cycleName = getConstructName(*cycleStmt);648 if (cycleName.empty() || cycleName == doName)649 // This candidate will match doStmt's EndDoStmt.650 ifCandidateStack.push_back({it, {}, true});651 }652 }653 }654 }655 }656 657 /// Mark IO statement ERR, EOR, and END specifier branch targets.658 /// Mark an IO statement with an assigned format as unstructured.659 template <typename A>660 void analyzeIoBranches(lower::pft::Evaluation &eval, const A &stmt) {661 auto analyzeFormatSpec = [&](const parser::Format &format) {662 if (const auto *expr = std::get_if<parser::Expr>(&format.u)) {663 if (semantics::ExprHasTypeCategory(*semantics::GetExpr(*expr),664 common::TypeCategory::Integer))665 eval.isUnstructured = true;666 }667 };668 auto analyzeSpecs{[&](const auto &specList) {669 for (const auto &spec : specList) {670 Fortran::common::visit(671 Fortran::common::visitors{672 [&](const Fortran::parser::Format &format) {673 analyzeFormatSpec(format);674 },675 [&](const auto &label) {676 using LabelNodes =677 std::tuple<parser::ErrLabel, parser::EorLabel,678 parser::EndLabel>;679 if constexpr (common::HasMember<decltype(label), LabelNodes>)680 markBranchTarget(eval, label.v);681 }},682 spec.u);683 }684 }};685 686 using OtherIOStmts =687 std::tuple<parser::BackspaceStmt, parser::CloseStmt,688 parser::EndfileStmt, parser::FlushStmt, parser::OpenStmt,689 parser::RewindStmt, parser::WaitStmt>;690 691 if constexpr (std::is_same_v<A, parser::ReadStmt> ||692 std::is_same_v<A, parser::WriteStmt>) {693 if (stmt.format)694 analyzeFormatSpec(*stmt.format);695 analyzeSpecs(stmt.controls);696 } else if constexpr (std::is_same_v<A, parser::PrintStmt>) {697 analyzeFormatSpec(std::get<parser::Format>(stmt.t));698 } else if constexpr (std::is_same_v<A, parser::InquireStmt>) {699 if (const auto *specList =700 std::get_if<std::list<parser::InquireSpec>>(&stmt.u))701 analyzeSpecs(*specList);702 } else if constexpr (common::HasMember<A, OtherIOStmts>) {703 analyzeSpecs(stmt.v);704 } else {705 // Always crash if this is instantiated706 static_assert(!std::is_same_v<A, parser::ReadStmt>,707 "Unexpected IO statement");708 }709 }710 711 /// Set the exit of a construct, possibly from multiple enclosing constructs.712 void setConstructExit(lower::pft::Evaluation &eval) {713 eval.constructExit = &eval.evaluationList->back().nonNopSuccessor();714 }715 716 /// Mark the target of a branch as a new block.717 void markBranchTarget(lower::pft::Evaluation &sourceEvaluation,718 lower::pft::Evaluation &targetEvaluation) {719 sourceEvaluation.isUnstructured = true;720 if (!sourceEvaluation.controlSuccessor)721 sourceEvaluation.controlSuccessor = &targetEvaluation;722 targetEvaluation.isNewBlock = true;723 // If this is a branch into the body of a construct (usually illegal,724 // but allowed in some legacy cases), then the targetEvaluation and its725 // ancestors must be marked as unstructured.726 lower::pft::Evaluation *sourceConstruct = sourceEvaluation.parentConstruct;727 lower::pft::Evaluation *targetConstruct = targetEvaluation.parentConstruct;728 if (targetConstruct &&729 &targetConstruct->getFirstNestedEvaluation() == &targetEvaluation)730 // A branch to an initial constructStmt is a branch to the construct.731 targetConstruct = targetConstruct->parentConstruct;732 if (targetConstruct) {733 while (sourceConstruct && sourceConstruct != targetConstruct)734 sourceConstruct = sourceConstruct->parentConstruct;735 if (sourceConstruct != targetConstruct) // branch into a construct body736 for (lower::pft::Evaluation *eval = &targetEvaluation; eval;737 eval = eval->parentConstruct) {738 eval->isUnstructured = true;739 // If the branch is a backward branch into an already analyzed740 // DO or IF construct, mark the construct exit as a new block.741 // For a forward branch, the isUnstructured flag will cause this742 // to be done when the construct is analyzed.743 if (eval->constructExit && (eval->isA<parser::DoConstruct>() ||744 eval->isA<parser::IfConstruct>()))745 eval->constructExit->isNewBlock = true;746 }747 }748 }749 void markBranchTarget(lower::pft::Evaluation &sourceEvaluation,750 parser::Label label) {751 assert(label && "missing branch target label");752 lower::pft::Evaluation *targetEvaluation{753 labelEvaluationMap->find(label)->second};754 assert(targetEvaluation && "missing branch target evaluation");755 markBranchTarget(sourceEvaluation, *targetEvaluation);756 }757 758 /// Mark the successor of an Evaluation as a new block.759 void markSuccessorAsNewBlock(lower::pft::Evaluation &eval) {760 eval.nonNopSuccessor().isNewBlock = true;761 }762 763 template <typename A>764 inline std::string getConstructName(const A &stmt) {765 using MaybeConstructNameWrapper =766 std::tuple<parser::BlockStmt, parser::CycleStmt, parser::ElseStmt,767 parser::ElsewhereStmt, parser::EndAssociateStmt,768 parser::EndBlockStmt, parser::EndCriticalStmt,769 parser::EndDoStmt, parser::EndForallStmt, parser::EndIfStmt,770 parser::EndSelectStmt, parser::EndWhereStmt,771 parser::ExitStmt>;772 if constexpr (common::HasMember<A, MaybeConstructNameWrapper>) {773 if (stmt.v)774 return stmt.v->ToString();775 }776 777 using MaybeConstructNameInTuple = std::tuple<778 parser::AssociateStmt, parser::CaseStmt, parser::ChangeTeamStmt,779 parser::CriticalStmt, parser::ElseIfStmt, parser::EndChangeTeamStmt,780 parser::ForallConstructStmt, parser::IfThenStmt, parser::LabelDoStmt,781 parser::MaskedElsewhereStmt, parser::NonLabelDoStmt,782 parser::SelectCaseStmt, parser::SelectRankCaseStmt,783 parser::TypeGuardStmt, parser::WhereConstructStmt>;784 if constexpr (common::HasMember<A, MaybeConstructNameInTuple>) {785 if (auto name = std::get<std::optional<parser::Name>>(stmt.t))786 return name->ToString();787 }788 789 // These statements have multiple std::optional<parser::Name> elements.790 if constexpr (std::is_same_v<A, parser::SelectRankStmt> ||791 std::is_same_v<A, parser::SelectTypeStmt>) {792 if (auto name = std::get<0>(stmt.t))793 return name->ToString();794 }795 796 return {};797 }798 799 /// \p parentConstruct can be null if this statement is at the highest800 /// level of a program.801 template <typename A>802 void insertConstructName(const A &stmt,803 lower::pft::Evaluation *parentConstruct) {804 std::string name = getConstructName(stmt);805 if (!name.empty())806 constructNameMap[name] = parentConstruct;807 }808 809 /// Insert branch links for a list of Evaluations.810 /// \p parentConstruct can be null if the evaluationList contains the811 /// top-level statements of a program.812 void analyzeBranches(lower::pft::Evaluation *parentConstruct,813 std::list<lower::pft::Evaluation> &evaluationList) {814 lower::pft::Evaluation *lastConstructStmtEvaluation{};815 for (auto &eval : evaluationList) {816 eval.visit(common::visitors{817 // Action statements (except IO statements)818 [&](const parser::CallStmt &s) {819 // Look for alternate return specifiers.820 const auto &args =821 std::get<std::list<parser::ActualArgSpec>>(s.call.t);822 for (const auto &arg : args) {823 const auto &actual = std::get<parser::ActualArg>(arg.t);824 if (const auto *altReturn =825 std::get_if<parser::AltReturnSpec>(&actual.u))826 markBranchTarget(eval, altReturn->v);827 }828 },829 [&](const parser::CycleStmt &s) {830 std::string name = getConstructName(s);831 lower::pft::Evaluation *construct{name.empty()832 ? doConstructStack.back()833 : constructNameMap[name]};834 assert(construct && "missing CYCLE construct");835 markBranchTarget(eval, construct->evaluationList->back());836 },837 [&](const parser::ExitStmt &s) {838 std::string name = getConstructName(s);839 lower::pft::Evaluation *construct{name.empty()840 ? doConstructStack.back()841 : constructNameMap[name]};842 assert(construct && "missing EXIT construct");843 markBranchTarget(eval, *construct->constructExit);844 },845 [&](const parser::FailImageStmt &) {846 eval.isUnstructured = true;847 if (eval.lexicalSuccessor->lexicalSuccessor)848 markSuccessorAsNewBlock(eval);849 },850 [&](const parser::GotoStmt &s) { markBranchTarget(eval, s.v); },851 [&](const parser::IfStmt &) {852 eval.lexicalSuccessor->isNewBlock = true;853 lastConstructStmtEvaluation = &eval;854 },855 [&](const parser::ReturnStmt &) {856 eval.isUnstructured = true;857 if (eval.lexicalSuccessor->lexicalSuccessor)858 markSuccessorAsNewBlock(eval);859 },860 [&](const parser::StopStmt &) {861 eval.isUnstructured = true;862 if (eval.lexicalSuccessor->lexicalSuccessor)863 markSuccessorAsNewBlock(eval);864 },865 [&](const parser::ComputedGotoStmt &s) {866 for (auto &label : std::get<std::list<parser::Label>>(s.t))867 markBranchTarget(eval, label);868 },869 [&](const parser::ArithmeticIfStmt &s) {870 markBranchTarget(eval, std::get<1>(s.t));871 markBranchTarget(eval, std::get<2>(s.t));872 markBranchTarget(eval, std::get<3>(s.t));873 },874 [&](const parser::AssignStmt &s) { // legacy label assignment875 auto &label = std::get<parser::Label>(s.t);876 const auto *sym = std::get<parser::Name>(s.t).symbol;877 assert(sym && "missing AssignStmt symbol");878 lower::pft::Evaluation *target{879 labelEvaluationMap->find(label)->second};880 assert(target && "missing branch target evaluation");881 if (!target->isA<parser::FormatStmt>()) {882 target->isNewBlock = true;883 for (lower::pft::Evaluation *parent = target->parentConstruct;884 parent; parent = parent->parentConstruct) {885 parent->isUnstructured = true;886 // The exit of an enclosing DO or IF construct is a new block.887 if (parent->constructExit &&888 (parent->isA<parser::DoConstruct>() ||889 parent->isA<parser::IfConstruct>()))890 parent->constructExit->isNewBlock = true;891 }892 }893 auto iter = assignSymbolLabelMap->find(*sym);894 if (iter == assignSymbolLabelMap->end()) {895 lower::pft::LabelSet labelSet{};896 labelSet.insert(label);897 assignSymbolLabelMap->try_emplace(*sym, labelSet);898 } else {899 iter->second.insert(label);900 }901 },902 [&](const parser::AssignedGotoStmt &) {903 // Although this statement is a branch, it doesn't have any904 // explicit control successors. So the code at the end of the905 // loop won't mark the successor. Do that here.906 eval.isUnstructured = true;907 markSuccessorAsNewBlock(eval);908 },909 910 // The first executable statement after an EntryStmt is a new block.911 [&](const parser::EntryStmt &) {912 eval.lexicalSuccessor->isNewBlock = true;913 },914 915 // Construct statements916 [&](const parser::AssociateStmt &s) {917 insertConstructName(s, parentConstruct);918 },919 [&](const parser::BlockStmt &s) {920 insertConstructName(s, parentConstruct);921 },922 [&](const parser::SelectCaseStmt &s) {923 insertConstructName(s, parentConstruct);924 lastConstructStmtEvaluation = &eval;925 },926 [&](const parser::CaseStmt &) {927 eval.isNewBlock = true;928 lastConstructStmtEvaluation->controlSuccessor = &eval;929 lastConstructStmtEvaluation = &eval;930 },931 [&](const parser::EndSelectStmt &) {932 eval.isNewBlock = true;933 lastConstructStmtEvaluation = nullptr;934 },935 [&](const parser::ChangeTeamStmt &s) {936 insertConstructName(s, parentConstruct);937 },938 [&](const parser::CriticalStmt &s) {939 insertConstructName(s, parentConstruct);940 },941 [&](const parser::NonLabelDoStmt &s) {942 insertConstructName(s, parentConstruct);943 doConstructStack.push_back(parentConstruct);944 const auto &loopControl =945 std::get<std::optional<parser::LoopControl>>(s.t);946 if (!loopControl.has_value()) {947 eval.isUnstructured = true; // infinite loop948 return;949 }950 eval.nonNopSuccessor().isNewBlock = true;951 eval.controlSuccessor = &evaluationList.back();952 if (const auto *bounds =953 std::get_if<parser::LoopControl::Bounds>(&loopControl->u)) {954 if (bounds->name.thing.symbol->GetType()->IsNumeric(955 common::TypeCategory::Real))956 eval.isUnstructured = true; // real-valued loop control957 } else if (std::get_if<parser::ScalarLogicalExpr>(958 &loopControl->u)) {959 eval.isUnstructured = true; // while loop960 }961 },962 [&](const parser::EndDoStmt &) {963 lower::pft::Evaluation &doEval = evaluationList.front();964 eval.controlSuccessor = &doEval;965 doConstructStack.pop_back();966 if (parentConstruct->lowerAsStructured())967 return;968 // The loop is unstructured, which wasn't known for all cases when969 // visiting the NonLabelDoStmt.970 parentConstruct->constructExit->isNewBlock = true;971 const auto &doStmt = *doEval.getIf<parser::NonLabelDoStmt>();972 const auto &loopControl =973 std::get<std::optional<parser::LoopControl>>(doStmt.t);974 if (!loopControl.has_value())975 return; // infinite loop976 if (const auto *concurrent =977 std::get_if<parser::LoopControl::Concurrent>(978 &loopControl->u)) {979 // If there is a mask, the EndDoStmt starts a new block.980 const auto &header =981 std::get<parser::ConcurrentHeader>(concurrent->t);982 eval.isNewBlock |=983 std::get<std::optional<parser::ScalarLogicalExpr>>(header.t)984 .has_value();985 }986 },987 [&](const parser::IfThenStmt &s) {988 insertConstructName(s, parentConstruct);989 eval.lexicalSuccessor->isNewBlock = true;990 lastConstructStmtEvaluation = &eval;991 },992 [&](const parser::ElseIfStmt &) {993 eval.isNewBlock = true;994 eval.lexicalSuccessor->isNewBlock = true;995 lastConstructStmtEvaluation->controlSuccessor = &eval;996 lastConstructStmtEvaluation = &eval;997 },998 [&](const parser::ElseStmt &) {999 eval.isNewBlock = true;1000 lastConstructStmtEvaluation->controlSuccessor = &eval;1001 lastConstructStmtEvaluation = nullptr;1002 },1003 [&](const parser::EndIfStmt &) {1004 if (parentConstruct->lowerAsUnstructured())1005 parentConstruct->constructExit->isNewBlock = true;1006 if (lastConstructStmtEvaluation) {1007 lastConstructStmtEvaluation->controlSuccessor =1008 parentConstruct->constructExit;1009 lastConstructStmtEvaluation = nullptr;1010 }1011 },1012 [&](const parser::SelectRankStmt &s) {1013 insertConstructName(s, parentConstruct);1014 lastConstructStmtEvaluation = &eval;1015 },1016 [&](const parser::SelectRankCaseStmt &) {1017 eval.isNewBlock = true;1018 lastConstructStmtEvaluation->controlSuccessor = &eval;1019 lastConstructStmtEvaluation = &eval;1020 },1021 [&](const parser::SelectTypeStmt &s) {1022 insertConstructName(s, parentConstruct);1023 lastConstructStmtEvaluation = &eval;1024 },1025 [&](const parser::TypeGuardStmt &) {1026 eval.isNewBlock = true;1027 lastConstructStmtEvaluation->controlSuccessor = &eval;1028 lastConstructStmtEvaluation = &eval;1029 },1030 1031 // Constructs - set (unstructured) construct exit targets1032 [&](const parser::AssociateConstruct &) {1033 eval.constructExit = &eval.evaluationList->back();1034 },1035 [&](const parser::BlockConstruct &) {1036 eval.constructExit = &eval.evaluationList->back();1037 },1038 [&](const parser::CaseConstruct &) {1039 eval.constructExit = &eval.evaluationList->back();1040 eval.isUnstructured = true;1041 },1042 [&](const parser::ChangeTeamConstruct &) {1043 eval.constructExit = &eval.evaluationList->back();1044 },1045 [&](const parser::CriticalConstruct &) {1046 eval.constructExit = &eval.evaluationList->back();1047 },1048 [&](const parser::DoConstruct &) { setConstructExit(eval); },1049 [&](const parser::ForallConstruct &) { setConstructExit(eval); },1050 [&](const parser::IfConstruct &) { setConstructExit(eval); },1051 [&](const parser::SelectRankConstruct &) {1052 eval.constructExit = &eval.evaluationList->back();1053 eval.isUnstructured = true;1054 },1055 [&](const parser::SelectTypeConstruct &) {1056 eval.constructExit = &eval.evaluationList->back();1057 eval.isUnstructured = true;1058 },1059 [&](const parser::WhereConstruct &) { setConstructExit(eval); },1060 1061 // Default - Common analysis for IO statements; otherwise nop.1062 [&](const auto &stmt) {1063 using A = std::decay_t<decltype(stmt)>;1064 using IoStmts = std::tuple<1065 parser::BackspaceStmt, parser::CloseStmt, parser::EndfileStmt,1066 parser::FlushStmt, parser::InquireStmt, parser::OpenStmt,1067 parser::PrintStmt, parser::ReadStmt, parser::RewindStmt,1068 parser::WaitStmt, parser::WriteStmt>;1069 if constexpr (common::HasMember<A, IoStmts>)1070 analyzeIoBranches(eval, stmt);1071 },1072 });1073 1074 // Analyze construct evaluations.1075 if (eval.evaluationList)1076 analyzeBranches(&eval, *eval.evaluationList);1077 1078 // Propagate isUnstructured flag to enclosing construct.1079 if (parentConstruct && eval.isUnstructured)1080 parentConstruct->isUnstructured = true;1081 1082 // The successor of a branch starts a new block.1083 if (eval.controlSuccessor && eval.isActionStmt() &&1084 eval.lowerAsUnstructured())1085 markSuccessorAsNewBlock(eval);1086 }1087 }1088 1089 /// Do processing specific to subprograms with multiple entry points.1090 void processEntryPoints() {1091 lower::pft::Evaluation *initialEval = &evaluationListStack.back()->front();1092 lower::pft::FunctionLikeUnit *unit = initialEval->getOwningProcedure();1093 int entryCount = unit->entryPointList.size();1094 if (entryCount == 1)1095 return;1096 1097 // The first executable statement in the subprogram is preceded by a1098 // branch to the entry point, so it starts a new block.1099 // OpenMP directives can generate code around the nested evaluations.1100 if (initialEval->hasNestedEvaluations() &&1101 !initialEval->isOpenMPDirective())1102 initialEval = &initialEval->getFirstNestedEvaluation();1103 else if (initialEval->isA<Fortran::parser::EntryStmt>())1104 initialEval = initialEval->lexicalSuccessor;1105 initialEval->isNewBlock = true;1106 1107 // All function entry points share a single result container.1108 // Find one of the largest results.1109 for (int entryIndex = 0; entryIndex < entryCount; ++entryIndex) {1110 unit->setActiveEntry(entryIndex);1111 const auto &details =1112 unit->getSubprogramSymbol().get<semantics::SubprogramDetails>();1113 if (details.isFunction()) {1114 const semantics::Symbol *resultSym = &details.result();1115 assert(resultSym && "missing result symbol");1116 if (!unit->primaryResult ||1117 unit->primaryResult->size() < resultSym->size())1118 unit->primaryResult = resultSym;1119 }1120 }1121 unit->setActiveEntry(0);1122 }1123 1124 std::unique_ptr<lower::pft::Program> pgm;1125 std::vector<lower::pft::PftNode> pftParentStack;1126 const semantics::SemanticsContext &semanticsContext;1127 1128 llvm::SmallVector<bool> containsStmtStack{};1129 lower::pft::ContainedUnitList *containedUnitList{};1130 std::vector<lower::pft::Evaluation *> constructAndDirectiveStack{};1131 std::vector<lower::pft::Evaluation *> doConstructStack{};1132 /// evaluationListStack is the current nested construct evaluationList state.1133 std::vector<lower::pft::EvaluationList *> evaluationListStack{};1134 llvm::DenseMap<parser::Label, lower::pft::Evaluation *> *labelEvaluationMap{};1135 lower::pft::SymbolLabelMap *assignSymbolLabelMap{};1136 std::map<std::string, lower::pft::Evaluation *> constructNameMap{};1137 int specificationPartLevel{};1138 lower::pft::Evaluation *lastLexicalEvaluation{};1139};1140 1141#ifndef NDEBUG1142/// Dump all program scopes and symbols with addresses to disambiguate names.1143/// This is static, unchanging front end information, so dump it only once.1144void dumpScope(const semantics::Scope *scope, int depth) {1145 static int initialVisitCounter = 0;1146 if (depth < 0) {1147 if (++initialVisitCounter != 1)1148 return;1149 while (!scope->IsGlobal())1150 scope = &scope->parent();1151 LLVM_DEBUG(llvm::dbgs() << "Full program scope information.\n"1152 "Addresses in angle brackets are scopes. "1153 "Unbracketed addresses are symbols.\n");1154 }1155 static const std::string white{" ++"};1156 std::string w = white.substr(0, depth * 2);1157 if (depth >= 0) {1158 LLVM_DEBUG(llvm::dbgs() << w << "<" << scope << "> ");1159 if (auto *sym{scope->symbol()}) {1160 LLVM_DEBUG(llvm::dbgs() << sym << " " << *sym << "\n");1161 } else {1162 if (scope->IsIntrinsicModules()) {1163 LLVM_DEBUG(llvm::dbgs() << "IntrinsicModules (no detail)\n");1164 return;1165 }1166 if (scope->kind() == Fortran::semantics::Scope::Kind::BlockConstruct)1167 LLVM_DEBUG(llvm::dbgs() << "[block]\n");1168 else1169 LLVM_DEBUG(llvm::dbgs() << "[anonymous]\n");1170 }1171 }1172 for (const auto &scp : scope->children())1173 if (!scp.symbol())1174 dumpScope(&scp, depth + 1);1175 for (auto iter = scope->begin(); iter != scope->end(); ++iter) {1176 common::Reference<semantics::Symbol> sym = iter->second;1177 if (auto scp = sym->scope())1178 dumpScope(scp, depth + 1);1179 else1180 LLVM_DEBUG(llvm::dbgs() << w + " " << &*sym << " " << *sym << "\n");1181 }1182}1183#endif // NDEBUG1184 1185class PFTDumper {1186public:1187 void dumpPFT(llvm::raw_ostream &outputStream,1188 const lower::pft::Program &pft) {1189 for (auto &unit : pft.getUnits()) {1190 Fortran::common::visit(1191 common::visitors{1192 [&](const lower::pft::BlockDataUnit &unit) {1193 outputStream << getNodeIndex(unit) << " ";1194 outputStream << "BlockData: ";1195 outputStream << "\nEnd BlockData\n\n";1196 },1197 [&](const lower::pft::FunctionLikeUnit &func) {1198 dumpFunctionLikeUnit(outputStream, func);1199 },1200 [&](const lower::pft::ModuleLikeUnit &unit) {1201 dumpModuleLikeUnit(outputStream, unit);1202 },1203 [&](const lower::pft::CompilerDirectiveUnit &unit) {1204 dumpCompilerDirectiveUnit(outputStream, unit);1205 },1206 [&](const lower::pft::OpenACCDirectiveUnit &unit) {1207 dumpOpenACCDirectiveUnit(outputStream, unit);1208 },1209 },1210 unit);1211 }1212 }1213 1214 llvm::StringRef evaluationName(const lower::pft::Evaluation &eval) {1215 return eval.visit([](const auto &parseTreeNode) {1216 return parser::ParseTreeDumper::GetNodeName(parseTreeNode);1217 });1218 }1219 1220 void dumpEvaluation(llvm::raw_ostream &outputStream,1221 const lower::pft::Evaluation &eval,1222 const std::string &indentString, int indent = 1) {1223 llvm::StringRef name = evaluationName(eval);1224 llvm::StringRef newBlock = eval.isNewBlock ? "^" : "";1225 llvm::StringRef bang = eval.isUnstructured ? "!" : "";1226 outputStream << indentString;1227 if (eval.printIndex)1228 outputStream << eval.printIndex << ' ';1229 if (eval.hasNestedEvaluations())1230 outputStream << "<<" << newBlock << name << bang << ">>";1231 else1232 outputStream << newBlock << name << bang;1233 if (eval.negateCondition)1234 outputStream << " [negate]";1235 if (eval.constructExit)1236 outputStream << " -> " << eval.constructExit->printIndex;1237 else if (eval.controlSuccessor)1238 outputStream << " -> " << eval.controlSuccessor->printIndex;1239 else if (eval.isA<parser::EntryStmt>() && eval.lexicalSuccessor)1240 outputStream << " -> " << eval.lexicalSuccessor->printIndex;1241 bool extraNewline = false;1242 if (!eval.position.empty())1243 outputStream << ": " << eval.position.ToString();1244 else if (auto *dir = eval.getIf<parser::CompilerDirective>()) {1245 extraNewline = dir->source.ToString().back() == '\n';1246 outputStream << ": !" << dir->source.ToString();1247 }1248 if (!extraNewline)1249 outputStream << '\n';1250 if (eval.hasNestedEvaluations()) {1251 dumpEvaluationList(outputStream, *eval.evaluationList, indent + 1);1252 outputStream << indentString << "<<End " << name << bang << ">>\n";1253 }1254 }1255 1256 void dumpEvaluation(llvm::raw_ostream &ostream,1257 const lower::pft::Evaluation &eval) {1258 dumpEvaluation(ostream, eval, "");1259 }1260 1261 void dumpEvaluationList(llvm::raw_ostream &outputStream,1262 const lower::pft::EvaluationList &evaluationList,1263 int indent = 1) {1264 static const auto white = " ++"s;1265 auto indentString = white.substr(0, indent * 2);1266 for (const lower::pft::Evaluation &eval : evaluationList)1267 dumpEvaluation(outputStream, eval, indentString, indent);1268 }1269 1270 void1271 dumpFunctionLikeUnit(llvm::raw_ostream &outputStream,1272 const lower::pft::FunctionLikeUnit &functionLikeUnit) {1273 outputStream << getNodeIndex(functionLikeUnit) << " ";1274 llvm::StringRef unitKind;1275 llvm::StringRef name;1276 llvm::StringRef header;1277 if (functionLikeUnit.beginStmt) {1278 functionLikeUnit.beginStmt->visit(common::visitors{1279 [&](const parser::Statement<parser::ProgramStmt> &stmt) {1280 unitKind = "Program";1281 name = toStringRef(stmt.statement.v.source);1282 },1283 [&](const parser::Statement<parser::FunctionStmt> &stmt) {1284 unitKind = "Function";1285 name = toStringRef(std::get<parser::Name>(stmt.statement.t).source);1286 header = toStringRef(stmt.source);1287 },1288 [&](const parser::Statement<parser::SubroutineStmt> &stmt) {1289 unitKind = "Subroutine";1290 name = toStringRef(std::get<parser::Name>(stmt.statement.t).source);1291 header = toStringRef(stmt.source);1292 },1293 [&](const parser::Statement<parser::MpSubprogramStmt> &stmt) {1294 unitKind = "MpSubprogram";1295 name = toStringRef(stmt.statement.v.source);1296 header = toStringRef(stmt.source);1297 },1298 [&](const auto &) { llvm_unreachable("not a valid begin stmt"); },1299 });1300 } else {1301 unitKind = "Program";1302 name = "<anonymous>";1303 }1304 outputStream << unitKind << ' ' << name;1305 if (!header.empty())1306 outputStream << ": " << header;1307 outputStream << '\n';1308 dumpEvaluationList(outputStream, functionLikeUnit.evaluationList);1309 dumpContainedUnitList(outputStream, functionLikeUnit.containedUnitList);1310 outputStream << "End " << unitKind << ' ' << name << "\n\n";1311 }1312 1313 void dumpModuleLikeUnit(llvm::raw_ostream &outputStream,1314 const lower::pft::ModuleLikeUnit &moduleLikeUnit) {1315 outputStream << getNodeIndex(moduleLikeUnit) << " ";1316 llvm::StringRef unitKind;1317 llvm::StringRef name;1318 llvm::StringRef header;1319 moduleLikeUnit.beginStmt.visit(common::visitors{1320 [&](const parser::Statement<parser::ModuleStmt> &stmt) {1321 unitKind = "Module";1322 name = toStringRef(stmt.statement.v.source);1323 header = toStringRef(stmt.source);1324 },1325 [&](const parser::Statement<parser::SubmoduleStmt> &stmt) {1326 unitKind = "Submodule";1327 name = toStringRef(std::get<parser::Name>(stmt.statement.t).source);1328 header = toStringRef(stmt.source);1329 },1330 [&](const auto &) {1331 llvm_unreachable("not a valid module begin stmt");1332 },1333 });1334 outputStream << unitKind << ' ' << name << ": " << header << '\n';1335 dumpEvaluationList(outputStream, moduleLikeUnit.evaluationList);1336 dumpContainedUnitList(outputStream, moduleLikeUnit.containedUnitList);1337 outputStream << "End " << unitKind << ' ' << name << "\n\n";1338 }1339 1340 // Top level directives1341 void dumpCompilerDirectiveUnit(1342 llvm::raw_ostream &outputStream,1343 const lower::pft::CompilerDirectiveUnit &directive) {1344 outputStream << getNodeIndex(directive) << " ";1345 outputStream << "CompilerDirective: !";1346 bool extraNewline =1347 directive.get<parser::CompilerDirective>().source.ToString().back() ==1348 '\n';1349 outputStream1350 << directive.get<parser::CompilerDirective>().source.ToString();1351 if (!extraNewline)1352 outputStream << "\n";1353 outputStream << "\n";1354 }1355 1356 void dumpContainedUnitList(1357 llvm::raw_ostream &outputStream,1358 const lower::pft::ContainedUnitList &containedUnitList) {1359 if (containedUnitList.empty())1360 return;1361 outputStream << "\nContains\n";1362 for (const lower::pft::ContainedUnit &unit : containedUnitList)1363 if (const auto *func = std::get_if<lower::pft::FunctionLikeUnit>(&unit)) {1364 dumpFunctionLikeUnit(outputStream, *func);1365 } else if (const auto *dir =1366 std::get_if<lower::pft::CompilerDirectiveUnit>(&unit)) {1367 outputStream << getNodeIndex(*dir) << " ";1368 dumpEvaluation(outputStream,1369 lower::pft::Evaluation{1370 dir->get<parser::CompilerDirective>(), dir->parent});1371 outputStream << "\n";1372 }1373 outputStream << "End Contains\n";1374 }1375 1376 void1377 dumpOpenACCDirectiveUnit(llvm::raw_ostream &outputStream,1378 const lower::pft::OpenACCDirectiveUnit &directive) {1379 outputStream << getNodeIndex(directive) << " ";1380 outputStream << "OpenACCDirective: !$acc ";1381 outputStream1382 << directive.get<parser::OpenACCRoutineConstruct>().source.ToString();1383 outputStream << "\nEnd OpenACCDirective\n\n";1384 }1385 1386 template <typename T>1387 std::size_t getNodeIndex(const T &node) {1388 auto addr = static_cast<const void *>(&node);1389 auto it = nodeIndexes.find(addr);1390 if (it != nodeIndexes.end())1391 return it->second;1392 nodeIndexes.try_emplace(addr, nextIndex);1393 return nextIndex++;1394 }1395 std::size_t getNodeIndex(const lower::pft::Program &) { return 0; }1396 1397private:1398 llvm::DenseMap<const void *, std::size_t> nodeIndexes;1399 std::size_t nextIndex{1}; // 0 is the root1400};1401 1402} // namespace1403 1404template <typename A, typename T>1405static lower::pft::FunctionLikeUnit::FunctionStatement1406getFunctionStmt(const T &func) {1407 lower::pft::FunctionLikeUnit::FunctionStatement result{1408 std::get<parser::Statement<A>>(func.t)};1409 return result;1410}1411 1412template <typename A, typename T>1413static lower::pft::ModuleLikeUnit::ModuleStatement getModuleStmt(const T &mod) {1414 lower::pft::ModuleLikeUnit::ModuleStatement result{1415 std::get<parser::Statement<A>>(mod.t)};1416 return result;1417}1418 1419template <typename A>1420static const semantics::Symbol *getSymbol(A &beginStmt) {1421 const auto *symbol = beginStmt.visit(common::visitors{1422 [](const parser::Statement<parser::ProgramStmt> &stmt)1423 -> const semantics::Symbol * { return stmt.statement.v.symbol; },1424 [](const parser::Statement<parser::FunctionStmt> &stmt)1425 -> const semantics::Symbol * {1426 return std::get<parser::Name>(stmt.statement.t).symbol;1427 },1428 [](const parser::Statement<parser::SubroutineStmt> &stmt)1429 -> const semantics::Symbol * {1430 return std::get<parser::Name>(stmt.statement.t).symbol;1431 },1432 [](const parser::Statement<parser::MpSubprogramStmt> &stmt)1433 -> const semantics::Symbol * { return stmt.statement.v.symbol; },1434 [](const parser::Statement<parser::ModuleStmt> &stmt)1435 -> const semantics::Symbol * { return stmt.statement.v.symbol; },1436 [](const parser::Statement<parser::SubmoduleStmt> &stmt)1437 -> const semantics::Symbol * {1438 return std::get<parser::Name>(stmt.statement.t).symbol;1439 },1440 [](const auto &) -> const semantics::Symbol * {1441 llvm_unreachable("unknown FunctionLike or ModuleLike beginStmt");1442 return nullptr;1443 }});1444 assert(symbol && "parser::Name must have resolved symbol");1445 return symbol;1446}1447 1448bool Fortran::lower::pft::Evaluation::lowerAsStructured() const {1449 return !lowerAsUnstructured();1450}1451 1452bool Fortran::lower::pft::Evaluation::lowerAsUnstructured() const {1453 return isUnstructured || clDisableStructuredFir;1454}1455 1456bool Fortran::lower::pft::Evaluation::forceAsUnstructured() const {1457 return clDisableStructuredFir;1458}1459 1460lower::pft::FunctionLikeUnit *1461Fortran::lower::pft::Evaluation::getOwningProcedure() const {1462 return parent.visit(common::visitors{1463 [](lower::pft::FunctionLikeUnit &c) { return &c; },1464 [&](lower::pft::Evaluation &c) { return c.getOwningProcedure(); },1465 [](auto &) -> lower::pft::FunctionLikeUnit * { return nullptr; },1466 });1467}1468 1469bool Fortran::lower::definedInCommonBlock(const semantics::Symbol &sym) {1470 return semantics::FindCommonBlockContaining(sym);1471}1472 1473/// Is the symbol `sym` a global?1474bool Fortran::lower::symbolIsGlobal(const semantics::Symbol &sym) {1475 return (semantics::IsSaved(sym) && semantics::CanCUDASymbolBeGlobal(sym)) ||1476 lower::definedInCommonBlock(sym) || semantics::IsNamedConstant(sym);1477}1478 1479namespace {1480/// This helper class sorts the symbols in a scope such that a symbol will1481/// be placed after those it depends upon. Otherwise the sort is stable and1482/// preserves the order of the symbol table, which is sorted by name. This1483/// analysis may also be done for an individual symbol.1484struct SymbolDependenceAnalysis {1485 explicit SymbolDependenceAnalysis(const semantics::Scope &scope) {1486 analyzeEquivalenceSets(scope);1487 for (const auto &iter : scope)1488 analyze(iter.second.get());1489 finalize();1490 }1491 explicit SymbolDependenceAnalysis(const semantics::Symbol &symbol) {1492 analyzeEquivalenceSets(symbol.owner());1493 analyze(symbol);1494 finalize();1495 }1496 Fortran::lower::pft::VariableList getVariableList() {1497 return std::move(layeredVarList[0]);1498 }1499 1500private:1501 /// Analyze the equivalence sets defined in \p scope, plus the equivalence1502 /// sets in host module, submodule, and procedure scopes that may define1503 /// symbols referenced in \p scope. This analysis excludes equivalence sets1504 /// involving common blocks, which are handled elsewhere.1505 void analyzeEquivalenceSets(const semantics::Scope &scope) {1506 // FIXME: When this function is called on the scope of an internal1507 // procedure whose parent contains an EQUIVALENCE set and the internal1508 // procedure uses variables from that EQUIVALENCE set, we end up creating1509 // an AggregateStore for those variables unnecessarily.1510 1511 // A function defined in a [sub]module has no explicit USE of its ancestor1512 // [sub]modules. Analyze those scopes here to accommodate references to1513 // symbols in them.1514 for (auto *scp = &scope.parent(); !scp->IsGlobal(); scp = &scp->parent())1515 if (scp->kind() == Fortran::semantics::Scope::Kind::Module)1516 analyzeLocalEquivalenceSets(*scp);1517 // Analyze local, USEd, and host procedure scope equivalences.1518 for (const auto &iter : scope) {1519 const semantics::Symbol &ultimate = iter.second.get().GetUltimate();1520 if (!skipSymbol(ultimate))1521 analyzeLocalEquivalenceSets(ultimate.owner());1522 }1523 // Add all aggregate stores to the front of the variable list.1524 adjustSize(1);1525 // The copy in the loop matters, 'stores' will still be used.1526 for (auto st : stores)1527 layeredVarList[0].emplace_back(std::move(st));1528 }1529 1530 /// Analyze the equivalence sets defined locally in \p scope that don't1531 /// involve common blocks.1532 void analyzeLocalEquivalenceSets(const semantics::Scope &scope) {1533 if (scope.equivalenceSets().empty())1534 return; // no equivalence sets to analyze1535 if (analyzedScopes.contains(&scope))1536 return; // equivalence sets already analyzed1537 1538 analyzedScopes.insert(&scope);1539 std::list<std::list<semantics::SymbolRef>> aggregates =1540 Fortran::semantics::GetStorageAssociations(scope);1541 for (std::list<semantics::SymbolRef> aggregate : aggregates) {1542 const Fortran::semantics::Symbol *aggregateSym = nullptr;1543 bool isGlobal = false;1544 const semantics::Symbol &first = *aggregate.front();1545 // Exclude equivalence sets involving common blocks.1546 // Those are handled in instantiateCommon.1547 if (lower::definedInCommonBlock(first))1548 continue;1549 std::size_t start = first.offset();1550 std::size_t end = first.offset() + first.size();1551 const Fortran::semantics::Symbol *namingSym = nullptr;1552 for (semantics::SymbolRef symRef : aggregate) {1553 const semantics::Symbol &sym = *symRef;1554 aliasSyms.insert(&sym);1555 if (sym.test(Fortran::semantics::Symbol::Flag::CompilerCreated)) {1556 aggregateSym = &sym;1557 } else {1558 isGlobal |= lower::symbolIsGlobal(sym);1559 start = std::min(sym.offset(), start);1560 end = std::max(sym.offset() + sym.size(), end);1561 if (!namingSym || (sym.name() < namingSym->name()))1562 namingSym = &sym;1563 }1564 }1565 assert(namingSym && "must contain at least one user symbol");1566 if (!aggregateSym) {1567 stores.emplace_back(1568 Fortran::lower::pft::Variable::Interval{start, end - start},1569 *namingSym, isGlobal);1570 } else {1571 stores.emplace_back(*aggregateSym, *namingSym, isGlobal);1572 }1573 }1574 }1575 1576 // Recursively visit each symbol to determine the height of its dependence on1577 // other symbols.1578 int analyze(const semantics::Symbol &sym) {1579 auto done = seen.insert(&sym);1580 if (!done.second)1581 return 0;1582 LLVM_DEBUG(llvm::dbgs() << "analyze symbol " << &sym << " in <"1583 << &sym.owner() << ">: " << sym << '\n');1584 const semantics::Symbol &ultimate = sym.GetUltimate();1585 if (const auto *details = ultimate.detailsIf<semantics::GenericDetails>()) {1586 // Procedure pointers may be "hidden" behind to the generic symbol if they1587 // have the same name.1588 if (const semantics::Symbol *specific = details->specific())1589 analyze(*specific);1590 return 0;1591 }1592 const bool isProcedurePointerOrDummy =1593 semantics::IsProcedurePointer(sym) ||1594 (semantics::IsProcedure(sym) && IsDummy(sym));1595 // A procedure argument in a subprogram with multiple entry points might1596 // need a layeredVarList entry to trigger creation of a symbol map entry1597 // in some cases. Non-dummy procedures don't.1598 if (semantics::IsProcedure(sym) && !isProcedurePointerOrDummy)1599 return 0;1600 // Derived type component symbols may be collected by "CollectSymbols"1601 // below when processing something like "real :: x(derived%component)". The1602 // symbol "component" has "ObjectEntityDetails", but it should not be1603 // instantiated: it is part of "derived" that should be the only one to1604 // be instantiated.1605 if (sym.owner().IsDerivedType())1606 return 0;1607 1608 if (const auto *details =1609 ultimate.detailsIf<semantics::NamelistDetails>()) {1610 // handle namelist group symbols1611 for (const semantics::SymbolRef &s : details->objects())1612 analyze(s);1613 return 0;1614 }1615 if (!ultimate.has<semantics::ObjectEntityDetails>() &&1616 !isProcedurePointerOrDummy)1617 return 0;1618 1619 if (sym.has<semantics::DerivedTypeDetails>())1620 llvm_unreachable("not yet implemented - derived type analysis");1621 1622 // Symbol must be something lowering will have to allocate.1623 int depth = 0;1624 // Analyze symbols appearing in object entity specification expressions.1625 // This ensures these symbols will be instantiated before the current one.1626 // This is not done for object entities that are host associated because1627 // they must be instantiated from the value of the host symbols.1628 // (The specification expressions should not be re-evaluated.)1629 if (const auto *details = sym.detailsIf<semantics::ObjectEntityDetails>()) {1630 const semantics::DeclTypeSpec *symTy = sym.GetType();1631 assert(symTy && "symbol must have a type");1632 // check CHARACTER's length1633 if (symTy->category() == semantics::DeclTypeSpec::Character)1634 if (auto e = symTy->characterTypeSpec().length().GetExplicit())1635 for (const auto &s : evaluate::CollectSymbols(*e))1636 depth = std::max(analyze(s) + 1, depth);1637 1638 auto doExplicit = [&](const auto &bound) {1639 if (bound.isExplicit()) {1640 semantics::SomeExpr e{*bound.GetExplicit()};1641 for (const auto &s : evaluate::CollectSymbols(e))1642 depth = std::max(analyze(s) + 1, depth);1643 }1644 };1645 // Handle any symbols in array bound declarations.1646 for (const semantics::ShapeSpec &subs : details->shape()) {1647 doExplicit(subs.lbound());1648 doExplicit(subs.ubound());1649 }1650 // Handle any symbols in coarray bound declarations.1651 for (const semantics::ShapeSpec &subs : details->coshape()) {1652 doExplicit(subs.lbound());1653 doExplicit(subs.ubound());1654 }1655 // Handle any symbols in initialization expressions.1656 if (auto e = details->init())1657 for (const auto &s : evaluate::CollectSymbols(*e))1658 if (!s->has<semantics::DerivedTypeDetails>())1659 depth = std::max(analyze(s) + 1, depth);1660 }1661 1662 // Make sure cray pointer is instantiated even if it is not visible.1663 if (ultimate.test(Fortran::semantics::Symbol::Flag::CrayPointee))1664 depth = std::max(1665 analyze(Fortran::semantics::GetCrayPointer(ultimate)) + 1, depth);1666 adjustSize(depth + 1);1667 bool global = lower::symbolIsGlobal(sym);1668 layeredVarList[depth].emplace_back(sym, global, depth);1669 if (semantics::IsAllocatable(sym))1670 layeredVarList[depth].back().setHeapAlloc();1671 if (semantics::IsPointer(sym))1672 layeredVarList[depth].back().setPointer();1673 if (ultimate.attrs().test(semantics::Attr::TARGET))1674 layeredVarList[depth].back().setTarget();1675 1676 // If there are alias sets, then link the participating variables to their1677 // aggregate stores when constructing the new variable on the list.1678 if (lower::pft::Variable::AggregateStore *store = findStoreIfAlias(sym))1679 layeredVarList[depth].back().setAlias(store->getOffset());1680 return depth;1681 }1682 1683 /// Skip symbol in alias analysis.1684 bool skipSymbol(const semantics::Symbol &sym) {1685 // Common block equivalences are largely managed by the front end.1686 // Compiler generated symbols ('.' names) cannot be equivalenced.1687 // FIXME: Equivalence code generation may need to be revisited.1688 return !sym.has<semantics::ObjectEntityDetails>() ||1689 lower::definedInCommonBlock(sym) || sym.name()[0] == '.';1690 }1691 1692 // Make sure the table is of appropriate size.1693 void adjustSize(std::size_t size) {1694 if (layeredVarList.size() < size)1695 layeredVarList.resize(size);1696 }1697 1698 Fortran::lower::pft::Variable::AggregateStore *1699 findStoreIfAlias(const Fortran::evaluate::Symbol &sym) {1700 const semantics::Symbol &ultimate = sym.GetUltimate();1701 const semantics::Scope &scope = ultimate.owner();1702 // Expect the total number of EQUIVALENCE sets to be small for a typical1703 // Fortran program.1704 if (aliasSyms.contains(&ultimate)) {1705 LLVM_DEBUG(llvm::dbgs() << "found aggregate containing " << &ultimate1706 << " " << ultimate.name() << " in <" << &scope1707 << "> " << scope.GetName() << '\n');1708 std::size_t off = ultimate.offset();1709 std::size_t symSize = ultimate.size();1710 for (lower::pft::Variable::AggregateStore &v : stores) {1711 if (&v.getOwningScope() == &scope) {1712 auto intervalOff = std::get<0>(v.interval);1713 auto intervalSize = std::get<1>(v.interval);1714 if (off >= intervalOff && off < intervalOff + intervalSize)1715 return &v;1716 // Zero sized symbol in zero sized equivalence.1717 if (off == intervalOff && symSize == 0)1718 return &v;1719 }1720 }1721 // clang-format off1722 LLVM_DEBUG(1723 llvm::dbgs() << "looking for " << off << "\n{\n";1724 for (lower::pft::Variable::AggregateStore &v : stores) {1725 llvm::dbgs() << " in scope: " << &v.getOwningScope() << "\n";1726 llvm::dbgs() << " i = [" << std::get<0>(v.interval) << ".."1727 << std::get<0>(v.interval) + std::get<1>(v.interval)1728 << "]\n";1729 }1730 llvm::dbgs() << "}\n");1731 // clang-format on1732 llvm_unreachable("the store must be present");1733 }1734 return nullptr;1735 }1736 1737 /// Flatten the result VariableList.1738 void finalize() {1739 for (int i = 1, end = layeredVarList.size(); i < end; ++i)1740 layeredVarList[0].insert(layeredVarList[0].end(),1741 layeredVarList[i].begin(),1742 layeredVarList[i].end());1743 }1744 1745 llvm::SmallPtrSet<const semantics::Symbol *, 32> seen;1746 std::vector<Fortran::lower::pft::VariableList> layeredVarList;1747 llvm::SmallPtrSet<const semantics::Symbol *, 32> aliasSyms;1748 /// Set of scopes that have been analyzed for aliases.1749 llvm::SmallPtrSet<const semantics::Scope *, 4> analyzedScopes;1750 std::vector<Fortran::lower::pft::Variable::AggregateStore> stores;1751};1752} // namespace1753 1754//===----------------------------------------------------------------------===//1755// FunctionLikeUnit implementation1756//===----------------------------------------------------------------------===//1757 1758Fortran::lower::pft::FunctionLikeUnit::FunctionLikeUnit(1759 const parser::MainProgram &func, const lower::pft::PftNode &parent,1760 const semantics::SemanticsContext &semanticsContext)1761 : ProgramUnit{func, parent},1762 endStmt{getFunctionStmt<parser::EndProgramStmt>(func)} {1763 const auto &programStmt =1764 std::get<std::optional<parser::Statement<parser::ProgramStmt>>>(func.t);1765 if (programStmt.has_value()) {1766 beginStmt = FunctionStatement(programStmt.value());1767 const semantics::Symbol *symbol = getSymbol(*beginStmt);1768 entryPointList[0].first = symbol;1769 scope = symbol->scope();1770 } else {1771 scope = &semanticsContext.FindScope(1772 std::get<parser::Statement<parser::EndProgramStmt>>(func.t).source);1773 }1774}1775 1776Fortran::lower::pft::FunctionLikeUnit::FunctionLikeUnit(1777 const parser::FunctionSubprogram &func, const lower::pft::PftNode &parent,1778 const semantics::SemanticsContext &)1779 : ProgramUnit{func, parent},1780 beginStmt{getFunctionStmt<parser::FunctionStmt>(func)},1781 endStmt{getFunctionStmt<parser::EndFunctionStmt>(func)} {1782 const semantics::Symbol *symbol = getSymbol(*beginStmt);1783 entryPointList[0].first = symbol;1784 scope = symbol->scope();1785}1786 1787Fortran::lower::pft::FunctionLikeUnit::FunctionLikeUnit(1788 const parser::SubroutineSubprogram &func, const lower::pft::PftNode &parent,1789 const semantics::SemanticsContext &)1790 : ProgramUnit{func, parent},1791 beginStmt{getFunctionStmt<parser::SubroutineStmt>(func)},1792 endStmt{getFunctionStmt<parser::EndSubroutineStmt>(func)} {1793 const semantics::Symbol *symbol = getSymbol(*beginStmt);1794 entryPointList[0].first = symbol;1795 scope = symbol->scope();1796}1797 1798Fortran::lower::pft::FunctionLikeUnit::FunctionLikeUnit(1799 const parser::SeparateModuleSubprogram &func,1800 const lower::pft::PftNode &parent, const semantics::SemanticsContext &)1801 : ProgramUnit{func, parent},1802 beginStmt{getFunctionStmt<parser::MpSubprogramStmt>(func)},1803 endStmt{getFunctionStmt<parser::EndMpSubprogramStmt>(func)} {1804 const semantics::Symbol *symbol = getSymbol(*beginStmt);1805 entryPointList[0].first = symbol;1806 scope = symbol->scope();1807}1808 1809Fortran::lower::HostAssociations &1810Fortran::lower::pft::FunctionLikeUnit::parentHostAssoc() {1811 if (auto *par = parent.getIf<FunctionLikeUnit>())1812 return par->hostAssociations;1813 llvm::report_fatal_error("parent is not a function");1814}1815 1816bool Fortran::lower::pft::FunctionLikeUnit::parentHasTupleHostAssoc() {1817 if (auto *par = parent.getIf<FunctionLikeUnit>())1818 return par->hostAssociations.hasTupleAssociations();1819 return false;1820}1821 1822bool Fortran::lower::pft::FunctionLikeUnit::parentHasHostAssoc() {1823 if (auto *par = parent.getIf<FunctionLikeUnit>())1824 return !par->hostAssociations.empty();1825 return false;1826}1827 1828parser::CharBlock1829Fortran::lower::pft::FunctionLikeUnit::getStartingSourceLoc() const {1830 if (beginStmt)1831 return stmtSourceLoc(*beginStmt);1832 return scope->sourceRange();1833}1834 1835//===----------------------------------------------------------------------===//1836// ModuleLikeUnit implementation1837//===----------------------------------------------------------------------===//1838 1839Fortran::lower::pft::ModuleLikeUnit::ModuleLikeUnit(1840 const parser::Module &m, const lower::pft::PftNode &parent)1841 : ProgramUnit{m, parent}, beginStmt{getModuleStmt<parser::ModuleStmt>(m)},1842 endStmt{getModuleStmt<parser::EndModuleStmt>(m)} {}1843 1844Fortran::lower::pft::ModuleLikeUnit::ModuleLikeUnit(1845 const parser::Submodule &m, const lower::pft::PftNode &parent)1846 : ProgramUnit{m, parent},1847 beginStmt{getModuleStmt<parser::SubmoduleStmt>(m)},1848 endStmt{getModuleStmt<parser::EndSubmoduleStmt>(m)} {}1849 1850parser::CharBlock1851Fortran::lower::pft::ModuleLikeUnit::getStartingSourceLoc() const {1852 return stmtSourceLoc(beginStmt);1853}1854const Fortran::semantics::Scope &1855Fortran::lower::pft::ModuleLikeUnit::getScope() const {1856 const Fortran::semantics::Symbol *symbol = getSymbol(beginStmt);1857 assert(symbol && symbol->scope() &&1858 "Module statement must have a symbol with a scope");1859 return *symbol->scope();1860}1861 1862//===----------------------------------------------------------------------===//1863// BlockDataUnit implementation1864//===----------------------------------------------------------------------===//1865 1866Fortran::lower::pft::BlockDataUnit::BlockDataUnit(1867 const parser::BlockData &bd, const lower::pft::PftNode &parent,1868 const semantics::SemanticsContext &semanticsContext)1869 : ProgramUnit{bd, parent},1870 symTab{semanticsContext.FindScope(1871 std::get<parser::Statement<parser::EndBlockDataStmt>>(bd.t).source)} {1872}1873 1874//===----------------------------------------------------------------------===//1875// Variable implementation1876//===----------------------------------------------------------------------===//1877 1878bool Fortran::lower::pft::Variable::isRuntimeTypeInfoData() const {1879 // So far, use flags to detect if this symbol were generated during1880 // semantics::BuildRuntimeDerivedTypeTables(). Scope cannot be used since the1881 // symbols are injected in the user scopes defining the described derived1882 // types. A robustness improvement for this test could be to get hands on the1883 // semantics::RuntimeDerivedTypeTables and to check if the symbol names1884 // belongs to this structure.1885 using Flags = Fortran::semantics::Symbol::Flag;1886 const auto *nominal = std::get_if<Nominal>(&var);1887 return nominal && nominal->symbol->test(Flags::CompilerCreated) &&1888 nominal->symbol->test(Flags::ReadOnly);1889}1890 1891//===----------------------------------------------------------------------===//1892// API implementation1893//===----------------------------------------------------------------------===//1894 1895std::unique_ptr<lower::pft::Program>1896Fortran::lower::createPFT(const parser::Program &root,1897 const semantics::SemanticsContext &semanticsContext) {1898 PFTBuilder walker(semanticsContext);1899 Walk(root, walker);1900 return walker.result();1901}1902 1903void Fortran::lower::dumpPFT(llvm::raw_ostream &outputStream,1904 const lower::pft::Program &pft) {1905 PFTDumper{}.dumpPFT(outputStream, pft);1906}1907 1908void Fortran::lower::pft::Program::dump() const {1909 dumpPFT(llvm::errs(), *this);1910}1911 1912void Fortran::lower::pft::Evaluation::dump() const {1913 PFTDumper{}.dumpEvaluation(llvm::errs(), *this);1914}1915 1916void Fortran::lower::pft::Variable::dump() const {1917 if (auto *s = std::get_if<Nominal>(&var)) {1918 llvm::errs() << s->symbol << " " << *s->symbol;1919 llvm::errs() << " (depth: " << s->depth << ')';1920 if (s->global)1921 llvm::errs() << ", global";1922 if (s->heapAlloc)1923 llvm::errs() << ", allocatable";1924 if (s->pointer)1925 llvm::errs() << ", pointer";1926 if (s->target)1927 llvm::errs() << ", target";1928 if (s->aliaser)1929 llvm::errs() << ", equivalence(" << s->aliasOffset << ')';1930 } else if (auto *s = std::get_if<AggregateStore>(&var)) {1931 llvm::errs() << "interval[" << std::get<0>(s->interval) << ", "1932 << std::get<1>(s->interval) << "]:";1933 llvm::errs() << " name: " << toStringRef(s->getNamingSymbol().name());1934 if (s->isGlobal())1935 llvm::errs() << ", global";1936 if (s->initialValueSymbol)1937 llvm::errs() << ", initial value: {" << *s->initialValueSymbol << "}";1938 } else {1939 llvm_unreachable("not a Variable");1940 }1941 llvm::errs() << '\n';1942}1943 1944void Fortran::lower::pft::dump(Fortran::lower::pft::VariableList &variableList,1945 std::string s) {1946 llvm::errs() << (s.empty() ? "VariableList" : s) << " " << &variableList1947 << " size=" << variableList.size() << "\n";1948 for (auto var : variableList) {1949 llvm::errs() << " ";1950 var.dump();1951 }1952}1953 1954void Fortran::lower::pft::FunctionLikeUnit::dump() const {1955 PFTDumper{}.dumpFunctionLikeUnit(llvm::errs(), *this);1956}1957 1958void Fortran::lower::pft::ModuleLikeUnit::dump() const {1959 PFTDumper{}.dumpModuleLikeUnit(llvm::errs(), *this);1960}1961 1962/// The BlockDataUnit dump is just the associated symbol table.1963void Fortran::lower::pft::BlockDataUnit::dump() const {1964 llvm::errs() << "block data {\n" << symTab << "\n}\n";1965}1966 1967/// Find or create an ordered list of equivalences and variables in \p scope.1968/// The result is cached in \p map.1969const lower::pft::VariableList &1970lower::pft::getScopeVariableList(const semantics::Scope &scope,1971 ScopeVariableListMap &map) {1972 LLVM_DEBUG(llvm::dbgs() << "\ngetScopeVariableList of [sub]module scope <"1973 << &scope << "> " << scope.GetName() << "\n");1974 auto iter = map.find(&scope);1975 if (iter == map.end()) {1976 SymbolDependenceAnalysis sda(scope);1977 map.emplace(&scope, sda.getVariableList());1978 iter = map.find(&scope);1979 }1980 return iter->second;1981}1982 1983/// Create an ordered list of equivalences and variables in \p scope.1984/// The result is not cached.1985lower::pft::VariableList1986lower::pft::getScopeVariableList(const semantics::Scope &scope) {1987 LLVM_DEBUG(1988 llvm::dbgs() << "\ngetScopeVariableList of [sub]program|block scope <"1989 << &scope << "> " << scope.GetName() << "\n");1990 SymbolDependenceAnalysis sda(scope);1991 return sda.getVariableList();1992}1993 1994/// Create an ordered list of equivalences and variables that \p symbol1995/// depends on (no caching). Include \p symbol at the end of the list.1996lower::pft::VariableList1997lower::pft::getDependentVariableList(const semantics::Symbol &symbol) {1998 LLVM_DEBUG(llvm::dbgs() << "\ngetDependentVariableList of " << &symbol1999 << " - " << symbol << "\n");2000 SymbolDependenceAnalysis sda(symbol);2001 return sda.getVariableList();2002}2003 2004namespace {2005/// Helper class to find all the symbols referenced in a FunctionLikeUnit.2006/// It defines a parse tree visitor doing a deep visit in all nodes with2007/// symbols (including evaluate::Expr).2008struct SymbolVisitor {2009 template <typename A>2010 bool Pre(const A &x) {2011 if constexpr (Fortran::parser::HasTypedExpr<A>::value)2012 // Some parse tree Expr may legitimately be un-analyzed after semantics2013 // (for instance PDT component initial value in the PDT definition body).2014 if (const auto *expr = Fortran::semantics::GetExpr(nullptr, x))2015 visitExpr(*expr);2016 return true;2017 }2018 2019 bool Pre(const Fortran::parser::Name &name) {2020 if (const semantics::Symbol *symbol = name.symbol)2021 visitSymbol(*symbol);2022 return false;2023 }2024 2025 template <typename T>2026 void visitExpr(const Fortran::evaluate::Expr<T> &expr) {2027 for (const semantics::Symbol &symbol :2028 Fortran::evaluate::CollectSymbols(expr))2029 visitSymbol(symbol);2030 }2031 2032 void visitSymbol(const Fortran::semantics::Symbol &symbol) {2033 callBack(symbol);2034 // - Visit statement function body since it will be inlined in lowering.2035 // - Visit function results specification expressions because allocations2036 // happens on the caller side.2037 if (const auto *subprogramDetails =2038 symbol.detailsIf<Fortran::semantics::SubprogramDetails>()) {2039 if (const auto &maybeExpr = subprogramDetails->stmtFunction()) {2040 visitExpr(*maybeExpr);2041 } else {2042 if (subprogramDetails->isFunction()) {2043 // Visit result extents expressions that are explicit.2044 const Fortran::semantics::Symbol &result =2045 subprogramDetails->result();2046 if (const auto *objectDetails =2047 result.detailsIf<Fortran::semantics::ObjectEntityDetails>())2048 if (objectDetails->shape().IsExplicitShape())2049 for (const Fortran::semantics::ShapeSpec &shapeSpec :2050 objectDetails->shape()) {2051 visitExpr(shapeSpec.lbound().GetExplicit().value());2052 visitExpr(shapeSpec.ubound().GetExplicit().value());2053 }2054 }2055 }2056 }2057 if (Fortran::semantics::IsProcedure(symbol)) {2058 if (auto dynamicType = Fortran::evaluate::DynamicType::From(symbol)) {2059 // Visit result length specification expressions that are explicit.2060 if (dynamicType->category() ==2061 Fortran::common::TypeCategory::Character) {2062 if (std::optional<Fortran::evaluate::ExtentExpr> length =2063 dynamicType->GetCharLength())2064 visitExpr(*length);2065 } else if (const Fortran::semantics::DerivedTypeSpec *derivedTypeSpec =2066 Fortran::evaluate::GetDerivedTypeSpec(dynamicType)) {2067 for (const auto &[_, param] : derivedTypeSpec->parameters())2068 if (const Fortran::semantics::MaybeIntExpr &expr =2069 param.GetExplicit())2070 visitExpr(expr.value());2071 }2072 }2073 }2074 // - CrayPointer needs to be available whenever a CrayPointee is used.2075 if (symbol.GetUltimate().test(2076 Fortran::semantics::Symbol::Flag::CrayPointee))2077 visitSymbol(Fortran::semantics::GetCrayPointer(symbol));2078 }2079 2080 template <typename A>2081 constexpr void Post(const A &) {}2082 2083 const std::function<void(const Fortran::semantics::Symbol &)> &callBack;2084};2085} // namespace2086 2087void Fortran::lower::pft::visitAllSymbols(2088 const Fortran::lower::pft::FunctionLikeUnit &funit,2089 const std::function<void(const Fortran::semantics::Symbol &)> callBack) {2090 SymbolVisitor visitor{callBack};2091 funit.visit([&](const auto &functionParserNode) {2092 parser::Walk(functionParserNode, visitor);2093 });2094}2095 2096void Fortran::lower::pft::visitAllSymbols(2097 const Fortran::lower::pft::Evaluation &eval,2098 const std::function<void(const Fortran::semantics::Symbol &)> callBack) {2099 SymbolVisitor visitor{callBack};2100 eval.visit([&](const auto &functionParserNode) {2101 parser::Walk(functionParserNode, visitor);2102 });2103}2104