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 /// For multiple entry subprograms, build a list of the dummy arguments that 979 /// appear in some, but not all entry points. For those that are functions, 980 /// also find one of the largest function results, since a single result 981 /// container holds the result for all entries. 982 void processEntryPoints() { 983 lower::pft::Evaluation *initialEval = &evaluationListStack.back()->front(); 984 lower::pft::FunctionLikeUnit *unit = initialEval->getOwningProcedure(); 985 int entryCount = unit->entryPointList.size(); 986 if (entryCount == 1) 987 return; 988 llvm::DenseMap<semantics::Symbol *, int> dummyCountMap; 989 for (int entryIndex = 0; entryIndex < entryCount; ++entryIndex) { 990 unit->setActiveEntry(entryIndex); 991 const auto &details = 992 unit->getSubprogramSymbol().get<semantics::SubprogramDetails>(); 993 for (semantics::Symbol *arg : details.dummyArgs()) { 994 if (!arg) 995 continue; // alternate return specifier (no actual argument) 996 const auto iter = dummyCountMap.find(arg); 997 if (iter == dummyCountMap.end()) 998 dummyCountMap.try_emplace(arg, 1); 999 else 1000 ++iter->second; 1001 } 1002 if (details.isFunction()) { 1003 const semantics::Symbol *resultSym = &details.result(); 1004 assert(resultSym && "missing result symbol"); 1005 if (!unit->primaryResult || 1006 unit->primaryResult->size() < resultSym->size()) 1007 unit->primaryResult = resultSym; 1008 } 1009 } 1010 unit->setActiveEntry(0); 1011 for (auto arg : dummyCountMap) 1012 if (arg.second < entryCount) 1013 unit->nonUniversalDummyArguments.push_back(arg.first); 1014 // The first executable statement in the subprogram is preceded by a 1015 // branch to the entry point, so it starts a new block. 1016 if (initialEval->hasNestedEvaluations()) 1017 initialEval = &initialEval->getFirstNestedEvaluation(); 1018 else if (initialEval->isA<Fortran::parser::EntryStmt>()) 1019 initialEval = initialEval->lexicalSuccessor; 1020 initialEval->isNewBlock = true; 1021 } 1022 1023 std::unique_ptr<lower::pft::Program> pgm; 1024 std::vector<lower::pft::PftNode> pftParentStack; 1025 const semantics::SemanticsContext &semanticsContext; 1026 1027 /// functionList points to the internal or module procedure function list 1028 /// of a FunctionLikeUnit or a ModuleLikeUnit. It may be null. 1029 std::list<lower::pft::FunctionLikeUnit> *functionList{}; 1030 std::vector<lower::pft::Evaluation *> constructAndDirectiveStack{}; 1031 std::vector<lower::pft::Evaluation *> doConstructStack{}; 1032 /// evaluationListStack is the current nested construct evaluationList state. 1033 std::vector<lower::pft::EvaluationList *> evaluationListStack{}; 1034 llvm::DenseMap<parser::Label, lower::pft::Evaluation *> *labelEvaluationMap{}; 1035 lower::pft::SymbolLabelMap *assignSymbolLabelMap{}; 1036 std::map<std::string, lower::pft::Evaluation *> constructNameMap{}; 1037 lower::pft::Evaluation *lastLexicalEvaluation{}; 1038 }; 1039 1040 class PFTDumper { 1041 public: 1042 void dumpPFT(llvm::raw_ostream &outputStream, 1043 const lower::pft::Program &pft) { 1044 for (auto &unit : pft.getUnits()) { 1045 std::visit(common::visitors{ 1046 [&](const lower::pft::BlockDataUnit &unit) { 1047 outputStream << getNodeIndex(unit) << " "; 1048 outputStream << "BlockData: "; 1049 outputStream << "\nEnd BlockData\n\n"; 1050 }, 1051 [&](const lower::pft::FunctionLikeUnit &func) { 1052 dumpFunctionLikeUnit(outputStream, func); 1053 }, 1054 [&](const lower::pft::ModuleLikeUnit &unit) { 1055 dumpModuleLikeUnit(outputStream, unit); 1056 }, 1057 [&](const lower::pft::CompilerDirectiveUnit &unit) { 1058 dumpCompilerDirectiveUnit(outputStream, unit); 1059 }, 1060 }, 1061 unit); 1062 } 1063 } 1064 1065 llvm::StringRef evaluationName(const lower::pft::Evaluation &eval) { 1066 return eval.visit([](const auto &parseTreeNode) { 1067 return parser::ParseTreeDumper::GetNodeName(parseTreeNode); 1068 }); 1069 } 1070 1071 void dumpEvaluation(llvm::raw_ostream &outputStream, 1072 const lower::pft::Evaluation &eval, 1073 const std::string &indentString, int indent = 1) { 1074 llvm::StringRef name = evaluationName(eval); 1075 llvm::StringRef newBlock = eval.isNewBlock ? "^" : ""; 1076 llvm::StringRef bang = eval.isUnstructured ? "!" : ""; 1077 outputStream << indentString; 1078 if (eval.printIndex) 1079 outputStream << eval.printIndex << ' '; 1080 if (eval.hasNestedEvaluations()) 1081 outputStream << "<<" << newBlock << name << bang << ">>"; 1082 else 1083 outputStream << newBlock << name << bang; 1084 if (eval.negateCondition) 1085 outputStream << " [negate]"; 1086 if (eval.constructExit) 1087 outputStream << " -> " << eval.constructExit->printIndex; 1088 else if (eval.controlSuccessor) 1089 outputStream << " -> " << eval.controlSuccessor->printIndex; 1090 else if (eval.isA<parser::EntryStmt>() && eval.lexicalSuccessor) 1091 outputStream << " -> " << eval.lexicalSuccessor->printIndex; 1092 if (!eval.position.empty()) 1093 outputStream << ": " << eval.position.ToString(); 1094 else if (auto *dir = eval.getIf<Fortran::parser::CompilerDirective>()) 1095 outputStream << ": !" << dir->source.ToString(); 1096 outputStream << '\n'; 1097 if (eval.hasNestedEvaluations()) { 1098 dumpEvaluationList(outputStream, *eval.evaluationList, indent + 1); 1099 outputStream << indentString << "<<End " << name << bang << ">>\n"; 1100 } 1101 } 1102 1103 void dumpEvaluation(llvm::raw_ostream &ostream, 1104 const lower::pft::Evaluation &eval) { 1105 dumpEvaluation(ostream, eval, ""); 1106 } 1107 1108 void dumpEvaluationList(llvm::raw_ostream &outputStream, 1109 const lower::pft::EvaluationList &evaluationList, 1110 int indent = 1) { 1111 static const auto white = " ++"s; 1112 auto indentString = white.substr(0, indent * 2); 1113 for (const lower::pft::Evaluation &eval : evaluationList) 1114 dumpEvaluation(outputStream, eval, indentString, indent); 1115 } 1116 1117 void 1118 dumpFunctionLikeUnit(llvm::raw_ostream &outputStream, 1119 const lower::pft::FunctionLikeUnit &functionLikeUnit) { 1120 outputStream << getNodeIndex(functionLikeUnit) << " "; 1121 llvm::StringRef unitKind; 1122 llvm::StringRef name; 1123 llvm::StringRef header; 1124 if (functionLikeUnit.beginStmt) { 1125 functionLikeUnit.beginStmt->visit(common::visitors{ 1126 [&](const parser::Statement<parser::ProgramStmt> &stmt) { 1127 unitKind = "Program"; 1128 name = toStringRef(stmt.statement.v.source); 1129 }, 1130 [&](const parser::Statement<parser::FunctionStmt> &stmt) { 1131 unitKind = "Function"; 1132 name = toStringRef(std::get<parser::Name>(stmt.statement.t).source); 1133 header = toStringRef(stmt.source); 1134 }, 1135 [&](const parser::Statement<parser::SubroutineStmt> &stmt) { 1136 unitKind = "Subroutine"; 1137 name = toStringRef(std::get<parser::Name>(stmt.statement.t).source); 1138 header = toStringRef(stmt.source); 1139 }, 1140 [&](const parser::Statement<parser::MpSubprogramStmt> &stmt) { 1141 unitKind = "MpSubprogram"; 1142 name = toStringRef(stmt.statement.v.source); 1143 header = toStringRef(stmt.source); 1144 }, 1145 [&](const auto &) { llvm_unreachable("not a valid begin stmt"); }, 1146 }); 1147 } else { 1148 unitKind = "Program"; 1149 name = "<anonymous>"; 1150 } 1151 outputStream << unitKind << ' ' << name; 1152 if (!header.empty()) 1153 outputStream << ": " << header; 1154 outputStream << '\n'; 1155 dumpEvaluationList(outputStream, functionLikeUnit.evaluationList); 1156 if (!functionLikeUnit.nestedFunctions.empty()) { 1157 outputStream << "\nContains\n"; 1158 for (const lower::pft::FunctionLikeUnit &func : 1159 functionLikeUnit.nestedFunctions) 1160 dumpFunctionLikeUnit(outputStream, func); 1161 outputStream << "End Contains\n"; 1162 } 1163 outputStream << "End " << unitKind << ' ' << name << "\n\n"; 1164 } 1165 1166 void dumpModuleLikeUnit(llvm::raw_ostream &outputStream, 1167 const lower::pft::ModuleLikeUnit &moduleLikeUnit) { 1168 outputStream << getNodeIndex(moduleLikeUnit) << " "; 1169 outputStream << "ModuleLike:\n"; 1170 dumpEvaluationList(outputStream, moduleLikeUnit.evaluationList); 1171 outputStream << "Contains\n"; 1172 for (const lower::pft::FunctionLikeUnit &func : 1173 moduleLikeUnit.nestedFunctions) 1174 dumpFunctionLikeUnit(outputStream, func); 1175 outputStream << "End Contains\nEnd ModuleLike\n\n"; 1176 } 1177 1178 // Top level directives 1179 void dumpCompilerDirectiveUnit( 1180 llvm::raw_ostream &outputStream, 1181 const lower::pft::CompilerDirectiveUnit &directive) { 1182 outputStream << getNodeIndex(directive) << " "; 1183 outputStream << "CompilerDirective: !"; 1184 outputStream << directive.get<Fortran::parser::CompilerDirective>() 1185 .source.ToString(); 1186 outputStream << "\nEnd CompilerDirective\n\n"; 1187 } 1188 1189 template <typename T> 1190 std::size_t getNodeIndex(const T &node) { 1191 auto addr = static_cast<const void *>(&node); 1192 auto it = nodeIndexes.find(addr); 1193 if (it != nodeIndexes.end()) 1194 return it->second; 1195 nodeIndexes.try_emplace(addr, nextIndex); 1196 return nextIndex++; 1197 } 1198 std::size_t getNodeIndex(const lower::pft::Program &) { return 0; } 1199 1200 private: 1201 llvm::DenseMap<const void *, std::size_t> nodeIndexes; 1202 std::size_t nextIndex{1}; // 0 is the root 1203 }; 1204 1205 } // namespace 1206 1207 template <typename A, typename T> 1208 static lower::pft::FunctionLikeUnit::FunctionStatement 1209 getFunctionStmt(const T &func) { 1210 lower::pft::FunctionLikeUnit::FunctionStatement result{ 1211 std::get<parser::Statement<A>>(func.t)}; 1212 return result; 1213 } 1214 1215 template <typename A, typename T> 1216 static lower::pft::ModuleLikeUnit::ModuleStatement getModuleStmt(const T &mod) { 1217 lower::pft::ModuleLikeUnit::ModuleStatement result{ 1218 std::get<parser::Statement<A>>(mod.t)}; 1219 return result; 1220 } 1221 1222 template <typename A> 1223 static const semantics::Symbol *getSymbol(A &beginStmt) { 1224 const auto *symbol = beginStmt.visit(common::visitors{ 1225 [](const parser::Statement<parser::ProgramStmt> &stmt) 1226 -> const semantics::Symbol * { return stmt.statement.v.symbol; }, 1227 [](const parser::Statement<parser::FunctionStmt> &stmt) 1228 -> const semantics::Symbol * { 1229 return std::get<parser::Name>(stmt.statement.t).symbol; 1230 }, 1231 [](const parser::Statement<parser::SubroutineStmt> &stmt) 1232 -> const semantics::Symbol * { 1233 return std::get<parser::Name>(stmt.statement.t).symbol; 1234 }, 1235 [](const parser::Statement<parser::MpSubprogramStmt> &stmt) 1236 -> const semantics::Symbol * { return stmt.statement.v.symbol; }, 1237 [](const parser::Statement<parser::ModuleStmt> &stmt) 1238 -> const semantics::Symbol * { return stmt.statement.v.symbol; }, 1239 [](const parser::Statement<parser::SubmoduleStmt> &stmt) 1240 -> const semantics::Symbol * { 1241 return std::get<parser::Name>(stmt.statement.t).symbol; 1242 }, 1243 [](const auto &) -> const semantics::Symbol * { 1244 llvm_unreachable("unknown FunctionLike or ModuleLike beginStmt"); 1245 return nullptr; 1246 }}); 1247 assert(symbol && "parser::Name must have resolved symbol"); 1248 return symbol; 1249 } 1250 1251 bool Fortran::lower::pft::Evaluation::lowerAsStructured() const { 1252 return !lowerAsUnstructured(); 1253 } 1254 1255 bool Fortran::lower::pft::Evaluation::lowerAsUnstructured() const { 1256 return isUnstructured || clDisableStructuredFir; 1257 } 1258 1259 lower::pft::FunctionLikeUnit * 1260 Fortran::lower::pft::Evaluation::getOwningProcedure() const { 1261 return parent.visit(common::visitors{ 1262 [](lower::pft::FunctionLikeUnit &c) { return &c; }, 1263 [&](lower::pft::Evaluation &c) { return c.getOwningProcedure(); }, 1264 [](auto &) -> lower::pft::FunctionLikeUnit * { return nullptr; }, 1265 }); 1266 } 1267 1268 bool Fortran::lower::definedInCommonBlock(const semantics::Symbol &sym) { 1269 return semantics::FindCommonBlockContaining(sym); 1270 } 1271 1272 static bool isReEntrant(const Fortran::semantics::Scope &scope) { 1273 if (scope.kind() == Fortran::semantics::Scope::Kind::MainProgram) 1274 return false; 1275 if (scope.kind() == Fortran::semantics::Scope::Kind::Subprogram) { 1276 const Fortran::semantics::Symbol *sym = scope.symbol(); 1277 assert(sym && "Subprogram scope must have a symbol"); 1278 return sym->attrs().test(semantics::Attr::RECURSIVE) || 1279 (!sym->attrs().test(semantics::Attr::NON_RECURSIVE) && 1280 Fortran::lower::defaultRecursiveFunctionSetting()); 1281 } 1282 if (scope.kind() == Fortran::semantics::Scope::Kind::Module) 1283 return false; 1284 return true; 1285 } 1286 1287 /// Is the symbol `sym` a global? 1288 bool Fortran::lower::symbolIsGlobal(const semantics::Symbol &sym) { 1289 if (const auto *details = sym.detailsIf<semantics::ObjectEntityDetails>()) { 1290 if (details->init()) 1291 return true; 1292 if (!isReEntrant(sym.owner())) { 1293 // Turn array and character of non re-entrant programs (like the main 1294 // program) into global memory. 1295 if (const Fortran::semantics::DeclTypeSpec *symTy = sym.GetType()) 1296 if (symTy->category() == semantics::DeclTypeSpec::Character) 1297 if (auto e = symTy->characterTypeSpec().length().GetExplicit()) 1298 return true; 1299 if (!details->shape().empty() || !details->coshape().empty()) 1300 return true; 1301 } 1302 } 1303 return semantics::IsSaved(sym) || lower::definedInCommonBlock(sym) || 1304 semantics::IsNamedConstant(sym); 1305 } 1306 1307 namespace { 1308 /// This helper class is for sorting the symbols in the symbol table. We want 1309 /// the symbols in an order such that a symbol will be visited after those it 1310 /// depends upon. Otherwise this sort is stable and preserves the order of the 1311 /// symbol table, which is sorted by name. 1312 struct SymbolDependenceDepth { 1313 explicit SymbolDependenceDepth( 1314 std::vector<std::vector<lower::pft::Variable>> &vars) 1315 : vars{vars} {} 1316 1317 void analyzeAliasesInCurrentScope(const semantics::Scope &scope) { 1318 // FIXME: When this function is called on the scope of an internal 1319 // procedure whose parent contains an EQUIVALENCE set and the internal 1320 // procedure uses variables from that EQUIVALENCE set, we end up creating 1321 // an AggregateStore for those variables unnecessarily. 1322 // 1323 /// If this is a function nested in a module no host associated 1324 /// symbol are added to the function scope for module symbols used in this 1325 /// scope. As a result, alias analysis in parent module scopes must be 1326 /// preformed here. 1327 const semantics::Scope *parentScope = &scope; 1328 while (!parentScope->IsGlobal()) { 1329 parentScope = &parentScope->parent(); 1330 if (parentScope->IsModule()) 1331 analyzeAliases(*parentScope); 1332 } 1333 for (const auto &iter : scope) { 1334 const semantics::Symbol &ultimate = iter.second.get().GetUltimate(); 1335 if (skipSymbol(ultimate)) 1336 continue; 1337 analyzeAliases(ultimate.owner()); 1338 } 1339 // add all aggregate stores to the front of the work list 1340 adjustSize(1); 1341 // The copy in the loop matters, 'stores' will still be used. 1342 for (auto st : stores) 1343 vars[0].emplace_back(std::move(st)); 1344 } 1345 1346 // Compute the offset of the last byte that resides in the symbol. 1347 inline static std::size_t offsetWidth(const Fortran::semantics::Symbol &sym) { 1348 std::size_t width = sym.offset(); 1349 if (std::size_t size = sym.size()) 1350 width += size - 1; 1351 return width; 1352 } 1353 1354 // Analyze the equivalence sets. This analysis need not be performed when the 1355 // scope has no equivalence sets. 1356 void analyzeAliases(const semantics::Scope &scope) { 1357 if (scope.equivalenceSets().empty()) 1358 return; 1359 // Don't analyze a scope if it has already been analyzed. 1360 if (analyzedScopes.find(&scope) != analyzedScopes.end()) 1361 return; 1362 1363 analyzedScopes.insert(&scope); 1364 std::list<std::list<semantics::SymbolRef>> aggregates = 1365 Fortran::semantics::GetStorageAssociations(scope); 1366 for (std::list<semantics::SymbolRef> aggregate : aggregates) { 1367 const Fortran::semantics::Symbol *aggregateSym = nullptr; 1368 bool isGlobal = false; 1369 const semantics::Symbol &first = *aggregate.front(); 1370 std::size_t start = first.offset(); 1371 std::size_t end = first.offset() + first.size(); 1372 const Fortran::semantics::Symbol *namingSym = nullptr; 1373 for (semantics::SymbolRef symRef : aggregate) { 1374 const semantics::Symbol &sym = *symRef; 1375 aliasSyms.insert(&sym); 1376 if (sym.test(Fortran::semantics::Symbol::Flag::CompilerCreated)) { 1377 aggregateSym = &sym; 1378 } else { 1379 isGlobal |= lower::symbolIsGlobal(sym); 1380 start = std::min(sym.offset(), start); 1381 end = std::max(sym.offset() + sym.size(), end); 1382 if (!namingSym || (sym.name() < namingSym->name())) 1383 namingSym = &sym; 1384 } 1385 } 1386 assert(namingSym && "must contain at least one user symbol"); 1387 if (!aggregateSym) { 1388 stores.emplace_back( 1389 Fortran::lower::pft::Variable::Interval{start, end - start}, 1390 *namingSym, isGlobal); 1391 } else { 1392 stores.emplace_back(*aggregateSym, *namingSym, isGlobal); 1393 } 1394 } 1395 } 1396 1397 // Recursively visit each symbol to determine the height of its dependence on 1398 // other symbols. 1399 int analyze(const semantics::Symbol &sym) { 1400 auto done = seen.insert(&sym); 1401 LLVM_DEBUG(llvm::dbgs() << "analyze symbol: " << sym << '\n'); 1402 if (!done.second) 1403 return 0; 1404 if (semantics::IsProcedure(sym)) { 1405 // TODO: add declaration? 1406 return 0; 1407 } 1408 semantics::Symbol ultimate = sym.GetUltimate(); 1409 if (const auto *details = 1410 ultimate.detailsIf<semantics::NamelistDetails>()) { 1411 // handle namelist group symbols 1412 for (const semantics::SymbolRef &s : details->objects()) 1413 analyze(s); 1414 return 0; 1415 } 1416 if (!ultimate.has<semantics::ObjectEntityDetails>() && 1417 !ultimate.has<semantics::ProcEntityDetails>()) 1418 return 0; 1419 1420 if (sym.has<semantics::DerivedTypeDetails>()) 1421 llvm_unreachable("not yet implemented - derived type analysis"); 1422 1423 // Symbol must be something lowering will have to allocate. 1424 int depth = 0; 1425 const semantics::DeclTypeSpec *symTy = sym.GetType(); 1426 assert(symTy && "symbol must have a type"); 1427 1428 // Analyze symbols appearing in object entity specification expression. This 1429 // ensures these symbols will be instantiated before the current one. 1430 // This is not done for object entities that are host associated because 1431 // they must be instantiated from the value of the host symbols (the 1432 // specification expressions should not be re-evaluated). 1433 if (const auto *details = sym.detailsIf<semantics::ObjectEntityDetails>()) { 1434 // check CHARACTER's length 1435 if (symTy->category() == semantics::DeclTypeSpec::Character) 1436 if (auto e = symTy->characterTypeSpec().length().GetExplicit()) 1437 for (const auto &s : evaluate::CollectSymbols(*e)) 1438 depth = std::max(analyze(s) + 1, depth); 1439 1440 auto doExplicit = [&](const auto &bound) { 1441 if (bound.isExplicit()) { 1442 semantics::SomeExpr e{*bound.GetExplicit()}; 1443 for (const auto &s : evaluate::CollectSymbols(e)) 1444 depth = std::max(analyze(s) + 1, depth); 1445 } 1446 }; 1447 // handle any symbols in array bound declarations 1448 for (const semantics::ShapeSpec &subs : details->shape()) { 1449 doExplicit(subs.lbound()); 1450 doExplicit(subs.ubound()); 1451 } 1452 // handle any symbols in coarray bound declarations 1453 for (const semantics::ShapeSpec &subs : details->coshape()) { 1454 doExplicit(subs.lbound()); 1455 doExplicit(subs.ubound()); 1456 } 1457 // handle any symbols in initialization expressions 1458 if (auto e = details->init()) 1459 for (const auto &s : evaluate::CollectSymbols(*e)) 1460 depth = std::max(analyze(s) + 1, depth); 1461 } 1462 adjustSize(depth + 1); 1463 bool global = lower::symbolIsGlobal(sym); 1464 vars[depth].emplace_back(sym, global, depth); 1465 if (semantics::IsAllocatable(sym)) 1466 vars[depth].back().setHeapAlloc(); 1467 if (semantics::IsPointer(sym)) 1468 vars[depth].back().setPointer(); 1469 if (ultimate.attrs().test(semantics::Attr::TARGET)) 1470 vars[depth].back().setTarget(); 1471 1472 // If there are alias sets, then link the participating variables to their 1473 // aggregate stores when constructing the new variable on the list. 1474 if (lower::pft::Variable::AggregateStore *store = findStoreIfAlias(sym)) { 1475 vars[depth].back().setAlias(store->getOffset()); 1476 } 1477 return depth; 1478 } 1479 1480 /// Save the final list of variable allocations as a single vector and free 1481 /// the rest. 1482 void finalize() { 1483 for (int i = 1, end = vars.size(); i < end; ++i) 1484 vars[0].insert(vars[0].end(), vars[i].begin(), vars[i].end()); 1485 vars.resize(1); 1486 } 1487 1488 Fortran::lower::pft::Variable::AggregateStore * 1489 findStoreIfAlias(const Fortran::evaluate::Symbol &sym) { 1490 const semantics::Symbol &ultimate = sym.GetUltimate(); 1491 const semantics::Scope &scope = ultimate.owner(); 1492 // Expect the total number of EQUIVALENCE sets to be small for a typical 1493 // Fortran program. 1494 if (aliasSyms.find(&ultimate) != aliasSyms.end()) { 1495 LLVM_DEBUG(llvm::dbgs() << "symbol: " << ultimate << '\n'); 1496 LLVM_DEBUG(llvm::dbgs() << "scope: " << scope << '\n'); 1497 std::size_t off = ultimate.offset(); 1498 std::size_t symSize = ultimate.size(); 1499 for (lower::pft::Variable::AggregateStore &v : stores) { 1500 if (&v.getOwningScope() == &scope) { 1501 auto intervalOff = std::get<0>(v.interval); 1502 auto intervalSize = std::get<1>(v.interval); 1503 if (off >= intervalOff && off < intervalOff + intervalSize) 1504 return &v; 1505 // Zero sized symbol in zero sized equivalence. 1506 if (off == intervalOff && symSize == 0) 1507 return &v; 1508 } 1509 } 1510 // clang-format off 1511 LLVM_DEBUG( 1512 llvm::dbgs() << "looking for " << off << "\n{\n"; 1513 for (lower::pft::Variable::AggregateStore &v : stores) { 1514 llvm::dbgs() << " in scope: " << &v.getOwningScope() << "\n"; 1515 llvm::dbgs() << " i = [" << std::get<0>(v.interval) << ".." 1516 << std::get<0>(v.interval) + std::get<1>(v.interval) 1517 << "]\n"; 1518 } 1519 llvm::dbgs() << "}\n"); 1520 // clang-format on 1521 llvm_unreachable("the store must be present"); 1522 } 1523 return nullptr; 1524 } 1525 1526 private: 1527 /// Skip symbol in alias analysis. 1528 bool skipSymbol(const semantics::Symbol &sym) { 1529 // Common block equivalences are largely managed by the front end. 1530 // Compiler generated symbols ('.' names) cannot be equivalenced. 1531 // FIXME: Equivalence code generation may need to be revisited. 1532 return !sym.has<semantics::ObjectEntityDetails>() || 1533 lower::definedInCommonBlock(sym) || sym.name()[0] == '.'; 1534 } 1535 1536 // Make sure the table is of appropriate size. 1537 void adjustSize(std::size_t size) { 1538 if (vars.size() < size) 1539 vars.resize(size); 1540 } 1541 1542 llvm::SmallSet<const semantics::Symbol *, 32> seen; 1543 std::vector<std::vector<lower::pft::Variable>> &vars; 1544 llvm::SmallSet<const semantics::Symbol *, 32> aliasSyms; 1545 /// Set of Scope that have been analyzed for aliases. 1546 llvm::SmallSet<const semantics::Scope *, 4> analyzedScopes; 1547 std::vector<Fortran::lower::pft::Variable::AggregateStore> stores; 1548 }; 1549 } // namespace 1550 1551 static void processSymbolTable( 1552 const semantics::Scope &scope, 1553 std::vector<std::vector<Fortran::lower::pft::Variable>> &varList) { 1554 SymbolDependenceDepth sdd{varList}; 1555 sdd.analyzeAliasesInCurrentScope(scope); 1556 for (const auto &iter : scope) 1557 sdd.analyze(iter.second.get()); 1558 sdd.finalize(); 1559 } 1560 1561 //===----------------------------------------------------------------------===// 1562 // FunctionLikeUnit implementation 1563 //===----------------------------------------------------------------------===// 1564 1565 Fortran::lower::pft::FunctionLikeUnit::FunctionLikeUnit( 1566 const parser::MainProgram &func, const lower::pft::PftNode &parent, 1567 const semantics::SemanticsContext &semanticsContext) 1568 : ProgramUnit{func, parent}, endStmt{ 1569 getFunctionStmt<parser::EndProgramStmt>( 1570 func)} { 1571 const auto &programStmt = 1572 std::get<std::optional<parser::Statement<parser::ProgramStmt>>>(func.t); 1573 if (programStmt.has_value()) { 1574 beginStmt = FunctionStatement(programStmt.value()); 1575 const semantics::Symbol *symbol = getSymbol(*beginStmt); 1576 entryPointList[0].first = symbol; 1577 processSymbolTable(*symbol->scope(), varList); 1578 } else { 1579 processSymbolTable( 1580 semanticsContext.FindScope( 1581 std::get<parser::Statement<parser::EndProgramStmt>>(func.t).source), 1582 varList); 1583 } 1584 } 1585 1586 Fortran::lower::pft::FunctionLikeUnit::FunctionLikeUnit( 1587 const parser::FunctionSubprogram &func, const lower::pft::PftNode &parent, 1588 const semantics::SemanticsContext &) 1589 : ProgramUnit{func, parent}, 1590 beginStmt{getFunctionStmt<parser::FunctionStmt>(func)}, 1591 endStmt{getFunctionStmt<parser::EndFunctionStmt>(func)} { 1592 const semantics::Symbol *symbol = getSymbol(*beginStmt); 1593 entryPointList[0].first = symbol; 1594 processSymbolTable(*symbol->scope(), varList); 1595 } 1596 1597 Fortran::lower::pft::FunctionLikeUnit::FunctionLikeUnit( 1598 const parser::SubroutineSubprogram &func, const lower::pft::PftNode &parent, 1599 const semantics::SemanticsContext &) 1600 : ProgramUnit{func, parent}, 1601 beginStmt{getFunctionStmt<parser::SubroutineStmt>(func)}, 1602 endStmt{getFunctionStmt<parser::EndSubroutineStmt>(func)} { 1603 const semantics::Symbol *symbol = getSymbol(*beginStmt); 1604 entryPointList[0].first = symbol; 1605 processSymbolTable(*symbol->scope(), varList); 1606 } 1607 1608 Fortran::lower::pft::FunctionLikeUnit::FunctionLikeUnit( 1609 const parser::SeparateModuleSubprogram &func, 1610 const lower::pft::PftNode &parent, const semantics::SemanticsContext &) 1611 : ProgramUnit{func, parent}, 1612 beginStmt{getFunctionStmt<parser::MpSubprogramStmt>(func)}, 1613 endStmt{getFunctionStmt<parser::EndMpSubprogramStmt>(func)} { 1614 const semantics::Symbol *symbol = getSymbol(*beginStmt); 1615 entryPointList[0].first = symbol; 1616 processSymbolTable(*symbol->scope(), varList); 1617 } 1618 1619 Fortran::lower::HostAssociations & 1620 Fortran::lower::pft::FunctionLikeUnit::parentHostAssoc() { 1621 if (auto *par = parent.getIf<FunctionLikeUnit>()) 1622 return par->hostAssociations; 1623 llvm::report_fatal_error("parent is not a function"); 1624 } 1625 1626 bool Fortran::lower::pft::FunctionLikeUnit::parentHasHostAssoc() { 1627 if (auto *par = parent.getIf<FunctionLikeUnit>()) 1628 return !par->hostAssociations.empty(); 1629 return false; 1630 } 1631 1632 parser::CharBlock 1633 Fortran::lower::pft::FunctionLikeUnit::getStartingSourceLoc() const { 1634 if (beginStmt) 1635 return stmtSourceLoc(*beginStmt); 1636 if (!evaluationList.empty()) 1637 return evaluationList.front().position; 1638 return stmtSourceLoc(endStmt); 1639 } 1640 1641 //===----------------------------------------------------------------------===// 1642 // ModuleLikeUnit implementation 1643 //===----------------------------------------------------------------------===// 1644 1645 Fortran::lower::pft::ModuleLikeUnit::ModuleLikeUnit( 1646 const parser::Module &m, const lower::pft::PftNode &parent) 1647 : ProgramUnit{m, parent}, beginStmt{getModuleStmt<parser::ModuleStmt>(m)}, 1648 endStmt{getModuleStmt<parser::EndModuleStmt>(m)} { 1649 const semantics::Symbol *symbol = getSymbol(beginStmt); 1650 processSymbolTable(*symbol->scope(), varList); 1651 } 1652 1653 Fortran::lower::pft::ModuleLikeUnit::ModuleLikeUnit( 1654 const parser::Submodule &m, const lower::pft::PftNode &parent) 1655 : ProgramUnit{m, parent}, beginStmt{getModuleStmt<parser::SubmoduleStmt>( 1656 m)}, 1657 endStmt{getModuleStmt<parser::EndSubmoduleStmt>(m)} { 1658 const semantics::Symbol *symbol = getSymbol(beginStmt); 1659 processSymbolTable(*symbol->scope(), varList); 1660 } 1661 1662 parser::CharBlock 1663 Fortran::lower::pft::ModuleLikeUnit::getStartingSourceLoc() const { 1664 return stmtSourceLoc(beginStmt); 1665 } 1666 const Fortran::semantics::Scope & 1667 Fortran::lower::pft::ModuleLikeUnit::getScope() const { 1668 const Fortran::semantics::Symbol *symbol = getSymbol(beginStmt); 1669 assert(symbol && symbol->scope() && 1670 "Module statement must have a symbol with a scope"); 1671 return *symbol->scope(); 1672 } 1673 1674 //===----------------------------------------------------------------------===// 1675 // BlockDataUnit implementation 1676 //===----------------------------------------------------------------------===// 1677 1678 Fortran::lower::pft::BlockDataUnit::BlockDataUnit( 1679 const parser::BlockData &bd, const lower::pft::PftNode &parent, 1680 const semantics::SemanticsContext &semanticsContext) 1681 : ProgramUnit{bd, parent}, 1682 symTab{semanticsContext.FindScope( 1683 std::get<parser::Statement<parser::EndBlockDataStmt>>(bd.t).source)} { 1684 } 1685 1686 std::unique_ptr<lower::pft::Program> 1687 Fortran::lower::createPFT(const parser::Program &root, 1688 const semantics::SemanticsContext &semanticsContext) { 1689 PFTBuilder walker(semanticsContext); 1690 Walk(root, walker); 1691 return walker.result(); 1692 } 1693 1694 // FIXME: FlangDriver 1695 // This option should be integrated with the real driver as the default of 1696 // RECURSIVE vs. NON_RECURSIVE may be changed by other command line options, 1697 // etc., etc. 1698 bool Fortran::lower::defaultRecursiveFunctionSetting() { 1699 return !nonRecursiveProcedures; 1700 } 1701 1702 void Fortran::lower::dumpPFT(llvm::raw_ostream &outputStream, 1703 const lower::pft::Program &pft) { 1704 PFTDumper{}.dumpPFT(outputStream, pft); 1705 } 1706 1707 void Fortran::lower::pft::Program::dump() const { 1708 dumpPFT(llvm::errs(), *this); 1709 } 1710 1711 void Fortran::lower::pft::Evaluation::dump() const { 1712 PFTDumper{}.dumpEvaluation(llvm::errs(), *this); 1713 } 1714 1715 void Fortran::lower::pft::Variable::dump() const { 1716 if (auto *s = std::get_if<Nominal>(&var)) { 1717 llvm::errs() << "symbol: " << s->symbol->name(); 1718 llvm::errs() << " (depth: " << s->depth << ')'; 1719 if (s->global) 1720 llvm::errs() << ", global"; 1721 if (s->heapAlloc) 1722 llvm::errs() << ", allocatable"; 1723 if (s->pointer) 1724 llvm::errs() << ", pointer"; 1725 if (s->target) 1726 llvm::errs() << ", target"; 1727 if (s->aliaser) 1728 llvm::errs() << ", equivalence(" << s->aliasOffset << ')'; 1729 } else if (auto *s = std::get_if<AggregateStore>(&var)) { 1730 llvm::errs() << "interval[" << std::get<0>(s->interval) << ", " 1731 << std::get<1>(s->interval) << "]:"; 1732 llvm::errs() << " name: " << toStringRef(s->getNamingSymbol().name()); 1733 if (s->isGlobal()) 1734 llvm::errs() << ", global"; 1735 if (s->initialValueSymbol) 1736 llvm::errs() << ", initial value: {" << *s->initialValueSymbol << "}"; 1737 } else { 1738 llvm_unreachable("not a Variable"); 1739 } 1740 llvm::errs() << '\n'; 1741 } 1742 1743 void Fortran::lower::pft::FunctionLikeUnit::dump() const { 1744 PFTDumper{}.dumpFunctionLikeUnit(llvm::errs(), *this); 1745 } 1746 1747 void Fortran::lower::pft::ModuleLikeUnit::dump() const { 1748 PFTDumper{}.dumpModuleLikeUnit(llvm::errs(), *this); 1749 } 1750 1751 /// The BlockDataUnit dump is just the associated symbol table. 1752 void Fortran::lower::pft::BlockDataUnit::dump() const { 1753 llvm::errs() << "block data {\n" << symTab << "\n}\n"; 1754 } 1755 1756 std::vector<Fortran::lower::pft::Variable> 1757 Fortran::lower::pft::buildFuncResultDependencyList( 1758 const Fortran::semantics::Symbol &symbol) { 1759 std::vector<std::vector<pft::Variable>> variableList; 1760 SymbolDependenceDepth sdd(variableList); 1761 sdd.analyzeAliasesInCurrentScope(symbol.owner()); 1762 sdd.analyze(symbol); 1763 sdd.finalize(); 1764 // Remove the pft::variable for the result itself, only its dependencies 1765 // should be returned in the list. 1766 assert(!variableList[0].empty() && "must at least contain the result"); 1767 assert(&variableList[0].back().getSymbol() == &symbol && 1768 "result sym should be last"); 1769 variableList[0].pop_back(); 1770 return variableList[0]; 1771 } 1772 1773 namespace { 1774 /// Helper class to find all the symbols referenced in a FunctionLikeUnit. 1775 /// It defines a parse tree visitor doing a deep visit in all nodes with 1776 /// symbols (including evaluate::Expr). 1777 struct SymbolVisitor { 1778 template <typename A> 1779 bool Pre(const A &x) { 1780 if constexpr (Fortran::parser::HasTypedExpr<A>::value) 1781 if (const auto *expr = Fortran::semantics::GetExpr(x)) 1782 visitExpr(*expr); 1783 return true; 1784 } 1785 1786 bool Pre(const Fortran::parser::Name &name) { 1787 if (const semantics::Symbol *symbol = name.symbol) 1788 visitSymbol(*symbol); 1789 return false; 1790 } 1791 1792 void visitExpr(const Fortran::lower::SomeExpr &expr) { 1793 for (const semantics::Symbol &symbol : 1794 Fortran::evaluate::CollectSymbols(expr)) 1795 visitSymbol(symbol); 1796 } 1797 1798 void visitSymbol(const Fortran::semantics::Symbol &symbol) { 1799 callBack(symbol); 1800 // Visit statement function body since it will be inlined in lowering. 1801 if (const auto *subprogramDetails = 1802 symbol.detailsIf<Fortran::semantics::SubprogramDetails>()) 1803 if (const auto &maybeExpr = subprogramDetails->stmtFunction()) 1804 visitExpr(*maybeExpr); 1805 } 1806 1807 template <typename A> 1808 constexpr void Post(const A &) {} 1809 1810 const std::function<void(const Fortran::semantics::Symbol &)> &callBack; 1811 }; 1812 } // namespace 1813 1814 void Fortran::lower::pft::visitAllSymbols( 1815 const Fortran::lower::pft::FunctionLikeUnit &funit, 1816 const std::function<void(const Fortran::semantics::Symbol &)> callBack) { 1817 SymbolVisitor visitor{callBack}; 1818 funit.visit([&](const auto &functionParserNode) { 1819 parser::Walk(functionParserNode, visitor); 1820 }); 1821 } 1822