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