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-exception 6 // 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 23 static 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 27 static llvm::cl::opt<bool> nonRecursiveProcedures( 28 "non-recursive-procedures", 29 llvm::cl::desc("Make procedures non-recursive by default. This was the " 30 "default for all Fortran standards prior to 2018."), 31 llvm::cl::init(/*2018 standard=*/false)); 32 33 using namespace Fortran; 34 35 namespace { 36 /// Helpers to unveil parser node inside Fortran::parser::Statement<>, 37 /// Fortran::parser::UnlabeledStatement, and Fortran::common::Indirection<> 38 template <typename A> 39 struct RemoveIndirectionHelper { 40 using Type = A; 41 }; 42 template <typename A> 43 struct RemoveIndirectionHelper<common::Indirection<A>> { 44 using Type = A; 45 }; 46 47 template <typename A> 48 struct UnwrapStmt { 49 static constexpr bool isStmt{false}; 50 }; 51 template <typename A> 52 struct UnwrapStmt<parser::Statement<A>> { 53 static constexpr bool isStmt{true}; 54 using Type = typename RemoveIndirectionHelper<A>::Type; 55 constexpr UnwrapStmt(const parser::Statement<A> &a) 56 : unwrapped{removeIndirection(a.statement)}, position{a.source}, 57 label{a.label} {} 58 const Type &unwrapped; 59 parser::CharBlock position; 60 std::optional<parser::Label> label; 61 }; 62 template <typename A> 63 struct UnwrapStmt<parser::UnlabeledStatement<A>> { 64 static constexpr bool isStmt{true}; 65 using Type = typename RemoveIndirectionHelper<A>::Type; 66 constexpr UnwrapStmt(const parser::UnlabeledStatement<A> &a) 67 : unwrapped{removeIndirection(a.statement)}, position{a.source} {} 68 const Type &unwrapped; 69 parser::CharBlock position; 70 std::optional<parser::Label> label; 71 }; 72 73 /// The instantiation of a parse tree visitor (Pre and Post) is extremely 74 /// expensive in terms of compile and link time. So one goal here is to 75 /// limit the bridge to one such instantiation. 76 class PFTBuilder { 77 public: 78 PFTBuilder(const semantics::SemanticsContext &semanticsContext) 79 : pgm{std::make_unique<lower::pft::Program>( 80 semanticsContext.GetCommonBlocks())}, 81 semanticsContext{semanticsContext} { 82 lower::pft::PftNode pftRoot{*pgm.get()}; 83 pftParentStack.push_back(pftRoot); 84 } 85 86 /// Get the result 87 std::unique_ptr<lower::pft::Program> result() { return std::move(pgm); } 88 89 template <typename A> 90 constexpr bool Pre(const A &a) { 91 if constexpr (lower::pft::isFunctionLike<A>) { 92 return enterFunction(a, semanticsContext); 93 } else if constexpr (lower::pft::isConstruct<A> || 94 lower::pft::isDirective<A>) { 95 return enterConstructOrDirective(a); 96 } else if constexpr (UnwrapStmt<A>::isStmt) { 97 using T = typename UnwrapStmt<A>::Type; 98 // Node "a" being visited has one of the following types: 99 // Statement<T>, Statement<Indirection<T>>, UnlabeledStatement<T>, 100 // or UnlabeledStatement<Indirection<T>> 101 auto stmt{UnwrapStmt<A>(a)}; 102 if constexpr (lower::pft::isConstructStmt<T> || 103 lower::pft::isOtherStmt<T>) { 104 addEvaluation(lower::pft::Evaluation{ 105 stmt.unwrapped, pftParentStack.back(), stmt.position, stmt.label}); 106 return false; 107 } else if constexpr (std::is_same_v<T, parser::ActionStmt>) { 108 return std::visit( 109 common::visitors{ 110 [&](const common::Indirection<parser::IfStmt> &x) { 111 convertIfStmt(x.value(), stmt.position, stmt.label); 112 return false; 113 }, 114 [&](const auto &x) { 115 addEvaluation(lower::pft::Evaluation{ 116 removeIndirection(x), pftParentStack.back(), 117 stmt.position, stmt.label}); 118 return true; 119 }, 120 }, 121 stmt.unwrapped.u); 122 } 123 } 124 return true; 125 } 126 127 /// Convert an IfStmt into an IfConstruct, retaining the IfStmt as the 128 /// first statement of the construct. 129 void convertIfStmt(const parser::IfStmt &ifStmt, parser::CharBlock position, 130 std::optional<parser::Label> label) { 131 // Generate a skeleton IfConstruct parse node. Its components are never 132 // referenced. The actual components are available via the IfConstruct 133 // evaluation's nested evaluationList, with the ifStmt in the position of 134 // the otherwise normal IfThenStmt. Caution: All other PFT nodes reference 135 // front end generated parse nodes; this is an exceptional case. 136 static const auto ifConstruct = parser::IfConstruct{ 137 parser::Statement<parser::IfThenStmt>{ 138 std::nullopt, 139 parser::IfThenStmt{ 140 std::optional<parser::Name>{}, 141 parser::ScalarLogicalExpr{parser::LogicalExpr{parser::Expr{ 142 parser::LiteralConstant{parser::LogicalLiteralConstant{ 143 false, std::optional<parser::KindParam>{}}}}}}}}, 144 parser::Block{}, std::list<parser::IfConstruct::ElseIfBlock>{}, 145 std::optional<parser::IfConstruct::ElseBlock>{}, 146 parser::Statement<parser::EndIfStmt>{std::nullopt, 147 parser::EndIfStmt{std::nullopt}}}; 148 enterConstructOrDirective(ifConstruct); 149 addEvaluation( 150 lower::pft::Evaluation{ifStmt, pftParentStack.back(), position, label}); 151 Pre(std::get<parser::UnlabeledStatement<parser::ActionStmt>>(ifStmt.t)); 152 static const auto endIfStmt = parser::EndIfStmt{std::nullopt}; 153 addEvaluation( 154 lower::pft::Evaluation{endIfStmt, pftParentStack.back(), {}, {}}); 155 exitConstructOrDirective(); 156 } 157 158 template <typename A> 159 constexpr void Post(const A &) { 160 if constexpr (lower::pft::isFunctionLike<A>) { 161 exitFunction(); 162 } else if constexpr (lower::pft::isConstruct<A> || 163 lower::pft::isDirective<A>) { 164 exitConstructOrDirective(); 165 } 166 } 167 168 // Module like 169 bool Pre(const parser::Module &node) { return enterModule(node); } 170 bool Pre(const parser::Submodule &node) { return enterModule(node); } 171 172 void Post(const parser::Module &) { exitModule(); } 173 void Post(const parser::Submodule &) { exitModule(); } 174 175 // Block data 176 bool Pre(const parser::BlockData &node) { 177 addUnit(lower::pft::BlockDataUnit{node, pftParentStack.back(), 178 semanticsContext}); 179 return false; 180 } 181 182 // Get rid of production wrapper 183 bool Pre(const parser::Statement<parser::ForallAssignmentStmt> &statement) { 184 addEvaluation(std::visit( 185 [&](const auto &x) { 186 return lower::pft::Evaluation{x, pftParentStack.back(), 187 statement.source, statement.label}; 188 }, 189 statement.statement.u)); 190 return false; 191 } 192 bool Pre(const parser::WhereBodyConstruct &whereBody) { 193 return std::visit( 194 common::visitors{ 195 [&](const parser::Statement<parser::AssignmentStmt> &stmt) { 196 // Not caught as other AssignmentStmt because it is not 197 // wrapped in a parser::ActionStmt. 198 addEvaluation(lower::pft::Evaluation{stmt.statement, 199 pftParentStack.back(), 200 stmt.source, stmt.label}); 201 return false; 202 }, 203 [&](const auto &) { return true; }, 204 }, 205 whereBody.u); 206 } 207 208 // CompilerDirective have special handling in case they are top level 209 // directives (i.e. they do not belong to a ProgramUnit). 210 bool Pre(const parser::CompilerDirective &directive) { 211 assert(pftParentStack.size() > 0 && 212 "At least the Program must be a parent"); 213 if (pftParentStack.back().isA<lower::pft::Program>()) { 214 addUnit( 215 lower::pft::CompilerDirectiveUnit(directive, pftParentStack.back())); 216 return false; 217 } 218 return enterConstructOrDirective(directive); 219 } 220 221 private: 222 /// Initialize a new module-like unit and make it the builder's focus. 223 template <typename A> 224 bool enterModule(const A &func) { 225 Fortran::lower::pft::ModuleLikeUnit &unit = 226 addUnit(lower::pft::ModuleLikeUnit{func, pftParentStack.back()}); 227 functionList = &unit.nestedFunctions; 228 pushEvaluationList(&unit.evaluationList); 229 pftParentStack.emplace_back(unit); 230 return true; 231 } 232 233 void exitModule() { 234 if (!evaluationListStack.empty()) 235 popEvaluationList(); 236 pftParentStack.pop_back(); 237 resetFunctionState(); 238 } 239 240 /// Add the end statement Evaluation of a sub/program to the PFT. 241 /// There may be intervening internal subprogram definitions between 242 /// prior statements and this end statement. 243 void endFunctionBody() { 244 if (evaluationListStack.empty()) 245 return; 246 auto evaluationList = evaluationListStack.back(); 247 if (evaluationList->empty() || !evaluationList->back().isEndStmt()) { 248 const auto &endStmt = 249 pftParentStack.back().get<lower::pft::FunctionLikeUnit>().endStmt; 250 endStmt.visit(common::visitors{ 251 [&](const parser::Statement<parser::EndProgramStmt> &s) { 252 addEvaluation(lower::pft::Evaluation{ 253 s.statement, pftParentStack.back(), s.source, s.label}); 254 }, 255 [&](const parser::Statement<parser::EndFunctionStmt> &s) { 256 addEvaluation(lower::pft::Evaluation{ 257 s.statement, pftParentStack.back(), s.source, s.label}); 258 }, 259 [&](const parser::Statement<parser::EndSubroutineStmt> &s) { 260 addEvaluation(lower::pft::Evaluation{ 261 s.statement, pftParentStack.back(), s.source, s.label}); 262 }, 263 [&](const parser::Statement<parser::EndMpSubprogramStmt> &s) { 264 addEvaluation(lower::pft::Evaluation{ 265 s.statement, pftParentStack.back(), s.source, s.label}); 266 }, 267 [&](const auto &s) { 268 llvm::report_fatal_error("missing end statement or unexpected " 269 "begin statement reference"); 270 }, 271 }); 272 } 273 lastLexicalEvaluation = nullptr; 274 } 275 276 /// Pop the ModuleLikeUnit evaluationList when entering the first module 277 /// procedure. 278 void cleanModuleEvaluationList() { 279 if (evaluationListStack.empty()) 280 return; 281 if (pftParentStack.back().isA<lower::pft::ModuleLikeUnit>()) 282 popEvaluationList(); 283 } 284 285 /// Initialize a new function-like unit and make it the builder's focus. 286 template <typename A> 287 bool enterFunction(const A &func, 288 const semantics::SemanticsContext &semanticsContext) { 289 cleanModuleEvaluationList(); 290 endFunctionBody(); // enclosing host subprogram body, if any 291 Fortran::lower::pft::FunctionLikeUnit &unit = 292 addFunction(lower::pft::FunctionLikeUnit{func, pftParentStack.back(), 293 semanticsContext}); 294 labelEvaluationMap = &unit.labelEvaluationMap; 295 assignSymbolLabelMap = &unit.assignSymbolLabelMap; 296 functionList = &unit.nestedFunctions; 297 pushEvaluationList(&unit.evaluationList); 298 pftParentStack.emplace_back(unit); 299 return true; 300 } 301 302 void exitFunction() { 303 rewriteIfGotos(); 304 endFunctionBody(); 305 analyzeBranches(nullptr, *evaluationListStack.back()); // add branch links 306 processEntryPoints(); 307 popEvaluationList(); 308 labelEvaluationMap = nullptr; 309 assignSymbolLabelMap = nullptr; 310 pftParentStack.pop_back(); 311 resetFunctionState(); 312 } 313 314 /// Initialize a new construct or directive and make it the builder's focus. 315 template <typename A> 316 bool enterConstructOrDirective(const A &constructOrDirective) { 317 Fortran::lower::pft::Evaluation &eval = addEvaluation( 318 lower::pft::Evaluation{constructOrDirective, pftParentStack.back()}); 319 eval.evaluationList.reset(new lower::pft::EvaluationList); 320 pushEvaluationList(eval.evaluationList.get()); 321 pftParentStack.emplace_back(eval); 322 constructAndDirectiveStack.emplace_back(&eval); 323 return true; 324 } 325 326 void exitConstructOrDirective() { 327 rewriteIfGotos(); 328 auto *eval = constructAndDirectiveStack.back(); 329 if (eval->isExecutableDirective()) { 330 // A construct at the end of an (unstructured) OpenACC or OpenMP 331 // construct region must have an exit target inside the region. 332 Fortran::lower::pft::EvaluationList &evaluationList = 333 *eval->evaluationList; 334 if (!evaluationList.empty() && evaluationList.back().isConstruct()) { 335 static const parser::ContinueStmt exitTarget{}; 336 addEvaluation( 337 lower::pft::Evaluation{exitTarget, pftParentStack.back(), {}, {}}); 338 } 339 } 340 popEvaluationList(); 341 pftParentStack.pop_back(); 342 constructAndDirectiveStack.pop_back(); 343 } 344 345 /// Reset function state to that of an enclosing host function. 346 void resetFunctionState() { 347 if (!pftParentStack.empty()) { 348 pftParentStack.back().visit(common::visitors{ 349 [&](lower::pft::FunctionLikeUnit &p) { 350 functionList = &p.nestedFunctions; 351 labelEvaluationMap = &p.labelEvaluationMap; 352 assignSymbolLabelMap = &p.assignSymbolLabelMap; 353 }, 354 [&](lower::pft::ModuleLikeUnit &p) { 355 functionList = &p.nestedFunctions; 356 }, 357 [&](auto &) { functionList = nullptr; }, 358 }); 359 } 360 } 361 362 template <typename A> 363 A &addUnit(A &&unit) { 364 pgm->getUnits().emplace_back(std::move(unit)); 365 return std::get<A>(pgm->getUnits().back()); 366 } 367 368 template <typename A> 369 A &addFunction(A &&func) { 370 if (functionList) { 371 functionList->emplace_back(std::move(func)); 372 return functionList->back(); 373 } 374 return addUnit(std::move(func)); 375 } 376 377 // ActionStmt has a couple of non-conforming cases, explicitly handled here. 378 // The other cases use an Indirection, which are discarded in the PFT. 379 lower::pft::Evaluation 380 makeEvaluationAction(const parser::ActionStmt &statement, 381 parser::CharBlock position, 382 std::optional<parser::Label> label) { 383 return std::visit( 384 common::visitors{ 385 [&](const auto &x) { 386 return lower::pft::Evaluation{ 387 removeIndirection(x), pftParentStack.back(), position, label}; 388 }, 389 }, 390 statement.u); 391 } 392 393 /// Append an Evaluation to the end of the current list. 394 lower::pft::Evaluation &addEvaluation(lower::pft::Evaluation &&eval) { 395 assert(functionList && "not in a function"); 396 assert(!evaluationListStack.empty() && "empty evaluation list stack"); 397 if (!constructAndDirectiveStack.empty()) 398 eval.parentConstruct = constructAndDirectiveStack.back(); 399 auto &entryPointList = eval.getOwningProcedure()->entryPointList; 400 evaluationListStack.back()->emplace_back(std::move(eval)); 401 lower::pft::Evaluation *p = &evaluationListStack.back()->back(); 402 if (p->isActionStmt() || p->isConstructStmt() || p->isEndStmt() || 403 p->isExecutableDirective()) { 404 if (lastLexicalEvaluation) { 405 lastLexicalEvaluation->lexicalSuccessor = p; 406 p->printIndex = lastLexicalEvaluation->printIndex + 1; 407 } else { 408 p->printIndex = 1; 409 } 410 lastLexicalEvaluation = p; 411 for (std::size_t entryIndex = entryPointList.size() - 1; 412 entryIndex && !entryPointList[entryIndex].second->lexicalSuccessor; 413 --entryIndex) 414 // Link to the entry's first executable statement. 415 entryPointList[entryIndex].second->lexicalSuccessor = p; 416 } else if (const auto *entryStmt = p->getIf<parser::EntryStmt>()) { 417 const semantics::Symbol *sym = 418 std::get<parser::Name>(entryStmt->t).symbol; 419 assert(sym->has<semantics::SubprogramDetails>() && 420 "entry must be a subprogram"); 421 entryPointList.push_back(std::pair{sym, p}); 422 } 423 if (p->label.has_value()) 424 labelEvaluationMap->try_emplace(*p->label, p); 425 return evaluationListStack.back()->back(); 426 } 427 428 /// push a new list on the stack of Evaluation lists 429 void pushEvaluationList(lower::pft::EvaluationList *evaluationList) { 430 assert(functionList && "not in a function"); 431 assert(evaluationList && evaluationList->empty() && 432 "evaluation list isn't correct"); 433 evaluationListStack.emplace_back(evaluationList); 434 } 435 436 /// pop the current list and return to the last Evaluation list 437 void popEvaluationList() { 438 assert(functionList && "not in a function"); 439 evaluationListStack.pop_back(); 440 } 441 442 /// Rewrite IfConstructs containing a GotoStmt or CycleStmt to eliminate an 443 /// unstructured branch and a trivial basic block. The pre-branch-analysis 444 /// code: 445 /// 446 /// <<IfConstruct>> 447 /// 1 If[Then]Stmt: if(cond) goto L 448 /// 2 GotoStmt: goto L 449 /// 3 EndIfStmt 450 /// <<End IfConstruct>> 451 /// 4 Statement: ... 452 /// 5 Statement: ... 453 /// 6 Statement: L ... 454 /// 455 /// becomes: 456 /// 457 /// <<IfConstruct>> 458 /// 1 If[Then]Stmt [negate]: if(cond) goto L 459 /// 4 Statement: ... 460 /// 5 Statement: ... 461 /// 3 EndIfStmt 462 /// <<End IfConstruct>> 463 /// 6 Statement: L ... 464 /// 465 /// The If[Then]Stmt condition is implicitly negated. It is not modified 466 /// in the PFT. It must be negated when generating FIR. The GotoStmt or 467 /// CycleStmt is deleted. 468 /// 469 /// The transformation is only valid for forward branch targets at the same 470 /// construct nesting level as the IfConstruct. The result must not violate 471 /// construct nesting requirements or contain an EntryStmt. The result 472 /// is subject to normal un/structured code classification analysis. The 473 /// result is allowed to violate the F18 Clause 11.1.2.1 prohibition on 474 /// transfer of control into the interior of a construct block, as that does 475 /// not compromise correct code generation. When two transformation 476 /// candidates overlap, at least one must be disallowed. In such cases, 477 /// the current heuristic favors simple code generation, which happens to 478 /// favor later candidates over earlier candidates. That choice is probably 479 /// not significant, but could be changed. 480 /// 481 void rewriteIfGotos() { 482 auto &evaluationList = *evaluationListStack.back(); 483 if (!evaluationList.size()) 484 return; 485 struct T { 486 lower::pft::EvaluationList::iterator ifConstructIt; 487 parser::Label ifTargetLabel; 488 bool isCycleStmt = false; 489 }; 490 llvm::SmallVector<T> ifCandidateStack; 491 const auto *doStmt = 492 evaluationList.begin()->getIf<parser::NonLabelDoStmt>(); 493 std::string doName = doStmt ? getConstructName(*doStmt) : std::string{}; 494 for (auto it = evaluationList.begin(), end = evaluationList.end(); 495 it != end; ++it) { 496 auto &eval = *it; 497 if (eval.isA<parser::EntryStmt>()) { 498 ifCandidateStack.clear(); 499 continue; 500 } 501 auto firstStmt = [](lower::pft::Evaluation *e) { 502 return e->isConstruct() ? &*e->evaluationList->begin() : e; 503 }; 504 const Fortran::lower::pft::Evaluation &targetEval = *firstStmt(&eval); 505 bool targetEvalIsEndDoStmt = targetEval.isA<parser::EndDoStmt>(); 506 auto branchTargetMatch = [&]() { 507 if (const parser::Label targetLabel = 508 ifCandidateStack.back().ifTargetLabel) 509 if (targetLabel == *targetEval.label) 510 return true; // goto target match 511 if (targetEvalIsEndDoStmt && ifCandidateStack.back().isCycleStmt) 512 return true; // cycle target match 513 return false; 514 }; 515 if (targetEval.label || targetEvalIsEndDoStmt) { 516 while (!ifCandidateStack.empty() && branchTargetMatch()) { 517 lower::pft::EvaluationList::iterator ifConstructIt = 518 ifCandidateStack.back().ifConstructIt; 519 lower::pft::EvaluationList::iterator successorIt = 520 std::next(ifConstructIt); 521 if (successorIt != it) { 522 Fortran::lower::pft::EvaluationList &ifBodyList = 523 *ifConstructIt->evaluationList; 524 lower::pft::EvaluationList::iterator branchStmtIt = 525 std::next(ifBodyList.begin()); 526 assert((branchStmtIt->isA<parser::GotoStmt>() || 527 branchStmtIt->isA<parser::CycleStmt>()) && 528 "expected goto or cycle statement"); 529 ifBodyList.erase(branchStmtIt); 530 lower::pft::Evaluation &ifStmt = *ifBodyList.begin(); 531 ifStmt.negateCondition = true; 532 ifStmt.lexicalSuccessor = firstStmt(&*successorIt); 533 lower::pft::EvaluationList::iterator endIfStmtIt = 534 std::prev(ifBodyList.end()); 535 std::prev(it)->lexicalSuccessor = &*endIfStmtIt; 536 endIfStmtIt->lexicalSuccessor = firstStmt(&*it); 537 ifBodyList.splice(endIfStmtIt, evaluationList, successorIt, it); 538 for (; successorIt != endIfStmtIt; ++successorIt) 539 successorIt->parentConstruct = &*ifConstructIt; 540 } 541 ifCandidateStack.pop_back(); 542 } 543 } 544 if (eval.isA<parser::IfConstruct>() && eval.evaluationList->size() == 3) { 545 const auto bodyEval = std::next(eval.evaluationList->begin()); 546 if (const auto *gotoStmt = bodyEval->getIf<parser::GotoStmt>()) { 547 ifCandidateStack.push_back({it, gotoStmt->v}); 548 } else if (doStmt) { 549 if (const auto *cycleStmt = bodyEval->getIf<parser::CycleStmt>()) { 550 std::string cycleName = getConstructName(*cycleStmt); 551 if (cycleName.empty() || cycleName == doName) 552 // This candidate will match doStmt's EndDoStmt. 553 ifCandidateStack.push_back({it, {}, true}); 554 } 555 } 556 } 557 } 558 } 559 560 /// Mark IO statement ERR, EOR, and END specifier branch targets. 561 /// Mark an IO statement with an assigned format as unstructured. 562 template <typename A> 563 void analyzeIoBranches(lower::pft::Evaluation &eval, const A &stmt) { 564 auto analyzeFormatSpec = [&](const parser::Format &format) { 565 if (const auto *expr = std::get_if<parser::Expr>(&format.u)) { 566 if (semantics::ExprHasTypeCategory(*semantics::GetExpr(*expr), 567 common::TypeCategory::Integer)) 568 eval.isUnstructured = true; 569 } 570 }; 571 auto analyzeSpecs{[&](const auto &specList) { 572 for (const auto &spec : specList) { 573 std::visit( 574 Fortran::common::visitors{ 575 [&](const Fortran::parser::Format &format) { 576 analyzeFormatSpec(format); 577 }, 578 [&](const auto &label) { 579 using LabelNodes = 580 std::tuple<parser::ErrLabel, parser::EorLabel, 581 parser::EndLabel>; 582 if constexpr (common::HasMember<decltype(label), LabelNodes>) 583 markBranchTarget(eval, label.v); 584 }}, 585 spec.u); 586 } 587 }}; 588 589 using OtherIOStmts = 590 std::tuple<parser::BackspaceStmt, parser::CloseStmt, 591 parser::EndfileStmt, parser::FlushStmt, parser::OpenStmt, 592 parser::RewindStmt, parser::WaitStmt>; 593 594 if constexpr (std::is_same_v<A, parser::ReadStmt> || 595 std::is_same_v<A, parser::WriteStmt>) { 596 if (stmt.format) 597 analyzeFormatSpec(*stmt.format); 598 analyzeSpecs(stmt.controls); 599 } else if constexpr (std::is_same_v<A, parser::PrintStmt>) { 600 analyzeFormatSpec(std::get<parser::Format>(stmt.t)); 601 } else if constexpr (std::is_same_v<A, parser::InquireStmt>) { 602 if (const auto *specList = 603 std::get_if<std::list<parser::InquireSpec>>(&stmt.u)) 604 analyzeSpecs(*specList); 605 } else if constexpr (common::HasMember<A, OtherIOStmts>) { 606 analyzeSpecs(stmt.v); 607 } else { 608 // Always crash if this is instantiated 609 static_assert(!std::is_same_v<A, parser::ReadStmt>, 610 "Unexpected IO statement"); 611 } 612 } 613 614 /// Set the exit of a construct, possibly from multiple enclosing constructs. 615 void setConstructExit(lower::pft::Evaluation &eval) { 616 eval.constructExit = &eval.evaluationList->back().nonNopSuccessor(); 617 } 618 619 /// Mark the target of a branch as a new block. 620 void markBranchTarget(lower::pft::Evaluation &sourceEvaluation, 621 lower::pft::Evaluation &targetEvaluation) { 622 sourceEvaluation.isUnstructured = true; 623 if (!sourceEvaluation.controlSuccessor) 624 sourceEvaluation.controlSuccessor = &targetEvaluation; 625 targetEvaluation.isNewBlock = true; 626 // If this is a branch into the body of a construct (usually illegal, 627 // but allowed in some legacy cases), then the targetEvaluation and its 628 // ancestors must be marked as unstructured. 629 lower::pft::Evaluation *sourceConstruct = sourceEvaluation.parentConstruct; 630 lower::pft::Evaluation *targetConstruct = targetEvaluation.parentConstruct; 631 if (targetConstruct && 632 &targetConstruct->getFirstNestedEvaluation() == &targetEvaluation) 633 // A branch to an initial constructStmt is a branch to the construct. 634 targetConstruct = targetConstruct->parentConstruct; 635 if (targetConstruct) { 636 while (sourceConstruct && sourceConstruct != targetConstruct) 637 sourceConstruct = sourceConstruct->parentConstruct; 638 if (sourceConstruct != targetConstruct) // branch into a construct body 639 for (lower::pft::Evaluation *eval = &targetEvaluation; eval; 640 eval = eval->parentConstruct) { 641 eval->isUnstructured = true; 642 // If the branch is a backward branch into an already analyzed 643 // DO or IF construct, mark the construct exit as a new block. 644 // For a forward branch, the isUnstructured flag will cause this 645 // to be done when the construct is analyzed. 646 if (eval->constructExit && (eval->isA<parser::DoConstruct>() || 647 eval->isA<parser::IfConstruct>())) 648 eval->constructExit->isNewBlock = true; 649 } 650 } 651 } 652 void markBranchTarget(lower::pft::Evaluation &sourceEvaluation, 653 parser::Label label) { 654 assert(label && "missing branch target label"); 655 lower::pft::Evaluation *targetEvaluation{ 656 labelEvaluationMap->find(label)->second}; 657 assert(targetEvaluation && "missing branch target evaluation"); 658 markBranchTarget(sourceEvaluation, *targetEvaluation); 659 } 660 661 /// Mark the successor of an Evaluation as a new block. 662 void markSuccessorAsNewBlock(lower::pft::Evaluation &eval) { 663 eval.nonNopSuccessor().isNewBlock = true; 664 } 665 666 template <typename A> 667 inline std::string getConstructName(const A &stmt) { 668 using MaybeConstructNameWrapper = 669 std::tuple<parser::BlockStmt, parser::CycleStmt, parser::ElseStmt, 670 parser::ElsewhereStmt, parser::EndAssociateStmt, 671 parser::EndBlockStmt, parser::EndCriticalStmt, 672 parser::EndDoStmt, parser::EndForallStmt, parser::EndIfStmt, 673 parser::EndSelectStmt, parser::EndWhereStmt, 674 parser::ExitStmt>; 675 if constexpr (common::HasMember<A, MaybeConstructNameWrapper>) { 676 if (stmt.v) 677 return stmt.v->ToString(); 678 } 679 680 using MaybeConstructNameInTuple = std::tuple< 681 parser::AssociateStmt, parser::CaseStmt, parser::ChangeTeamStmt, 682 parser::CriticalStmt, parser::ElseIfStmt, parser::EndChangeTeamStmt, 683 parser::ForallConstructStmt, parser::IfThenStmt, parser::LabelDoStmt, 684 parser::MaskedElsewhereStmt, parser::NonLabelDoStmt, 685 parser::SelectCaseStmt, parser::SelectRankCaseStmt, 686 parser::TypeGuardStmt, parser::WhereConstructStmt>; 687 if constexpr (common::HasMember<A, MaybeConstructNameInTuple>) { 688 if (auto name = std::get<std::optional<parser::Name>>(stmt.t)) 689 return name->ToString(); 690 } 691 692 // These statements have multiple std::optional<parser::Name> elements. 693 if constexpr (std::is_same_v<A, parser::SelectRankStmt> || 694 std::is_same_v<A, parser::SelectTypeStmt>) { 695 if (auto name = std::get<0>(stmt.t)) 696 return name->ToString(); 697 } 698 699 return {}; 700 } 701 702 /// \p parentConstruct can be null if this statement is at the highest 703 /// level of a program. 704 template <typename A> 705 void insertConstructName(const A &stmt, 706 lower::pft::Evaluation *parentConstruct) { 707 std::string name = getConstructName(stmt); 708 if (!name.empty()) 709 constructNameMap[name] = parentConstruct; 710 } 711 712 /// Insert branch links for a list of Evaluations. 713 /// \p parentConstruct can be null if the evaluationList contains the 714 /// top-level statements of a program. 715 void analyzeBranches(lower::pft::Evaluation *parentConstruct, 716 std::list<lower::pft::Evaluation> &evaluationList) { 717 lower::pft::Evaluation *lastConstructStmtEvaluation{}; 718 for (auto &eval : evaluationList) { 719 eval.visit(common::visitors{ 720 // Action statements (except IO statements) 721 [&](const parser::CallStmt &s) { 722 // Look for alternate return specifiers. 723 const auto &args = 724 std::get<std::list<parser::ActualArgSpec>>(s.v.t); 725 for (const auto &arg : args) { 726 const auto &actual = std::get<parser::ActualArg>(arg.t); 727 if (const auto *altReturn = 728 std::get_if<parser::AltReturnSpec>(&actual.u)) 729 markBranchTarget(eval, altReturn->v); 730 } 731 }, 732 [&](const parser::CycleStmt &s) { 733 std::string name = getConstructName(s); 734 lower::pft::Evaluation *construct{name.empty() 735 ? doConstructStack.back() 736 : constructNameMap[name]}; 737 assert(construct && "missing CYCLE construct"); 738 markBranchTarget(eval, construct->evaluationList->back()); 739 }, 740 [&](const parser::ExitStmt &s) { 741 std::string name = getConstructName(s); 742 lower::pft::Evaluation *construct{name.empty() 743 ? doConstructStack.back() 744 : constructNameMap[name]}; 745 assert(construct && "missing EXIT construct"); 746 markBranchTarget(eval, *construct->constructExit); 747 }, 748 [&](const parser::FailImageStmt &) { 749 eval.isUnstructured = true; 750 if (eval.lexicalSuccessor->lexicalSuccessor) 751 markSuccessorAsNewBlock(eval); 752 }, 753 [&](const parser::GotoStmt &s) { markBranchTarget(eval, s.v); }, 754 [&](const parser::IfStmt &) { 755 eval.lexicalSuccessor->isNewBlock = true; 756 lastConstructStmtEvaluation = &eval; 757 }, 758 [&](const parser::ReturnStmt &) { 759 eval.isUnstructured = true; 760 if (eval.lexicalSuccessor->lexicalSuccessor) 761 markSuccessorAsNewBlock(eval); 762 }, 763 [&](const parser::StopStmt &) { 764 eval.isUnstructured = true; 765 if (eval.lexicalSuccessor->lexicalSuccessor) 766 markSuccessorAsNewBlock(eval); 767 }, 768 [&](const parser::ComputedGotoStmt &s) { 769 for (auto &label : std::get<std::list<parser::Label>>(s.t)) 770 markBranchTarget(eval, label); 771 }, 772 [&](const parser::ArithmeticIfStmt &s) { 773 markBranchTarget(eval, std::get<1>(s.t)); 774 markBranchTarget(eval, std::get<2>(s.t)); 775 markBranchTarget(eval, std::get<3>(s.t)); 776 }, 777 [&](const parser::AssignStmt &s) { // legacy label assignment 778 auto &label = std::get<parser::Label>(s.t); 779 const auto *sym = std::get<parser::Name>(s.t).symbol; 780 assert(sym && "missing AssignStmt symbol"); 781 lower::pft::Evaluation *target{ 782 labelEvaluationMap->find(label)->second}; 783 assert(target && "missing branch target evaluation"); 784 if (!target->isA<parser::FormatStmt>()) 785 target->isNewBlock = true; 786 auto iter = assignSymbolLabelMap->find(*sym); 787 if (iter == assignSymbolLabelMap->end()) { 788 lower::pft::LabelSet labelSet{}; 789 labelSet.insert(label); 790 assignSymbolLabelMap->try_emplace(*sym, labelSet); 791 } else { 792 iter->second.insert(label); 793 } 794 }, 795 [&](const parser::AssignedGotoStmt &) { 796 // Although this statement is a branch, it doesn't have any 797 // explicit control successors. So the code at the end of the 798 // loop won't mark the successor. Do that here. 799 eval.isUnstructured = true; 800 markSuccessorAsNewBlock(eval); 801 }, 802 803 // The first executable statement after an EntryStmt is a new block. 804 [&](const parser::EntryStmt &) { 805 eval.lexicalSuccessor->isNewBlock = true; 806 }, 807 808 // Construct statements 809 [&](const parser::AssociateStmt &s) { 810 insertConstructName(s, parentConstruct); 811 }, 812 [&](const parser::BlockStmt &s) { 813 insertConstructName(s, parentConstruct); 814 }, 815 [&](const parser::SelectCaseStmt &s) { 816 insertConstructName(s, parentConstruct); 817 lastConstructStmtEvaluation = &eval; 818 }, 819 [&](const parser::CaseStmt &) { 820 eval.isNewBlock = true; 821 lastConstructStmtEvaluation->controlSuccessor = &eval; 822 lastConstructStmtEvaluation = &eval; 823 }, 824 [&](const parser::EndSelectStmt &) { 825 eval.nonNopSuccessor().isNewBlock = true; 826 lastConstructStmtEvaluation = nullptr; 827 }, 828 [&](const parser::ChangeTeamStmt &s) { 829 insertConstructName(s, parentConstruct); 830 }, 831 [&](const parser::CriticalStmt &s) { 832 insertConstructName(s, parentConstruct); 833 }, 834 [&](const parser::NonLabelDoStmt &s) { 835 insertConstructName(s, parentConstruct); 836 doConstructStack.push_back(parentConstruct); 837 const auto &loopControl = 838 std::get<std::optional<parser::LoopControl>>(s.t); 839 if (!loopControl.has_value()) { 840 eval.isUnstructured = true; // infinite loop 841 return; 842 } 843 eval.nonNopSuccessor().isNewBlock = true; 844 eval.controlSuccessor = &evaluationList.back(); 845 if (const auto *bounds = 846 std::get_if<parser::LoopControl::Bounds>(&loopControl->u)) { 847 if (bounds->name.thing.symbol->GetType()->IsNumeric( 848 common::TypeCategory::Real)) 849 eval.isUnstructured = true; // real-valued loop control 850 } else if (std::get_if<parser::ScalarLogicalExpr>( 851 &loopControl->u)) { 852 eval.isUnstructured = true; // while loop 853 } 854 }, 855 [&](const parser::EndDoStmt &) { 856 lower::pft::Evaluation &doEval = evaluationList.front(); 857 eval.controlSuccessor = &doEval; 858 doConstructStack.pop_back(); 859 if (parentConstruct->lowerAsStructured()) 860 return; 861 // The loop is unstructured, which wasn't known for all cases when 862 // visiting the NonLabelDoStmt. 863 parentConstruct->constructExit->isNewBlock = true; 864 const auto &doStmt = *doEval.getIf<parser::NonLabelDoStmt>(); 865 const auto &loopControl = 866 std::get<std::optional<parser::LoopControl>>(doStmt.t); 867 if (!loopControl.has_value()) 868 return; // infinite loop 869 if (const auto *concurrent = 870 std::get_if<parser::LoopControl::Concurrent>( 871 &loopControl->u)) { 872 // If there is a mask, the EndDoStmt starts a new block. 873 const auto &header = 874 std::get<parser::ConcurrentHeader>(concurrent->t); 875 eval.isNewBlock |= 876 std::get<std::optional<parser::ScalarLogicalExpr>>(header.t) 877 .has_value(); 878 } 879 }, 880 [&](const parser::IfThenStmt &s) { 881 insertConstructName(s, parentConstruct); 882 eval.lexicalSuccessor->isNewBlock = true; 883 lastConstructStmtEvaluation = &eval; 884 }, 885 [&](const parser::ElseIfStmt &) { 886 eval.isNewBlock = true; 887 eval.lexicalSuccessor->isNewBlock = true; 888 lastConstructStmtEvaluation->controlSuccessor = &eval; 889 lastConstructStmtEvaluation = &eval; 890 }, 891 [&](const parser::ElseStmt &) { 892 eval.isNewBlock = true; 893 lastConstructStmtEvaluation->controlSuccessor = &eval; 894 lastConstructStmtEvaluation = nullptr; 895 }, 896 [&](const parser::EndIfStmt &) { 897 if (parentConstruct->lowerAsUnstructured()) 898 parentConstruct->constructExit->isNewBlock = true; 899 if (lastConstructStmtEvaluation) { 900 lastConstructStmtEvaluation->controlSuccessor = 901 parentConstruct->constructExit; 902 lastConstructStmtEvaluation = nullptr; 903 } 904 }, 905 [&](const parser::SelectRankStmt &s) { 906 insertConstructName(s, parentConstruct); 907 }, 908 [&](const parser::SelectRankCaseStmt &) { eval.isNewBlock = true; }, 909 [&](const parser::SelectTypeStmt &s) { 910 insertConstructName(s, parentConstruct); 911 }, 912 [&](const parser::TypeGuardStmt &) { eval.isNewBlock = true; }, 913 914 // Constructs - set (unstructured) construct exit targets 915 [&](const parser::AssociateConstruct &) { setConstructExit(eval); }, 916 [&](const parser::BlockConstruct &) { 917 // EndBlockStmt may have code. 918 eval.constructExit = &eval.evaluationList->back(); 919 }, 920 [&](const parser::CaseConstruct &) { 921 setConstructExit(eval); 922 eval.isUnstructured = true; 923 }, 924 [&](const parser::ChangeTeamConstruct &) { 925 // EndChangeTeamStmt may have code. 926 eval.constructExit = &eval.evaluationList->back(); 927 }, 928 [&](const parser::CriticalConstruct &) { 929 // EndCriticalStmt may have code. 930 eval.constructExit = &eval.evaluationList->back(); 931 }, 932 [&](const parser::DoConstruct &) { setConstructExit(eval); }, 933 [&](const parser::IfConstruct &) { setConstructExit(eval); }, 934 [&](const parser::SelectRankConstruct &) { 935 setConstructExit(eval); 936 eval.isUnstructured = true; 937 }, 938 [&](const parser::SelectTypeConstruct &) { 939 setConstructExit(eval); 940 eval.isUnstructured = true; 941 }, 942 943 // Default - Common analysis for IO statements; otherwise nop. 944 [&](const auto &stmt) { 945 using A = std::decay_t<decltype(stmt)>; 946 using IoStmts = std::tuple< 947 parser::BackspaceStmt, parser::CloseStmt, parser::EndfileStmt, 948 parser::FlushStmt, parser::InquireStmt, parser::OpenStmt, 949 parser::PrintStmt, parser::ReadStmt, parser::RewindStmt, 950 parser::WaitStmt, parser::WriteStmt>; 951 if constexpr (common::HasMember<A, IoStmts>) 952 analyzeIoBranches(eval, stmt); 953 }, 954 }); 955 956 // Analyze construct evaluations. 957 if (eval.evaluationList) 958 analyzeBranches(&eval, *eval.evaluationList); 959 960 // Set the successor of the last statement in an IF or SELECT block. 961 if (!eval.controlSuccessor && eval.lexicalSuccessor && 962 eval.lexicalSuccessor->isIntermediateConstructStmt()) { 963 eval.controlSuccessor = parentConstruct->constructExit; 964 eval.lexicalSuccessor->isNewBlock = true; 965 } 966 967 // Propagate isUnstructured flag to enclosing construct. 968 if (parentConstruct && eval.isUnstructured) 969 parentConstruct->isUnstructured = true; 970 971 // The successor of a branch starts a new block. 972 if (eval.controlSuccessor && eval.isActionStmt() && 973 eval.lowerAsUnstructured()) 974 markSuccessorAsNewBlock(eval); 975 } 976 } 977 978 /// Do processing specific to subprograms with multiple entry points. 979 void processEntryPoints() { 980 lower::pft::Evaluation *initialEval = &evaluationListStack.back()->front(); 981 lower::pft::FunctionLikeUnit *unit = initialEval->getOwningProcedure(); 982 int entryCount = unit->entryPointList.size(); 983 if (entryCount == 1) 984 return; 985 986 // The first executable statement in the subprogram is preceded by a 987 // branch to the entry point, so it starts a new block. 988 if (initialEval->hasNestedEvaluations()) 989 initialEval = &initialEval->getFirstNestedEvaluation(); 990 else if (initialEval->isA<Fortran::parser::EntryStmt>()) 991 initialEval = initialEval->lexicalSuccessor; 992 initialEval->isNewBlock = true; 993 994 // All function entry points share a single result container. 995 // Find one of the largest results. 996 for (int entryIndex = 0; entryIndex < entryCount; ++entryIndex) { 997 unit->setActiveEntry(entryIndex); 998 const auto &details = 999 unit->getSubprogramSymbol().get<semantics::SubprogramDetails>(); 1000 if (details.isFunction()) { 1001 const semantics::Symbol *resultSym = &details.result(); 1002 assert(resultSym && "missing result symbol"); 1003 if (!unit->primaryResult || 1004 unit->primaryResult->size() < resultSym->size()) 1005 unit->primaryResult = resultSym; 1006 } 1007 } 1008 unit->setActiveEntry(0); 1009 } 1010 1011 std::unique_ptr<lower::pft::Program> pgm; 1012 std::vector<lower::pft::PftNode> pftParentStack; 1013 const semantics::SemanticsContext &semanticsContext; 1014 1015 /// functionList points to the internal or module procedure function list 1016 /// of a FunctionLikeUnit or a ModuleLikeUnit. It may be null. 1017 std::list<lower::pft::FunctionLikeUnit> *functionList{}; 1018 std::vector<lower::pft::Evaluation *> constructAndDirectiveStack{}; 1019 std::vector<lower::pft::Evaluation *> doConstructStack{}; 1020 /// evaluationListStack is the current nested construct evaluationList state. 1021 std::vector<lower::pft::EvaluationList *> evaluationListStack{}; 1022 llvm::DenseMap<parser::Label, lower::pft::Evaluation *> *labelEvaluationMap{}; 1023 lower::pft::SymbolLabelMap *assignSymbolLabelMap{}; 1024 std::map<std::string, lower::pft::Evaluation *> constructNameMap{}; 1025 lower::pft::Evaluation *lastLexicalEvaluation{}; 1026 }; 1027 1028 class PFTDumper { 1029 public: 1030 void dumpPFT(llvm::raw_ostream &outputStream, 1031 const lower::pft::Program &pft) { 1032 for (auto &unit : pft.getUnits()) { 1033 std::visit(common::visitors{ 1034 [&](const lower::pft::BlockDataUnit &unit) { 1035 outputStream << getNodeIndex(unit) << " "; 1036 outputStream << "BlockData: "; 1037 outputStream << "\nEnd BlockData\n\n"; 1038 }, 1039 [&](const lower::pft::FunctionLikeUnit &func) { 1040 dumpFunctionLikeUnit(outputStream, func); 1041 }, 1042 [&](const lower::pft::ModuleLikeUnit &unit) { 1043 dumpModuleLikeUnit(outputStream, unit); 1044 }, 1045 [&](const lower::pft::CompilerDirectiveUnit &unit) { 1046 dumpCompilerDirectiveUnit(outputStream, unit); 1047 }, 1048 }, 1049 unit); 1050 } 1051 } 1052 1053 llvm::StringRef evaluationName(const lower::pft::Evaluation &eval) { 1054 return eval.visit([](const auto &parseTreeNode) { 1055 return parser::ParseTreeDumper::GetNodeName(parseTreeNode); 1056 }); 1057 } 1058 1059 void dumpEvaluation(llvm::raw_ostream &outputStream, 1060 const lower::pft::Evaluation &eval, 1061 const std::string &indentString, int indent = 1) { 1062 llvm::StringRef name = evaluationName(eval); 1063 llvm::StringRef newBlock = eval.isNewBlock ? "^" : ""; 1064 llvm::StringRef bang = eval.isUnstructured ? "!" : ""; 1065 outputStream << indentString; 1066 if (eval.printIndex) 1067 outputStream << eval.printIndex << ' '; 1068 if (eval.hasNestedEvaluations()) 1069 outputStream << "<<" << newBlock << name << bang << ">>"; 1070 else 1071 outputStream << newBlock << name << bang; 1072 if (eval.negateCondition) 1073 outputStream << " [negate]"; 1074 if (eval.constructExit) 1075 outputStream << " -> " << eval.constructExit->printIndex; 1076 else if (eval.controlSuccessor) 1077 outputStream << " -> " << eval.controlSuccessor->printIndex; 1078 else if (eval.isA<parser::EntryStmt>() && eval.lexicalSuccessor) 1079 outputStream << " -> " << eval.lexicalSuccessor->printIndex; 1080 if (!eval.position.empty()) 1081 outputStream << ": " << eval.position.ToString(); 1082 else if (auto *dir = eval.getIf<Fortran::parser::CompilerDirective>()) 1083 outputStream << ": !" << dir->source.ToString(); 1084 outputStream << '\n'; 1085 if (eval.hasNestedEvaluations()) { 1086 dumpEvaluationList(outputStream, *eval.evaluationList, indent + 1); 1087 outputStream << indentString << "<<End " << name << bang << ">>\n"; 1088 } 1089 } 1090 1091 void dumpEvaluation(llvm::raw_ostream &ostream, 1092 const lower::pft::Evaluation &eval) { 1093 dumpEvaluation(ostream, eval, ""); 1094 } 1095 1096 void dumpEvaluationList(llvm::raw_ostream &outputStream, 1097 const lower::pft::EvaluationList &evaluationList, 1098 int indent = 1) { 1099 static const auto white = " ++"s; 1100 auto indentString = white.substr(0, indent * 2); 1101 for (const lower::pft::Evaluation &eval : evaluationList) 1102 dumpEvaluation(outputStream, eval, indentString, indent); 1103 } 1104 1105 void 1106 dumpFunctionLikeUnit(llvm::raw_ostream &outputStream, 1107 const lower::pft::FunctionLikeUnit &functionLikeUnit) { 1108 outputStream << getNodeIndex(functionLikeUnit) << " "; 1109 llvm::StringRef unitKind; 1110 llvm::StringRef name; 1111 llvm::StringRef header; 1112 if (functionLikeUnit.beginStmt) { 1113 functionLikeUnit.beginStmt->visit(common::visitors{ 1114 [&](const parser::Statement<parser::ProgramStmt> &stmt) { 1115 unitKind = "Program"; 1116 name = toStringRef(stmt.statement.v.source); 1117 }, 1118 [&](const parser::Statement<parser::FunctionStmt> &stmt) { 1119 unitKind = "Function"; 1120 name = toStringRef(std::get<parser::Name>(stmt.statement.t).source); 1121 header = toStringRef(stmt.source); 1122 }, 1123 [&](const parser::Statement<parser::SubroutineStmt> &stmt) { 1124 unitKind = "Subroutine"; 1125 name = toStringRef(std::get<parser::Name>(stmt.statement.t).source); 1126 header = toStringRef(stmt.source); 1127 }, 1128 [&](const parser::Statement<parser::MpSubprogramStmt> &stmt) { 1129 unitKind = "MpSubprogram"; 1130 name = toStringRef(stmt.statement.v.source); 1131 header = toStringRef(stmt.source); 1132 }, 1133 [&](const auto &) { llvm_unreachable("not a valid begin stmt"); }, 1134 }); 1135 } else { 1136 unitKind = "Program"; 1137 name = "<anonymous>"; 1138 } 1139 outputStream << unitKind << ' ' << name; 1140 if (!header.empty()) 1141 outputStream << ": " << header; 1142 outputStream << '\n'; 1143 dumpEvaluationList(outputStream, functionLikeUnit.evaluationList); 1144 if (!functionLikeUnit.nestedFunctions.empty()) { 1145 outputStream << "\nContains\n"; 1146 for (const lower::pft::FunctionLikeUnit &func : 1147 functionLikeUnit.nestedFunctions) 1148 dumpFunctionLikeUnit(outputStream, func); 1149 outputStream << "End Contains\n"; 1150 } 1151 outputStream << "End " << unitKind << ' ' << name << "\n\n"; 1152 } 1153 1154 void dumpModuleLikeUnit(llvm::raw_ostream &outputStream, 1155 const lower::pft::ModuleLikeUnit &moduleLikeUnit) { 1156 outputStream << getNodeIndex(moduleLikeUnit) << " "; 1157 outputStream << "ModuleLike:\n"; 1158 dumpEvaluationList(outputStream, moduleLikeUnit.evaluationList); 1159 outputStream << "Contains\n"; 1160 for (const lower::pft::FunctionLikeUnit &func : 1161 moduleLikeUnit.nestedFunctions) 1162 dumpFunctionLikeUnit(outputStream, func); 1163 outputStream << "End Contains\nEnd ModuleLike\n\n"; 1164 } 1165 1166 // Top level directives 1167 void dumpCompilerDirectiveUnit( 1168 llvm::raw_ostream &outputStream, 1169 const lower::pft::CompilerDirectiveUnit &directive) { 1170 outputStream << getNodeIndex(directive) << " "; 1171 outputStream << "CompilerDirective: !"; 1172 outputStream << directive.get<Fortran::parser::CompilerDirective>() 1173 .source.ToString(); 1174 outputStream << "\nEnd CompilerDirective\n\n"; 1175 } 1176 1177 template <typename T> 1178 std::size_t getNodeIndex(const T &node) { 1179 auto addr = static_cast<const void *>(&node); 1180 auto it = nodeIndexes.find(addr); 1181 if (it != nodeIndexes.end()) 1182 return it->second; 1183 nodeIndexes.try_emplace(addr, nextIndex); 1184 return nextIndex++; 1185 } 1186 std::size_t getNodeIndex(const lower::pft::Program &) { return 0; } 1187 1188 private: 1189 llvm::DenseMap<const void *, std::size_t> nodeIndexes; 1190 std::size_t nextIndex{1}; // 0 is the root 1191 }; 1192 1193 } // namespace 1194 1195 template <typename A, typename T> 1196 static lower::pft::FunctionLikeUnit::FunctionStatement 1197 getFunctionStmt(const T &func) { 1198 lower::pft::FunctionLikeUnit::FunctionStatement result{ 1199 std::get<parser::Statement<A>>(func.t)}; 1200 return result; 1201 } 1202 1203 template <typename A, typename T> 1204 static lower::pft::ModuleLikeUnit::ModuleStatement getModuleStmt(const T &mod) { 1205 lower::pft::ModuleLikeUnit::ModuleStatement result{ 1206 std::get<parser::Statement<A>>(mod.t)}; 1207 return result; 1208 } 1209 1210 template <typename A> 1211 static const semantics::Symbol *getSymbol(A &beginStmt) { 1212 const auto *symbol = beginStmt.visit(common::visitors{ 1213 [](const parser::Statement<parser::ProgramStmt> &stmt) 1214 -> const semantics::Symbol * { return stmt.statement.v.symbol; }, 1215 [](const parser::Statement<parser::FunctionStmt> &stmt) 1216 -> const semantics::Symbol * { 1217 return std::get<parser::Name>(stmt.statement.t).symbol; 1218 }, 1219 [](const parser::Statement<parser::SubroutineStmt> &stmt) 1220 -> const semantics::Symbol * { 1221 return std::get<parser::Name>(stmt.statement.t).symbol; 1222 }, 1223 [](const parser::Statement<parser::MpSubprogramStmt> &stmt) 1224 -> const semantics::Symbol * { return stmt.statement.v.symbol; }, 1225 [](const parser::Statement<parser::ModuleStmt> &stmt) 1226 -> const semantics::Symbol * { return stmt.statement.v.symbol; }, 1227 [](const parser::Statement<parser::SubmoduleStmt> &stmt) 1228 -> const semantics::Symbol * { 1229 return std::get<parser::Name>(stmt.statement.t).symbol; 1230 }, 1231 [](const auto &) -> const semantics::Symbol * { 1232 llvm_unreachable("unknown FunctionLike or ModuleLike beginStmt"); 1233 return nullptr; 1234 }}); 1235 assert(symbol && "parser::Name must have resolved symbol"); 1236 return symbol; 1237 } 1238 1239 bool Fortran::lower::pft::Evaluation::lowerAsStructured() const { 1240 return !lowerAsUnstructured(); 1241 } 1242 1243 bool Fortran::lower::pft::Evaluation::lowerAsUnstructured() const { 1244 return isUnstructured || clDisableStructuredFir; 1245 } 1246 1247 lower::pft::FunctionLikeUnit * 1248 Fortran::lower::pft::Evaluation::getOwningProcedure() const { 1249 return parent.visit(common::visitors{ 1250 [](lower::pft::FunctionLikeUnit &c) { return &c; }, 1251 [&](lower::pft::Evaluation &c) { return c.getOwningProcedure(); }, 1252 [](auto &) -> lower::pft::FunctionLikeUnit * { return nullptr; }, 1253 }); 1254 } 1255 1256 bool Fortran::lower::definedInCommonBlock(const semantics::Symbol &sym) { 1257 return semantics::FindCommonBlockContaining(sym); 1258 } 1259 1260 static bool isReEntrant(const Fortran::semantics::Scope &scope) { 1261 if (scope.kind() == Fortran::semantics::Scope::Kind::MainProgram) 1262 return false; 1263 if (scope.kind() == Fortran::semantics::Scope::Kind::Subprogram) { 1264 const Fortran::semantics::Symbol *sym = scope.symbol(); 1265 assert(sym && "Subprogram scope must have a symbol"); 1266 return sym->attrs().test(semantics::Attr::RECURSIVE) || 1267 (!sym->attrs().test(semantics::Attr::NON_RECURSIVE) && 1268 Fortran::lower::defaultRecursiveFunctionSetting()); 1269 } 1270 if (scope.kind() == Fortran::semantics::Scope::Kind::Module) 1271 return false; 1272 return true; 1273 } 1274 1275 /// Is the symbol `sym` a global? 1276 bool Fortran::lower::symbolIsGlobal(const semantics::Symbol &sym) { 1277 if (const auto *details = sym.detailsIf<semantics::ObjectEntityDetails>()) { 1278 if (details->init()) 1279 return true; 1280 if (!isReEntrant(sym.owner())) { 1281 // Turn array and character of non re-entrant programs (like the main 1282 // program) into global memory. 1283 if (const Fortran::semantics::DeclTypeSpec *symTy = sym.GetType()) 1284 if (symTy->category() == semantics::DeclTypeSpec::Character) 1285 if (auto e = symTy->characterTypeSpec().length().GetExplicit()) 1286 return true; 1287 if (!details->shape().empty() || !details->coshape().empty()) 1288 return true; 1289 } 1290 } 1291 return semantics::IsSaved(sym) || lower::definedInCommonBlock(sym) || 1292 semantics::IsNamedConstant(sym); 1293 } 1294 1295 namespace { 1296 /// This helper class is for sorting the symbols in the symbol table. We want 1297 /// the symbols in an order such that a symbol will be visited after those it 1298 /// depends upon. Otherwise this sort is stable and preserves the order of the 1299 /// symbol table, which is sorted by name. 1300 struct SymbolDependenceDepth { 1301 explicit SymbolDependenceDepth( 1302 std::vector<std::vector<lower::pft::Variable>> &vars) 1303 : vars{vars} {} 1304 1305 void analyzeAliasesInCurrentScope(const semantics::Scope &scope) { 1306 // FIXME: When this function is called on the scope of an internal 1307 // procedure whose parent contains an EQUIVALENCE set and the internal 1308 // procedure uses variables from that EQUIVALENCE set, we end up creating 1309 // an AggregateStore for those variables unnecessarily. 1310 // 1311 /// If this is a function nested in a module no host associated 1312 /// symbol are added to the function scope for module symbols used in this 1313 /// scope. As a result, alias analysis in parent module scopes must be 1314 /// preformed here. 1315 const semantics::Scope *parentScope = &scope; 1316 while (!parentScope->IsGlobal()) { 1317 parentScope = &parentScope->parent(); 1318 if (parentScope->IsModule()) 1319 analyzeAliases(*parentScope); 1320 } 1321 for (const auto &iter : scope) { 1322 const semantics::Symbol &ultimate = iter.second.get().GetUltimate(); 1323 if (skipSymbol(ultimate)) 1324 continue; 1325 analyzeAliases(ultimate.owner()); 1326 } 1327 // add all aggregate stores to the front of the work list 1328 adjustSize(1); 1329 // The copy in the loop matters, 'stores' will still be used. 1330 for (auto st : stores) 1331 vars[0].emplace_back(std::move(st)); 1332 } 1333 1334 // Compute the offset of the last byte that resides in the symbol. 1335 inline static std::size_t offsetWidth(const Fortran::semantics::Symbol &sym) { 1336 std::size_t width = sym.offset(); 1337 if (std::size_t size = sym.size()) 1338 width += size - 1; 1339 return width; 1340 } 1341 1342 // Analyze the equivalence sets. This analysis need not be performed when the 1343 // scope has no equivalence sets. 1344 void analyzeAliases(const semantics::Scope &scope) { 1345 if (scope.equivalenceSets().empty()) 1346 return; 1347 // Don't analyze a scope if it has already been analyzed. 1348 if (analyzedScopes.find(&scope) != analyzedScopes.end()) 1349 return; 1350 1351 analyzedScopes.insert(&scope); 1352 std::list<std::list<semantics::SymbolRef>> aggregates = 1353 Fortran::semantics::GetStorageAssociations(scope); 1354 for (std::list<semantics::SymbolRef> aggregate : aggregates) { 1355 const Fortran::semantics::Symbol *aggregateSym = nullptr; 1356 bool isGlobal = false; 1357 const semantics::Symbol &first = *aggregate.front(); 1358 std::size_t start = first.offset(); 1359 std::size_t end = first.offset() + first.size(); 1360 const Fortran::semantics::Symbol *namingSym = nullptr; 1361 for (semantics::SymbolRef symRef : aggregate) { 1362 const semantics::Symbol &sym = *symRef; 1363 aliasSyms.insert(&sym); 1364 if (sym.test(Fortran::semantics::Symbol::Flag::CompilerCreated)) { 1365 aggregateSym = &sym; 1366 } else { 1367 isGlobal |= lower::symbolIsGlobal(sym); 1368 start = std::min(sym.offset(), start); 1369 end = std::max(sym.offset() + sym.size(), end); 1370 if (!namingSym || (sym.name() < namingSym->name())) 1371 namingSym = &sym; 1372 } 1373 } 1374 assert(namingSym && "must contain at least one user symbol"); 1375 if (!aggregateSym) { 1376 stores.emplace_back( 1377 Fortran::lower::pft::Variable::Interval{start, end - start}, 1378 *namingSym, isGlobal); 1379 } else { 1380 stores.emplace_back(*aggregateSym, *namingSym, isGlobal); 1381 } 1382 } 1383 } 1384 1385 // Recursively visit each symbol to determine the height of its dependence on 1386 // other symbols. 1387 int analyze(const semantics::Symbol &sym) { 1388 auto done = seen.insert(&sym); 1389 LLVM_DEBUG(llvm::dbgs() << "analyze symbol: " << sym << '\n'); 1390 if (!done.second) 1391 return 0; 1392 const bool isProcedurePointerOrDummy = 1393 semantics::IsProcedurePointer(sym) || 1394 (semantics::IsProcedure(sym) && IsDummy(sym)); 1395 // A procedure argument in a subprogram with multiple entry points might 1396 // need a vars list entry to trigger creation of a symbol map entry in 1397 // some cases. Non-dummy procedures don't. 1398 if (semantics::IsProcedure(sym) && !isProcedurePointerOrDummy) 1399 return 0; 1400 semantics::Symbol ultimate = sym.GetUltimate(); 1401 if (const auto *details = 1402 ultimate.detailsIf<semantics::NamelistDetails>()) { 1403 // handle namelist group symbols 1404 for (const semantics::SymbolRef &s : details->objects()) 1405 analyze(s); 1406 return 0; 1407 } 1408 if (!ultimate.has<semantics::ObjectEntityDetails>() && 1409 !isProcedurePointerOrDummy) 1410 return 0; 1411 1412 if (sym.has<semantics::DerivedTypeDetails>()) 1413 llvm_unreachable("not yet implemented - derived type analysis"); 1414 1415 // Symbol must be something lowering will have to allocate. 1416 int depth = 0; 1417 // Analyze symbols appearing in object entity specification expression. This 1418 // ensures these symbols will be instantiated before the current one. 1419 // This is not done for object entities that are host associated because 1420 // they must be instantiated from the value of the host symbols (the 1421 // specification expressions should not be re-evaluated). 1422 if (const auto *details = sym.detailsIf<semantics::ObjectEntityDetails>()) { 1423 const semantics::DeclTypeSpec *symTy = sym.GetType(); 1424 assert(symTy && "symbol must have a type"); 1425 // check CHARACTER's length 1426 if (symTy->category() == semantics::DeclTypeSpec::Character) 1427 if (auto e = symTy->characterTypeSpec().length().GetExplicit()) 1428 for (const auto &s : evaluate::CollectSymbols(*e)) 1429 depth = std::max(analyze(s) + 1, depth); 1430 1431 auto doExplicit = [&](const auto &bound) { 1432 if (bound.isExplicit()) { 1433 semantics::SomeExpr e{*bound.GetExplicit()}; 1434 for (const auto &s : evaluate::CollectSymbols(e)) 1435 depth = std::max(analyze(s) + 1, depth); 1436 } 1437 }; 1438 // handle any symbols in array bound declarations 1439 for (const semantics::ShapeSpec &subs : details->shape()) { 1440 doExplicit(subs.lbound()); 1441 doExplicit(subs.ubound()); 1442 } 1443 // handle any symbols in coarray bound declarations 1444 for (const semantics::ShapeSpec &subs : details->coshape()) { 1445 doExplicit(subs.lbound()); 1446 doExplicit(subs.ubound()); 1447 } 1448 // handle any symbols in initialization expressions 1449 if (auto e = details->init()) 1450 for (const auto &s : evaluate::CollectSymbols(*e)) 1451 depth = std::max(analyze(s) + 1, depth); 1452 } 1453 adjustSize(depth + 1); 1454 bool global = lower::symbolIsGlobal(sym); 1455 vars[depth].emplace_back(sym, global, depth); 1456 if (semantics::IsAllocatable(sym)) 1457 vars[depth].back().setHeapAlloc(); 1458 if (semantics::IsPointer(sym)) 1459 vars[depth].back().setPointer(); 1460 if (ultimate.attrs().test(semantics::Attr::TARGET)) 1461 vars[depth].back().setTarget(); 1462 1463 // If there are alias sets, then link the participating variables to their 1464 // aggregate stores when constructing the new variable on the list. 1465 if (lower::pft::Variable::AggregateStore *store = findStoreIfAlias(sym)) 1466 vars[depth].back().setAlias(store->getOffset()); 1467 return depth; 1468 } 1469 1470 /// Save the final list of variable allocations as a single vector and free 1471 /// the rest. 1472 void finalize() { 1473 for (int i = 1, end = vars.size(); i < end; ++i) 1474 vars[0].insert(vars[0].end(), vars[i].begin(), vars[i].end()); 1475 vars.resize(1); 1476 } 1477 1478 Fortran::lower::pft::Variable::AggregateStore * 1479 findStoreIfAlias(const Fortran::evaluate::Symbol &sym) { 1480 const semantics::Symbol &ultimate = sym.GetUltimate(); 1481 const semantics::Scope &scope = ultimate.owner(); 1482 // Expect the total number of EQUIVALENCE sets to be small for a typical 1483 // Fortran program. 1484 if (aliasSyms.find(&ultimate) != aliasSyms.end()) { 1485 LLVM_DEBUG(llvm::dbgs() << "symbol: " << ultimate << '\n'); 1486 LLVM_DEBUG(llvm::dbgs() << "scope: " << scope << '\n'); 1487 std::size_t off = ultimate.offset(); 1488 std::size_t symSize = ultimate.size(); 1489 for (lower::pft::Variable::AggregateStore &v : stores) { 1490 if (&v.getOwningScope() == &scope) { 1491 auto intervalOff = std::get<0>(v.interval); 1492 auto intervalSize = std::get<1>(v.interval); 1493 if (off >= intervalOff && off < intervalOff + intervalSize) 1494 return &v; 1495 // Zero sized symbol in zero sized equivalence. 1496 if (off == intervalOff && symSize == 0) 1497 return &v; 1498 } 1499 } 1500 // clang-format off 1501 LLVM_DEBUG( 1502 llvm::dbgs() << "looking for " << off << "\n{\n"; 1503 for (lower::pft::Variable::AggregateStore &v : stores) { 1504 llvm::dbgs() << " in scope: " << &v.getOwningScope() << "\n"; 1505 llvm::dbgs() << " i = [" << std::get<0>(v.interval) << ".." 1506 << std::get<0>(v.interval) + std::get<1>(v.interval) 1507 << "]\n"; 1508 } 1509 llvm::dbgs() << "}\n"); 1510 // clang-format on 1511 llvm_unreachable("the store must be present"); 1512 } 1513 return nullptr; 1514 } 1515 1516 private: 1517 /// Skip symbol in alias analysis. 1518 bool skipSymbol(const semantics::Symbol &sym) { 1519 // Common block equivalences are largely managed by the front end. 1520 // Compiler generated symbols ('.' names) cannot be equivalenced. 1521 // FIXME: Equivalence code generation may need to be revisited. 1522 return !sym.has<semantics::ObjectEntityDetails>() || 1523 lower::definedInCommonBlock(sym) || sym.name()[0] == '.'; 1524 } 1525 1526 // Make sure the table is of appropriate size. 1527 void adjustSize(std::size_t size) { 1528 if (vars.size() < size) 1529 vars.resize(size); 1530 } 1531 1532 llvm::SmallSet<const semantics::Symbol *, 32> seen; 1533 std::vector<std::vector<lower::pft::Variable>> &vars; 1534 llvm::SmallSet<const semantics::Symbol *, 32> aliasSyms; 1535 /// Set of Scope that have been analyzed for aliases. 1536 llvm::SmallSet<const semantics::Scope *, 4> analyzedScopes; 1537 std::vector<Fortran::lower::pft::Variable::AggregateStore> stores; 1538 }; 1539 } // namespace 1540 1541 static void processSymbolTable( 1542 const semantics::Scope &scope, 1543 std::vector<std::vector<Fortran::lower::pft::Variable>> &varList) { 1544 SymbolDependenceDepth sdd{varList}; 1545 sdd.analyzeAliasesInCurrentScope(scope); 1546 for (const auto &iter : scope) 1547 sdd.analyze(iter.second.get()); 1548 sdd.finalize(); 1549 } 1550 1551 //===----------------------------------------------------------------------===// 1552 // FunctionLikeUnit implementation 1553 //===----------------------------------------------------------------------===// 1554 1555 Fortran::lower::pft::FunctionLikeUnit::FunctionLikeUnit( 1556 const parser::MainProgram &func, const lower::pft::PftNode &parent, 1557 const semantics::SemanticsContext &semanticsContext) 1558 : ProgramUnit{func, parent}, endStmt{ 1559 getFunctionStmt<parser::EndProgramStmt>( 1560 func)} { 1561 const auto &programStmt = 1562 std::get<std::optional<parser::Statement<parser::ProgramStmt>>>(func.t); 1563 if (programStmt.has_value()) { 1564 beginStmt = FunctionStatement(programStmt.value()); 1565 const semantics::Symbol *symbol = getSymbol(*beginStmt); 1566 entryPointList[0].first = symbol; 1567 processSymbolTable(*symbol->scope(), varList); 1568 } else { 1569 processSymbolTable( 1570 semanticsContext.FindScope( 1571 std::get<parser::Statement<parser::EndProgramStmt>>(func.t).source), 1572 varList); 1573 } 1574 } 1575 1576 Fortran::lower::pft::FunctionLikeUnit::FunctionLikeUnit( 1577 const parser::FunctionSubprogram &func, const lower::pft::PftNode &parent, 1578 const semantics::SemanticsContext &) 1579 : ProgramUnit{func, parent}, 1580 beginStmt{getFunctionStmt<parser::FunctionStmt>(func)}, 1581 endStmt{getFunctionStmt<parser::EndFunctionStmt>(func)} { 1582 const semantics::Symbol *symbol = getSymbol(*beginStmt); 1583 entryPointList[0].first = symbol; 1584 processSymbolTable(*symbol->scope(), varList); 1585 } 1586 1587 Fortran::lower::pft::FunctionLikeUnit::FunctionLikeUnit( 1588 const parser::SubroutineSubprogram &func, const lower::pft::PftNode &parent, 1589 const semantics::SemanticsContext &) 1590 : ProgramUnit{func, parent}, 1591 beginStmt{getFunctionStmt<parser::SubroutineStmt>(func)}, 1592 endStmt{getFunctionStmt<parser::EndSubroutineStmt>(func)} { 1593 const semantics::Symbol *symbol = getSymbol(*beginStmt); 1594 entryPointList[0].first = symbol; 1595 processSymbolTable(*symbol->scope(), varList); 1596 } 1597 1598 Fortran::lower::pft::FunctionLikeUnit::FunctionLikeUnit( 1599 const parser::SeparateModuleSubprogram &func, 1600 const lower::pft::PftNode &parent, const semantics::SemanticsContext &) 1601 : ProgramUnit{func, parent}, 1602 beginStmt{getFunctionStmt<parser::MpSubprogramStmt>(func)}, 1603 endStmt{getFunctionStmt<parser::EndMpSubprogramStmt>(func)} { 1604 const semantics::Symbol *symbol = getSymbol(*beginStmt); 1605 entryPointList[0].first = symbol; 1606 processSymbolTable(*symbol->scope(), varList); 1607 } 1608 1609 Fortran::lower::HostAssociations & 1610 Fortran::lower::pft::FunctionLikeUnit::parentHostAssoc() { 1611 if (auto *par = parent.getIf<FunctionLikeUnit>()) 1612 return par->hostAssociations; 1613 llvm::report_fatal_error("parent is not a function"); 1614 } 1615 1616 bool Fortran::lower::pft::FunctionLikeUnit::parentHasHostAssoc() { 1617 if (auto *par = parent.getIf<FunctionLikeUnit>()) 1618 return !par->hostAssociations.empty(); 1619 return false; 1620 } 1621 1622 parser::CharBlock 1623 Fortran::lower::pft::FunctionLikeUnit::getStartingSourceLoc() const { 1624 if (beginStmt) 1625 return stmtSourceLoc(*beginStmt); 1626 if (!evaluationList.empty()) 1627 return evaluationList.front().position; 1628 return stmtSourceLoc(endStmt); 1629 } 1630 1631 //===----------------------------------------------------------------------===// 1632 // ModuleLikeUnit implementation 1633 //===----------------------------------------------------------------------===// 1634 1635 Fortran::lower::pft::ModuleLikeUnit::ModuleLikeUnit( 1636 const parser::Module &m, const lower::pft::PftNode &parent) 1637 : ProgramUnit{m, parent}, beginStmt{getModuleStmt<parser::ModuleStmt>(m)}, 1638 endStmt{getModuleStmt<parser::EndModuleStmt>(m)} { 1639 const semantics::Symbol *symbol = getSymbol(beginStmt); 1640 processSymbolTable(*symbol->scope(), varList); 1641 } 1642 1643 Fortran::lower::pft::ModuleLikeUnit::ModuleLikeUnit( 1644 const parser::Submodule &m, const lower::pft::PftNode &parent) 1645 : ProgramUnit{m, parent}, beginStmt{getModuleStmt<parser::SubmoduleStmt>( 1646 m)}, 1647 endStmt{getModuleStmt<parser::EndSubmoduleStmt>(m)} { 1648 const semantics::Symbol *symbol = getSymbol(beginStmt); 1649 processSymbolTable(*symbol->scope(), varList); 1650 } 1651 1652 parser::CharBlock 1653 Fortran::lower::pft::ModuleLikeUnit::getStartingSourceLoc() const { 1654 return stmtSourceLoc(beginStmt); 1655 } 1656 const Fortran::semantics::Scope & 1657 Fortran::lower::pft::ModuleLikeUnit::getScope() const { 1658 const Fortran::semantics::Symbol *symbol = getSymbol(beginStmt); 1659 assert(symbol && symbol->scope() && 1660 "Module statement must have a symbol with a scope"); 1661 return *symbol->scope(); 1662 } 1663 1664 //===----------------------------------------------------------------------===// 1665 // BlockDataUnit implementation 1666 //===----------------------------------------------------------------------===// 1667 1668 Fortran::lower::pft::BlockDataUnit::BlockDataUnit( 1669 const parser::BlockData &bd, const lower::pft::PftNode &parent, 1670 const semantics::SemanticsContext &semanticsContext) 1671 : ProgramUnit{bd, parent}, 1672 symTab{semanticsContext.FindScope( 1673 std::get<parser::Statement<parser::EndBlockDataStmt>>(bd.t).source)} { 1674 } 1675 1676 std::unique_ptr<lower::pft::Program> 1677 Fortran::lower::createPFT(const parser::Program &root, 1678 const semantics::SemanticsContext &semanticsContext) { 1679 PFTBuilder walker(semanticsContext); 1680 Walk(root, walker); 1681 return walker.result(); 1682 } 1683 1684 // FIXME: FlangDriver 1685 // This option should be integrated with the real driver as the default of 1686 // RECURSIVE vs. NON_RECURSIVE may be changed by other command line options, 1687 // etc., etc. 1688 bool Fortran::lower::defaultRecursiveFunctionSetting() { 1689 return !nonRecursiveProcedures; 1690 } 1691 1692 void Fortran::lower::dumpPFT(llvm::raw_ostream &outputStream, 1693 const lower::pft::Program &pft) { 1694 PFTDumper{}.dumpPFT(outputStream, pft); 1695 } 1696 1697 void Fortran::lower::pft::Program::dump() const { 1698 dumpPFT(llvm::errs(), *this); 1699 } 1700 1701 void Fortran::lower::pft::Evaluation::dump() const { 1702 PFTDumper{}.dumpEvaluation(llvm::errs(), *this); 1703 } 1704 1705 void Fortran::lower::pft::Variable::dump() const { 1706 if (auto *s = std::get_if<Nominal>(&var)) { 1707 llvm::errs() << "symbol: " << s->symbol->name(); 1708 llvm::errs() << " (depth: " << s->depth << ')'; 1709 if (s->global) 1710 llvm::errs() << ", global"; 1711 if (s->heapAlloc) 1712 llvm::errs() << ", allocatable"; 1713 if (s->pointer) 1714 llvm::errs() << ", pointer"; 1715 if (s->target) 1716 llvm::errs() << ", target"; 1717 if (s->aliaser) 1718 llvm::errs() << ", equivalence(" << s->aliasOffset << ')'; 1719 } else if (auto *s = std::get_if<AggregateStore>(&var)) { 1720 llvm::errs() << "interval[" << std::get<0>(s->interval) << ", " 1721 << std::get<1>(s->interval) << "]:"; 1722 llvm::errs() << " name: " << toStringRef(s->getNamingSymbol().name()); 1723 if (s->isGlobal()) 1724 llvm::errs() << ", global"; 1725 if (s->initialValueSymbol) 1726 llvm::errs() << ", initial value: {" << *s->initialValueSymbol << "}"; 1727 } else { 1728 llvm_unreachable("not a Variable"); 1729 } 1730 llvm::errs() << '\n'; 1731 } 1732 1733 void Fortran::lower::pft::FunctionLikeUnit::dump() const { 1734 PFTDumper{}.dumpFunctionLikeUnit(llvm::errs(), *this); 1735 } 1736 1737 void Fortran::lower::pft::ModuleLikeUnit::dump() const { 1738 PFTDumper{}.dumpModuleLikeUnit(llvm::errs(), *this); 1739 } 1740 1741 /// The BlockDataUnit dump is just the associated symbol table. 1742 void Fortran::lower::pft::BlockDataUnit::dump() const { 1743 llvm::errs() << "block data {\n" << symTab << "\n}\n"; 1744 } 1745 1746 std::vector<Fortran::lower::pft::Variable> 1747 Fortran::lower::pft::buildFuncResultDependencyList( 1748 const Fortran::semantics::Symbol &symbol) { 1749 std::vector<std::vector<pft::Variable>> variableList; 1750 SymbolDependenceDepth sdd(variableList); 1751 sdd.analyzeAliasesInCurrentScope(symbol.owner()); 1752 sdd.analyze(symbol); 1753 sdd.finalize(); 1754 // Remove the pft::variable for the result itself, only its dependencies 1755 // should be returned in the list. 1756 assert(!variableList[0].empty() && "must at least contain the result"); 1757 assert(&variableList[0].back().getSymbol() == &symbol && 1758 "result sym should be last"); 1759 variableList[0].pop_back(); 1760 return variableList[0]; 1761 } 1762 1763 namespace { 1764 /// Helper class to find all the symbols referenced in a FunctionLikeUnit. 1765 /// It defines a parse tree visitor doing a deep visit in all nodes with 1766 /// symbols (including evaluate::Expr). 1767 struct SymbolVisitor { 1768 template <typename A> 1769 bool Pre(const A &x) { 1770 if constexpr (Fortran::parser::HasTypedExpr<A>::value) 1771 if (const auto *expr = Fortran::semantics::GetExpr(x)) 1772 visitExpr(*expr); 1773 return true; 1774 } 1775 1776 bool Pre(const Fortran::parser::Name &name) { 1777 if (const semantics::Symbol *symbol = name.symbol) 1778 visitSymbol(*symbol); 1779 return false; 1780 } 1781 1782 void visitExpr(const Fortran::lower::SomeExpr &expr) { 1783 for (const semantics::Symbol &symbol : 1784 Fortran::evaluate::CollectSymbols(expr)) 1785 visitSymbol(symbol); 1786 } 1787 1788 void visitSymbol(const Fortran::semantics::Symbol &symbol) { 1789 callBack(symbol); 1790 // Visit statement function body since it will be inlined in lowering. 1791 if (const auto *subprogramDetails = 1792 symbol.detailsIf<Fortran::semantics::SubprogramDetails>()) 1793 if (const auto &maybeExpr = subprogramDetails->stmtFunction()) 1794 visitExpr(*maybeExpr); 1795 } 1796 1797 template <typename A> 1798 constexpr void Post(const A &) {} 1799 1800 const std::function<void(const Fortran::semantics::Symbol &)> &callBack; 1801 }; 1802 } // namespace 1803 1804 void Fortran::lower::pft::visitAllSymbols( 1805 const Fortran::lower::pft::FunctionLikeUnit &funit, 1806 const std::function<void(const Fortran::semantics::Symbol &)> callBack) { 1807 SymbolVisitor visitor{callBack}; 1808 funit.visit([&](const auto &functionParserNode) { 1809 parser::Walk(functionParserNode, visitor); 1810 }); 1811 } 1812 1813 void Fortran::lower::pft::visitAllSymbols( 1814 const Fortran::lower::pft::Evaluation &eval, 1815 const std::function<void(const Fortran::semantics::Symbol &)> callBack) { 1816 SymbolVisitor visitor{callBack}; 1817 eval.visit([&](const auto &functionParserNode) { 1818 parser::Walk(functionParserNode, visitor); 1819 }); 1820 } 1821