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	// OpenMP directives can generate code around the nested evaluations.
1100	if (initialEval->hasNestedEvaluations() &&
1101	!initialEval->isOpenMPDirective())
1102	initialEval = &initialEval->getFirstNestedEvaluation();
1103	else if (initialEval->isA<Fortran::parser::EntryStmt>())
1104	initialEval = initialEval->lexicalSuccessor;
1105	initialEval->isNewBlock = true;
1106
1107	// All function entry points share a single result container.
1108	// Find one of the largest results.
1109	for (int entryIndex = 0; entryIndex < entryCount; ++entryIndex) {
1110	unit->setActiveEntry(entryIndex);
1111	const auto &details =
1112	unit->getSubprogramSymbol().get<semantics::SubprogramDetails>();
1113	if (details.isFunction()) {
1114	const semantics::Symbol *resultSym = &details.result();
1115	assert(resultSym && "missing result symbol");
1116	if (!unit->primaryResult ||
1117	unit->primaryResult->size() < resultSym->size())
1118	unit->primaryResult = resultSym;
1119	}
1120	}
1121	unit->setActiveEntry(0);
1122	}
1123
1124	std::unique_ptr<lower::pft::Program> pgm;
1125	std::vector<lower::pft::PftNode> pftParentStack;
1126	const semantics::SemanticsContext &semanticsContext;
1127
1128	llvm::SmallVector<bool> containsStmtStack{};
1129	lower::pft::ContainedUnitList *containedUnitList{};
1130	std::vector<lower::pft::Evaluation *> constructAndDirectiveStack{};
1131	std::vector<lower::pft::Evaluation *> doConstructStack{};
1132	/// evaluationListStack is the current nested construct evaluationList state.
1133	std::vector<lower::pft::EvaluationList *> evaluationListStack{};
1134	llvm::DenseMap<parser::Label, lower::pft::Evaluation *> *labelEvaluationMap{};
1135	lower::pft::SymbolLabelMap *assignSymbolLabelMap{};
1136	std::map<std::string, lower::pft::Evaluation *> constructNameMap{};
1137	int specificationPartLevel{};
1138	lower::pft::Evaluation *lastLexicalEvaluation{};
1139	};
1140
1141	#ifndef NDEBUG
1142	/// Dump all program scopes and symbols with addresses to disambiguate names.
1143	/// This is static, unchanging front end information, so dump it only once.
1144	void dumpScope(const semantics::Scope *scope, int depth) {
1145	static int initialVisitCounter = 0;
1146	if (depth < 0) {
1147	if (++initialVisitCounter != 1)
1148	return;
1149	while (!scope->IsGlobal())
1150	scope = &scope->parent();
1151	LLVM_DEBUG(llvm::dbgs() << "Full program scope information.\n"
1152	"Addresses in angle brackets are scopes. "
1153	"Unbracketed addresses are symbols.\n");
1154	}
1155	static const std::string white{" ++"};
1156	std::string w = white.substr(0, depth * 2);
1157	if (depth >= 0) {
1158	LLVM_DEBUG(llvm::dbgs() << w << "<" << scope << "> ");
1159	if (auto *sym{scope->symbol()}) {
1160	LLVM_DEBUG(llvm::dbgs() << sym << " " << *sym << "\n");
1161	} else {
1162	if (scope->IsIntrinsicModules()) {
1163	LLVM_DEBUG(llvm::dbgs() << "IntrinsicModules (no detail)\n");
1164	return;
1165	}
1166	if (scope->kind() == Fortran::semantics::Scope::Kind::BlockConstruct)
1167	LLVM_DEBUG(llvm::dbgs() << "[block]\n");
1168	else
1169	LLVM_DEBUG(llvm::dbgs() << "[anonymous]\n");
1170	}
1171	}
1172	for (const auto &scp : scope->children())
1173	if (!scp.symbol())
1174	dumpScope(&scp, depth + 1);
1175	for (auto iter = scope->begin(); iter != scope->end(); ++iter) {
1176	common::Reference<semantics::Symbol> sym = iter->second;
1177	if (auto scp = sym->scope())
1178	dumpScope(scp, depth + 1);
1179	else
1180	LLVM_DEBUG(llvm::dbgs() << w + " " << &*sym << " " << *sym << "\n");
1181	}
1182	}
1183	#endif // NDEBUG
1184
1185	class PFTDumper {
1186	public:
1187	void dumpPFT(llvm::raw_ostream &outputStream,
1188	const lower::pft::Program &pft) {
1189	for (auto &unit : pft.getUnits()) {
1190	Fortran::common::visit(
1191	common::visitors{
1192	[&](const lower::pft::BlockDataUnit &unit) {
1193	outputStream << getNodeIndex(unit) << " ";
1194	outputStream << "BlockData: ";
1195	outputStream << "\nEnd BlockData\n\n";
1196	},
1197	[&](const lower::pft::FunctionLikeUnit &func) {
1198	dumpFunctionLikeUnit(outputStream, func);
1199	},
1200	[&](const lower::pft::ModuleLikeUnit &unit) {
1201	dumpModuleLikeUnit(outputStream, unit);
1202	},
1203	[&](const lower::pft::CompilerDirectiveUnit &unit) {
1204	dumpCompilerDirectiveUnit(outputStream, unit);
1205	},
1206	[&](const lower::pft::OpenACCDirectiveUnit &unit) {
1207	dumpOpenACCDirectiveUnit(outputStream, unit);
1208	},
1209	},
1210	unit);
1211	}
1212	}
1213
1214	llvm::StringRef evaluationName(const lower::pft::Evaluation &eval) {
1215	return eval.visit([](const auto &parseTreeNode) {
1216	return parser::ParseTreeDumper::GetNodeName(parseTreeNode);
1217	});
1218	}
1219
1220	void dumpEvaluation(llvm::raw_ostream &outputStream,
1221	const lower::pft::Evaluation &eval,
1222	const std::string &indentString, int indent = 1) {
1223	llvm::StringRef name = evaluationName(eval);
1224	llvm::StringRef newBlock = eval.isNewBlock ? "^" : "";
1225	llvm::StringRef bang = eval.isUnstructured ? "!" : "";
1226	outputStream << indentString;
1227	if (eval.printIndex)
1228	outputStream << eval.printIndex << ' ';
1229	if (eval.hasNestedEvaluations())
1230	outputStream << "<<" << newBlock << name << bang << ">>";
1231	else
1232	outputStream << newBlock << name << bang;
1233	if (eval.negateCondition)
1234	outputStream << " [negate]";
1235	if (eval.constructExit)
1236	outputStream << " -> " << eval.constructExit->printIndex;
1237	else if (eval.controlSuccessor)
1238	outputStream << " -> " << eval.controlSuccessor->printIndex;
1239	else if (eval.isA<parser::EntryStmt>() && eval.lexicalSuccessor)
1240	outputStream << " -> " << eval.lexicalSuccessor->printIndex;
1241	bool extraNewline = false;
1242	if (!eval.position.empty())
1243	outputStream << ": " << eval.position.ToString();
1244	else if (auto *dir = eval.getIf<parser::CompilerDirective>()) {
1245	extraNewline = dir->source.ToString().back() == '\n';
1246	outputStream << ": !" << dir->source.ToString();
1247	}
1248	if (!extraNewline)
1249	outputStream << '\n';
1250	if (eval.hasNestedEvaluations()) {
1251	dumpEvaluationList(outputStream, *eval.evaluationList, indent + 1);
1252	outputStream << indentString << "<<End " << name << bang << ">>\n";
1253	}
1254	}
1255
1256	void dumpEvaluation(llvm::raw_ostream &ostream,
1257	const lower::pft::Evaluation &eval) {
1258	dumpEvaluation(ostream, eval, "");
1259	}
1260
1261	void dumpEvaluationList(llvm::raw_ostream &outputStream,
1262	const lower::pft::EvaluationList &evaluationList,
1263	int indent = 1) {
1264	static const auto white = " ++"s;
1265	auto indentString = white.substr(0, indent * 2);
1266	for (const lower::pft::Evaluation &eval : evaluationList)
1267	dumpEvaluation(outputStream, eval, indentString, indent);
1268	}
1269
1270	void
1271	dumpFunctionLikeUnit(llvm::raw_ostream &outputStream,
1272	const lower::pft::FunctionLikeUnit &functionLikeUnit) {
1273	outputStream << getNodeIndex(functionLikeUnit) << " ";
1274	llvm::StringRef unitKind;
1275	llvm::StringRef name;
1276	llvm::StringRef header;
1277	if (functionLikeUnit.beginStmt) {
1278	functionLikeUnit.beginStmt->visit(common::visitors{
1279	[&](const parser::Statement<parser::ProgramStmt> &stmt) {
1280	unitKind = "Program";
1281	name = toStringRef(stmt.statement.v.source);
1282	},
1283	[&](const parser::Statement<parser::FunctionStmt> &stmt) {
1284	unitKind = "Function";
1285	name = toStringRef(std::get<parser::Name>(stmt.statement.t).source);
1286	header = toStringRef(stmt.source);
1287	},
1288	[&](const parser::Statement<parser::SubroutineStmt> &stmt) {
1289	unitKind = "Subroutine";
1290	name = toStringRef(std::get<parser::Name>(stmt.statement.t).source);
1291	header = toStringRef(stmt.source);
1292	},
1293	[&](const parser::Statement<parser::MpSubprogramStmt> &stmt) {
1294	unitKind = "MpSubprogram";
1295	name = toStringRef(stmt.statement.v.source);
1296	header = toStringRef(stmt.source);
1297	},
1298	[&](const auto &) { llvm_unreachable("not a valid begin stmt"); },
1299	});
1300	} else {
1301	unitKind = "Program";
1302	name = "<anonymous>";
1303	}
1304	outputStream << unitKind << ' ' << name;
1305	if (!header.empty())
1306	outputStream << ": " << header;
1307	outputStream << '\n';
1308	dumpEvaluationList(outputStream, functionLikeUnit.evaluationList);
1309	dumpContainedUnitList(outputStream, functionLikeUnit.containedUnitList);
1310	outputStream << "End " << unitKind << ' ' << name << "\n\n";
1311	}
1312
1313	void dumpModuleLikeUnit(llvm::raw_ostream &outputStream,
1314	const lower::pft::ModuleLikeUnit &moduleLikeUnit) {
1315	outputStream << getNodeIndex(moduleLikeUnit) << " ";
1316	llvm::StringRef unitKind;
1317	llvm::StringRef name;
1318	llvm::StringRef header;
1319	moduleLikeUnit.beginStmt.visit(common::visitors{
1320	[&](const parser::Statement<parser::ModuleStmt> &stmt) {
1321	unitKind = "Module";
1322	name = toStringRef(stmt.statement.v.source);
1323	header = toStringRef(stmt.source);
1324	},
1325	[&](const parser::Statement<parser::SubmoduleStmt> &stmt) {
1326	unitKind = "Submodule";
1327	name = toStringRef(std::get<parser::Name>(stmt.statement.t).source);
1328	header = toStringRef(stmt.source);
1329	},
1330	[&](const auto &) {
1331	llvm_unreachable("not a valid module begin stmt");
1332	},
1333	});
1334	outputStream << unitKind << ' ' << name << ": " << header << '\n';
1335	dumpEvaluationList(outputStream, moduleLikeUnit.evaluationList);
1336	dumpContainedUnitList(outputStream, moduleLikeUnit.containedUnitList);
1337	outputStream << "End " << unitKind << ' ' << name << "\n\n";
1338	}
1339
1340	// Top level directives
1341	void dumpCompilerDirectiveUnit(
1342	llvm::raw_ostream &outputStream,
1343	const lower::pft::CompilerDirectiveUnit &directive) {
1344	outputStream << getNodeIndex(directive) << " ";
1345	outputStream << "CompilerDirective: !";
1346	bool extraNewline =
1347	directive.get<parser::CompilerDirective>().source.ToString().back() ==
1348	'\n';
1349	outputStream
1350	<< directive.get<parser::CompilerDirective>().source.ToString();
1351	if (!extraNewline)
1352	outputStream << "\n";
1353	outputStream << "\n";
1354	}
1355
1356	void dumpContainedUnitList(
1357	llvm::raw_ostream &outputStream,
1358	const lower::pft::ContainedUnitList &containedUnitList) {
1359	if (containedUnitList.empty())
1360	return;
1361	outputStream << "\nContains\n";
1362	for (const lower::pft::ContainedUnit &unit : containedUnitList)
1363	if (const auto *func = std::get_if<lower::pft::FunctionLikeUnit>(&unit)) {
1364	dumpFunctionLikeUnit(outputStream, *func);
1365	} else if (const auto *dir =
1366	std::get_if<lower::pft::CompilerDirectiveUnit>(&unit)) {
1367	outputStream << getNodeIndex(*dir) << " ";
1368	dumpEvaluation(outputStream,
1369	lower::pft::Evaluation{
1370	dir->get<parser::CompilerDirective>(), dir->parent});
1371	outputStream << "\n";
1372	}
1373	outputStream << "End Contains\n";
1374	}
1375
1376	void
1377	dumpOpenACCDirectiveUnit(llvm::raw_ostream &outputStream,
1378	const lower::pft::OpenACCDirectiveUnit &directive) {
1379	outputStream << getNodeIndex(directive) << " ";
1380	outputStream << "OpenACCDirective: !$acc ";
1381	outputStream
1382	<< directive.get<parser::OpenACCRoutineConstruct>().source.ToString();
1383	outputStream << "\nEnd OpenACCDirective\n\n";
1384	}
1385
1386	template <typename T>
1387	std::size_t getNodeIndex(const T &node) {
1388	auto addr = static_cast<const void *>(&node);
1389	auto it = nodeIndexes.find(Val: addr);
1390	if (it != nodeIndexes.end())
1391	return it->second;
1392	nodeIndexes.try_emplace(Key: addr, Args&: nextIndex);
1393	return nextIndex++;
1394	}
1395	std::size_t getNodeIndex(const lower::pft::Program &) { return 0; }
1396
1397	private:
1398	llvm::DenseMap<const void *, std::size_t> nodeIndexes;
1399	std::size_t nextIndex{1}; // 0 is the root
1400	};
1401
1402	} // namespace
1403
1404	template <typename A, typename T>
1405	static lower::pft::FunctionLikeUnit::FunctionStatement
1406	getFunctionStmt(const T &func) {
1407	lower::pft::FunctionLikeUnit::FunctionStatement result{
1408	std::get<parser::Statement<A>>(func.t)};
1409	return result;
1410	}
1411
1412	template <typename A, typename T>
1413	static lower::pft::ModuleLikeUnit::ModuleStatement getModuleStmt(const T &mod) {
1414	lower::pft::ModuleLikeUnit::ModuleStatement result{
1415	std::get<parser::Statement<A>>(mod.t)};
1416	return result;
1417	}
1418
1419	template <typename A>
1420	static const semantics::Symbol *getSymbol(A &beginStmt) {
1421	const auto *symbol = beginStmt.visit(common::visitors{
1422	[](const parser::Statement<parser::ProgramStmt> &stmt)
1423	-> const semantics::Symbol * { return stmt.statement.v.symbol; },
1424	[](const parser::Statement<parser::FunctionStmt> &stmt)
1425	-> const semantics::Symbol * {
1426	return std::get<parser::Name>(stmt.statement.t).symbol;
1427	},
1428	[](const parser::Statement<parser::SubroutineStmt> &stmt)
1429	-> const semantics::Symbol * {
1430	return std::get<parser::Name>(stmt.statement.t).symbol;
1431	},
1432	[](const parser::Statement<parser::MpSubprogramStmt> &stmt)
1433	-> const semantics::Symbol * { return stmt.statement.v.symbol; },
1434	[](const parser::Statement<parser::ModuleStmt> &stmt)
1435	-> const semantics::Symbol * { return stmt.statement.v.symbol; },
1436	[](const parser::Statement<parser::SubmoduleStmt> &stmt)
1437	-> const semantics::Symbol * {
1438	return std::get<parser::Name>(stmt.statement.t).symbol;
1439	},
1440	[](const auto &) -> const semantics::Symbol * {
1441	llvm_unreachable("unknown FunctionLike or ModuleLike beginStmt");
1442	return nullptr;
1443	}});
1444	assert(symbol && "parser::Name must have resolved symbol");
1445	return symbol;
1446	}
1447
1448	bool Fortran::lower::pft::Evaluation::lowerAsStructured() const {
1449	return !lowerAsUnstructured();
1450	}
1451
1452	bool Fortran::lower::pft::Evaluation::lowerAsUnstructured() const {
1453	return isUnstructured || clDisableStructuredFir;
1454	}
1455
1456	bool Fortran::lower::pft::Evaluation::forceAsUnstructured() const {
1457	return clDisableStructuredFir;
1458	}
1459
1460	lower::pft::FunctionLikeUnit *
1461	Fortran::lower::pft::Evaluation::getOwningProcedure() const {
1462	return parent.visit(common::visitors{
1463	[](lower::pft::FunctionLikeUnit &c) { return &c; },
1464	[&](lower::pft::Evaluation &c) { return c.getOwningProcedure(); },
1465	[](auto &) -> lower::pft::FunctionLikeUnit * { return nullptr; },
1466	});
1467	}
1468
1469	bool Fortran::lower::definedInCommonBlock(const semantics::Symbol &sym) {
1470	return semantics::FindCommonBlockContaining(sym);
1471	}
1472
1473	/// Is the symbol `sym` a global?
1474	bool Fortran::lower::symbolIsGlobal(const semantics::Symbol &sym) {
1475	return (semantics::IsSaved(sym) && semantics::CanCUDASymbolBeGlobal(sym)) ||
1476	lower::definedInCommonBlock(sym) || semantics::IsNamedConstant(sym);
1477	}
1478
1479	namespace {
1480	/// This helper class sorts the symbols in a scope such that a symbol will
1481	/// be placed after those it depends upon. Otherwise the sort is stable and
1482	/// preserves the order of the symbol table, which is sorted by name. This
1483	/// analysis may also be done for an individual symbol.
1484	struct SymbolDependenceAnalysis {
1485	explicit SymbolDependenceAnalysis(const semantics::Scope &scope) {
1486	analyzeEquivalenceSets(scope);
1487	for (const auto &iter : scope)
1488	analyze(iter.second.get());
1489	finalize();
1490	}
1491	explicit SymbolDependenceAnalysis(const semantics::Symbol &symbol) {
1492	analyzeEquivalenceSets(symbol.owner());
1493	analyze(symbol);
1494	finalize();
1495	}
1496	Fortran::lower::pft::VariableList getVariableList() {
1497	return std::move(layeredVarList[0]);
1498	}
1499
1500	private:
1501	/// Analyze the equivalence sets defined in \p scope, plus the equivalence
1502	/// sets in host module, submodule, and procedure scopes that may define
1503	/// symbols referenced in \p scope. This analysis excludes equivalence sets
1504	/// involving common blocks, which are handled elsewhere.
1505	void analyzeEquivalenceSets(const semantics::Scope &scope) {
1506	// FIXME: When this function is called on the scope of an internal
1507	// procedure whose parent contains an EQUIVALENCE set and the internal
1508	// procedure uses variables from that EQUIVALENCE set, we end up creating
1509	// an AggregateStore for those variables unnecessarily.
1510
1511	// A function defined in a [sub]module has no explicit USE of its ancestor
1512	// [sub]modules. Analyze those scopes here to accommodate references to
1513	// symbols in them.
1514	for (auto *scp = &scope.parent(); !scp->IsGlobal(); scp = &scp->parent())
1515	if (scp->kind() == Fortran::semantics::Scope::Kind::Module)
1516	analyzeLocalEquivalenceSets(*scp);
1517	// Analyze local, USEd, and host procedure scope equivalences.
1518	for (const auto &iter : scope) {
1519	const semantics::Symbol &ultimate = iter.second.get().GetUltimate();
1520	if (!skipSymbol(ultimate))
1521	analyzeLocalEquivalenceSets(ultimate.owner());
1522	}
1523	// Add all aggregate stores to the front of the variable list.
1524	adjustSize(size: 1);
1525	// The copy in the loop matters, 'stores' will still be used.
1526	for (auto st : stores)
1527	layeredVarList[0].emplace_back(std::move(st));
1528	}
1529
1530	/// Analyze the equivalence sets defined locally in \p scope that don't
1531	/// involve common blocks.
1532	void analyzeLocalEquivalenceSets(const semantics::Scope &scope) {
1533	if (scope.equivalenceSets().empty())
1534	return; // no equivalence sets to analyze
1535	if (analyzedScopes.contains(&scope))
1536	return; // equivalence sets already analyzed
1537
1538	analyzedScopes.insert(&scope);
1539	std::list<std::list<semantics::SymbolRef>> aggregates =
1540	Fortran::semantics::GetStorageAssociations(scope);
1541	for (std::list<semantics::SymbolRef> aggregate : aggregates) {
1542	const Fortran::semantics::Symbol *aggregateSym = nullptr;
1543	bool isGlobal = false;
1544	const semantics::Symbol &first = *aggregate.front();
1545	// Exclude equivalence sets involving common blocks.
1546	// Those are handled in instantiateCommon.
1547	if (lower::definedInCommonBlock(first))
1548	continue;
1549	std::size_t start = first.offset();
1550	std::size_t end = first.offset() + first.size();
1551	const Fortran::semantics::Symbol *namingSym = nullptr;
1552	for (semantics::SymbolRef symRef : aggregate) {
1553	const semantics::Symbol &sym = *symRef;
1554	aliasSyms.insert(&sym);
1555	if (sym.test(Fortran::semantics::Symbol::Flag::CompilerCreated)) {
1556	aggregateSym = &sym;
1557	} else {
1558	isGlobal |= lower::symbolIsGlobal(sym);
1559	start = std::min(sym.offset(), start);
1560	end = std::max(sym.offset() + sym.size(), end);
1561	if (!namingSym || (sym.name() < namingSym->name()))
1562	namingSym = &sym;
1563	}
1564	}
1565	assert(namingSym && "must contain at least one user symbol");
1566	if (!aggregateSym) {
1567	stores.emplace_back(
1568	Fortran::lower::pft::Variable::Interval{start, end - start},
1569	*namingSym, isGlobal);
1570	} else {
1571	stores.emplace_back(*aggregateSym, *namingSym, isGlobal);
1572	}
1573	}
1574	}
1575
1576	// Recursively visit each symbol to determine the height of its dependence on
1577	// other symbols.
1578	int analyze(const semantics::Symbol &sym) {
1579	auto done = seen.insert(&sym);
1580	if (!done.second)
1581	return 0;
1582	LLVM_DEBUG(llvm::dbgs() << "analyze symbol " << &sym << " in <"
1583	<< &sym.owner() << ">: " << sym << '\n');
1584	const semantics::Symbol &ultimate = sym.GetUltimate();
1585	if (const auto *details = ultimate.detailsIf<semantics::GenericDetails>()) {
1586	// Procedure pointers may be "hidden" behind to the generic symbol if they
1587	// have the same name.
1588	if (const semantics::Symbol *specific = details->specific())
1589	analyze(*specific);
1590	return 0;
1591	}
1592	const bool isProcedurePointerOrDummy =
1593	semantics::IsProcedurePointer(sym) ||
1594	(semantics::IsProcedure(sym) && IsDummy(sym));
1595	// A procedure argument in a subprogram with multiple entry points might
1596	// need a layeredVarList entry to trigger creation of a symbol map entry
1597	// in some cases. Non-dummy procedures don't.
1598	if (semantics::IsProcedure(sym) && !isProcedurePointerOrDummy)
1599	return 0;
1600	// Derived type component symbols may be collected by "CollectSymbols"
1601	// below when processing something like "real :: x(derived%component)". The
1602	// symbol "component" has "ObjectEntityDetails", but it should not be
1603	// instantiated: it is part of "derived" that should be the only one to
1604	// be instantiated.
1605	if (sym.owner().IsDerivedType())
1606	return 0;
1607
1608	if (const auto *details =
1609	ultimate.detailsIf<semantics::NamelistDetails>()) {
1610	// handle namelist group symbols
1611	for (const semantics::SymbolRef &s : details->objects())
1612	analyze(s);
1613	return 0;
1614	}
1615	if (!ultimate.has<semantics::ObjectEntityDetails>() &&
1616	!isProcedurePointerOrDummy)
1617	return 0;
1618
1619	if (sym.has<semantics::DerivedTypeDetails>())
1620	llvm_unreachable("not yet implemented - derived type analysis");
1621
1622	// Symbol must be something lowering will have to allocate.
1623	int depth = 0;
1624	// Analyze symbols appearing in object entity specification expressions.
1625	// This ensures these symbols will be instantiated before the current one.
1626	// This is not done for object entities that are host associated because
1627	// they must be instantiated from the value of the host symbols.
1628	// (The specification expressions should not be re-evaluated.)
1629	if (const auto *details = sym.detailsIf<semantics::ObjectEntityDetails>()) {
1630	const semantics::DeclTypeSpec *symTy = sym.GetType();
1631	assert(symTy && "symbol must have a type");
1632	// check CHARACTER's length
1633	if (symTy->category() == semantics::DeclTypeSpec::Character)
1634	if (auto e = symTy->characterTypeSpec().length().GetExplicit())
1635	for (const auto &s : evaluate::CollectSymbols(*e))
1636	depth = std::max(analyze(s) + 1, depth);
1637
1638	auto doExplicit = [&](const auto &bound) {
1639	if (bound.isExplicit()) {
1640	semantics::SomeExpr e{*bound.GetExplicit()};
1641	for (const auto &s : evaluate::CollectSymbols(e))
1642	depth = std::max(analyze(s) + 1, depth);
1643	}
1644	};
1645	// Handle any symbols in array bound declarations.
1646	for (const semantics::ShapeSpec &subs : details->shape()) {
1647	doExplicit(subs.lbound());
1648	doExplicit(subs.ubound());
1649	}
1650	// Handle any symbols in coarray bound declarations.
1651	for (const semantics::ShapeSpec &subs : details->coshape()) {
1652	doExplicit(subs.lbound());
1653	doExplicit(subs.ubound());
1654	}
1655	// Handle any symbols in initialization expressions.
1656	if (auto e = details->init())
1657	for (const auto &s : evaluate::CollectSymbols(*e))
1658	if (!s->has<semantics::DerivedTypeDetails>())
1659	depth = std::max(analyze(s) + 1, depth);
1660	}
1661
1662	// Make sure cray pointer is instantiated even if it is not visible.
1663	if (ultimate.test(Fortran::semantics::Symbol::Flag::CrayPointee))
1664	depth = std::max(
1665	analyze(Fortran::semantics::GetCrayPointer(ultimate)) + 1, depth);
1666	adjustSize(size: depth + 1);
1667	bool global = lower::symbolIsGlobal(sym);
1668	layeredVarList[depth].emplace_back(sym, global, depth);
1669	if (semantics::IsAllocatable(sym))
1670	layeredVarList[depth].back().setHeapAlloc();
1671	if (semantics::IsPointer(sym))
1672	layeredVarList[depth].back().setPointer();
1673	if (ultimate.attrs().test(semantics::Attr::TARGET))
1674	layeredVarList[depth].back().setTarget();
1675
1676	// If there are alias sets, then link the participating variables to their
1677	// aggregate stores when constructing the new variable on the list.
1678	if (lower::pft::Variable::AggregateStore *store = findStoreIfAlias(sym))
1679	layeredVarList[depth].back().setAlias(store->getOffset());
1680	return depth;
1681	}
1682
1683	/// Skip symbol in alias analysis.
1684	bool skipSymbol(const semantics::Symbol &sym) {
1685	// Common block equivalences are largely managed by the front end.
1686	// Compiler generated symbols ('.' names) cannot be equivalenced.
1687	// FIXME: Equivalence code generation may need to be revisited.
1688	return !sym.has<semantics::ObjectEntityDetails>() ||
1689	lower::definedInCommonBlock(sym) || sym.name()[0] == '.';
1690	}
1691
1692	// Make sure the table is of appropriate size.
1693	void adjustSize(std::size_t size) {
1694	if (layeredVarList.size() < size)
1695	layeredVarList.resize(size);
1696	}
1697
1698	Fortran::lower::pft::Variable::AggregateStore *
1699	findStoreIfAlias(const Fortran::evaluate::Symbol &sym) {
1700	const semantics::Symbol &ultimate = sym.GetUltimate();
1701	const semantics::Scope &scope = ultimate.owner();
1702	// Expect the total number of EQUIVALENCE sets to be small for a typical
1703	// Fortran program.
1704	if (aliasSyms.contains(&ultimate)) {
1705	LLVM_DEBUG(llvm::dbgs() << "found aggregate containing " << &ultimate
1706	<< " " << ultimate.name() << " in <" << &scope
1707	<< "> " << scope.GetName() << '\n');
1708	std::size_t off = ultimate.offset();
1709	std::size_t symSize = ultimate.size();
1710	for (lower::pft::Variable::AggregateStore &v : stores) {
1711	if (&v.getOwningScope() == &scope) {
1712	auto intervalOff = std::get<0>(v.interval);
1713	auto intervalSize = std::get<1>(v.interval);
1714	if (off >= intervalOff && off < intervalOff + intervalSize)
1715	return &v;
1716	// Zero sized symbol in zero sized equivalence.
1717	if (off == intervalOff && symSize == 0)
1718	return &v;
1719	}
1720	}
1721	// clang-format off
1722	LLVM_DEBUG(
1723	llvm::dbgs() << "looking for " << off << "\n{\n";
1724	for (lower::pft::Variable::AggregateStore &v : stores) {
1725	llvm::dbgs() << " in scope: " << &v.getOwningScope() << "\n";
1726	llvm::dbgs() << " i = [" << std::get<0>(v.interval) << ".."
1727	<< std::get<0>(v.interval) + std::get<1>(v.interval)
1728	<< "]\n";
1729	}
1730	llvm::dbgs() << "}\n");
1731	// clang-format on
1732	llvm_unreachable("the store must be present");
1733	}
1734	return nullptr;
1735	}
1736
1737	/// Flatten the result VariableList.
1738	void finalize() {
1739	for (int i = 1, end = layeredVarList.size(); i < end; ++i)
1740	layeredVarList[0].insert(layeredVarList[0].end(),
1741	layeredVarList[i].begin(),
1742	layeredVarList[i].end());
1743	}
1744
1745	llvm::SmallSet<const semantics::Symbol *, 32> seen;
1746	std::vector<Fortran::lower::pft::VariableList> layeredVarList;
1747	llvm::SmallSet<const semantics::Symbol *, 32> aliasSyms;
1748	/// Set of scopes that have been analyzed for aliases.
1749	llvm::SmallSet<const semantics::Scope *, 4> analyzedScopes;
1750	std::vector<Fortran::lower::pft::Variable::AggregateStore> stores;
1751	};
1752	} // namespace
1753
1754	//===----------------------------------------------------------------------===//
1755	// FunctionLikeUnit implementation
1756	//===----------------------------------------------------------------------===//
1757
1758	Fortran::lower::pft::FunctionLikeUnit::FunctionLikeUnit(
1759	const parser::MainProgram &func, const lower::pft::PftNode &parent,
1760	const semantics::SemanticsContext &semanticsContext)
1761	: ProgramUnit{func, parent},
1762	endStmt{getFunctionStmt<parser::EndProgramStmt>(func)} {
1763	const auto &programStmt =
1764	std::get<std::optional<parser::Statement<parser::ProgramStmt>>>(func.t);
1765	if (programStmt.has_value()) {
1766	beginStmt = FunctionStatement(programStmt.value());
1767	const semantics::Symbol *symbol = getSymbol(*beginStmt);
1768	entryPointList[0].first = symbol;
1769	scope = symbol->scope();
1770	} else {
1771	scope = &semanticsContext.FindScope(
1772	std::get<parser::Statement<parser::EndProgramStmt>>(func.t).source);
1773	}
1774	}
1775
1776	Fortran::lower::pft::FunctionLikeUnit::FunctionLikeUnit(
1777	const parser::FunctionSubprogram &func, const lower::pft::PftNode &parent,
1778	const semantics::SemanticsContext &)
1779	: ProgramUnit{func, parent},
1780	beginStmt{getFunctionStmt<parser::FunctionStmt>(func)},
1781	endStmt{getFunctionStmt<parser::EndFunctionStmt>(func)} {
1782	const semantics::Symbol *symbol = getSymbol(*beginStmt);
1783	entryPointList[0].first = symbol;
1784	scope = symbol->scope();
1785	}
1786
1787	Fortran::lower::pft::FunctionLikeUnit::FunctionLikeUnit(
1788	const parser::SubroutineSubprogram &func, const lower::pft::PftNode &parent,
1789	const semantics::SemanticsContext &)
1790	: ProgramUnit{func, parent},
1791	beginStmt{getFunctionStmt<parser::SubroutineStmt>(func)},
1792	endStmt{getFunctionStmt<parser::EndSubroutineStmt>(func)} {
1793	const semantics::Symbol *symbol = getSymbol(*beginStmt);
1794	entryPointList[0].first = symbol;
1795	scope = symbol->scope();
1796	}
1797
1798	Fortran::lower::pft::FunctionLikeUnit::FunctionLikeUnit(
1799	const parser::SeparateModuleSubprogram &func,
1800	const lower::pft::PftNode &parent, const semantics::SemanticsContext &)
1801	: ProgramUnit{func, parent},
1802	beginStmt{getFunctionStmt<parser::MpSubprogramStmt>(func)},
1803	endStmt{getFunctionStmt<parser::EndMpSubprogramStmt>(func)} {
1804	const semantics::Symbol *symbol = getSymbol(*beginStmt);
1805	entryPointList[0].first = symbol;
1806	scope = symbol->scope();
1807	}
1808
1809	Fortran::lower::HostAssociations &
1810	Fortran::lower::pft::FunctionLikeUnit::parentHostAssoc() {
1811	if (auto *par = parent.getIf<FunctionLikeUnit>())
1812	return par->hostAssociations;
1813	llvm::report_fatal_error("parent is not a function");
1814	}
1815
1816	bool Fortran::lower::pft::FunctionLikeUnit::parentHasTupleHostAssoc() {
1817	if (auto *par = parent.getIf<FunctionLikeUnit>())
1818	return par->hostAssociations.hasTupleAssociations();
1819	return false;
1820	}
1821
1822	bool Fortran::lower::pft::FunctionLikeUnit::parentHasHostAssoc() {
1823	if (auto *par = parent.getIf<FunctionLikeUnit>())
1824	return !par->hostAssociations.empty();
1825	return false;
1826	}
1827
1828	parser::CharBlock
1829	Fortran::lower::pft::FunctionLikeUnit::getStartingSourceLoc() const {
1830	if (beginStmt)
1831	return stmtSourceLoc(*beginStmt);
1832	return scope->sourceRange();
1833	}
1834
1835	//===----------------------------------------------------------------------===//
1836	// ModuleLikeUnit implementation
1837	//===----------------------------------------------------------------------===//
1838
1839	Fortran::lower::pft::ModuleLikeUnit::ModuleLikeUnit(
1840	const parser::Module &m, const lower::pft::PftNode &parent)
1841	: ProgramUnit{m, parent}, beginStmt{getModuleStmt<parser::ModuleStmt>(m)},
1842	endStmt{getModuleStmt<parser::EndModuleStmt>(m)} {}
1843
1844	Fortran::lower::pft::ModuleLikeUnit::ModuleLikeUnit(
1845	const parser::Submodule &m, const lower::pft::PftNode &parent)
1846	: ProgramUnit{m, parent},
1847	beginStmt{getModuleStmt<parser::SubmoduleStmt>(m)},
1848	endStmt{getModuleStmt<parser::EndSubmoduleStmt>(m)} {}
1849
1850	parser::CharBlock
1851	Fortran::lower::pft::ModuleLikeUnit::getStartingSourceLoc() const {
1852	return stmtSourceLoc(beginStmt);
1853	}
1854	const Fortran::semantics::Scope &
1855	Fortran::lower::pft::ModuleLikeUnit::getScope() const {
1856	const Fortran::semantics::Symbol *symbol = getSymbol(beginStmt);
1857	assert(symbol && symbol->scope() &&
1858	"Module statement must have a symbol with a scope");
1859	return *symbol->scope();
1860	}
1861
1862	//===----------------------------------------------------------------------===//
1863	// BlockDataUnit implementation
1864	//===----------------------------------------------------------------------===//
1865
1866	Fortran::lower::pft::BlockDataUnit::BlockDataUnit(
1867	const parser::BlockData &bd, const lower::pft::PftNode &parent,
1868	const semantics::SemanticsContext &semanticsContext)
1869	: ProgramUnit{bd, parent},
1870	symTab{semanticsContext.FindScope(
1871	std::get<parser::Statement<parser::EndBlockDataStmt>>(bd.t).source)} {
1872	}
1873
1874	//===----------------------------------------------------------------------===//
1875	// Variable implementation
1876	//===----------------------------------------------------------------------===//
1877
1878	bool Fortran::lower::pft::Variable::isRuntimeTypeInfoData() const {
1879	// So far, use flags to detect if this symbol were generated during
1880	// semantics::BuildRuntimeDerivedTypeTables(). Scope cannot be used since the
1881	// symbols are injected in the user scopes defining the described derived
1882	// types. A robustness improvement for this test could be to get hands on the
1883	// semantics::RuntimeDerivedTypeTables and to check if the symbol names
1884	// belongs to this structure.
1885	using Flags = Fortran::semantics::Symbol::Flag;
1886	const auto *nominal = std::get_if<Nominal>(&var);
1887	return nominal && nominal->symbol->test(Flags::CompilerCreated) &&
1888	nominal->symbol->test(Flags::ReadOnly);
1889	}
1890
1891	//===----------------------------------------------------------------------===//
1892	// API implementation
1893	//===----------------------------------------------------------------------===//
1894
1895	std::unique_ptr<lower::pft::Program>
1896	Fortran::lower::createPFT(const parser::Program &root,
1897	const semantics::SemanticsContext &semanticsContext) {
1898	PFTBuilder walker(semanticsContext);
1899	Walk(root, walker);
1900	return walker.result();
1901	}
1902
1903	void Fortran::lower::dumpPFT(llvm::raw_ostream &outputStream,
1904	const lower::pft::Program &pft) {
1905	PFTDumper{}.dumpPFT(outputStream, pft);
1906	}
1907
1908	void Fortran::lower::pft::Program::dump() const {
1909	dumpPFT(llvm::errs(), *this);
1910	}
1911
1912	void Fortran::lower::pft::Evaluation::dump() const {
1913	PFTDumper{}.dumpEvaluation(llvm::errs(), *this);
1914	}
1915
1916	void Fortran::lower::pft::Variable::dump() const {
1917	if (auto *s = std::get_if<Nominal>(&var)) {
1918	llvm::errs() << s->symbol << " " << *s->symbol;
1919	llvm::errs() << " (depth: " << s->depth << ')';
1920	if (s->global)
1921	llvm::errs() << ", global";
1922	if (s->heapAlloc)
1923	llvm::errs() << ", allocatable";
1924	if (s->pointer)
1925	llvm::errs() << ", pointer";
1926	if (s->target)
1927	llvm::errs() << ", target";
1928	if (s->aliaser)
1929	llvm::errs() << ", equivalence(" << s->aliasOffset << ')';
1930	} else if (auto *s = std::get_if<AggregateStore>(&var)) {
1931	llvm::errs() << "interval[" << std::get<0>(s->interval) << ", "
1932	<< std::get<1>(s->interval) << "]:";
1933	llvm::errs() << " name: " << toStringRef(s->getNamingSymbol().name());
1934	if (s->isGlobal())
1935	llvm::errs() << ", global";
1936	if (s->initialValueSymbol)
1937	llvm::errs() << ", initial value: {" << *s->initialValueSymbol << "}";
1938	} else {
1939	llvm_unreachable("not a Variable");
1940	}
1941	llvm::errs() << '\n';
1942	}
1943
1944	void Fortran::lower::pft::dump(Fortran::lower::pft::VariableList &variableList,
1945	std::string s) {
1946	llvm::errs() << (s.empty() ? "VariableList" : s) << " " << &variableList
1947	<< " size=" << variableList.size() << "\n";
1948	for (auto var : variableList) {
1949	llvm::errs() << " ";
1950	var.dump();
1951	}
1952	}
1953
1954	void Fortran::lower::pft::FunctionLikeUnit::dump() const {
1955	PFTDumper{}.dumpFunctionLikeUnit(llvm::errs(), *this);
1956	}
1957
1958	void Fortran::lower::pft::ModuleLikeUnit::dump() const {
1959	PFTDumper{}.dumpModuleLikeUnit(llvm::errs(), *this);
1960	}
1961
1962	/// The BlockDataUnit dump is just the associated symbol table.
1963	void Fortran::lower::pft::BlockDataUnit::dump() const {
1964	llvm::errs() << "block data {\n" << symTab << "\n}\n";
1965	}
1966
1967	/// Find or create an ordered list of equivalences and variables in \p scope.
1968	/// The result is cached in \p map.
1969	const lower::pft::VariableList &
1970	lower::pft::getScopeVariableList(const semantics::Scope &scope,
1971	ScopeVariableListMap &map) {
1972	LLVM_DEBUG(llvm::dbgs() << "\ngetScopeVariableList of [sub]module scope <"
1973	<< &scope << "> " << scope.GetName() << "\n");
1974	auto iter = map.find(&scope);
1975	if (iter == map.end()) {
1976	SymbolDependenceAnalysis sda(scope);
1977	map.emplace(&scope, sda.getVariableList());
1978	iter = map.find(&scope);
1979	}
1980	return iter->second;
1981	}
1982
1983	/// Create an ordered list of equivalences and variables in \p scope.
1984	/// The result is not cached.
1985	lower::pft::VariableList
1986	lower::pft::getScopeVariableList(const semantics::Scope &scope) {
1987	LLVM_DEBUG(
1988	llvm::dbgs() << "\ngetScopeVariableList of [sub]program|block scope <"
1989	<< &scope << "> " << scope.GetName() << "\n");
1990	SymbolDependenceAnalysis sda(scope);
1991	return sda.getVariableList();
1992	}
1993
1994	/// Create an ordered list of equivalences and variables that \p symbol
1995	/// depends on (no caching). Include \p symbol at the end of the list.
1996	lower::pft::VariableList
1997	lower::pft::getDependentVariableList(const semantics::Symbol &symbol) {
1998	LLVM_DEBUG(llvm::dbgs() << "\ngetDependentVariableList of " << &symbol
1999	<< " - " << symbol << "\n");
2000	SymbolDependenceAnalysis sda(symbol);
2001	return sda.getVariableList();
2002	}
2003
2004	namespace {
2005	/// Helper class to find all the symbols referenced in a FunctionLikeUnit.
2006	/// It defines a parse tree visitor doing a deep visit in all nodes with
2007	/// symbols (including evaluate::Expr).
2008	struct SymbolVisitor {
2009	template <typename A>
2010	bool Pre(const A &x) {
2011	if constexpr (Fortran::parser::HasTypedExpr<A>::value)
2012	// Some parse tree Expr may legitimately be un-analyzed after semantics
2013	// (for instance PDT component initial value in the PDT definition body).
2014	if (const auto *expr = Fortran::semantics::GetExpr(nullptr, x))
2015	visitExpr(*expr);
2016	return true;
2017	}
2018
2019	bool Pre(const Fortran::parser::Name &name) {
2020	if (const semantics::Symbol *symbol = name.symbol)
2021	visitSymbol(*symbol);
2022	return false;
2023	}
2024
2025	template <typename T>
2026	void visitExpr(const Fortran::evaluate::Expr<T> &expr) {
2027	for (const semantics::Symbol &symbol :
2028	Fortran::evaluate::CollectSymbols(expr))
2029	visitSymbol(symbol);
2030	}
2031
2032	void visitSymbol(const Fortran::semantics::Symbol &symbol) {
2033	callBack(symbol);
2034	// - Visit statement function body since it will be inlined in lowering.
2035	// - Visit function results specification expressions because allocations
2036	// happens on the caller side.
2037	if (const auto *subprogramDetails =
2038	symbol.detailsIf<Fortran::semantics::SubprogramDetails>()) {
2039	if (const auto &maybeExpr = subprogramDetails->stmtFunction()) {
2040	visitExpr(*maybeExpr);
2041	} else {
2042	if (subprogramDetails->isFunction()) {
2043	// Visit result extents expressions that are explicit.
2044	const Fortran::semantics::Symbol &result =
2045	subprogramDetails->result();
2046	if (const auto *objectDetails =
2047	result.detailsIf<Fortran::semantics::ObjectEntityDetails>())
2048	if (objectDetails->shape().IsExplicitShape())
2049	for (const Fortran::semantics::ShapeSpec &shapeSpec :
2050	objectDetails->shape()) {
2051	visitExpr(shapeSpec.lbound().GetExplicit().value());
2052	visitExpr(shapeSpec.ubound().GetExplicit().value());
2053	}
2054	}
2055	}
2056	}
2057	if (Fortran::semantics::IsProcedure(symbol)) {
2058	if (auto dynamicType = Fortran::evaluate::DynamicType::From(symbol)) {
2059	// Visit result length specification expressions that are explicit.
2060	if (dynamicType->category() ==
2061	Fortran::common::TypeCategory::Character) {
2062	if (std::optional<Fortran::evaluate::ExtentExpr> length =
2063	dynamicType->GetCharLength())
2064	visitExpr(*length);
2065	} else if (const Fortran::semantics::DerivedTypeSpec *derivedTypeSpec =
2066	Fortran::evaluate::GetDerivedTypeSpec(dynamicType)) {
2067	for (const auto &[_, param] : derivedTypeSpec->parameters())
2068	if (const Fortran::semantics::MaybeIntExpr &expr =
2069	param.GetExplicit())
2070	visitExpr(expr.value());
2071	}
2072	}
2073	}
2074	// - CrayPointer needs to be available whenever a CrayPointee is used.
2075	if (symbol.GetUltimate().test(
2076	Fortran::semantics::Symbol::Flag::CrayPointee))
2077	visitSymbol(Fortran::semantics::GetCrayPointer(symbol));
2078	}
2079
2080	template <typename A>
2081	constexpr void Post(const A &) {}
2082
2083	const std::function<void(const Fortran::semantics::Symbol &)> &callBack;
2084	};
2085	} // namespace
2086
2087	void Fortran::lower::pft::visitAllSymbols(
2088	const Fortran::lower::pft::FunctionLikeUnit &funit,
2089	const std::function<void(const Fortran::semantics::Symbol &)> callBack) {
2090	SymbolVisitor visitor{callBack};
2091	funit.visit([&](const auto &functionParserNode) {
2092	parser::Walk(functionParserNode, visitor);
2093	});
2094	}
2095
2096	void Fortran::lower::pft::visitAllSymbols(
2097	const Fortran::lower::pft::Evaluation &eval,
2098	const std::function<void(const Fortran::semantics::Symbol &)> callBack) {
2099	SymbolVisitor visitor{callBack};
2100	eval.visit([&](const auto &functionParserNode) {
2101	parser::Walk(functionParserNode, visitor);
2102	});
2103	}
2104