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