1	//===-- Bridge.cpp -- bridge to lower to MLIR -----------------------------===//
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	// Coding style: https://mlir.llvm.org/getting_started/DeveloperGuide/
10	//
11	//===----------------------------------------------------------------------===//
12
13	#include "flang/Lower/Bridge.h"
14
15	#include "flang/Lower/Allocatable.h"
16	#include "flang/Lower/CallInterface.h"
17	#include "flang/Lower/Coarray.h"
18	#include "flang/Lower/ConvertCall.h"
19	#include "flang/Lower/ConvertExpr.h"
20	#include "flang/Lower/ConvertExprToHLFIR.h"
21	#include "flang/Lower/ConvertType.h"
22	#include "flang/Lower/ConvertVariable.h"
23	#include "flang/Lower/Cuda.h"
24	#include "flang/Lower/DirectivesCommon.h"
25	#include "flang/Lower/HostAssociations.h"
26	#include "flang/Lower/IO.h"
27	#include "flang/Lower/IterationSpace.h"
28	#include "flang/Lower/Mangler.h"
29	#include "flang/Lower/OpenACC.h"
30	#include "flang/Lower/OpenMP.h"
31	#include "flang/Lower/PFTBuilder.h"
32	#include "flang/Lower/Runtime.h"
33	#include "flang/Lower/StatementContext.h"
34	#include "flang/Lower/Support/Utils.h"
35	#include "flang/Optimizer/Builder/BoxValue.h"
36	#include "flang/Optimizer/Builder/CUFCommon.h"
37	#include "flang/Optimizer/Builder/Character.h"
38	#include "flang/Optimizer/Builder/FIRBuilder.h"
39	#include "flang/Optimizer/Builder/Runtime/Assign.h"
40	#include "flang/Optimizer/Builder/Runtime/Character.h"
41	#include "flang/Optimizer/Builder/Runtime/Derived.h"
42	#include "flang/Optimizer/Builder/Runtime/EnvironmentDefaults.h"
43	#include "flang/Optimizer/Builder/Runtime/Exceptions.h"
44	#include "flang/Optimizer/Builder/Runtime/Main.h"
45	#include "flang/Optimizer/Builder/Runtime/Ragged.h"
46	#include "flang/Optimizer/Builder/Runtime/Stop.h"
47	#include "flang/Optimizer/Builder/Todo.h"
48	#include "flang/Optimizer/Dialect/CUF/Attributes/CUFAttr.h"
49	#include "flang/Optimizer/Dialect/CUF/CUFOps.h"
50	#include "flang/Optimizer/Dialect/FIRAttr.h"
51	#include "flang/Optimizer/Dialect/FIRDialect.h"
52	#include "flang/Optimizer/Dialect/FIROps.h"
53	#include "flang/Optimizer/Dialect/Support/FIRContext.h"
54	#include "flang/Optimizer/HLFIR/HLFIROps.h"
55	#include "flang/Optimizer/Support/DataLayout.h"
56	#include "flang/Optimizer/Support/FatalError.h"
57	#include "flang/Optimizer/Support/InternalNames.h"
58	#include "flang/Optimizer/Transforms/Passes.h"
59	#include "flang/Parser/parse-tree.h"
60	#include "flang/Runtime/iostat-consts.h"
61	#include "flang/Semantics/openmp-dsa.h"
62	#include "flang/Semantics/runtime-type-info.h"
63	#include "flang/Semantics/symbol.h"
64	#include "flang/Semantics/tools.h"
65	#include "flang/Support/Flags.h"
66	#include "flang/Support/Version.h"
67	#include "mlir/Dialect/ControlFlow/IR/ControlFlowOps.h"
68	#include "mlir/IR/BuiltinAttributes.h"
69	#include "mlir/IR/Matchers.h"
70	#include "mlir/IR/PatternMatch.h"
71	#include "mlir/Parser/Parser.h"
72	#include "mlir/Transforms/RegionUtils.h"
73	#include "llvm/ADT/SmallVector.h"
74	#include "llvm/ADT/StringSet.h"
75	#include "llvm/Support/CommandLine.h"
76	#include "llvm/Support/Debug.h"
77	#include "llvm/Support/ErrorHandling.h"
78	#include "llvm/Support/FileSystem.h"
79	#include "llvm/Support/Path.h"
80	#include "llvm/Target/TargetMachine.h"
81	#include <optional>
82
83	#define DEBUG_TYPE "flang-lower-bridge"
84
85	static llvm::cl::opt<bool> dumpBeforeFir(
86	"fdebug-dump-pre-fir", llvm::cl::init(Val: false),
87	llvm::cl::desc("dump the Pre-FIR tree prior to FIR generation"));
88
89	static llvm::cl::opt<bool> forceLoopToExecuteOnce(
90	"always-execute-loop-body", llvm::cl::init(Val: false),
91	llvm::cl::desc("force the body of a loop to execute at least once"));
92
93	namespace {
94	/// Information for generating a structured or unstructured increment loop.
95	struct IncrementLoopInfo {
96	template <typename T>
97	explicit IncrementLoopInfo(Fortran::semantics::Symbol &sym, const T &lower,
98	const T &upper, const std::optional<T> &step,
99	bool isConcurrent = false)
100	: loopVariableSym{&sym}, lowerExpr{Fortran::semantics::GetExpr(lower)},
101	upperExpr{Fortran::semantics::GetExpr(upper)},
102	stepExpr{Fortran::semantics::GetExpr(step)},
103	isConcurrent{isConcurrent} {}
104
105	IncrementLoopInfo(IncrementLoopInfo &&) = default;
106	IncrementLoopInfo &operator=(IncrementLoopInfo &&x) = default;
107
108	bool isStructured() const { return !headerBlock; }
109
110	mlir::Type getLoopVariableType() const {
111	assert(loopVariable && "must be set");
112	return fir::unwrapRefType(loopVariable.getType());
113	}
114
115	bool hasLocalitySpecs() const {
116	return !localSymList.empty() || !localInitSymList.empty() ||
117	!reduceSymList.empty() || !sharedSymList.empty();
118	}
119
120	// Data members common to both structured and unstructured loops.
121	const Fortran::semantics::Symbol *loopVariableSym;
122	const Fortran::lower::SomeExpr *lowerExpr;
123	const Fortran::lower::SomeExpr *upperExpr;
124	const Fortran::lower::SomeExpr *stepExpr;
125	const Fortran::lower::SomeExpr *maskExpr = nullptr;
126	bool isConcurrent;
127	llvm::SmallVector<const Fortran::semantics::Symbol *> localSymList;
128	llvm::SmallVector<const Fortran::semantics::Symbol *> localInitSymList;
129	llvm::SmallVector<
130	std::pair<fir::ReduceOperationEnum, const Fortran::semantics::Symbol *>>
131	reduceSymList;
132	llvm::SmallVector<const Fortran::semantics::Symbol *> sharedSymList;
133	mlir::Value loopVariable = nullptr;
134
135	// Data members for structured loops.
136	mlir::Operation *loopOp = nullptr;
137
138	// Data members for unstructured loops.
139	bool hasRealControl = false;
140	mlir::Value tripVariable = nullptr;
141	mlir::Value stepVariable = nullptr;
142	mlir::Block *headerBlock = nullptr; // loop entry and test block
143	mlir::Block *maskBlock = nullptr; // concurrent loop mask block
144	mlir::Block *bodyBlock = nullptr; // first loop body block
145	mlir::Block *exitBlock = nullptr; // loop exit target block
146	};
147
148	/// Information to support stack management, object deallocation, and
149	/// object finalization at early and normal construct exits.
150	struct ConstructContext {
151	explicit ConstructContext(Fortran::lower::pft::Evaluation &eval,
152	Fortran::lower::StatementContext &stmtCtx)
153	: eval{eval}, stmtCtx{stmtCtx} {}
154
155	Fortran::lower::pft::Evaluation &eval; // construct eval
156	Fortran::lower::StatementContext &stmtCtx; // construct exit code
157	std::optional<hlfir::Entity> selector; // construct selector, if any.
158	bool pushedScope = false; // was a scoped pushed for this construct?
159	};
160
161	/// Helper to gather the lower bounds of array components with non deferred
162	/// shape when they are not all ones. Return an empty array attribute otherwise.
163	static mlir::DenseI64ArrayAttr
164	gatherComponentNonDefaultLowerBounds(mlir::Location loc,
165	mlir::MLIRContext *mlirContext,
166	const Fortran::semantics::Symbol &sym) {
167	if (Fortran::semantics::IsAllocatableOrObjectPointer(&sym))
168	return {};
169	mlir::DenseI64ArrayAttr lbs_attr;
170	if (const auto *objDetails =
171	sym.detailsIf<Fortran::semantics::ObjectEntityDetails>()) {
172	llvm::SmallVector<std::int64_t> lbs;
173	bool hasNonDefaultLbs = false;
174	for (const Fortran::semantics::ShapeSpec &bounds : objDetails->shape())
175	if (auto lb = bounds.lbound().GetExplicit()) {
176	if (auto constant = Fortran::evaluate::ToInt64(*lb)) {
177	hasNonDefaultLbs |= (*constant != 1);
178	lbs.push_back(*constant);
179	} else {
180	TODO(loc, "generate fir.dt_component for length parametrized derived "
181	"types");
182	}
183	}
184	if (hasNonDefaultLbs) {
185	assert(static_cast<int>(lbs.size()) == sym.Rank() &&
186	"expected component bounds to be constant or deferred");
187	lbs_attr = mlir::DenseI64ArrayAttr::get(mlirContext, lbs);
188	}
189	}
190	return lbs_attr;
191	}
192
193	// Helper class to generate name of fir.global containing component explicit
194	// default value for objects, and initial procedure target for procedure pointer
195	// components.
196	static mlir::FlatSymbolRefAttr gatherComponentInit(
197	mlir::Location loc, Fortran::lower::AbstractConverter &converter,
198	const Fortran::semantics::Symbol &sym, fir::RecordType derivedType) {
199	mlir::MLIRContext *mlirContext = &converter.getMLIRContext();
200	// Return procedure target mangled name for procedure pointer components.
201	if (const auto *procPtr =
202	sym.detailsIf<Fortran::semantics::ProcEntityDetails>()) {
203	if (std::optional<const Fortran::semantics::Symbol *> maybeInitSym =
204	procPtr->init()) {
205	// So far, do not make distinction between p => NULL() and p without init,
206	// f18 always initialize pointers to NULL anyway.
207	if (!*maybeInitSym)
208	return {};
209	return mlir::FlatSymbolRefAttr::get(mlirContext,
210	converter.mangleName(**maybeInitSym));
211	}
212	}
213
214	const auto *objDetails =
215	sym.detailsIf<Fortran::semantics::ObjectEntityDetails>();
216	if (!objDetails || !objDetails->init().has_value())
217	return {};
218	// Object component initial value. Semantic package component object default
219	// value into compiler generated symbols that are lowered as read-only
220	// fir.global. Get the name of this global.
221	std::string name = fir::NameUniquer::getComponentInitName(
222	derivedType.getName(), toStringRef(sym.name()));
223	return mlir::FlatSymbolRefAttr::get(mlirContext, name);
224	}
225
226	/// Helper class to generate the runtime type info global data and the
227	/// fir.type_info operations that contain the dipatch tables (if any).
228	/// The type info global data is required to describe the derived type to the
229	/// runtime so that it can operate over it.
230	/// It must be ensured these operations will be generated for every derived type
231	/// lowered in the current translated unit. However, these operations
232	/// cannot be generated before FuncOp have been created for functions since the
233	/// initializers may take their address (e.g for type bound procedures). This
234	/// class allows registering all the required type info while it is not
235	/// possible to create GlobalOp/TypeInfoOp, and to generate this data afte
236	/// function lowering.
237	class TypeInfoConverter {
238	/// Store the location and symbols of derived type info to be generated.
239	/// The location of the derived type instantiation is also stored because
240	/// runtime type descriptor symbols are compiler generated and cannot be
241	/// mapped to user code on their own.
242	struct TypeInfo {
243	Fortran::semantics::SymbolRef symbol;
244	const Fortran::semantics::DerivedTypeSpec &typeSpec;
245	fir::RecordType type;
246	mlir::Location loc;
247	};
248
249	public:
250	void registerTypeInfo(Fortran::lower::AbstractConverter &converter,
251	mlir::Location loc,
252	Fortran::semantics::SymbolRef typeInfoSym,
253	const Fortran::semantics::DerivedTypeSpec &typeSpec,
254	fir::RecordType type) {
255	if (seen.contains(typeInfoSym))
256	return;
257	seen.insert(typeInfoSym);
258	currentTypeInfoStack->emplace_back(
259	Args: TypeInfo{typeInfoSym, typeSpec, type, loc});
260	return;
261	}
262
263	void createTypeInfo(Fortran::lower::AbstractConverter &converter) {
264	while (!registeredTypeInfoA.empty()) {
265	currentTypeInfoStack = &registeredTypeInfoB;
266	for (const TypeInfo &info : registeredTypeInfoA)
267	createTypeInfoOpAndGlobal(converter, info);
268	registeredTypeInfoA.clear();
269	currentTypeInfoStack = &registeredTypeInfoA;
270	for (const TypeInfo &info : registeredTypeInfoB)
271	createTypeInfoOpAndGlobal(converter, info);
272	registeredTypeInfoB.clear();
273	}
274	}
275
276	private:
277	void createTypeInfoOpAndGlobal(Fortran::lower::AbstractConverter &converter,
278	const TypeInfo &info) {
279	Fortran::lower::createRuntimeTypeInfoGlobal(converter, info.symbol.get());
280	createTypeInfoOp(converter, info);
281	}
282
283	void createTypeInfoOp(Fortran::lower::AbstractConverter &converter,
284	const TypeInfo &info) {
285	fir::RecordType parentType{};
286	if (const Fortran::semantics::DerivedTypeSpec *parent =
287	Fortran::evaluate::GetParentTypeSpec(info.typeSpec))
288	parentType = mlir::cast<fir::RecordType>(converter.genType(*parent));
289
290	fir::FirOpBuilder &builder = converter.getFirOpBuilder();
291	fir::TypeInfoOp dt;
292	mlir::OpBuilder::InsertPoint insertPointIfCreated;
293	std::tie(dt, insertPointIfCreated) =
294	builder.createTypeInfoOp(info.loc, info.type, parentType);
295	if (!insertPointIfCreated.isSet())
296	return; // fir.type_info was already built in a previous call.
297
298	// Set init, destroy, and nofinal attributes.
299	if (!info.typeSpec.HasDefaultInitialization(/*ignoreAllocatable=*/false,
300	/*ignorePointer=*/false))
301	dt->setAttr(dt.getNoInitAttrName(), builder.getUnitAttr());
302	if (!info.typeSpec.HasDestruction())
303	dt->setAttr(dt.getNoDestroyAttrName(), builder.getUnitAttr());
304	if (!Fortran::semantics::MayRequireFinalization(info.typeSpec))
305	dt->setAttr(dt.getNoFinalAttrName(), builder.getUnitAttr());
306
307	const Fortran::semantics::Scope &derivedScope =
308	DEREF(info.typeSpec.GetScope());
309
310	// Fill binding table region if the derived type has bindings.
311	Fortran::semantics::SymbolVector bindings =
312	Fortran::semantics::CollectBindings(derivedScope);
313	if (!bindings.empty()) {
314	builder.createBlock(&dt.getDispatchTable());
315	for (const Fortran::semantics::SymbolRef &binding : bindings) {
316	const auto &details =
317	binding.get().get<Fortran::semantics::ProcBindingDetails>();
318	std::string tbpName = binding.get().name().ToString();
319	if (details.numPrivatesNotOverridden() > 0)
320	tbpName += "."s + std::to_string(details.numPrivatesNotOverridden());
321	std::string bindingName = converter.mangleName(details.symbol());
322	builder.create<fir::DTEntryOp>(
323	info.loc, mlir::StringAttr::get(builder.getContext(), tbpName),
324	mlir::SymbolRefAttr::get(builder.getContext(), bindingName));
325	}
326	builder.create<fir::FirEndOp>(info.loc);
327	}
328	// Gather info about components that is not reflected in fir.type and may be
329	// needed later: component initial values and array component non default
330	// lower bounds.
331	mlir::Block *componentInfo = nullptr;
332	for (const auto &componentName :
333	info.typeSpec.typeSymbol()
334	.get<Fortran::semantics::DerivedTypeDetails>()
335	.componentNames()) {
336	auto scopeIter = derivedScope.find(componentName);
337	assert(scopeIter != derivedScope.cend() &&
338	"failed to find derived type component symbol");
339	const Fortran::semantics::Symbol &component = scopeIter->second.get();
340	mlir::FlatSymbolRefAttr init_val =
341	gatherComponentInit(info.loc, converter, component, info.type);
342	mlir::DenseI64ArrayAttr lbs = gatherComponentNonDefaultLowerBounds(
343	info.loc, builder.getContext(), component);
344	if (init_val || lbs) {
345	if (!componentInfo)
346	componentInfo = builder.createBlock(&dt.getComponentInfo());
347	auto compName = mlir::StringAttr::get(builder.getContext(),
348	toStringRef(component.name()));
349	builder.create<fir::DTComponentOp>(info.loc, compName, lbs, init_val);
350	}
351	}
352	if (componentInfo)
353	builder.create<fir::FirEndOp>(info.loc);
354	builder.restoreInsertionPoint(insertPointIfCreated);
355	}
356
357	/// Store the front-end data that will be required to generate the type info
358	/// for the derived types that have been converted to fir.type<>. There are
359	/// two stacks since the type info may visit new types, so the new types must
360	/// be added to a new stack.
361	llvm::SmallVector<TypeInfo> registeredTypeInfoA;
362	llvm::SmallVector<TypeInfo> registeredTypeInfoB;
363	llvm::SmallVector<TypeInfo> *currentTypeInfoStack = &registeredTypeInfoA;
364	/// Track symbols symbols processed during and after the registration
365	/// to avoid infinite loops between type conversions and global variable
366	/// creation.
367	llvm::SmallSetVector<Fortran::semantics::SymbolRef, 32> seen;
368	};
369
370	using IncrementLoopNestInfo = llvm::SmallVector<IncrementLoopInfo, 8>;
371	} // namespace
372
373	//===----------------------------------------------------------------------===//
374	// FirConverter
375	//===----------------------------------------------------------------------===//
376
377	namespace {
378
379	/// Traverse the pre-FIR tree (PFT) to generate the FIR dialect of MLIR.
380	class FirConverter : public Fortran::lower::AbstractConverter {
381	public:
382	explicit FirConverter(Fortran::lower::LoweringBridge &bridge)
383	: Fortran::lower::AbstractConverter(bridge.getLoweringOptions()),
384	bridge{bridge}, foldingContext{bridge.createFoldingContext()},
385	mlirSymbolTable{bridge.getModule()} {}
386	virtual ~FirConverter() = default;
387
388	/// Convert the PFT to FIR.
389	void run(Fortran::lower::pft::Program &pft) {
390	// Preliminary translation pass.
391
392	// Lower common blocks, taking into account initialization and the largest
393	// size of all instances of each common block. This is done before lowering
394	// since the global definition may differ from any one local definition.
395	lowerCommonBlocks(pft.getCommonBlocks());
396
397	// - Declare all functions that have definitions so that definition
398	// signatures prevail over call site signatures.
399	// - Define module variables and OpenMP/OpenACC declarative constructs so
400	// they are available before lowering any function that may use them.
401	bool hasMainProgram = false;
402	const Fortran::semantics::Symbol *globalOmpRequiresSymbol = nullptr;
403	createBuilderOutsideOfFuncOpAndDo(createGlobals: [&]() {
404	for (Fortran::lower::pft::Program::Units &u : pft.getUnits()) {
405	Fortran::common::visit(
406	Fortran::common::visitors{
407	[&](Fortran::lower::pft::FunctionLikeUnit &f) {
408	if (f.isMainProgram())
409	hasMainProgram = true;
410	declareFunction(f);
411	if (!globalOmpRequiresSymbol)
412	globalOmpRequiresSymbol = f.getScope().symbol();
413	},
414	[&](Fortran::lower::pft::ModuleLikeUnit &m) {
415	lowerModuleDeclScope(m);
416	for (Fortran::lower::pft::ContainedUnit &unit :
417	m.containedUnitList)
418	if (auto *f =
419	std::get_if<Fortran::lower::pft::FunctionLikeUnit>(
420	&unit))
421	declareFunction(*f);
422	},
423	[&](Fortran::lower::pft::BlockDataUnit &b) {
424	if (!globalOmpRequiresSymbol)
425	globalOmpRequiresSymbol = b.symTab.symbol();
426	},
427	[&](Fortran::lower::pft::CompilerDirectiveUnit &d) {},
428	[&](Fortran::lower::pft::OpenACCDirectiveUnit &d) {},
429	},
430	u);
431	}
432	});
433
434	// Create definitions of intrinsic module constants.
435	createBuilderOutsideOfFuncOpAndDo(
436	createGlobals: [&]() { createIntrinsicModuleDefinitions(pft); });
437
438	// Primary translation pass.
439	for (Fortran::lower::pft::Program::Units &u : pft.getUnits()) {
440	Fortran::common::visit(
441	Fortran::common::visitors{
442	[&](Fortran::lower::pft::FunctionLikeUnit &f) { lowerFunc(f); },
443	[&](Fortran::lower::pft::ModuleLikeUnit &m) { lowerMod(m); },
444	[&](Fortran::lower::pft::BlockDataUnit &b) {},
445	[&](Fortran::lower::pft::CompilerDirectiveUnit &d) {},
446	[&](Fortran::lower::pft::OpenACCDirectiveUnit &d) {},
447	},
448	u);
449	}
450
451	// Once all the code has been translated, create global runtime type info
452	// data structures for the derived types that have been processed, as well
453	// as fir.type_info operations for the dispatch tables.
454	createBuilderOutsideOfFuncOpAndDo(
455	createGlobals: [&]() { typeInfoConverter.createTypeInfo(*this); });
456
457	// Generate the `main` entry point if necessary
458	if (hasMainProgram)
459	createBuilderOutsideOfFuncOpAndDo(createGlobals: [&]() {
460	fir::runtime::genMain(*builder, toLocation(),
461	bridge.getEnvironmentDefaults(),
462	getFoldingContext().languageFeatures().IsEnabled(
463	Fortran::common::LanguageFeature::CUDA));
464	});
465
466	finalizeOpenMPLowering(globalOmpRequiresSymbol);
467	}
468
469	/// Declare a function.
470	void declareFunction(Fortran::lower::pft::FunctionLikeUnit &funit) {
471	CHECK(builder && "declareFunction called with uninitialized builder");
472	setCurrentPosition(funit.getStartingSourceLoc());
473	for (int entryIndex = 0, last = funit.entryPointList.size();
474	entryIndex < last; ++entryIndex) {
475	funit.setActiveEntry(entryIndex);
476	// Calling CalleeInterface ctor will build a declaration
477	// mlir::func::FuncOp with no other side effects.
478	// TODO: when doing some compiler profiling on real apps, it may be worth
479	// to check it's better to save the CalleeInterface instead of recomputing
480	// it later when lowering the body. CalleeInterface ctor should be linear
481	// with the number of arguments, so it is not awful to do it that way for
482	// now, but the linear coefficient might be non negligible. Until
483	// measured, stick to the solution that impacts the code less.
484	Fortran::lower::CalleeInterface{funit, *this};
485	}
486	funit.setActiveEntry(0);
487
488	// Compute the set of host associated entities from the nested functions.
489	llvm::SetVector<const Fortran::semantics::Symbol *> escapeHost;
490	for (Fortran::lower::pft::ContainedUnit &unit : funit.containedUnitList)
491	if (auto *f = std::get_if<Fortran::lower::pft::FunctionLikeUnit>(&unit))
492	collectHostAssociatedVariables(*f, escapeHost);
493	funit.setHostAssociatedSymbols(escapeHost);
494
495	// Declare internal procedures
496	for (Fortran::lower::pft::ContainedUnit &unit : funit.containedUnitList)
497	if (auto *f = std::get_if<Fortran::lower::pft::FunctionLikeUnit>(&unit))
498	declareFunction(*f);
499	}
500
501	/// Get the scope that is defining or using \p sym. The returned scope is not
502	/// the ultimate scope, since this helper does not traverse use association.
503	/// This allows capturing module variables that are referenced in an internal
504	/// procedure but whose use statement is inside the host program.
505	const Fortran::semantics::Scope &
506	getSymbolHostScope(const Fortran::semantics::Symbol &sym) {
507	const Fortran::semantics::Symbol *hostSymbol = &sym;
508	while (const auto *details =
509	hostSymbol->detailsIf<Fortran::semantics::HostAssocDetails>())
510	hostSymbol = &details->symbol();
511	return hostSymbol->owner();
512	}
513
514	/// Collects the canonical list of all host associated symbols. These bindings
515	/// must be aggregated into a tuple which can then be added to each of the
516	/// internal procedure declarations and passed at each call site.
517	void collectHostAssociatedVariables(
518	Fortran::lower::pft::FunctionLikeUnit &funit,
519	llvm::SetVector<const Fortran::semantics::Symbol *> &escapees) {
520	const Fortran::semantics::Scope *internalScope =
521	funit.getSubprogramSymbol().scope();
522	assert(internalScope && "internal procedures symbol must create a scope");
523	auto addToListIfEscapee = [&](const Fortran::semantics::Symbol &sym) {
524	const Fortran::semantics::Symbol &ultimate = sym.GetUltimate();
525	const auto *namelistDetails =
526	ultimate.detailsIf<Fortran::semantics::NamelistDetails>();
527	if (ultimate.has<Fortran::semantics::ObjectEntityDetails>() ||
528	Fortran::semantics::IsProcedurePointer(ultimate) ||
529	Fortran::semantics::IsDummy(sym) || namelistDetails) {
530	const Fortran::semantics::Scope &symbolScope = getSymbolHostScope(sym);
531	if (symbolScope.kind() ==
532	Fortran::semantics::Scope::Kind::MainProgram ||
533	symbolScope.kind() == Fortran::semantics::Scope::Kind::Subprogram)
534	if (symbolScope != *internalScope &&
535	symbolScope.Contains(*internalScope)) {
536	if (namelistDetails) {
537	// So far, namelist symbols are processed on the fly in IO and
538	// the related namelist data structure is not added to the symbol
539	// map, so it cannot be passed to the internal procedures.
540	// Instead, all the symbols of the host namelist used in the
541	// internal procedure must be considered as host associated so
542	// that IO lowering can find them when needed.
543	for (const auto &namelistObject : namelistDetails->objects())
544	escapees.insert(&*namelistObject);
545	} else {
546	escapees.insert(&ultimate);
547	}
548	}
549	}
550	};
551	Fortran::lower::pft::visitAllSymbols(funit, addToListIfEscapee);
552	}
553
554	//===--------------------------------------------------------------------===//
555	// AbstractConverter overrides
556	//===--------------------------------------------------------------------===//
557
558	mlir::Value getSymbolAddress(Fortran::lower::SymbolRef sym) override final {
559	return lookupSymbol(sym).getAddr();
560	}
561
562	fir::ExtendedValue symBoxToExtendedValue(
563	const Fortran::lower::SymbolBox &symBox) override final {
564	return symBox.match(
565	[](const Fortran::lower::SymbolBox::Intrinsic &box)
566	-> fir::ExtendedValue { return box.getAddr(); },
567	[](const Fortran::lower::SymbolBox::None &) -> fir::ExtendedValue {
568	llvm::report_fatal_error("symbol not mapped");
569	},
570	[&](const fir::FortranVariableOpInterface &x) -> fir::ExtendedValue {
571	return hlfir::translateToExtendedValue(getCurrentLocation(),
572	getFirOpBuilder(), x);
573	},
574	[](const auto &box) -> fir::ExtendedValue { return box; });
575	}
576
577	fir::ExtendedValue
578	getSymbolExtendedValue(const Fortran::semantics::Symbol &sym,
579	Fortran::lower::SymMap *symMap) override final {
580	Fortran::lower::SymbolBox sb = lookupSymbol(sym, symMap);
581	if (!sb) {
582	LLVM_DEBUG(llvm::dbgs() << "unknown symbol: " << sym << "\nmap: "
583	<< (symMap ? *symMap : localSymbols) << '\n');
584	fir::emitFatalError(getCurrentLocation(),
585	"symbol is not mapped to any IR value");
586	}
587	return symBoxToExtendedValue(sb);
588	}
589
590	mlir::Value impliedDoBinding(llvm::StringRef name) override final {
591	mlir::Value val = localSymbols.lookupImpliedDo(name);
592	if (!val)
593	fir::emitFatalError(toLocation(), "ac-do-variable has no binding");
594	return val;
595	}
596
597	void copySymbolBinding(Fortran::lower::SymbolRef src,
598	Fortran::lower::SymbolRef target) override final {
599	localSymbols.copySymbolBinding(src, target);
600	}
601
602	/// Add the symbol binding to the inner-most level of the symbol map and
603	/// return true if it is not already present. Otherwise, return false.
604	bool bindIfNewSymbol(Fortran::lower::SymbolRef sym,
605	const fir::ExtendedValue &exval) {
606	if (shallowLookupSymbol(sym))
607	return false;
608	bindSymbol(sym, exval);
609	return true;
610	}
611
612	void bindSymbol(Fortran::lower::SymbolRef sym,
613	const fir::ExtendedValue &exval) override final {
614	addSymbol(sym, exval, /*forced=*/true);
615	}
616
617	void
618	overrideExprValues(const Fortran::lower::ExprToValueMap *map) override final {
619	exprValueOverrides = map;
620	}
621
622	const Fortran::lower::ExprToValueMap *getExprOverrides() override final {
623	return exprValueOverrides;
624	}
625
626	bool lookupLabelSet(Fortran::lower::SymbolRef sym,
627	Fortran::lower::pft::LabelSet &labelSet) override final {
628	Fortran::lower::pft::FunctionLikeUnit &owningProc =
629	*getEval().getOwningProcedure();
630	auto iter = owningProc.assignSymbolLabelMap.find(sym);
631	if (iter == owningProc.assignSymbolLabelMap.end())
632	return false;
633	labelSet = iter->second;
634	return true;
635	}
636
637	Fortran::lower::pft::Evaluation *
638	lookupLabel(Fortran::lower::pft::Label label) override final {
639	Fortran::lower::pft::FunctionLikeUnit &owningProc =
640	*getEval().getOwningProcedure();
641	return owningProc.labelEvaluationMap.lookup(label);
642	}
643
644	fir::ExtendedValue
645	genExprAddr(const Fortran::lower::SomeExpr &expr,
646	Fortran::lower::StatementContext &context,
647	mlir::Location *locPtr = nullptr) override final {
648	mlir::Location loc = locPtr ? *locPtr : toLocation();
649	if (lowerToHighLevelFIR())
650	return Fortran::lower::convertExprToAddress(loc, *this, expr,
651	localSymbols, context);
652	return Fortran::lower::createSomeExtendedAddress(loc, *this, expr,
653	localSymbols, context);
654	}
655
656	fir::ExtendedValue
657	genExprValue(const Fortran::lower::SomeExpr &expr,
658	Fortran::lower::StatementContext &context,
659	mlir::Location *locPtr = nullptr) override final {
660	mlir::Location loc = locPtr ? *locPtr : toLocation();
661	if (lowerToHighLevelFIR())
662	return Fortran::lower::convertExprToValue(loc, *this, expr, localSymbols,
663	context);
664	return Fortran::lower::createSomeExtendedExpression(loc, *this, expr,
665	localSymbols, context);
666	}
667
668	fir::ExtendedValue
669	genExprBox(mlir::Location loc, const Fortran::lower::SomeExpr &expr,
670	Fortran::lower::StatementContext &stmtCtx) override final {
671	if (lowerToHighLevelFIR())
672	return Fortran::lower::convertExprToBox(loc, *this, expr, localSymbols,
673	stmtCtx);
674	return Fortran::lower::createBoxValue(loc, *this, expr, localSymbols,
675	stmtCtx);
676	}
677
678	Fortran::evaluate::FoldingContext &getFoldingContext() override final {
679	return foldingContext;
680	}
681
682	mlir::Type genType(const Fortran::lower::SomeExpr &expr) override final {
683	return Fortran::lower::translateSomeExprToFIRType(*this, expr);
684	}
685	mlir::Type genType(const Fortran::lower::pft::Variable &var) override final {
686	return Fortran::lower::translateVariableToFIRType(*this, var);
687	}
688	mlir::Type genType(Fortran::lower::SymbolRef sym) override final {
689	return Fortran::lower::translateSymbolToFIRType(*this, sym);
690	}
691	mlir::Type
692	genType(Fortran::common::TypeCategory tc, int kind,
693	llvm::ArrayRef<std::int64_t> lenParameters) override final {
694	return Fortran::lower::getFIRType(&getMLIRContext(), tc, kind,
695	lenParameters);
696	}
697	mlir::Type
698	genType(const Fortran::semantics::DerivedTypeSpec &tySpec) override final {
699	return Fortran::lower::translateDerivedTypeToFIRType(*this, tySpec);
700	}
701	mlir::Type genType(Fortran::common::TypeCategory tc) override final {
702	return Fortran::lower::getFIRType(
703	&getMLIRContext(), tc, bridge.getDefaultKinds().GetDefaultKind(tc),
704	std::nullopt);
705	}
706
707	Fortran::lower::TypeConstructionStack &
708	getTypeConstructionStack() override final {
709	return typeConstructionStack;
710	}
711
712	bool
713	isPresentShallowLookup(const Fortran::semantics::Symbol &sym) override final {
714	return bool(shallowLookupSymbol(sym));
715	}
716
717	bool createHostAssociateVarClone(const Fortran::semantics::Symbol &sym,
718	bool skipDefaultInit) override final {
719	mlir::Location loc = genLocation(sym.name());
720	mlir::Type symType = genType(sym);
721	const auto *details = sym.detailsIf<Fortran::semantics::HostAssocDetails>();
722	assert(details && "No host-association found");
723	const Fortran::semantics::Symbol &hsym = details->symbol();
724	mlir::Type hSymType = genType(hsym.GetUltimate());
725	Fortran::lower::SymbolBox hsb =
726	lookupSymbol(hsym, /*symMap=*/nullptr, /*forceHlfirBase=*/true);
727
728	auto allocate = [&](llvm::ArrayRef<mlir::Value> shape,
729	llvm::ArrayRef<mlir::Value> typeParams) -> mlir::Value {
730	mlir::Value allocVal = builder->allocateLocal(
731	loc,
732	Fortran::semantics::IsAllocatableOrObjectPointer(&hsym.GetUltimate())
733	? hSymType
734	: symType,
735	mangleName(sym), toStringRef(sym.GetUltimate().name()),
736	/*pinned=*/true, shape, typeParams,
737	sym.GetUltimate().attrs().test(Fortran::semantics::Attr::TARGET));
738	return allocVal;
739	};
740
741	fir::ExtendedValue hexv = symBoxToExtendedValue(hsb);
742	fir::ExtendedValue exv = hexv.match(
743	[&](const fir::BoxValue &box) -> fir::ExtendedValue {
744	const Fortran::semantics::DeclTypeSpec *type = sym.GetType();
745	if (type && type->IsPolymorphic())
746	TODO(loc, "create polymorphic host associated copy");
747	// Create a contiguous temp with the same shape and length as
748	// the original variable described by a fir.box.
749	llvm::SmallVector<mlir::Value> extents =
750	fir::factory::getExtents(loc, *builder, hexv);
751	if (box.isDerivedWithLenParameters())
752	TODO(loc, "get length parameters from derived type BoxValue");
753	if (box.isCharacter()) {
754	mlir::Value len = fir::factory::readCharLen(*builder, loc, box);
755	mlir::Value temp = allocate(extents, {len});
756	return fir::CharArrayBoxValue{temp, len, extents};
757	}
758	return fir::ArrayBoxValue{allocate(extents, {}), extents};
759	},
760	[&](const fir::MutableBoxValue &box) -> fir::ExtendedValue {
761	// Allocate storage for a pointer/allocatble descriptor.
762	// No shape/lengths to be passed to the alloca.
763	return fir::MutableBoxValue(allocate({}, {}), {}, {});
764	},
765	[&](const auto &) -> fir::ExtendedValue {
766	mlir::Value temp =
767	allocate(fir::factory::getExtents(loc, *builder, hexv),
768	fir::factory::getTypeParams(loc, *builder, hexv));
769	return fir::substBase(hexv, temp);
770	});
771
772	// Initialise cloned allocatable
773	hexv.match(
774	[&](const fir::MutableBoxValue &box) -> void {
775	const auto new_box = exv.getBoxOf<fir::MutableBoxValue>();
776	if (Fortran::semantics::IsPointer(sym.GetUltimate())) {
777	// Establish the pointer descriptors. The rank and type code/size
778	// at least must be set properly for later inquiry of the pointer
779	// to work, and new pointers are always given disassociated status
780	// by flang for safety, even if this is not required by the
781	// language.
782	auto empty = fir::factory::createUnallocatedBox(
783	*builder, loc, new_box->getBoxTy(), box.nonDeferredLenParams(),
784	{});
785	builder->create<fir::StoreOp>(loc, empty, new_box->getAddr());
786	return;
787	}
788	// Copy allocation status of Allocatables, creating new storage if
789	// needed.
790
791	// allocate if allocated
792	mlir::Value isAllocated =
793	fir::factory::genIsAllocatedOrAssociatedTest(*builder, loc, box);
794	auto if_builder = builder->genIfThenElse(loc, isAllocated);
795	if_builder.genThen([&]() {
796	std::string name = mangleName(name&: sym) + ".alloc";
797	fir::ExtendedValue read = fir::factory::genMutableBoxRead(
798	*builder, loc, box, /*mayBePolymorphic=*/false);
799	if (auto read_arr_box = read.getBoxOf<fir::ArrayBoxValue>()) {
800	fir::factory::genInlinedAllocation(
801	*builder, loc, *new_box, read_arr_box->getLBounds(),
802	read_arr_box->getExtents(),
803	/*lenParams=*/std::nullopt, name,
804	/*mustBeHeap=*/true);
805	} else if (auto read_char_arr_box =
806	read.getBoxOf<fir::CharArrayBoxValue>()) {
807	fir::factory::genInlinedAllocation(
808	*builder, loc, *new_box, read_char_arr_box->getLBounds(),
809	read_char_arr_box->getExtents(), read_char_arr_box->getLen(),
810	name,
811	/*mustBeHeap=*/true);
812	} else if (auto read_char_box =
813	read.getBoxOf<fir::CharBoxValue>()) {
814	fir::factory::genInlinedAllocation(*builder, loc, *new_box,
815	/*lbounds=*/std::nullopt,
816	/*extents=*/std::nullopt,
817	read_char_box->getLen(), name,
818	/*mustBeHeap=*/true);
819	} else {
820	fir::factory::genInlinedAllocation(
821	*builder, loc, *new_box, box.getMutableProperties().lbounds,
822	box.getMutableProperties().extents,
823	box.nonDeferredLenParams(), name,
824	/*mustBeHeap=*/true);
825	}
826	});
827	if_builder.genElse([&]() {
828	// nullify box
829	auto empty = fir::factory::createUnallocatedBox(
830	*builder, loc, new_box->getBoxTy(),
831	new_box->nonDeferredLenParams(), {});
832	builder->create<fir::StoreOp>(loc, empty, new_box->getAddr());
833	});
834	if_builder.end();
835	},
836	[&](const auto &) -> void {
837	// Always initialize allocatable component descriptor, even when the
838	// value is later copied from the host (e.g. firstprivate) because the
839	// assignment from the host to the copy will fail if the component
840	// descriptors are not initialized.
841	if (skipDefaultInit && !hlfir::mayHaveAllocatableComponent(hSymType))
842	return;
843	// Initialize local/private derived types with default
844	// initialization (Fortran 2023 section 11.1.7.5 and OpenMP 5.2
845	// section 5.3). Pointer and allocatable components, when allowed,
846	// also need to be established so that flang runtime can later work
847	// with them.
848	if (const Fortran::semantics::DeclTypeSpec *declTypeSpec =
849	sym.GetType())
850	if (const Fortran::semantics::DerivedTypeSpec *derivedTypeSpec =
851	declTypeSpec->AsDerived())
852	if (derivedTypeSpec->HasDefaultInitialization(
853	/*ignoreAllocatable=*/false, /*ignorePointer=*/false)) {
854	mlir::Value box = builder->createBox(loc, exv);
855	fir::runtime::genDerivedTypeInitialize(*builder, loc, box);
856	}
857	});
858
859	return bindIfNewSymbol(sym, exv);
860	}
861
862	void createHostAssociateVarCloneDealloc(
863	const Fortran::semantics::Symbol &sym) override final {
864	mlir::Location loc = genLocation(sym.name());
865	Fortran::lower::SymbolBox hsb =
866	lookupSymbol(sym, /*symMap=*/nullptr, /*forceHlfirBase=*/true);
867
868	fir::ExtendedValue hexv = symBoxToExtendedValue(hsb);
869	hexv.match(
870	[&](const fir::MutableBoxValue &new_box) -> void {
871	// Do not process pointers
872	if (Fortran::semantics::IsPointer(sym.GetUltimate())) {
873	return;
874	}
875	// deallocate allocated in createHostAssociateVarClone value
876	Fortran::lower::genDeallocateIfAllocated(*this, new_box, loc);
877	},
878	[&](const auto &) -> void {
879	// Do nothing
880	});
881	}
882
883	void copyVar(mlir::Location loc, mlir::Value dst, mlir::Value src,
884	fir::FortranVariableFlagsEnum attrs) override final {
885	bool isAllocatable =
886	bitEnumContainsAny(attrs, fir::FortranVariableFlagsEnum::allocatable);
887	bool isPointer =
888	bitEnumContainsAny(attrs, fir::FortranVariableFlagsEnum::pointer);
889
890	copyVarHLFIR(loc, Fortran::lower::SymbolBox::Intrinsic{dst},
891	Fortran::lower::SymbolBox::Intrinsic{src}, isAllocatable,
892	isPointer, Fortran::semantics::Symbol::Flags());
893	}
894
895	void
896	copyHostAssociateVar(const Fortran::semantics::Symbol &sym,
897	mlir::OpBuilder::InsertPoint *copyAssignIP = nullptr,
898	bool hostIsSource = true) override final {
899	// 1) Fetch the original copy of the variable.
900	assert(sym.has<Fortran::semantics::HostAssocDetails>() &&
901	"No host-association found");
902	const Fortran::semantics::Symbol &hsym = sym.GetUltimate();
903	Fortran::lower::SymbolBox hsb = lookupOneLevelUpSymbol(hsym);
904	assert(hsb && "Host symbol box not found");
905
906	// 2) Fetch the copied one that will mask the original.
907	Fortran::lower::SymbolBox sb = shallowLookupSymbol(sym);
908	assert(sb && "Host-associated symbol box not found");
909	assert(hsb.getAddr() != sb.getAddr() &&
910	"Host and associated symbol boxes are the same");
911
912	// 3) Perform the assignment.
913	mlir::OpBuilder::InsertionGuard guard(*builder);
914	if (copyAssignIP && copyAssignIP->isSet())
915	builder->restoreInsertionPoint(*copyAssignIP);
916	else
917	builder->setInsertionPointAfter(sb.getAddr().getDefiningOp());
918
919	Fortran::lower::SymbolBox *lhs_sb, *rhs_sb;
920	if (!hostIsSource) {
921	lhs_sb = &hsb;
922	rhs_sb = &sb;
923	} else {
924	lhs_sb = &sb;
925	rhs_sb = &hsb;
926	}
927
928	copyVar(sym, *lhs_sb, *rhs_sb, sym.flags());
929	}
930
931	void genEval(Fortran::lower::pft::Evaluation &eval,
932	bool unstructuredContext) override final {
933	genFIR(eval, unstructuredContext);
934	}
935
936	//===--------------------------------------------------------------------===//
937	// Utility methods
938	//===--------------------------------------------------------------------===//
939
940	void collectSymbolSet(
941	Fortran::lower::pft::Evaluation &eval,
942	llvm::SetVector<const Fortran::semantics::Symbol *> &symbolSet,
943	Fortran::semantics::Symbol::Flag flag, bool collectSymbols,
944	bool checkHostAssociatedSymbols) override final {
945	auto addToList = [&](const Fortran::semantics::Symbol &sym) {
946	std::function<void(const Fortran::semantics::Symbol &, bool)>
947	insertSymbols = [&](const Fortran::semantics::Symbol &oriSymbol,
948	bool collectSymbol) {
949	if (collectSymbol && oriSymbol.test(flag)) {
950	symbolSet.insert(&oriSymbol);
951	} else if (const auto *commonDetails =
952	oriSymbol.detailsIf<
953	Fortran::semantics::CommonBlockDetails>()) {
954	for (const auto &mem : commonDetails->objects())
955	if (collectSymbol && mem->test(flag))
956	symbolSet.insert(&(*mem).GetUltimate());
957	} else if (checkHostAssociatedSymbols) {
958	if (const auto *details{
959	oriSymbol
960	.detailsIf<Fortran::semantics::HostAssocDetails>()})
961	insertSymbols(details->symbol(), true);
962	}
963	};
964	insertSymbols(sym, collectSymbols);
965	};
966	Fortran::lower::pft::visitAllSymbols(eval, addToList);
967	}
968
969	mlir::Location getCurrentLocation() override final { return toLocation(); }
970
971	/// Generate a dummy location.
972	mlir::Location genUnknownLocation() override final {
973	// Note: builder may not be instantiated yet
974	return mlir::UnknownLoc::get(&getMLIRContext());
975	}
976
977	static mlir::Location genLocation(Fortran::parser::SourcePosition pos,
978	mlir::MLIRContext &ctx) {
979	llvm::SmallString<256> path(*pos.path);
980	llvm::sys::fs::make_absolute(path);
981	llvm::sys::path::remove_dots(path);
982	return mlir::FileLineColLoc::get(&ctx, path.str(), pos.line, pos.column);
983	}
984
985	/// Generate a `Location` from the `CharBlock`.
986	mlir::Location
987	genLocation(const Fortran::parser::CharBlock &block) override final {
988	mlir::Location mainLocation = genUnknownLocation();
989	if (const Fortran::parser::AllCookedSources *cooked =
990	bridge.getCookedSource()) {
991	if (std::optional<Fortran::parser::ProvenanceRange> provenance =
992	cooked->GetProvenanceRange(block)) {
993	if (std::optional<Fortran::parser::SourcePosition> filePos =
994	cooked->allSources().GetSourcePosition(provenance->start()))
995	mainLocation = genLocation(*filePos, getMLIRContext());
996
997	llvm::SmallVector<mlir::Location> locs;
998	locs.push_back(mainLocation);
999
1000	llvm::SmallVector<fir::LocationKindAttr> locAttrs;
1001	locAttrs.push_back(fir::LocationKindAttr::get(&getMLIRContext(),
1002	fir::LocationKind::Base));
1003
1004	// Gather include location information if any.
1005	Fortran::parser::ProvenanceRange *prov = &*provenance;
1006	while (prov) {
1007	if (std::optional<Fortran::parser::ProvenanceRange> include =
1008	cooked->allSources().GetInclusionInfo(*prov)) {
1009	if (std::optional<Fortran::parser::SourcePosition> incPos =
1010	cooked->allSources().GetSourcePosition(include->start())) {
1011	locs.push_back(genLocation(*incPos, getMLIRContext()));
1012	locAttrs.push_back(fir::LocationKindAttr::get(
1013	&getMLIRContext(), fir::LocationKind::Inclusion));
1014	}
1015	prov = &*include;
1016	} else {
1017	prov = nullptr;
1018	}
1019	}
1020	if (locs.size() > 1) {
1021	assert(locs.size() == locAttrs.size() &&
1022	"expect as many attributes as locations");
1023	return mlir::FusedLocWith<fir::LocationKindArrayAttr>::get(
1024	&getMLIRContext(), locs,
1025	fir::LocationKindArrayAttr::get(&getMLIRContext(), locAttrs));
1026	}
1027	}
1028	}
1029	return mainLocation;
1030	}
1031
1032	const Fortran::semantics::Scope &getCurrentScope() override final {
1033	return bridge.getSemanticsContext().FindScope(currentPosition);
1034	}
1035
1036	fir::FirOpBuilder &getFirOpBuilder() override final {
1037	CHECK(builder && "builder is not set before calling getFirOpBuilder");
1038	return *builder;
1039	}
1040
1041	mlir::ModuleOp getModuleOp() override final { return bridge.getModule(); }
1042
1043	mlir::MLIRContext &getMLIRContext() override final {
1044	return bridge.getMLIRContext();
1045	}
1046	std::string
1047	mangleName(const Fortran::semantics::Symbol &symbol) override final {
1048	return Fortran::lower::mangle::mangleName(
1049	symbol, scopeBlockIdMap, /*keepExternalInScope=*/false,
1050	getLoweringOptions().getUnderscoring());
1051	}
1052	std::string mangleName(
1053	const Fortran::semantics::DerivedTypeSpec &derivedType) override final {
1054	return Fortran::lower::mangle::mangleName(derivedType, scopeBlockIdMap);
1055	}
1056	std::string mangleName(std::string &name) override final {
1057	return Fortran::lower::mangle::mangleName(name, getCurrentScope(),
1058	scopeBlockIdMap);
1059	}
1060	std::string
1061	mangleName(std::string &name,
1062	const Fortran::semantics::Scope &myScope) override final {
1063	return Fortran::lower::mangle::mangleName(name, myScope, scopeBlockIdMap);
1064	}
1065	std::string getRecordTypeFieldName(
1066	const Fortran::semantics::Symbol &component) override final {
1067	return Fortran::lower::mangle::getRecordTypeFieldName(component,
1068	scopeBlockIdMap);
1069	}
1070	const fir::KindMapping &getKindMap() override final {
1071	return bridge.getKindMap();
1072	}
1073
1074	/// Return the current function context, which may be a nested BLOCK context
1075	/// or a full subprogram context.
1076	Fortran::lower::StatementContext &getFctCtx() override final {
1077	if (!activeConstructStack.empty() &&
1078	activeConstructStack.back().eval.isA<Fortran::parser::BlockConstruct>())
1079	return activeConstructStack.back().stmtCtx;
1080	return bridge.fctCtx();
1081	}
1082
1083	mlir::Value hostAssocTupleValue() override final { return hostAssocTuple; }
1084
1085	/// Record a binding for the ssa-value of the tuple for this function.
1086	void bindHostAssocTuple(mlir::Value val) override final {
1087	assert(!hostAssocTuple && val);
1088	hostAssocTuple = val;
1089	}
1090
1091	mlir::Value dummyArgsScopeValue() const override final {
1092	return dummyArgsScope;
1093	}
1094
1095	bool isRegisteredDummySymbol(
1096	Fortran::semantics::SymbolRef symRef) const override final {
1097	auto *sym = &*symRef;
1098	return registeredDummySymbols.contains(sym);
1099	}
1100
1101	const Fortran::lower::pft::FunctionLikeUnit *
1102	getCurrentFunctionUnit() const override final {
1103	return currentFunctionUnit;
1104	}
1105
1106	void registerTypeInfo(mlir::Location loc,
1107	Fortran::lower::SymbolRef typeInfoSym,
1108	const Fortran::semantics::DerivedTypeSpec &typeSpec,
1109	fir::RecordType type) override final {
1110	typeInfoConverter.registerTypeInfo(*this, loc, typeInfoSym, typeSpec, type);
1111	}
1112
1113	llvm::StringRef
1114	getUniqueLitName(mlir::Location loc,
1115	std::unique_ptr<Fortran::lower::SomeExpr> expr,
1116	mlir::Type eleTy) override final {
1117	std::string namePrefix =
1118	getConstantExprManglePrefix(loc, *expr.get(), eleTy);
1119	auto [it, inserted] = literalNamesMap.try_emplace(
1120	expr.get(), namePrefix + std::to_string(uniqueLitId));
1121	const auto &name = it->second;
1122	if (inserted) {
1123	// Keep ownership of the expr key.
1124	literalExprsStorage.push_back(std::move(expr));
1125
1126	// If we've just added a new name, we have to make sure
1127	// there is no global object with the same name in the module.
1128	fir::GlobalOp global = builder->getNamedGlobal(name);
1129	if (global)
1130	fir::emitFatalError(loc, llvm::Twine("global object with name '") +
1131	llvm::Twine(name) +
1132	llvm::Twine("' already exists"));
1133	++uniqueLitId;
1134	return name;
1135	}
1136
1137	// The name already exists. Verify that the prefix is the same.
1138	if (!llvm::StringRef(name).starts_with(namePrefix))
1139	fir::emitFatalError(loc, llvm::Twine("conflicting prefixes: '") +
1140	llvm::Twine(name) +
1141	llvm::Twine("' does not start with '") +
1142	llvm::Twine(namePrefix) + llvm::Twine("'"));
1143
1144	return name;
1145	}
1146
1147	/// Find the symbol in the inner-most level of the local map or return null.
1148	Fortran::lower::SymbolBox
1149	shallowLookupSymbol(const Fortran::semantics::Symbol &sym) override {
1150	if (Fortran::lower::SymbolBox v = localSymbols.shallowLookupSymbol(sym))
1151	return v;
1152	return {};
1153	}
1154
1155	private:
1156	FirConverter() = delete;
1157	FirConverter(const FirConverter &) = delete;
1158	FirConverter &operator=(const FirConverter &) = delete;
1159
1160	//===--------------------------------------------------------------------===//
1161	// Helper member functions
1162	//===--------------------------------------------------------------------===//
1163
1164	mlir::Value createFIRExpr(mlir::Location loc,
1165	const Fortran::lower::SomeExpr *expr,
1166	Fortran::lower::StatementContext &stmtCtx) {
1167	return fir::getBase(genExprValue(*expr, stmtCtx, &loc));
1168	}
1169
1170	/// Find the symbol in the local map or return null.
1171	Fortran::lower::SymbolBox
1172	lookupSymbol(const Fortran::semantics::Symbol &sym,
1173	Fortran::lower::SymMap *symMap = nullptr,
1174	bool forceHlfirBase = false) {
1175	symMap = symMap ? symMap : &localSymbols;
1176	if (lowerToHighLevelFIR()) {
1177	if (std::optional<fir::FortranVariableOpInterface> var =
1178	symMap->lookupVariableDefinition(sym)) {
1179	auto exv = hlfir::translateToExtendedValue(toLocation(), *builder, *var,
1180	forceHlfirBase);
1181	return exv.match(
1182	[](mlir::Value x) -> Fortran::lower::SymbolBox {
1183	return Fortran::lower::SymbolBox::Intrinsic{x};
1184	},
1185	[](auto x) -> Fortran::lower::SymbolBox { return x; });
1186	}
1187
1188	// Entry character result represented as an argument pair
1189	// needs to be represented in the symbol table even before
1190	// we can create DeclareOp for it. The temporary mapping
1191	// is EmboxCharOp that conveys the address and length information.
1192	// After mapSymbolAttributes is done, the mapping is replaced
1193	// with the new DeclareOp, and the following table lookups
1194	// do not reach here.
1195	if (sym.IsFuncResult())
1196	if (const Fortran::semantics::DeclTypeSpec *declTy = sym.GetType())
1197	if (declTy->category() ==
1198	Fortran::semantics::DeclTypeSpec::Category::Character)
1199	return symMap->lookupSymbol(sym);
1200
1201	// Procedure dummies are not mapped with an hlfir.declare because
1202	// they are not "variable" (cannot be assigned to), and it would
1203	// make hlfir.declare more complex than it needs to to allow this.
1204	// Do a regular lookup.
1205	if (Fortran::semantics::IsProcedure(sym))
1206	return symMap->lookupSymbol(sym);
1207
1208	// Commonblock names are not variables, but in some lowerings (like
1209	// OpenMP) it is useful to maintain the address of the commonblock in an
1210	// MLIR value and query it. hlfir.declare need not be created for these.
1211	if (sym.detailsIf<Fortran::semantics::CommonBlockDetails>())
1212	return symMap->lookupSymbol(sym);
1213
1214	// For symbols to be privatized in OMP, the symbol is mapped to an
1215	// instance of `SymbolBox::Intrinsic` (i.e. a direct mapping to an MLIR
1216	// SSA value). This MLIR SSA value is the block argument to the
1217	// `omp.private`'s `alloc` block. If this is the case, we return this
1218	// `SymbolBox::Intrinsic` value.
1219	if (Fortran::lower::SymbolBox v = symMap->lookupSymbol(sym))
1220	return v;
1221
1222	return {};
1223	}
1224	if (Fortran::lower::SymbolBox v = symMap->lookupSymbol(sym))
1225	return v;
1226	return {};
1227	}
1228
1229	/// Find the symbol in one level up of symbol map such as for host-association
1230	/// in OpenMP code or return null.
1231	Fortran::lower::SymbolBox
1232	lookupOneLevelUpSymbol(const Fortran::semantics::Symbol &sym) override {
1233	if (Fortran::lower::SymbolBox v = localSymbols.lookupOneLevelUpSymbol(sym))
1234	return v;
1235	return {};
1236	}
1237
1238	mlir::SymbolTable *getMLIRSymbolTable() override { return &mlirSymbolTable; }
1239
1240	/// Add the symbol to the local map and return `true`. If the symbol is
1241	/// already in the map and \p forced is `false`, the map is not updated.
1242	/// Instead the value `false` is returned.
1243	bool addSymbol(const Fortran::semantics::SymbolRef sym,
1244	fir::ExtendedValue val, bool forced = false) {
1245	if (!forced && lookupSymbol(sym))
1246	return false;
1247	if (lowerToHighLevelFIR()) {
1248	Fortran::lower::genDeclareSymbol(*this, localSymbols, sym, val,
1249	fir::FortranVariableFlagsEnum::None,
1250	forced);
1251	} else {
1252	localSymbols.addSymbol(sym, val, forced);
1253	}
1254	return true;
1255	}
1256
1257	void copyVar(const Fortran::semantics::Symbol &sym,
1258	const Fortran::lower::SymbolBox &lhs_sb,
1259	const Fortran::lower::SymbolBox &rhs_sb,
1260	Fortran::semantics::Symbol::Flags flags) {
1261	mlir::Location loc = genLocation(sym.name());
1262	if (lowerToHighLevelFIR())
1263	copyVarHLFIR(loc, lhs_sb, rhs_sb, flags);
1264	else
1265	copyVarFIR(loc, sym, lhs_sb, rhs_sb);
1266	}
1267
1268	void copyVarHLFIR(mlir::Location loc, Fortran::lower::SymbolBox dst,
1269	Fortran::lower::SymbolBox src,
1270	Fortran::semantics::Symbol::Flags flags) {
1271	assert(lowerToHighLevelFIR());
1272
1273	bool isBoxAllocatable = dst.match(
1274	[](const fir::MutableBoxValue &box) { return box.isAllocatable(); },
1275	[](const fir::FortranVariableOpInterface &box) {
1276	return fir::FortranVariableOpInterface(box).isAllocatable();
1277	},
1278	[](const auto &box) { return false; });
1279
1280	bool isBoxPointer = dst.match(
1281	[](const fir::MutableBoxValue &box) { return box.isPointer(); },
1282	[](const fir::FortranVariableOpInterface &box) {
1283	return fir::FortranVariableOpInterface(box).isPointer();
1284	},
1285	[](const fir::AbstractBox &box) {
1286	return fir::isBoxProcAddressType(box.getAddr().getType());
1287	},
1288	[](const auto &box) { return false; });
1289
1290	copyVarHLFIR(loc, dst, src, isBoxAllocatable, isBoxPointer, flags);
1291	}
1292
1293	void copyVarHLFIR(mlir::Location loc, Fortran::lower::SymbolBox dst,
1294	Fortran::lower::SymbolBox src, bool isAllocatable,
1295	bool isPointer, Fortran::semantics::Symbol::Flags flags) {
1296	assert(lowerToHighLevelFIR());
1297	hlfir::Entity lhs{dst.getAddr()};
1298	hlfir::Entity rhs{src.getAddr()};
1299
1300	auto copyData = [&](hlfir::Entity l, hlfir::Entity r) {
1301	// Dereference RHS and load it if trivial scalar.
1302	r = hlfir::loadTrivialScalar(loc, *builder, r);
1303	builder->create<hlfir::AssignOp>(loc, r, l, isAllocatable);
1304	};
1305
1306	if (isPointer) {
1307	// Set LHS target to the target of RHS (do not copy the RHS
1308	// target data into the LHS target storage).
1309	auto loadVal = builder->create<fir::LoadOp>(loc, rhs);
1310	builder->create<fir::StoreOp>(loc, loadVal, lhs);
1311	} else if (isAllocatable &&
1312	flags.test(Fortran::semantics::Symbol::Flag::OmpCopyIn)) {
1313	// For copyin allocatable variables, RHS must be copied to lhs
1314	// only when rhs is allocated.
1315	hlfir::Entity temp =
1316	hlfir::derefPointersAndAllocatables(loc, *builder, rhs);
1317	mlir::Value addr = hlfir::genVariableRawAddress(loc, *builder, temp);
1318	mlir::Value isAllocated = builder->genIsNotNullAddr(loc, addr);
1319	builder->genIfThenElse(loc, isAllocated)
1320	.genThen([&]() { copyData(lhs, rhs); })
1321	.genElse([&]() {
1322	fir::ExtendedValue hexv = symBoxToExtendedValue(dst);
1323	hexv.match(
1324	[&](const fir::MutableBoxValue &new_box) -> void {
1325	// if the allocation status of original list item is
1326	// unallocated, unallocate the copy if it is allocated, else
1327	// do nothing.
1328	Fortran::lower::genDeallocateIfAllocated(*this, new_box, loc);
1329	},
1330	[&](const auto &) -> void {});
1331	})
1332	.end();
1333	} else if (isAllocatable &&
1334	flags.test(Fortran::semantics::Symbol::Flag::OmpFirstPrivate)) {
1335	// For firstprivate allocatable variables, RHS must be copied
1336	// only when LHS is allocated.
1337	hlfir::Entity temp =
1338	hlfir::derefPointersAndAllocatables(loc, *builder, lhs);
1339	mlir::Value addr = hlfir::genVariableRawAddress(loc, *builder, temp);
1340	mlir::Value isAllocated = builder->genIsNotNullAddr(loc, addr);
1341	builder->genIfThen(loc, isAllocated)
1342	.genThen([&]() { copyData(lhs, rhs); })
1343	.end();
1344	} else {
1345	copyData(lhs, rhs);
1346	}
1347	}
1348
1349	void copyVarFIR(mlir::Location loc, const Fortran::semantics::Symbol &sym,
1350	const Fortran::lower::SymbolBox &lhs_sb,
1351	const Fortran::lower::SymbolBox &rhs_sb) {
1352	assert(!lowerToHighLevelFIR());
1353	fir::ExtendedValue lhs = symBoxToExtendedValue(lhs_sb);
1354	fir::ExtendedValue rhs = symBoxToExtendedValue(rhs_sb);
1355	mlir::Type symType = genType(sym);
1356	if (auto seqTy = mlir::dyn_cast<fir::SequenceType>(symType)) {
1357	Fortran::lower::StatementContext stmtCtx;
1358	Fortran::lower::createSomeArrayAssignment(*this, lhs, rhs, localSymbols,
1359	stmtCtx);
1360	stmtCtx.finalizeAndReset();
1361	} else if (lhs.getBoxOf<fir::CharBoxValue>()) {
1362	fir::factory::CharacterExprHelper{*builder, loc}.createAssign(lhs, rhs);
1363	} else {
1364	auto loadVal = builder->create<fir::LoadOp>(loc, fir::getBase(rhs));
1365	builder->create<fir::StoreOp>(loc, loadVal, fir::getBase(lhs));
1366	}
1367	}
1368
1369	/// Map a block argument to a result or dummy symbol. This is not the
1370	/// definitive mapping. The specification expression have not been lowered
1371	/// yet. The final mapping will be done using this pre-mapping in
1372	/// Fortran::lower::mapSymbolAttributes.
1373	bool mapBlockArgToDummyOrResult(const Fortran::semantics::SymbolRef sym,
1374	mlir::Value val, bool isResult) {
1375	localSymbols.addSymbol(sym, val);
1376	if (!isResult)
1377	registerDummySymbol(sym);
1378
1379	return true;
1380	}
1381
1382	/// Generate the address of loop variable \p sym.
1383	/// If \p sym is not mapped yet, allocate local storage for it.
1384	mlir::Value genLoopVariableAddress(mlir::Location loc,
1385	const Fortran::semantics::Symbol &sym,
1386	bool isUnordered) {
1387	if (isUnordered || sym.has<Fortran::semantics::HostAssocDetails>() ||
1388	sym.has<Fortran::semantics::UseDetails>()) {
1389	if (!shallowLookupSymbol(sym) &&
1390	!GetSymbolDSA(sym).test(
1391	Fortran::semantics::Symbol::Flag::OmpShared)) {
1392	// Do concurrent loop variables are not mapped yet since they are local
1393	// to the Do concurrent scope (same for OpenMP loops).
1394	mlir::OpBuilder::InsertPoint insPt = builder->saveInsertionPoint();
1395	builder->setInsertionPointToStart(builder->getAllocaBlock());
1396	mlir::Type tempTy = genType(sym);
1397	mlir::Value temp =
1398	builder->createTemporaryAlloc(loc, tempTy, toStringRef(sym.name()));
1399	bindIfNewSymbol(sym, temp);
1400	builder->restoreInsertionPoint(insPt);
1401	}
1402	}
1403	auto entry = lookupSymbol(sym);
1404	(void)entry;
1405	assert(entry && "loop control variable must already be in map");
1406	Fortran::lower::StatementContext stmtCtx;
1407	return fir::getBase(
1408	genExprAddr(Fortran::evaluate::AsGenericExpr(sym).value(), stmtCtx));
1409	}
1410
1411	static bool isNumericScalarCategory(Fortran::common::TypeCategory cat) {
1412	return cat == Fortran::common::TypeCategory::Integer ||
1413	cat == Fortran::common::TypeCategory::Real ||
1414	cat == Fortran::common::TypeCategory::Complex ||
1415	cat == Fortran::common::TypeCategory::Logical;
1416	}
1417	static bool isLogicalCategory(Fortran::common::TypeCategory cat) {
1418	return cat == Fortran::common::TypeCategory::Logical;
1419	}
1420	static bool isCharacterCategory(Fortran::common::TypeCategory cat) {
1421	return cat == Fortran::common::TypeCategory::Character;
1422	}
1423	static bool isDerivedCategory(Fortran::common::TypeCategory cat) {
1424	return cat == Fortran::common::TypeCategory::Derived;
1425	}
1426
1427	/// Insert a new block before \p block. Leave the insertion point unchanged.
1428	mlir::Block *insertBlock(mlir::Block *block) {
1429	mlir::OpBuilder::InsertPoint insertPt = builder->saveInsertionPoint();
1430	mlir::Block *newBlock = builder->createBlock(block);
1431	builder->restoreInsertionPoint(insertPt);
1432	return newBlock;
1433	}
1434
1435	Fortran::lower::pft::Evaluation &evalOfLabel(Fortran::parser::Label label) {
1436	const Fortran::lower::pft::LabelEvalMap &labelEvaluationMap =
1437	getEval().getOwningProcedure()->labelEvaluationMap;
1438	const auto iter = labelEvaluationMap.find(label);
1439	assert(iter != labelEvaluationMap.end() && "label missing from map");
1440	return *iter->second;
1441	}
1442
1443	void genBranch(mlir::Block *targetBlock) {
1444	assert(targetBlock && "missing unconditional target block");
1445	builder->create<mlir::cf::BranchOp>(toLocation(), targetBlock);
1446	}
1447
1448	void genConditionalBranch(mlir::Value cond, mlir::Block *trueTarget,
1449	mlir::Block *falseTarget) {
1450	assert(trueTarget && "missing conditional branch true block");
1451	assert(falseTarget && "missing conditional branch false block");
1452	mlir::Location loc = toLocation();
1453	mlir::Value bcc = builder->createConvert(loc, builder->getI1Type(), cond);
1454	builder->create<mlir::cf::CondBranchOp>(loc, bcc, trueTarget, std::nullopt,
1455	falseTarget, std::nullopt);
1456	}
1457	void genConditionalBranch(mlir::Value cond,
1458	Fortran::lower::pft::Evaluation *trueTarget,
1459	Fortran::lower::pft::Evaluation *falseTarget) {
1460	genConditionalBranch(cond, trueTarget->block, falseTarget->block);
1461	}
1462	void genConditionalBranch(const Fortran::parser::ScalarLogicalExpr &expr,
1463	mlir::Block *trueTarget, mlir::Block *falseTarget) {
1464	Fortran::lower::StatementContext stmtCtx;
1465	mlir::Value cond =
1466	createFIRExpr(toLocation(), Fortran::semantics::GetExpr(expr), stmtCtx);
1467	stmtCtx.finalizeAndReset();
1468	genConditionalBranch(cond, trueTarget, falseTarget);
1469	}
1470	void genConditionalBranch(const Fortran::parser::ScalarLogicalExpr &expr,
1471	Fortran::lower::pft::Evaluation *trueTarget,
1472	Fortran::lower::pft::Evaluation *falseTarget) {
1473	Fortran::lower::StatementContext stmtCtx;
1474	mlir::Value cond =
1475	createFIRExpr(toLocation(), Fortran::semantics::GetExpr(expr), stmtCtx);
1476	stmtCtx.finalizeAndReset();
1477	genConditionalBranch(cond, trueTarget->block, falseTarget->block);
1478	}
1479
1480	/// Return the nearest active ancestor construct of \p eval, or nullptr.
1481	Fortran::lower::pft::Evaluation *
1482	getActiveAncestor(const Fortran::lower::pft::Evaluation &eval) {
1483	Fortran::lower::pft::Evaluation *ancestor = eval.parentConstruct;
1484	for (; ancestor; ancestor = ancestor->parentConstruct)
1485	if (ancestor->activeConstruct)
1486	break;
1487	return ancestor;
1488	}
1489
1490	/// Return the predicate: "a branch to \p targetEval has exit code".
1491	bool hasExitCode(const Fortran::lower::pft::Evaluation &targetEval) {
1492	Fortran::lower::pft::Evaluation *activeAncestor =
1493	getActiveAncestor(targetEval);
1494	for (auto it = activeConstructStack.rbegin(),
1495	rend = activeConstructStack.rend();
1496	it != rend; ++it) {
1497	if (&it->eval == activeAncestor)
1498	break;
1499	if (it->stmtCtx.hasCode())
1500	return true;
1501	}
1502	return false;
1503	}
1504
1505	/// Generate a branch to \p targetEval after generating on-exit code for
1506	/// any enclosing construct scopes that are exited by taking the branch.
1507	void
1508	genConstructExitBranch(const Fortran::lower::pft::Evaluation &targetEval) {
1509	Fortran::lower::pft::Evaluation *activeAncestor =
1510	getActiveAncestor(targetEval);
1511	for (auto it = activeConstructStack.rbegin(),
1512	rend = activeConstructStack.rend();
1513	it != rend; ++it) {
1514	if (&it->eval == activeAncestor)
1515	break;
1516	it->stmtCtx.finalizeAndKeep();
1517	}
1518	genBranch(targetEval.block);
1519	}
1520
1521	/// A construct contains nested evaluations. Some of these evaluations
1522	/// may start a new basic block, others will add code to an existing
1523	/// block.
1524	/// Collect the list of nested evaluations that are last in their block,
1525	/// organize them into two sets:
1526	/// 1. Exiting evaluations: they may need a branch exiting from their
1527	/// parent construct,
1528	/// 2. Fall-through evaluations: they will continue to the following
1529	/// evaluation. They may still need a branch, but they do not exit
1530	/// the construct. They appear in cases where the following evaluation
1531	/// is a target of some branch.
1532	void collectFinalEvaluations(
1533	Fortran::lower::pft::Evaluation &construct,
1534	llvm::SmallVector<Fortran::lower::pft::Evaluation *> &exits,
1535	llvm::SmallVector<Fortran::lower::pft::Evaluation *> &fallThroughs) {
1536	Fortran::lower::pft::EvaluationList &nested =
1537	construct.getNestedEvaluations();
1538	if (nested.empty())
1539	return;
1540
1541	Fortran::lower::pft::Evaluation *exit = construct.constructExit;
1542	Fortran::lower::pft::Evaluation *previous = &nested.front();
1543
1544	for (auto it = ++nested.begin(), end = nested.end(); it != end;
1545	previous = &*it++) {
1546	if (it->block == nullptr)
1547	continue;
1548	// "*it" starts a new block, check what to do with "previous"
1549	if (it->isIntermediateConstructStmt() && previous != exit)
1550	exits.push_back(previous);
1551	else if (previous->lexicalSuccessor && previous->lexicalSuccessor->block)
1552	fallThroughs.push_back(previous);
1553	}
1554	if (previous != exit)
1555	exits.push_back(previous);
1556	}
1557
1558	/// Generate a SelectOp or branch sequence that compares \p selector against
1559	/// values in \p valueList and targets corresponding labels in \p labelList.
1560	/// If no value matches the selector, branch to \p defaultEval.
1561	///
1562	/// Three cases require special processing.
1563	///
1564	/// An empty \p valueList indicates an ArithmeticIfStmt context that requires
1565	/// two comparisons against 0 or 0.0. The selector may have either INTEGER
1566	/// or REAL type.
1567	///
1568	/// A nonpositive \p valuelist value indicates an IO statement context
1569	/// (0 for ERR, -1 for END, -2 for EOR). An ERR branch must be taken for
1570	/// any positive (IOSTAT) value. A missing (zero) label requires a branch
1571	/// to \p defaultEval for that value.
1572	///
1573	/// A non-null \p errorBlock indicates an AssignedGotoStmt context that
1574	/// must always branch to an explicit target. There is no valid defaultEval
1575	/// in this case. Generate a branch to \p errorBlock for an AssignedGotoStmt
1576	/// that violates this program requirement.
1577	///
1578	/// If this is not an ArithmeticIfStmt and no targets have exit code,
1579	/// generate a SelectOp. Otherwise, for each target, if it has exit code,
1580	/// branch to a new block, insert exit code, and then branch to the target.
1581	/// Otherwise, branch directly to the target.
1582	void genMultiwayBranch(mlir::Value selector,
1583	llvm::SmallVector<int64_t> valueList,
1584	llvm::SmallVector<Fortran::parser::Label> labelList,
1585	const Fortran::lower::pft::Evaluation &defaultEval,
1586	mlir::Block *errorBlock = nullptr) {
1587	bool inArithmeticIfContext = valueList.empty();
1588	assert(((inArithmeticIfContext && labelList.size() == 2) ||
1589	(valueList.size() && labelList.size() == valueList.size())) &&
1590	"mismatched multiway branch targets");
1591	mlir::Block *defaultBlock = errorBlock ? errorBlock : defaultEval.block;
1592	bool defaultHasExitCode = !errorBlock && hasExitCode(defaultEval);
1593	bool hasAnyExitCode = defaultHasExitCode;
1594	if (!hasAnyExitCode)
1595	for (auto label : labelList)
1596	if (label && hasExitCode(evalOfLabel(label))) {
1597	hasAnyExitCode = true;
1598	break;
1599	}
1600	mlir::Location loc = toLocation();
1601	size_t branchCount = labelList.size();
1602	if (!inArithmeticIfContext && !hasAnyExitCode &&
1603	!getEval().forceAsUnstructured()) { // from -no-structured-fir option
1604	// Generate a SelectOp.
1605	llvm::SmallVector<mlir::Block *> blockList;
1606	for (auto label : labelList) {
1607	mlir::Block *block =
1608	label ? evalOfLabel(label).block : defaultEval.block;
1609	assert(block && "missing multiway branch block");
1610	blockList.push_back(block);
1611	}
1612	blockList.push_back(defaultBlock);
1613	if (valueList[branchCount - 1] == 0) // Swap IO ERR and default blocks.
1614	std::swap(blockList[branchCount - 1], blockList[branchCount]);
1615	builder->create<fir::SelectOp>(loc, selector, valueList, blockList);
1616	return;
1617	}
1618	mlir::Type selectorType = selector.getType();
1619	bool realSelector = mlir::isa<mlir::FloatType>(selectorType);
1620	assert((inArithmeticIfContext || !realSelector) && "invalid selector type");
1621	mlir::Value zero;
1622	if (inArithmeticIfContext)
1623	zero =
1624	realSelector
1625	? builder->create<mlir::arith::ConstantOp>(
1626	loc, selectorType, builder->getFloatAttr(selectorType, 0.0))
1627	: builder->createIntegerConstant(loc, selectorType, 0);
1628	for (auto label : llvm::enumerate(labelList)) {
1629	mlir::Value cond;
1630	if (realSelector) // inArithmeticIfContext
1631	cond = builder->create<mlir::arith::CmpFOp>(
1632	loc,
1633	label.index() == 0 ? mlir::arith::CmpFPredicate::OLT
1634	: mlir::arith::CmpFPredicate::OGT,
1635	selector, zero);
1636	else if (inArithmeticIfContext) // INTEGER selector
1637	cond = builder->create<mlir::arith::CmpIOp>(
1638	loc,
1639	label.index() == 0 ? mlir::arith::CmpIPredicate::slt
1640	: mlir::arith::CmpIPredicate::sgt,
1641	selector, zero);
1642	else // A value of 0 is an IO ERR branch: invert comparison.
1643	cond = builder->create<mlir::arith::CmpIOp>(
1644	loc,
1645	valueList[label.index()] == 0 ? mlir::arith::CmpIPredicate::ne
1646	: mlir::arith::CmpIPredicate::eq,
1647	selector,
1648	builder->createIntegerConstant(loc, selectorType,
1649	valueList[label.index()]));
1650	// Branch to a new block with exit code and then to the target, or branch
1651	// directly to the target. defaultBlock is the "else" target.
1652	bool lastBranch = label.index() == branchCount - 1;
1653	mlir::Block *nextBlock =
1654	lastBranch && !defaultHasExitCode
1655	? defaultBlock
1656	: builder->getBlock()->splitBlock(builder->getInsertionPoint());
1657	const Fortran::lower::pft::Evaluation &targetEval =
1658	label.value() ? evalOfLabel(label.value()) : defaultEval;
1659	if (hasExitCode(targetEval)) {
1660	mlir::Block *jumpBlock =
1661	builder->getBlock()->splitBlock(builder->getInsertionPoint());
1662	genConditionalBranch(cond, jumpBlock, nextBlock);
1663	startBlock(jumpBlock);
1664	genConstructExitBranch(targetEval);
1665	} else {
1666	genConditionalBranch(cond, targetEval.block, nextBlock);
1667	}
1668	if (!lastBranch) {
1669	startBlock(nextBlock);
1670	} else if (defaultHasExitCode) {
1671	startBlock(nextBlock);
1672	genConstructExitBranch(defaultEval);
1673	}
1674	}
1675	}
1676
1677	void pushActiveConstruct(Fortran::lower::pft::Evaluation &eval,
1678	Fortran::lower::StatementContext &stmtCtx) {
1679	activeConstructStack.push_back(Elt: ConstructContext{eval, stmtCtx});
1680	eval.activeConstruct = true;
1681	}
1682	void popActiveConstruct() {
1683	assert(!activeConstructStack.empty() && "invalid active construct stack");
1684	activeConstructStack.back().eval.activeConstruct = false;
1685	if (activeConstructStack.back().pushedScope)
1686	localSymbols.popScope();
1687	activeConstructStack.pop_back();
1688	}
1689
1690	//===--------------------------------------------------------------------===//
1691	// Termination of symbolically referenced execution units
1692	//===--------------------------------------------------------------------===//
1693
1694	/// Exit of a routine
1695	///
1696	/// Generate the cleanup block before the routine exits
1697	void genExitRoutine(bool earlyReturn, mlir::ValueRange retval = {}) {
1698	if (blockIsUnterminated()) {
1699	bridge.openAccCtx().finalizeAndKeep();
1700	bridge.fctCtx().finalizeAndKeep();
1701	builder->create<mlir::func::ReturnOp>(toLocation(), retval);
1702	}
1703	if (!earlyReturn) {
1704	bridge.openAccCtx().pop();
1705	bridge.fctCtx().pop();
1706	}
1707	}
1708
1709	/// END of procedure-like constructs
1710	///
1711	/// Generate the cleanup block before the procedure exits
1712	void genReturnSymbol(const Fortran::semantics::Symbol &functionSymbol) {
1713	const Fortran::semantics::Symbol &resultSym =
1714	functionSymbol.get<Fortran::semantics::SubprogramDetails>().result();
1715	Fortran::lower::SymbolBox resultSymBox = lookupSymbol(resultSym);
1716	mlir::Location loc = toLocation();
1717	if (!resultSymBox) {
1718	mlir::emitError(loc, "internal error when processing function return");
1719	return;
1720	}
1721	mlir::Value resultVal = resultSymBox.match(
1722	[&](const fir::CharBoxValue &x) -> mlir::Value {
1723	if (Fortran::semantics::IsBindCProcedure(functionSymbol))
1724	return builder->create<fir::LoadOp>(loc, x.getBuffer());
1725	return fir::factory::CharacterExprHelper{*builder, loc}
1726	.createEmboxChar(x.getBuffer(), x.getLen());
1727	},
1728	[&](const fir::MutableBoxValue &x) -> mlir::Value {
1729	mlir::Value resultRef = resultSymBox.getAddr();
1730	mlir::Value load = builder->create<fir::LoadOp>(loc, resultRef);
1731	unsigned rank = x.rank();
1732	if (x.isAllocatable() && rank > 0) {
1733	// ALLOCATABLE array result must have default lower bounds.
1734	// At the call site the result box of a function reference
1735	// might be considered having default lower bounds, but
1736	// the runtime box should probably comply with this assumption
1737	// as well. If the result box has proper lbounds in runtime,
1738	// this may improve the debugging experience of Fortran apps.
1739	// We may consider removing this, if the overhead of setting
1740	// default lower bounds is too big.
1741	mlir::Value one =
1742	builder->createIntegerConstant(loc, builder->getIndexType(), 1);
1743	llvm::SmallVector<mlir::Value> lbounds{rank, one};
1744	auto shiftTy = fir::ShiftType::get(builder->getContext(), rank);
1745	mlir::Value shiftOp =
1746	builder->create<fir::ShiftOp>(loc, shiftTy, lbounds);
1747	load = builder->create<fir::ReboxOp>(
1748	loc, load.getType(), load, shiftOp, /*slice=*/mlir::Value{});
1749	}
1750	return load;
1751	},
1752	[&](const auto &) -> mlir::Value {
1753	mlir::Value resultRef = resultSymBox.getAddr();
1754	mlir::Type resultType = genType(resultSym);
1755	mlir::Type resultRefType = builder->getRefType(resultType);
1756	// A function with multiple entry points returning different types
1757	// tags all result variables with one of the largest types to allow
1758	// them to share the same storage. Convert this to the actual type.
1759	if (resultRef.getType() != resultRefType)
1760	resultRef = builder->createConvertWithVolatileCast(
1761	loc, resultRefType, resultRef);
1762	return builder->create<fir::LoadOp>(loc, resultRef);
1763	});
1764	genExitRoutine(false, resultVal);
1765	}
1766
1767	/// Get the return value of a call to \p symbol, which is a subroutine entry
1768	/// point that has alternative return specifiers.
1769	const mlir::Value
1770	getAltReturnResult(const Fortran::semantics::Symbol &symbol) {
1771	assert(Fortran::semantics::HasAlternateReturns(symbol) &&
1772	"subroutine does not have alternate returns");
1773	return getSymbolAddress(symbol);
1774	}
1775
1776	void genFIRProcedureExit(Fortran::lower::pft::FunctionLikeUnit &funit,
1777	const Fortran::semantics::Symbol &symbol) {
1778	if (mlir::Block *finalBlock = funit.finalBlock) {
1779	// The current block must end with a terminator.
1780	if (blockIsUnterminated())
1781	builder->create<mlir::cf::BranchOp>(toLocation(), finalBlock);
1782	// Set insertion point to final block.
1783	builder->setInsertionPoint(finalBlock, finalBlock->end());
1784	}
1785	if (Fortran::semantics::IsFunction(symbol)) {
1786	genReturnSymbol(symbol);
1787	} else if (Fortran::semantics::HasAlternateReturns(symbol)) {
1788	mlir::Value retval = builder->create<fir::LoadOp>(
1789	toLocation(), getAltReturnResult(symbol));
1790	genExitRoutine(false, retval);
1791	} else {
1792	genExitRoutine(false);
1793	}
1794	}
1795
1796	//
1797	// Statements that have control-flow semantics
1798	//
1799
1800	/// Generate an If[Then]Stmt condition or its negation.
1801	template <typename A>
1802	mlir::Value genIfCondition(const A *stmt, bool negate = false) {
1803	mlir::Location loc = toLocation();
1804	Fortran::lower::StatementContext stmtCtx;
1805	mlir::Value condExpr = createFIRExpr(
1806	loc,
1807	Fortran::semantics::GetExpr(
1808	std::get<Fortran::parser::ScalarLogicalExpr>(stmt->t)),
1809	stmtCtx);
1810	stmtCtx.finalizeAndReset();
1811	mlir::Value cond =
1812	builder->createConvert(loc, builder->getI1Type(), condExpr);
1813	if (negate)
1814	cond = builder->create<mlir::arith::XOrIOp>(
1815	loc, cond, builder->createIntegerConstant(loc, cond.getType(), 1));
1816	return cond;
1817	}
1818
1819	mlir::func::FuncOp getFunc(llvm::StringRef name, mlir::FunctionType ty) {
1820	if (mlir::func::FuncOp func = builder->getNamedFunction(name)) {
1821	assert(func.getFunctionType() == ty);
1822	return func;
1823	}
1824	return builder->createFunction(toLocation(), name, ty);
1825	}
1826
1827	/// Lowering of CALL statement
1828	void genFIR(const Fortran::parser::CallStmt &stmt) {
1829	Fortran::lower::StatementContext stmtCtx;
1830	Fortran::lower::pft::Evaluation &eval = getEval();
1831	setCurrentPosition(stmt.source);
1832	assert(stmt.typedCall && "Call was not analyzed");
1833	mlir::Value res{};
1834	if (lowerToHighLevelFIR()) {
1835	std::optional<mlir::Type> resultType;
1836	if (stmt.typedCall->hasAlternateReturns())
1837	resultType = builder->getIndexType();
1838	auto hlfirRes = Fortran::lower::convertCallToHLFIR(
1839	toLocation(), *this, *stmt.typedCall, resultType, localSymbols,
1840	stmtCtx);
1841	if (hlfirRes)
1842	res = *hlfirRes;
1843	} else {
1844	// Call statement lowering shares code with function call lowering.
1845	res = Fortran::lower::createSubroutineCall(
1846	*this, *stmt.typedCall, explicitIterSpace, implicitIterSpace,
1847	localSymbols, stmtCtx, /*isUserDefAssignment=*/false);
1848	}
1849	stmtCtx.finalizeAndReset();
1850	if (!res)
1851	return; // "Normal" subroutine call.
1852	// Call with alternate return specifiers.
1853	// The call returns an index that selects an alternate return branch target.
1854	llvm::SmallVector<int64_t> indexList;
1855	llvm::SmallVector<Fortran::parser::Label> labelList;
1856	int64_t index = 0;
1857	for (const Fortran::parser::ActualArgSpec &arg :
1858	std::get<std::list<Fortran::parser::ActualArgSpec>>(stmt.call.t)) {
1859	const auto &actual = std::get<Fortran::parser::ActualArg>(arg.t);
1860	if (const auto *altReturn =
1861	std::get_if<Fortran::parser::AltReturnSpec>(&actual.u)) {
1862	indexList.push_back(++index);
1863	labelList.push_back(altReturn->v);
1864	}
1865	}
1866	genMultiwayBranch(res, indexList, labelList, eval.nonNopSuccessor());
1867	}
1868
1869	void genFIR(const Fortran::parser::ComputedGotoStmt &stmt) {
1870	Fortran::lower::StatementContext stmtCtx;
1871	Fortran::lower::pft::Evaluation &eval = getEval();
1872	mlir::Value selectExpr =
1873	createFIRExpr(toLocation(),
1874	Fortran::semantics::GetExpr(
1875	std::get<Fortran::parser::ScalarIntExpr>(stmt.t)),
1876	stmtCtx);
1877	stmtCtx.finalizeAndReset();
1878	llvm::SmallVector<int64_t> indexList;
1879	llvm::SmallVector<Fortran::parser::Label> labelList;
1880	int64_t index = 0;
1881	for (Fortran::parser::Label label :
1882	std::get<std::list<Fortran::parser::Label>>(stmt.t)) {
1883	indexList.push_back(++index);
1884	labelList.push_back(label);
1885	}
1886	genMultiwayBranch(selectExpr, indexList, labelList, eval.nonNopSuccessor());
1887	}
1888
1889	void genFIR(const Fortran::parser::ArithmeticIfStmt &stmt) {
1890	Fortran::lower::StatementContext stmtCtx;
1891	mlir::Value expr = createFIRExpr(
1892	toLocation(),
1893	Fortran::semantics::GetExpr(std::get<Fortran::parser::Expr>(stmt.t)),
1894	stmtCtx);
1895	stmtCtx.finalizeAndReset();
1896	// Raise an exception if REAL expr is a NaN.
1897	if (mlir::isa<mlir::FloatType>(expr.getType()))
1898	expr = builder->create<mlir::arith::AddFOp>(toLocation(), expr, expr);
1899	// An empty valueList indicates to genMultiwayBranch that the branch is
1900	// an ArithmeticIfStmt that has two branches on value 0 or 0.0.
1901	llvm::SmallVector<int64_t> valueList;
1902	llvm::SmallVector<Fortran::parser::Label> labelList;
1903	labelList.push_back(std::get<1>(stmt.t));
1904	labelList.push_back(std::get<3>(stmt.t));
1905	const Fortran::lower::pft::LabelEvalMap &labelEvaluationMap =
1906	getEval().getOwningProcedure()->labelEvaluationMap;
1907	const auto iter = labelEvaluationMap.find(std::get<2>(stmt.t));
1908	assert(iter != labelEvaluationMap.end() && "label missing from map");
1909	genMultiwayBranch(expr, valueList, labelList, *iter->second);
1910	}
1911
1912	void genFIR(const Fortran::parser::AssignedGotoStmt &stmt) {
1913	// See Fortran 90 Clause 8.2.4.
1914	// Relax the requirement that the GOTO variable must have a value in the
1915	// label list when a list is present, and allow a branch to any non-format
1916	// target that has an ASSIGN statement for the variable.
1917	mlir::Location loc = toLocation();
1918	Fortran::lower::pft::Evaluation &eval = getEval();
1919	Fortran::lower::pft::FunctionLikeUnit &owningProc =
1920	*eval.getOwningProcedure();
1921	const Fortran::lower::pft::SymbolLabelMap &symbolLabelMap =
1922	owningProc.assignSymbolLabelMap;
1923	const Fortran::lower::pft::LabelEvalMap &labelEvalMap =
1924	owningProc.labelEvaluationMap;
1925	const Fortran::semantics::Symbol &symbol =
1926	*std::get<Fortran::parser::Name>(stmt.t).symbol;
1927	auto labelSetIter = symbolLabelMap.find(symbol);
1928	llvm::SmallVector<int64_t> valueList;
1929	llvm::SmallVector<Fortran::parser::Label> labelList;
1930	if (labelSetIter != symbolLabelMap.end()) {
1931	for (auto &label : labelSetIter->second) {
1932	const auto evalIter = labelEvalMap.find(label);
1933	assert(evalIter != labelEvalMap.end() && "assigned goto label missing");
1934	if (evalIter->second->block) { // non-format statement
1935	valueList.push_back(label); // label as an integer
1936	labelList.push_back(label);
1937	}
1938	}
1939	}
1940	if (!labelList.empty()) {
1941	auto selectExpr =
1942	builder->create<fir::LoadOp>(loc, getSymbolAddress(symbol));
1943	// Add a default error target in case the goto is nonconforming.
1944	mlir::Block *errorBlock =
1945	builder->getBlock()->splitBlock(builder->getInsertionPoint());
1946	genMultiwayBranch(selectExpr, valueList, labelList,
1947	eval.nonNopSuccessor(), errorBlock);
1948	startBlock(errorBlock);
1949	}
1950	fir::runtime::genReportFatalUserError(
1951	*builder, loc,
1952	"Assigned GOTO variable '" + symbol.name().ToString() +
1953	"' does not have a valid target label value");
1954	builder->create<fir::UnreachableOp>(loc);
1955	}
1956
1957	fir::ReduceOperationEnum
1958	getReduceOperationEnum(const Fortran::parser::ReductionOperator &rOpr) {
1959	switch (rOpr.v) {
1960	case Fortran::parser::ReductionOperator::Operator::Plus:
1961	return fir::ReduceOperationEnum::Add;
1962	case Fortran::parser::ReductionOperator::Operator::Multiply:
1963	return fir::ReduceOperationEnum::Multiply;
1964	case Fortran::parser::ReductionOperator::Operator::And:
1965	return fir::ReduceOperationEnum::AND;
1966	case Fortran::parser::ReductionOperator::Operator::Or:
1967	return fir::ReduceOperationEnum::OR;
1968	case Fortran::parser::ReductionOperator::Operator::Eqv:
1969	return fir::ReduceOperationEnum::EQV;
1970	case Fortran::parser::ReductionOperator::Operator::Neqv:
1971	return fir::ReduceOperationEnum::NEQV;
1972	case Fortran::parser::ReductionOperator::Operator::Max:
1973	return fir::ReduceOperationEnum::MAX;
1974	case Fortran::parser::ReductionOperator::Operator::Min:
1975	return fir::ReduceOperationEnum::MIN;
1976	case Fortran::parser::ReductionOperator::Operator::Iand:
1977	return fir::ReduceOperationEnum::IAND;
1978	case Fortran::parser::ReductionOperator::Operator::Ior:
1979	return fir::ReduceOperationEnum::IOR;
1980	case Fortran::parser::ReductionOperator::Operator::Ieor:
1981	return fir::ReduceOperationEnum::EIOR;
1982	}
1983	llvm_unreachable("illegal reduction operator");
1984	}
1985
1986	/// Collect DO CONCURRENT loop control information.
1987	IncrementLoopNestInfo getConcurrentControl(
1988	const Fortran::parser::ConcurrentHeader &header,
1989	const std::list<Fortran::parser::LocalitySpec> &localityList = {}) {
1990	IncrementLoopNestInfo incrementLoopNestInfo;
1991	for (const Fortran::parser::ConcurrentControl &control :
1992	std::get<std::list<Fortran::parser::ConcurrentControl>>(header.t))
1993	incrementLoopNestInfo.emplace_back(
1994	*std::get<0>(control.t).symbol, std::get<1>(control.t),
1995	std::get<2>(control.t), std::get<3>(control.t), /*isUnordered=*/true);
1996	IncrementLoopInfo &info = incrementLoopNestInfo.back();
1997	info.maskExpr = Fortran::semantics::GetExpr(
1998	std::get<std::optional<Fortran::parser::ScalarLogicalExpr>>(header.t));
1999	for (const Fortran::parser::LocalitySpec &x : localityList) {
2000	if (const auto *localList =
2001	std::get_if<Fortran::parser::LocalitySpec::Local>(&x.u))
2002	for (const Fortran::parser::Name &x : localList->v)
2003	info.localSymList.push_back(x.symbol);
2004	if (const auto *localInitList =
2005	std::get_if<Fortran::parser::LocalitySpec::LocalInit>(&x.u))
2006	for (const Fortran::parser::Name &x : localInitList->v)
2007	info.localInitSymList.push_back(x.symbol);
2008	for (IncrementLoopInfo &info : incrementLoopNestInfo) {
2009	if (const auto *reduceList =
2010	std::get_if<Fortran::parser::LocalitySpec::Reduce>(&x.u)) {
2011	fir::ReduceOperationEnum reduce_operation = getReduceOperationEnum(
2012	std::get<Fortran::parser::ReductionOperator>(reduceList->t));
2013	for (const Fortran::parser::Name &x :
2014	std::get<std::list<Fortran::parser::Name>>(reduceList->t)) {
2015	info.reduceSymList.push_back(
2016	std::make_pair(reduce_operation, x.symbol));
2017	}
2018	}
2019	}
2020	if (const auto *sharedList =
2021	std::get_if<Fortran::parser::LocalitySpec::Shared>(&x.u))
2022	for (const Fortran::parser::Name &x : sharedList->v)
2023	info.sharedSymList.push_back(x.symbol);
2024	}
2025	return incrementLoopNestInfo;
2026	}
2027
2028	/// Create DO CONCURRENT construct symbol bindings and generate LOCAL_INIT
2029	/// assignments.
2030	void handleLocalitySpecs(const IncrementLoopInfo &info) {
2031	Fortran::semantics::SemanticsContext &semanticsContext =
2032	bridge.getSemanticsContext();
2033	fir::LocalitySpecifierOperands privateClauseOps;
2034	auto doConcurrentLoopOp =
2035	mlir::dyn_cast_if_present<fir::DoConcurrentLoopOp>(info.loopOp);
2036	bool useDelayedPriv = enableDelayedPrivatization && doConcurrentLoopOp;
2037	llvm::SetVector<const Fortran::semantics::Symbol *> allPrivatizedSymbols;
2038	llvm::SmallSet<const Fortran::semantics::Symbol *, 16> mightHaveReadHostSym;
2039
2040	for (const Fortran::semantics::Symbol *symToPrivatize : info.localSymList) {
2041	if (useDelayedPriv) {
2042	Fortran::lower::privatizeSymbol<fir::LocalitySpecifierOp>(
2043	*this, this->getFirOpBuilder(), localSymbols, allPrivatizedSymbols,
2044	mightHaveReadHostSym, symToPrivatize, &privateClauseOps);
2045	continue;
2046	}
2047
2048	createHostAssociateVarClone(*symToPrivatize, /*skipDefaultInit=*/false);
2049	}
2050
2051	for (const Fortran::semantics::Symbol *symToPrivatize :
2052	info.localInitSymList) {
2053	if (useDelayedPriv) {
2054	Fortran::lower::privatizeSymbol<fir::LocalitySpecifierOp>(
2055	*this, this->getFirOpBuilder(), localSymbols, allPrivatizedSymbols,
2056	mightHaveReadHostSym, symToPrivatize, &privateClauseOps);
2057	continue;
2058	}
2059
2060	createHostAssociateVarClone(*symToPrivatize, /*skipDefaultInit=*/true);
2061	const auto *hostDetails =
2062	symToPrivatize->detailsIf<Fortran::semantics::HostAssocDetails>();
2063	assert(hostDetails && "missing locality spec host symbol");
2064	const Fortran::semantics::Symbol *hostSym = &hostDetails->symbol();
2065	Fortran::evaluate::ExpressionAnalyzer ea{semanticsContext};
2066	Fortran::evaluate::Assignment assign{
2067	ea.Designate(Fortran::evaluate::DataRef{*symToPrivatize}).value(),
2068	ea.Designate(Fortran::evaluate::DataRef{*hostSym}).value()};
2069	if (Fortran::semantics::IsPointer(*symToPrivatize))
2070	assign.u = Fortran::evaluate::Assignment::BoundsSpec{};
2071	genAssignment(assign);
2072	}
2073	for (const Fortran::semantics::Symbol *sym : info.sharedSymList) {
2074	const auto *hostDetails =
2075	sym->detailsIf<Fortran::semantics::HostAssocDetails>();
2076	copySymbolBinding(hostDetails->symbol(), *sym);
2077	}
2078
2079	if (useDelayedPriv) {
2080	doConcurrentLoopOp.getLocalVarsMutable().assign(
2081	privateClauseOps.privateVars);
2082	doConcurrentLoopOp.setLocalSymsAttr(
2083	builder->getArrayAttr(privateClauseOps.privateSyms));
2084
2085	for (auto [sym, privateVar] : llvm::zip_equal(
2086	allPrivatizedSymbols, privateClauseOps.privateVars)) {
2087	auto arg = doConcurrentLoopOp.getRegion().begin()->addArgument(
2088	privateVar.getType(), doConcurrentLoopOp.getLoc());
2089	bindSymbol(*sym, hlfir::translateToExtendedValue(
2090	privateVar.getLoc(), *builder, hlfir::Entity{arg},
2091	/*contiguousHint=*/true)
2092	.first);
2093	}
2094	}
2095
2096	// Note that allocatable, types with ultimate components, and type
2097	// requiring finalization are forbidden in LOCAL/LOCAL_INIT (F2023 C1130),
2098	// so no clean-up needs to be generated for these entities.
2099	}
2100
2101	/// Generate FIR for a DO construct. There are six variants:
2102	/// - unstructured infinite and while loops
2103	/// - structured and unstructured increment loops
2104	/// - structured and unstructured concurrent loops
2105	void genFIR(const Fortran::parser::DoConstruct &doConstruct) {
2106	setCurrentPositionAt(doConstruct);
2107	// Collect loop nest information.
2108	// Generate begin loop code directly for infinite and while loops.
2109	Fortran::lower::pft::Evaluation &eval = getEval();
2110	bool unstructuredContext = eval.lowerAsUnstructured();
2111	Fortran::lower::pft::Evaluation &doStmtEval =
2112	eval.getFirstNestedEvaluation();
2113	auto *doStmt = doStmtEval.getIf<Fortran::parser::NonLabelDoStmt>();
2114	const auto &loopControl =
2115	std::get<std::optional<Fortran::parser::LoopControl>>(doStmt->t);
2116	mlir::Block *preheaderBlock = doStmtEval.block;
2117	mlir::Block *beginBlock =
2118	preheaderBlock ? preheaderBlock : builder->getBlock();
2119	auto createNextBeginBlock = [&]() {
2120	// Step beginBlock through unstructured preheader, header, and mask
2121	// blocks, created in outermost to innermost order.
2122	return beginBlock = beginBlock->splitBlock(beginBlock->end());
2123	};
2124	mlir::Block *headerBlock =
2125	unstructuredContext ? createNextBeginBlock() : nullptr;
2126	mlir::Block *bodyBlock = doStmtEval.lexicalSuccessor->block;
2127	mlir::Block *exitBlock = doStmtEval.parentConstruct->constructExit->block;
2128	IncrementLoopNestInfo incrementLoopNestInfo;
2129	const Fortran::parser::ScalarLogicalExpr *whileCondition = nullptr;
2130	bool infiniteLoop = !loopControl.has_value();
2131	if (infiniteLoop) {
2132	assert(unstructuredContext && "infinite loop must be unstructured");
2133	startBlock(headerBlock);
2134	} else if ((whileCondition =
2135	std::get_if<Fortran::parser::ScalarLogicalExpr>(
2136	&loopControl->u))) {
2137	assert(unstructuredContext && "while loop must be unstructured");
2138	maybeStartBlock(preheaderBlock); // no block or empty block
2139	startBlock(headerBlock);
2140	genConditionalBranch(*whileCondition, bodyBlock, exitBlock);
2141	} else if (const auto *bounds =
2142	std::get_if<Fortran::parser::LoopControl::Bounds>(
2143	&loopControl->u)) {
2144	// Non-concurrent increment loop.
2145	IncrementLoopInfo &info = incrementLoopNestInfo.emplace_back(
2146	*bounds->name.thing.symbol, bounds->lower, bounds->upper,
2147	bounds->step);
2148	if (unstructuredContext) {
2149	maybeStartBlock(preheaderBlock);
2150	info.hasRealControl = info.loopVariableSym->GetType()->IsNumeric(
2151	Fortran::common::TypeCategory::Real);
2152	info.headerBlock = headerBlock;
2153	info.bodyBlock = bodyBlock;
2154	info.exitBlock = exitBlock;
2155	}
2156	} else {
2157	const auto *concurrent =
2158	std::get_if<Fortran::parser::LoopControl::Concurrent>(
2159	&loopControl->u);
2160	assert(concurrent && "invalid DO loop variant");
2161	incrementLoopNestInfo = getConcurrentControl(
2162	std::get<Fortran::parser::ConcurrentHeader>(concurrent->t),
2163	std::get<std::list<Fortran::parser::LocalitySpec>>(concurrent->t));
2164	if (unstructuredContext) {
2165	maybeStartBlock(preheaderBlock);
2166	for (IncrementLoopInfo &info : incrementLoopNestInfo) {
2167	// The original loop body provides the body and latch blocks of the
2168	// innermost dimension. The (first) body block of a non-innermost
2169	// dimension is the preheader block of the immediately enclosed
2170	// dimension. The latch block of a non-innermost dimension is the
2171	// exit block of the immediately enclosed dimension.
2172	auto createNextExitBlock = [&]() {
2173	// Create unstructured loop exit blocks, outermost to innermost.
2174	return exitBlock = insertBlock(exitBlock);
2175	};
2176	bool isInnermost = &info == &incrementLoopNestInfo.back();
2177	bool isOutermost = &info == &incrementLoopNestInfo.front();
2178	info.headerBlock = isOutermost ? headerBlock : createNextBeginBlock();
2179	info.bodyBlock = isInnermost ? bodyBlock : createNextBeginBlock();
2180	info.exitBlock = isOutermost ? exitBlock : createNextExitBlock();
2181	if (info.maskExpr)
2182	info.maskBlock = createNextBeginBlock();
2183	}
2184	}
2185	}
2186
2187	// Increment loop begin code. (Infinite/while code was already generated.)
2188	if (!infiniteLoop && !whileCondition)
2189	genFIRIncrementLoopBegin(incrementLoopNestInfo, doStmtEval.dirs);
2190
2191	// Loop body code.
2192	auto iter = eval.getNestedEvaluations().begin();
2193	for (auto end = --eval.getNestedEvaluations().end(); iter != end; ++iter)
2194	genFIR(*iter, unstructuredContext);
2195
2196	// An EndDoStmt in unstructured code may start a new block.
2197	Fortran::lower::pft::Evaluation &endDoEval = *iter;
2198	assert(endDoEval.getIf<Fortran::parser::EndDoStmt>() && "no enddo stmt");
2199	if (unstructuredContext)
2200	maybeStartBlock(endDoEval.block);
2201
2202	// Loop end code.
2203	if (infiniteLoop || whileCondition)
2204	genBranch(headerBlock);
2205	else
2206	genFIRIncrementLoopEnd(incrementLoopNestInfo);
2207
2208	// This call may generate a branch in some contexts.
2209	genFIR(endDoEval, unstructuredContext);
2210	}
2211
2212	/// Generate FIR to evaluate loop control values (lower, upper and step).
2213	mlir::Value genControlValue(const Fortran::lower::SomeExpr *expr,
2214	const IncrementLoopInfo &info,
2215	bool *isConst = nullptr) {
2216	mlir::Location loc = toLocation();
2217	mlir::Type controlType = info.isStructured() ? builder->getIndexType()
2218	: info.getLoopVariableType();
2219	Fortran::lower::StatementContext stmtCtx;
2220	if (expr) {
2221	if (isConst)
2222	*isConst = Fortran::evaluate::IsConstantExpr(*expr);
2223	return builder->createConvert(loc, controlType,
2224	createFIRExpr(loc, expr, stmtCtx));
2225	}
2226
2227	if (isConst)
2228	*isConst = true;
2229	if (info.hasRealControl)
2230	return builder->createRealConstant(loc, controlType, 1u);
2231	return builder->createIntegerConstant(loc, controlType, 1); // step
2232	}
2233
2234	// For unroll directives without a value, force full unrolling.
2235	// For unroll directives with a value, if the value is greater than 1,
2236	// force unrolling with the given factor. Otherwise, disable unrolling.
2237	mlir::LLVM::LoopUnrollAttr
2238	genLoopUnrollAttr(std::optional<std::uint64_t> directiveArg) {
2239	mlir::BoolAttr falseAttr =
2240	mlir::BoolAttr::get(builder->getContext(), false);
2241	mlir::BoolAttr trueAttr = mlir::BoolAttr::get(builder->getContext(), true);
2242	mlir::IntegerAttr countAttr;
2243	mlir::BoolAttr fullUnrollAttr;
2244	bool shouldUnroll = true;
2245	if (directiveArg.has_value()) {
2246	auto unrollingFactor = directiveArg.value();
2247	if (unrollingFactor == 0 || unrollingFactor == 1) {
2248	shouldUnroll = false;
2249	} else {
2250	countAttr =
2251	builder->getIntegerAttr(builder->getI64Type(), unrollingFactor);
2252	}
2253	} else {
2254	fullUnrollAttr = trueAttr;
2255	}
2256
2257	mlir::BoolAttr disableAttr = shouldUnroll ? falseAttr : trueAttr;
2258	return mlir::LLVM::LoopUnrollAttr::get(
2259	builder->getContext(), /*disable=*/disableAttr, /*count=*/countAttr, {},
2260	/*full=*/fullUnrollAttr, {}, {}, {});
2261	}
2262
2263	// Enabling unroll and jamming directive without a value.
2264	// For directives with a value, if the value is greater than 1,
2265	// force unrolling with the given factor. Otherwise, disable unrolling and
2266	// jamming.
2267	mlir::LLVM::LoopUnrollAndJamAttr
2268	genLoopUnrollAndJamAttr(std::optional<std::uint64_t> count) {
2269	mlir::BoolAttr falseAttr =
2270	mlir::BoolAttr::get(builder->getContext(), false);
2271	mlir::BoolAttr trueAttr = mlir::BoolAttr::get(builder->getContext(), true);
2272	mlir::IntegerAttr countAttr;
2273	bool shouldUnroll = true;
2274	if (count.has_value()) {
2275	auto unrollingFactor = count.value();
2276	if (unrollingFactor == 0 || unrollingFactor == 1) {
2277	shouldUnroll = false;
2278	} else {
2279	countAttr =
2280	builder->getIntegerAttr(builder->getI64Type(), unrollingFactor);
2281	}
2282	}
2283
2284	mlir::BoolAttr disableAttr = shouldUnroll ? falseAttr : trueAttr;
2285	return mlir::LLVM::LoopUnrollAndJamAttr::get(
2286	builder->getContext(), /*disable=*/disableAttr, /*count*/ countAttr, {},
2287	{}, {}, {}, {});
2288	}
2289
2290	void addLoopAnnotationAttr(
2291	IncrementLoopInfo &info,
2292	llvm::SmallVectorImpl<const Fortran::parser::CompilerDirective *> &dirs) {
2293	mlir::LLVM::LoopVectorizeAttr va;
2294	mlir::LLVM::LoopUnrollAttr ua;
2295	mlir::LLVM::LoopUnrollAndJamAttr uja;
2296	bool has_attrs = false;
2297	for (const auto *dir : dirs) {
2298	Fortran::common::visit(
2299	Fortran::common::visitors{
2300	[&](const Fortran::parser::CompilerDirective::VectorAlways &) {
2301	mlir::BoolAttr falseAttr =
2302	mlir::BoolAttr::get(builder->getContext(), false);
2303	va = mlir::LLVM::LoopVectorizeAttr::get(builder->getContext(),
2304	/*disable=*/falseAttr,
2305	{}, {}, {}, {}, {}, {});
2306	has_attrs = true;
2307	},
2308	[&](const Fortran::parser::CompilerDirective::Unroll &u) {
2309	ua = genLoopUnrollAttr(u.v);
2310	has_attrs = true;
2311	},
2312	[&](const Fortran::parser::CompilerDirective::UnrollAndJam &u) {
2313	uja = genLoopUnrollAndJamAttr(u.v);
2314	has_attrs = true;
2315	},
2316	[&](const Fortran::parser::CompilerDirective::NoVector &u) {
2317	mlir::BoolAttr trueAttr =
2318	mlir::BoolAttr::get(builder->getContext(), true);
2319	va = mlir::LLVM::LoopVectorizeAttr::get(builder->getContext(),
2320	/*disable=*/trueAttr,
2321	{}, {}, {}, {}, {}, {});
2322	has_attrs = true;
2323	},
2324	[&](const Fortran::parser::CompilerDirective::NoUnroll &u) {
2325	ua = genLoopUnrollAttr(/*unrollingFactor=*/0);
2326	has_attrs = true;
2327	},
2328	[&](const Fortran::parser::CompilerDirective::NoUnrollAndJam &u) {
2329	uja = genLoopUnrollAndJamAttr(/*unrollingFactor=*/0);
2330	has_attrs = true;
2331	},
2332
2333	[&](const auto &) {}},
2334	dir->u);
2335	}
2336	mlir::LLVM::LoopAnnotationAttr la = mlir::LLVM::LoopAnnotationAttr::get(
2337	builder->getContext(), {}, /*vectorize=*/va, {}, /*unroll*/ ua,
2338	/*unroll_and_jam*/ uja, {}, {}, {}, {}, {}, {}, {}, {}, {}, {});
2339	if (has_attrs) {
2340	if (auto loopOp = mlir::dyn_cast<fir::DoLoopOp>(info.loopOp))
2341	loopOp.setLoopAnnotationAttr(la);
2342
2343	if (auto doConcurrentOp =
2344	mlir::dyn_cast<fir::DoConcurrentLoopOp>(info.loopOp))
2345	doConcurrentOp.setLoopAnnotationAttr(la);
2346	}
2347	}
2348
2349	/// Generate FIR to begin a structured or unstructured increment loop nest.
2350	void genFIRIncrementLoopBegin(
2351	IncrementLoopNestInfo &incrementLoopNestInfo,
2352	llvm::SmallVectorImpl<const Fortran::parser::CompilerDirective *> &dirs) {
2353	assert(!incrementLoopNestInfo.empty() && "empty loop nest");
2354	mlir::Location loc = toLocation();
2355	mlir::arith::IntegerOverflowFlags iofBackup{};
2356
2357	llvm::SmallVector<mlir::Value> nestLBs;
2358	llvm::SmallVector<mlir::Value> nestUBs;
2359	llvm::SmallVector<mlir::Value> nestSts;
2360	llvm::SmallVector<mlir::Value> nestReduceOperands;
2361	llvm::SmallVector<mlir::Attribute> nestReduceAttrs;
2362	bool genDoConcurrent = false;
2363
2364	for (IncrementLoopInfo &info : incrementLoopNestInfo) {
2365	genDoConcurrent = info.isStructured() && info.isConcurrent;
2366
2367	if (!genDoConcurrent)
2368	info.loopVariable = genLoopVariableAddress(loc, *info.loopVariableSym,
2369	info.isConcurrent);
2370
2371	if (!getLoweringOptions().getIntegerWrapAround()) {
2372	iofBackup = builder->getIntegerOverflowFlags();
2373	builder->setIntegerOverflowFlags(
2374	mlir::arith::IntegerOverflowFlags::nsw);
2375	}
2376
2377	nestLBs.push_back(genControlValue(info.lowerExpr, info));
2378	nestUBs.push_back(genControlValue(info.upperExpr, info));
2379	bool isConst = true;
2380	nestSts.push_back(genControlValue(
2381	info.stepExpr, info, info.isStructured() ? nullptr : &isConst));
2382
2383	if (!getLoweringOptions().getIntegerWrapAround())
2384	builder->setIntegerOverflowFlags(iofBackup);
2385
2386	// Use a temp variable for unstructured loops with non-const step.
2387	if (!isConst) {
2388	mlir::Value stepValue = nestSts.back();
2389	info.stepVariable = builder->createTemporary(loc, stepValue.getType());
2390	builder->create<fir::StoreOp>(loc, stepValue, info.stepVariable);
2391	}
2392
2393	if (genDoConcurrent && nestReduceOperands.empty()) {
2394	// Create DO CONCURRENT reduce operands and attributes
2395	for (const auto &reduceSym : info.reduceSymList) {
2396	const fir::ReduceOperationEnum reduceOperation = reduceSym.first;
2397	const Fortran::semantics::Symbol *sym = reduceSym.second;
2398	fir::ExtendedValue exv = getSymbolExtendedValue(*sym, nullptr);
2399	nestReduceOperands.push_back(fir::getBase(exv));
2400	auto reduceAttr =
2401	fir::ReduceAttr::get(builder->getContext(), reduceOperation);
2402	nestReduceAttrs.push_back(reduceAttr);
2403	}
2404	}
2405	}
2406
2407	for (auto [info, lowerValue, upperValue, stepValue] :
2408	llvm::zip_equal(incrementLoopNestInfo, nestLBs, nestUBs, nestSts)) {
2409	// Structured loop - generate fir.do_loop.
2410	if (info.isStructured()) {
2411	if (genDoConcurrent)
2412	continue;
2413
2414	// The loop variable is a doLoop op argument.
2415	mlir::Type loopVarType = info.getLoopVariableType();
2416	auto loopOp = builder->create<fir::DoLoopOp>(
2417	loc, lowerValue, upperValue, stepValue, /*unordered=*/false,
2418	/*finalCountValue=*/true,
2419	builder->createConvert(loc, loopVarType, lowerValue));
2420	info.loopOp = loopOp;
2421	builder->setInsertionPointToStart(loopOp.getBody());
2422	mlir::Value loopValue = loopOp.getRegionIterArgs()[0];
2423
2424	// Update the loop variable value in case it has non-index references.
2425	builder->create<fir::StoreOp>(loc, loopValue, info.loopVariable);
2426	addLoopAnnotationAttr(info, dirs);
2427	continue;
2428	}
2429
2430	// Unstructured loop preheader - initialize tripVariable and loopVariable.
2431	mlir::Value tripCount;
2432	if (info.hasRealControl) {
2433	auto diff1 =
2434	builder->create<mlir::arith::SubFOp>(loc, upperValue, lowerValue);
2435	auto diff2 =
2436	builder->create<mlir::arith::AddFOp>(loc, diff1, stepValue);
2437	tripCount = builder->create<mlir::arith::DivFOp>(loc, diff2, stepValue);
2438	tripCount =
2439	builder->createConvert(loc, builder->getIndexType(), tripCount);
2440	} else {
2441	auto diff1 =
2442	builder->create<mlir::arith::SubIOp>(loc, upperValue, lowerValue);
2443	auto diff2 =
2444	builder->create<mlir::arith::AddIOp>(loc, diff1, stepValue);
2445	tripCount =
2446	builder->create<mlir::arith::DivSIOp>(loc, diff2, stepValue);
2447	}
2448	if (forceLoopToExecuteOnce) { // minimum tripCount is 1
2449	mlir::Value one =
2450	builder->createIntegerConstant(loc, tripCount.getType(), 1);
2451	auto cond = builder->create<mlir::arith::CmpIOp>(
2452	loc, mlir::arith::CmpIPredicate::slt, tripCount, one);
2453	tripCount =
2454	builder->create<mlir::arith::SelectOp>(loc, cond, one, tripCount);
2455	}
2456	info.tripVariable = builder->createTemporary(loc, tripCount.getType());
2457	builder->create<fir::StoreOp>(loc, tripCount, info.tripVariable);
2458	builder->create<fir::StoreOp>(loc, lowerValue, info.loopVariable);
2459
2460	// Unstructured loop header - generate loop condition and mask.
2461	// Note - Currently there is no way to tag a loop as a concurrent loop.
2462	startBlock(info.headerBlock);
2463	tripCount = builder->create<fir::LoadOp>(loc, info.tripVariable);
2464	mlir::Value zero =
2465	builder->createIntegerConstant(loc, tripCount.getType(), 0);
2466	auto cond = builder->create<mlir::arith::CmpIOp>(
2467	loc, mlir::arith::CmpIPredicate::sgt, tripCount, zero);
2468	if (info.maskExpr) {
2469	genConditionalBranch(cond, info.maskBlock, info.exitBlock);
2470	startBlock(info.maskBlock);
2471	mlir::Block *latchBlock = getEval().getLastNestedEvaluation().block;
2472	assert(latchBlock && "missing masked concurrent loop latch block");
2473	Fortran::lower::StatementContext stmtCtx;
2474	mlir::Value maskCond = createFIRExpr(loc, info.maskExpr, stmtCtx);
2475	stmtCtx.finalizeAndReset();
2476	genConditionalBranch(maskCond, info.bodyBlock, latchBlock);
2477	} else {
2478	genConditionalBranch(cond, info.bodyBlock, info.exitBlock);
2479	if (&info != &incrementLoopNestInfo.back()) // not innermost
2480	startBlock(info.bodyBlock); // preheader block of enclosed dimension
2481	}
2482	if (info.hasLocalitySpecs()) {
2483	mlir::OpBuilder::InsertPoint insertPt = builder->saveInsertionPoint();
2484	builder->setInsertionPointToStart(info.bodyBlock);
2485	handleLocalitySpecs(info);
2486	builder->restoreInsertionPoint(insertPt);
2487	}
2488	}
2489
2490	if (genDoConcurrent) {
2491	auto loopWrapperOp = builder->create<fir::DoConcurrentOp>(loc);
2492	builder->setInsertionPointToStart(
2493	builder->createBlock(&loopWrapperOp.getRegion()));
2494
2495	for (IncrementLoopInfo &info : llvm::reverse(C&: incrementLoopNestInfo)) {
2496	info.loopVariable = genLoopVariableAddress(loc, *info.loopVariableSym,
2497	info.isConcurrent);
2498	}
2499
2500	builder->setInsertionPointToEnd(loopWrapperOp.getBody());
2501	auto loopOp = builder->create<fir::DoConcurrentLoopOp>(
2502	loc, nestLBs, nestUBs, nestSts, nestReduceOperands,
2503	nestReduceAttrs.empty()
2504	? nullptr
2505	: mlir::ArrayAttr::get(builder->getContext(), nestReduceAttrs),
2506	nullptr, /*local_vars=*/std::nullopt, /*local_syms=*/nullptr);
2507
2508	llvm::SmallVector<mlir::Type> loopBlockArgTypes(
2509	incrementLoopNestInfo.size(), builder->getIndexType());
2510	llvm::SmallVector<mlir::Location> loopBlockArgLocs(
2511	incrementLoopNestInfo.size(), loc);
2512	mlir::Region &loopRegion = loopOp.getRegion();
2513	mlir::Block *loopBlock = builder->createBlock(
2514	&loopRegion, loopRegion.begin(), loopBlockArgTypes, loopBlockArgLocs);
2515	builder->setInsertionPointToStart(loopBlock);
2516
2517	for (auto [info, blockArg] :
2518	llvm::zip_equal(incrementLoopNestInfo, loopBlock->getArguments())) {
2519	info.loopOp = loopOp;
2520	mlir::Value loopValue =
2521	builder->createConvert(loc, info.getLoopVariableType(), blockArg);
2522	builder->create<fir::StoreOp>(loc, loopValue, info.loopVariable);
2523
2524	if (info.maskExpr) {
2525	Fortran::lower::StatementContext stmtCtx;
2526	mlir::Value maskCond = createFIRExpr(loc, info.maskExpr, stmtCtx);
2527	stmtCtx.finalizeAndReset();
2528	mlir::Value maskCondCast =
2529	builder->createConvert(loc, builder->getI1Type(), maskCond);
2530	auto ifOp = builder->create<fir::IfOp>(loc, maskCondCast,
2531	/*withElseRegion=*/false);
2532	builder->setInsertionPointToStart(&ifOp.getThenRegion().front());
2533	}
2534	}
2535
2536	IncrementLoopInfo &innermostInfo = incrementLoopNestInfo.back();
2537
2538	if (innermostInfo.hasLocalitySpecs())
2539	handleLocalitySpecs(info: innermostInfo);
2540
2541	addLoopAnnotationAttr(innermostInfo, dirs);
2542	}
2543	}
2544
2545	/// Generate FIR to end a structured or unstructured increment loop nest.
2546	void genFIRIncrementLoopEnd(IncrementLoopNestInfo &incrementLoopNestInfo) {
2547	assert(!incrementLoopNestInfo.empty() && "empty loop nest");
2548	mlir::Location loc = toLocation();
2549	mlir::arith::IntegerOverflowFlags flags{};
2550	if (!getLoweringOptions().getIntegerWrapAround())
2551	flags = bitEnumSet(flags, mlir::arith::IntegerOverflowFlags::nsw);
2552	auto iofAttr = mlir::arith::IntegerOverflowFlagsAttr::get(
2553	builder->getContext(), flags);
2554	for (auto it = incrementLoopNestInfo.rbegin(),
2555	rend = incrementLoopNestInfo.rend();
2556	it != rend; ++it) {
2557	IncrementLoopInfo &info = *it;
2558	if (info.isStructured()) {
2559	// End fir.do_concurent.loop.
2560	if (info.isConcurrent) {
2561	builder->setInsertionPointAfter(info.loopOp->getParentOp());
2562	continue;
2563	}
2564
2565	// End fir.do_loop.
2566	// Decrement tripVariable.
2567	auto doLoopOp = mlir::cast<fir::DoLoopOp>(info.loopOp);
2568	builder->setInsertionPointToEnd(doLoopOp.getBody());
2569	llvm::SmallVector<mlir::Value, 2> results;
2570	results.push_back(builder->create<mlir::arith::AddIOp>(
2571	loc, doLoopOp.getInductionVar(), doLoopOp.getStep(), iofAttr));
2572	// Step loopVariable to help optimizations such as vectorization.
2573	// Induction variable elimination will clean up as necessary.
2574	mlir::Value step = builder->createConvert(
2575	loc, info.getLoopVariableType(), doLoopOp.getStep());
2576	mlir::Value loopVar =
2577	builder->create<fir::LoadOp>(loc, info.loopVariable);
2578	results.push_back(
2579	builder->create<mlir::arith::AddIOp>(loc, loopVar, step, iofAttr));
2580	builder->create<fir::ResultOp>(loc, results);
2581	builder->setInsertionPointAfter(doLoopOp);
2582	// The loop control variable may be used after the loop.
2583	builder->create<fir::StoreOp>(loc, doLoopOp.getResult(1),
2584	info.loopVariable);
2585	continue;
2586	}
2587
2588	// Unstructured loop - decrement tripVariable and step loopVariable.
2589	mlir::Value tripCount =
2590	builder->create<fir::LoadOp>(loc, info.tripVariable);
2591	mlir::Value one =
2592	builder->createIntegerConstant(loc, tripCount.getType(), 1);
2593	tripCount = builder->create<mlir::arith::SubIOp>(loc, tripCount, one);
2594	builder->create<fir::StoreOp>(loc, tripCount, info.tripVariable);
2595	mlir::Value value = builder->create<fir::LoadOp>(loc, info.loopVariable);
2596	mlir::Value step;
2597	if (info.stepVariable)
2598	step = builder->create<fir::LoadOp>(loc, info.stepVariable);
2599	else
2600	step = genControlValue(info.stepExpr, info);
2601	if (info.hasRealControl)
2602	value = builder->create<mlir::arith::AddFOp>(loc, value, step);
2603	else
2604	value = builder->create<mlir::arith::AddIOp>(loc, value, step, iofAttr);
2605	builder->create<fir::StoreOp>(loc, value, info.loopVariable);
2606
2607	genBranch(info.headerBlock);
2608	if (&info != &incrementLoopNestInfo.front()) // not outermost
2609	startBlock(info.exitBlock); // latch block of enclosing dimension
2610	}
2611	}
2612
2613	/// Generate structured or unstructured FIR for an IF construct.
2614	/// The initial statement may be either an IfStmt or an IfThenStmt.
2615	void genFIR(const Fortran::parser::IfConstruct &) {
2616	Fortran::lower::pft::Evaluation &eval = getEval();
2617
2618	// Structured fir.if nest.
2619	if (eval.lowerAsStructured()) {
2620	fir::IfOp topIfOp, currentIfOp;
2621	for (Fortran::lower::pft::Evaluation &e : eval.getNestedEvaluations()) {
2622	auto genIfOp = [&](mlir::Value cond) {
2623	Fortran::lower::pft::Evaluation &succ = *e.controlSuccessor;
2624	bool hasElse = succ.isA<Fortran::parser::ElseIfStmt>() ||
2625	succ.isA<Fortran::parser::ElseStmt>();
2626	auto ifOp = builder->create<fir::IfOp>(toLocation(), cond,
2627	/*withElseRegion=*/hasElse);
2628	builder->setInsertionPointToStart(&ifOp.getThenRegion().front());
2629	return ifOp;
2630	};
2631	setCurrentPosition(e.position);
2632	if (auto *s = e.getIf<Fortran::parser::IfThenStmt>()) {
2633	topIfOp = currentIfOp = genIfOp(genIfCondition(s, e.negateCondition));
2634	} else if (auto *s = e.getIf<Fortran::parser::IfStmt>()) {
2635	topIfOp = currentIfOp = genIfOp(genIfCondition(s, e.negateCondition));
2636	} else if (auto *s = e.getIf<Fortran::parser::ElseIfStmt>()) {
2637	builder->setInsertionPointToStart(
2638	&currentIfOp.getElseRegion().front());
2639	currentIfOp = genIfOp(genIfCondition(s));
2640	} else if (e.isA<Fortran::parser::ElseStmt>()) {
2641	builder->setInsertionPointToStart(
2642	&currentIfOp.getElseRegion().front());
2643	} else if (e.isA<Fortran::parser::EndIfStmt>()) {
2644	builder->setInsertionPointAfter(topIfOp);
2645	genFIR(e, /*unstructuredContext=*/false); // may generate branch
2646	} else {
2647	genFIR(e, /*unstructuredContext=*/false);
2648	}
2649	}
2650	return;
2651	}
2652
2653	// Unstructured branch sequence.
2654	llvm::SmallVector<Fortran::lower::pft::Evaluation *> exits, fallThroughs;
2655	collectFinalEvaluations(eval, exits, fallThroughs);
2656
2657	for (Fortran::lower::pft::Evaluation &e : eval.getNestedEvaluations()) {
2658	auto genIfBranch = [&](mlir::Value cond) {
2659	if (e.lexicalSuccessor == e.controlSuccessor) // empty block -> exit
2660	genConditionalBranch(cond, e.parentConstruct->constructExit,
2661	e.controlSuccessor);
2662	else // non-empty block
2663	genConditionalBranch(cond, e.lexicalSuccessor, e.controlSuccessor);
2664	};
2665	setCurrentPosition(e.position);
2666	if (auto *s = e.getIf<Fortran::parser::IfThenStmt>()) {
2667	maybeStartBlock(e.block);
2668	genIfBranch(genIfCondition(s, e.negateCondition));
2669	} else if (auto *s = e.getIf<Fortran::parser::IfStmt>()) {
2670	maybeStartBlock(e.block);
2671	genIfBranch(genIfCondition(s, e.negateCondition));
2672	} else if (auto *s = e.getIf<Fortran::parser::ElseIfStmt>()) {
2673	startBlock(e.block);
2674	genIfBranch(genIfCondition(s));
2675	} else {
2676	genFIR(e);
2677	if (blockIsUnterminated()) {
2678	if (llvm::is_contained(exits, &e))
2679	genConstructExitBranch(*eval.constructExit);
2680	else if (llvm::is_contained(fallThroughs, &e))
2681	genBranch(e.lexicalSuccessor->block);
2682	}
2683	}
2684	}
2685	}
2686
2687	void genCaseOrRankConstruct() {
2688	Fortran::lower::pft::Evaluation &eval = getEval();
2689	Fortran::lower::StatementContext stmtCtx;
2690	pushActiveConstruct(eval, stmtCtx);
2691
2692	llvm::SmallVector<Fortran::lower::pft::Evaluation *> exits, fallThroughs;
2693	collectFinalEvaluations(eval, exits, fallThroughs);
2694
2695	for (Fortran::lower::pft::Evaluation &e : eval.getNestedEvaluations()) {
2696	if (e.getIf<Fortran::parser::EndSelectStmt>())
2697	maybeStartBlock(e.block);
2698	else
2699	genFIR(e);
2700	if (blockIsUnterminated()) {
2701	if (llvm::is_contained(exits, &e))
2702	genConstructExitBranch(*eval.constructExit);
2703	else if (llvm::is_contained(fallThroughs, &e))
2704	genBranch(e.lexicalSuccessor->block);
2705	}
2706	}
2707	popActiveConstruct();
2708	}
2709	void genFIR(const Fortran::parser::CaseConstruct &) {
2710	genCaseOrRankConstruct();
2711	}
2712
2713	template <typename A>
2714	void genNestedStatement(const Fortran::parser::Statement<A> &stmt) {
2715	setCurrentPosition(stmt.source);
2716	genFIR(stmt.statement);
2717	}
2718
2719	/// Force the binding of an explicit symbol. This is used to bind and re-bind
2720	/// a concurrent control symbol to its value.
2721	void forceControlVariableBinding(const Fortran::semantics::Symbol *sym,
2722	mlir::Value inducVar) {
2723	mlir::Location loc = toLocation();
2724	assert(sym && "There must be a symbol to bind");
2725	mlir::Type toTy = genType(*sym);
2726	// FIXME: this should be a "per iteration" temporary.
2727	mlir::Value tmp =
2728	builder->createTemporary(loc, toTy, toStringRef(sym->name()),
2729	llvm::ArrayRef<mlir::NamedAttribute>{
2730	fir::getAdaptToByRefAttr(*builder)});
2731	mlir::Value cast = builder->createConvert(loc, toTy, inducVar);
2732	builder->create<fir::StoreOp>(loc, cast, tmp);
2733	addSymbol(*sym, tmp, /*force=*/true);
2734	}
2735
2736	/// Process a concurrent header for a FORALL. (Concurrent headers for DO
2737	/// CONCURRENT loops are lowered elsewhere.)
2738	void genFIR(const Fortran::parser::ConcurrentHeader &header) {
2739	llvm::SmallVector<mlir::Value> lows;
2740	llvm::SmallVector<mlir::Value> highs;
2741	llvm::SmallVector<mlir::Value> steps;
2742	if (explicitIterSpace.isOutermostForall()) {
2743	// For the outermost forall, we evaluate the bounds expressions once.
2744	// Contrastingly, if this forall is nested, the bounds expressions are
2745	// assumed to be pure, possibly dependent on outer concurrent control
2746	// variables, possibly variant with respect to arguments, and will be
2747	// re-evaluated.
2748	mlir::Location loc = toLocation();
2749	mlir::Type idxTy = builder->getIndexType();
2750	Fortran::lower::StatementContext &stmtCtx =
2751	explicitIterSpace.stmtContext();
2752	auto lowerExpr = [&](auto &e) {
2753	return fir::getBase(genExprValue(e, stmtCtx));
2754	};
2755	for (const Fortran::parser::ConcurrentControl &ctrl :
2756	std::get<std::list<Fortran::parser::ConcurrentControl>>(header.t)) {
2757	const Fortran::lower::SomeExpr *lo =
2758	Fortran::semantics::GetExpr(std::get<1>(ctrl.t));
2759	const Fortran::lower::SomeExpr *hi =
2760	Fortran::semantics::GetExpr(std::get<2>(ctrl.t));
2761	auto &optStep =
2762	std::get<std::optional<Fortran::parser::ScalarIntExpr>>(ctrl.t);
2763	lows.push_back(builder->createConvert(loc, idxTy, lowerExpr(*lo)));
2764	highs.push_back(builder->createConvert(loc, idxTy, lowerExpr(*hi)));
2765	steps.push_back(
2766	optStep.has_value()
2767	? builder->createConvert(
2768	loc, idxTy,
2769	lowerExpr(*Fortran::semantics::GetExpr(*optStep)))
2770	: builder->createIntegerConstant(loc, idxTy, 1));
2771	}
2772	}
2773	auto lambda = [&, lows, highs, steps]() {
2774	// Create our iteration space from the header spec.
2775	mlir::Location loc = toLocation();
2776	mlir::Type idxTy = builder->getIndexType();
2777	llvm::SmallVector<fir::DoLoopOp> loops;
2778	Fortran::lower::StatementContext &stmtCtx =
2779	explicitIterSpace.stmtContext();
2780	auto lowerExpr = [&](auto &e) {
2781	return fir::getBase(genExprValue(e, stmtCtx));
2782	};
2783	const bool outermost = !lows.empty();
2784	std::size_t headerIndex = 0;
2785	for (const Fortran::parser::ConcurrentControl &ctrl :
2786	std::get<std::list<Fortran::parser::ConcurrentControl>>(header.t)) {
2787	const Fortran::semantics::Symbol *ctrlVar =
2788	std::get<Fortran::parser::Name>(ctrl.t).symbol;
2789	mlir::Value lb;
2790	mlir::Value ub;
2791	mlir::Value by;
2792	if (outermost) {
2793	assert(headerIndex < lows.size());
2794	if (headerIndex == 0)
2795	explicitIterSpace.resetInnerArgs();
2796	lb = lows[headerIndex];
2797	ub = highs[headerIndex];
2798	by = steps[headerIndex++];
2799	} else {
2800	const Fortran::lower::SomeExpr *lo =
2801	Fortran::semantics::GetExpr(std::get<1>(ctrl.t));
2802	const Fortran::lower::SomeExpr *hi =
2803	Fortran::semantics::GetExpr(std::get<2>(ctrl.t));
2804	auto &optStep =
2805	std::get<std::optional<Fortran::parser::ScalarIntExpr>>(ctrl.t);
2806	lb = builder->createConvert(loc, idxTy, lowerExpr(*lo));
2807	ub = builder->createConvert(loc, idxTy, lowerExpr(*hi));
2808	by = optStep.has_value()
2809	? builder->createConvert(
2810	loc, idxTy,
2811	lowerExpr(*Fortran::semantics::GetExpr(*optStep)))
2812	: builder->createIntegerConstant(loc, idxTy, 1);
2813	}
2814	auto lp = builder->create<fir::DoLoopOp>(
2815	loc, lb, ub, by, /*unordered=*/true,
2816	/*finalCount=*/false, explicitIterSpace.getInnerArgs());
2817	if ((!loops.empty() || !outermost) && !lp.getRegionIterArgs().empty())
2818	builder->create<fir::ResultOp>(loc, lp.getResults());
2819	explicitIterSpace.setInnerArgs(lp.getRegionIterArgs());
2820	builder->setInsertionPointToStart(lp.getBody());
2821	forceControlVariableBinding(ctrlVar, lp.getInductionVar());
2822	loops.push_back(lp);
2823	}
2824	if (outermost)
2825	explicitIterSpace.setOuterLoop(loops[0]);
2826	explicitIterSpace.appendLoops(loops);
2827	if (const auto &mask =
2828	std::get<std::optional<Fortran::parser::ScalarLogicalExpr>>(
2829	header.t);
2830	mask.has_value()) {
2831	mlir::Type i1Ty = builder->getI1Type();
2832	fir::ExtendedValue maskExv =
2833	genExprValue(*Fortran::semantics::GetExpr(mask.value()), stmtCtx);
2834	mlir::Value cond =
2835	builder->createConvert(loc, i1Ty, fir::getBase(maskExv));
2836	auto ifOp = builder->create<fir::IfOp>(
2837	loc, explicitIterSpace.innerArgTypes(), cond,
2838	/*withElseRegion=*/true);
2839	builder->create<fir::ResultOp>(loc, ifOp.getResults());
2840	builder->setInsertionPointToStart(&ifOp.getElseRegion().front());
2841	builder->create<fir::ResultOp>(loc, explicitIterSpace.getInnerArgs());
2842	builder->setInsertionPointToStart(&ifOp.getThenRegion().front());
2843	}
2844	};
2845	// Push the lambda to gen the loop nest context.
2846	explicitIterSpace.pushLoopNest(lambda);
2847	}
2848
2849	void genFIR(const Fortran::parser::ForallAssignmentStmt &stmt) {
2850	Fortran::common::visit([&](const auto &x) { genFIR(x); }, stmt.u);
2851	}
2852
2853	void genFIR(const Fortran::parser::EndForallStmt &) {
2854	if (!lowerToHighLevelFIR())
2855	cleanupExplicitSpace();
2856	}
2857
2858	template <typename A>
2859	void prepareExplicitSpace(const A &forall) {
2860	if (!explicitIterSpace.isActive())
2861	analyzeExplicitSpace(forall);
2862	localSymbols.pushScope();
2863	explicitIterSpace.enter();
2864	}
2865
2866	/// Cleanup all the FORALL context information when we exit.
2867	void cleanupExplicitSpace() {
2868	explicitIterSpace.leave();
2869	localSymbols.popScope();
2870	}
2871
2872	/// Generate FIR for a FORALL statement.
2873	void genFIR(const Fortran::parser::ForallStmt &stmt) {
2874	const auto &concurrentHeader =
2875	std::get<
2876	Fortran::common::Indirection<Fortran::parser::ConcurrentHeader>>(
2877	stmt.t)
2878	.value();
2879	if (lowerToHighLevelFIR()) {
2880	mlir::OpBuilder::InsertionGuard guard(*builder);
2881	Fortran::lower::SymMapScope scope(localSymbols);
2882	genForallNest(concurrentHeader);
2883	genFIR(std::get<Fortran::parser::UnlabeledStatement<
2884	Fortran::parser::ForallAssignmentStmt>>(stmt.t)
2885	.statement);
2886	return;
2887	}
2888	prepareExplicitSpace(stmt);
2889	genFIR(concurrentHeader);
2890	genFIR(std::get<Fortran::parser::UnlabeledStatement<
2891	Fortran::parser::ForallAssignmentStmt>>(stmt.t)
2892	.statement);
2893	cleanupExplicitSpace();
2894	}
2895
2896	/// Generate FIR for a FORALL construct.
2897	void genFIR(const Fortran::parser::ForallConstruct &forall) {
2898	mlir::OpBuilder::InsertPoint insertPt = builder->saveInsertionPoint();
2899	if (lowerToHighLevelFIR())
2900	localSymbols.pushScope();
2901	else
2902	prepareExplicitSpace(forall);
2903	genNestedStatement(
2904	std::get<
2905	Fortran::parser::Statement<Fortran::parser::ForallConstructStmt>>(
2906	forall.t));
2907	for (const Fortran::parser::ForallBodyConstruct &s :
2908	std::get<std::list<Fortran::parser::ForallBodyConstruct>>(forall.t)) {
2909	Fortran::common::visit(
2910	Fortran::common::visitors{
2911	[&](const Fortran::parser::WhereConstruct &b) { genFIR(b); },
2912	[&](const Fortran::common::Indirection<
2913	Fortran::parser::ForallConstruct> &b) { genFIR(b.value()); },
2914	[&](const auto &b) { genNestedStatement(b); }},
2915	s.u);
2916	}
2917	genNestedStatement(
2918	std::get<Fortran::parser::Statement<Fortran::parser::EndForallStmt>>(
2919	forall.t));
2920	if (lowerToHighLevelFIR()) {
2921	localSymbols.popScope();
2922	builder->restoreInsertionPoint(insertPt);
2923	}
2924	}
2925
2926	/// Lower the concurrent header specification.
2927	void genFIR(const Fortran::parser::ForallConstructStmt &stmt) {
2928	const auto &concurrentHeader =
2929	std::get<
2930	Fortran::common::Indirection<Fortran::parser::ConcurrentHeader>>(
2931	stmt.t)
2932	.value();
2933	if (lowerToHighLevelFIR())
2934	genForallNest(concurrentHeader);
2935	else
2936	genFIR(concurrentHeader);
2937	}
2938
2939	/// Generate hlfir.forall and hlfir.forall_mask nest given a Forall
2940	/// concurrent header
2941	void genForallNest(const Fortran::parser::ConcurrentHeader &header) {
2942	mlir::Location loc = getCurrentLocation();
2943	const bool isOutterForall = !isInsideHlfirForallOrWhere();
2944	hlfir::ForallOp outerForall;
2945	auto evaluateControl = [&](const auto &parserExpr, mlir::Region &region,
2946	bool isMask = false) {
2947	if (region.empty())
2948	builder->createBlock(&region);
2949	Fortran::lower::StatementContext localStmtCtx;
2950	const Fortran::semantics::SomeExpr *anlalyzedExpr =
2951	Fortran::semantics::GetExpr(parserExpr);
2952	assert(anlalyzedExpr && "expression semantics failed");
2953	// Generate the controls of outer forall outside of the hlfir.forall
2954	// region. They do not depend on any previous forall indices (C1123) and
2955	// no assignment has been made yet that could modify their value. This
2956	// will simplify hlfir.forall analysis because the SSA integer value
2957	// yielded will obviously not depend on any variable modified by the
2958	// forall when produced outside of it.
2959	// This is not done for the mask because it may (and in usual code, does)
2960	// depend on the forall indices that have just been defined as
2961	// hlfir.forall block arguments.
2962	mlir::OpBuilder::InsertPoint innerInsertionPoint;
2963	if (outerForall && !isMask) {
2964	innerInsertionPoint = builder->saveInsertionPoint();
2965	builder->setInsertionPoint(outerForall);
2966	}
2967	mlir::Value exprVal =
2968	fir::getBase(genExprValue(*anlalyzedExpr, localStmtCtx, &loc));
2969	localStmtCtx.finalizeAndPop();
2970	if (isMask)
2971	exprVal = builder->createConvert(loc, builder->getI1Type(), exprVal);
2972	if (innerInsertionPoint.isSet())
2973	builder->restoreInsertionPoint(innerInsertionPoint);
2974	builder->create<hlfir::YieldOp>(loc, exprVal);
2975	};
2976	for (const Fortran::parser::ConcurrentControl &control :
2977	std::get<std::list<Fortran::parser::ConcurrentControl>>(header.t)) {
2978	auto forallOp = builder->create<hlfir::ForallOp>(loc);
2979	if (isOutterForall && !outerForall)
2980	outerForall = forallOp;
2981	evaluateControl(std::get<1>(control.t), forallOp.getLbRegion());
2982	evaluateControl(std::get<2>(control.t), forallOp.getUbRegion());
2983	if (const auto &optionalStep =
2984	std::get<std::optional<Fortran::parser::ScalarIntExpr>>(
2985	control.t))
2986	evaluateControl(*optionalStep, forallOp.getStepRegion());
2987	// Create block argument and map it to a symbol via an hlfir.forall_index
2988	// op (symbols must be mapped to in memory values).
2989	const Fortran::semantics::Symbol *controlVar =
2990	std::get<Fortran::parser::Name>(control.t).symbol;
2991	assert(controlVar && "symbol analysis failed");
2992	mlir::Type controlVarType = genType(*controlVar);
2993	mlir::Block *forallBody = builder->createBlock(&forallOp.getBody(), {},
2994	{controlVarType}, {loc});
2995	auto forallIndex = builder->create<hlfir::ForallIndexOp>(
2996	loc, fir::ReferenceType::get(controlVarType),
2997	forallBody->getArguments()[0],
2998	builder->getStringAttr(controlVar->name().ToString()));
2999	localSymbols.addVariableDefinition(*controlVar, forallIndex,
3000	/*force=*/true);
3001	auto end = builder->create<fir::FirEndOp>(loc);
3002	builder->setInsertionPoint(end);
3003	}
3004
3005	if (const auto &maskExpr =
3006	std::get<std::optional<Fortran::parser::ScalarLogicalExpr>>(
3007	header.t)) {
3008	// Create hlfir.forall_mask and set insertion point in its body.
3009	auto forallMaskOp = builder->create<hlfir::ForallMaskOp>(loc);
3010	evaluateControl(*maskExpr, forallMaskOp.getMaskRegion(), /*isMask=*/true);
3011	builder->createBlock(&forallMaskOp.getBody());
3012	auto end = builder->create<fir::FirEndOp>(loc);
3013	builder->setInsertionPoint(end);
3014	}
3015	}
3016
3017	void attachDirectiveToLoop(const Fortran::parser::CompilerDirective &dir,
3018	Fortran::lower::pft::Evaluation *e) {
3019	while (e->isDirective())
3020	e = e->lexicalSuccessor;
3021
3022	if (e->isA<Fortran::parser::NonLabelDoStmt>())
3023	e->dirs.push_back(&dir);
3024	}
3025
3026	void genFIR(const Fortran::parser::CompilerDirective &dir) {
3027	Fortran::lower::pft::Evaluation &eval = getEval();
3028
3029	Fortran::common::visit(
3030	Fortran::common::visitors{
3031	[&](const Fortran::parser::CompilerDirective::VectorAlways &) {
3032	attachDirectiveToLoop(dir, &eval);
3033	},
3034	[&](const Fortran::parser::CompilerDirective::Unroll &) {
3035	attachDirectiveToLoop(dir, &eval);
3036	},
3037	[&](const Fortran::parser::CompilerDirective::UnrollAndJam &) {
3038	attachDirectiveToLoop(dir, &eval);
3039	},
3040	[&](const Fortran::parser::CompilerDirective::NoVector &) {
3041	attachDirectiveToLoop(dir, &eval);
3042	},
3043	[&](const Fortran::parser::CompilerDirective::NoUnroll &) {
3044	attachDirectiveToLoop(dir, &eval);
3045	},
3046	[&](const Fortran::parser::CompilerDirective::NoUnrollAndJam &) {
3047	attachDirectiveToLoop(dir, &eval);
3048	},
3049	[&](const auto &) {}},
3050	dir.u);
3051	}
3052
3053	void genFIR(const Fortran::parser::OpenACCConstruct &acc) {
3054	mlir::OpBuilder::InsertPoint insertPt = builder->saveInsertionPoint();
3055	localSymbols.pushScope();
3056	mlir::Value exitCond = genOpenACCConstruct(
3057	*this, bridge.getSemanticsContext(), getEval(), acc);
3058
3059	const Fortran::parser::OpenACCLoopConstruct *accLoop =
3060	std::get_if<Fortran::parser::OpenACCLoopConstruct>(&acc.u);
3061	const Fortran::parser::OpenACCCombinedConstruct *accCombined =
3062	std::get_if<Fortran::parser::OpenACCCombinedConstruct>(&acc.u);
3063
3064	Fortran::lower::pft::Evaluation *curEval = &getEval();
3065
3066	if (accLoop || accCombined) {
3067	int64_t collapseValue;
3068	if (accLoop) {
3069	const Fortran::parser::AccBeginLoopDirective &beginLoopDir =
3070	std::get<Fortran::parser::AccBeginLoopDirective>(accLoop->t);
3071	const Fortran::parser::AccClauseList &clauseList =
3072	std::get<Fortran::parser::AccClauseList>(beginLoopDir.t);
3073	collapseValue = Fortran::lower::getCollapseValue(clauseList);
3074	} else if (accCombined) {
3075	const Fortran::parser::AccBeginCombinedDirective &beginCombinedDir =
3076	std::get<Fortran::parser::AccBeginCombinedDirective>(
3077	accCombined->t);
3078	const Fortran::parser::AccClauseList &clauseList =
3079	std::get<Fortran::parser::AccClauseList>(beginCombinedDir.t);
3080	collapseValue = Fortran::lower::getCollapseValue(clauseList);
3081	}
3082
3083	if (curEval->lowerAsStructured()) {
3084	curEval = &curEval->getFirstNestedEvaluation();
3085	for (int64_t i = 1; i < collapseValue; i++)
3086	curEval = &*std::next(curEval->getNestedEvaluations().begin());
3087	}
3088	}
3089
3090	for (Fortran::lower::pft::Evaluation &e : curEval->getNestedEvaluations())
3091	genFIR(e);
3092	localSymbols.popScope();
3093	builder->restoreInsertionPoint(insertPt);
3094
3095	if (accLoop && exitCond) {
3096	Fortran::lower::pft::FunctionLikeUnit *funit =
3097	getEval().getOwningProcedure();
3098	assert(funit && "not inside main program, function or subroutine");
3099	mlir::Block *continueBlock =
3100	builder->getBlock()->splitBlock(builder->getBlock()->end());
3101	builder->create<mlir::cf::CondBranchOp>(toLocation(), exitCond,
3102	funit->finalBlock, continueBlock);
3103	builder->setInsertionPointToEnd(continueBlock);
3104	}
3105	}
3106
3107	void genFIR(const Fortran::parser::OpenACCDeclarativeConstruct &accDecl) {
3108	genOpenACCDeclarativeConstruct(*this, bridge.getSemanticsContext(),
3109	bridge.openAccCtx(), accDecl);
3110	for (Fortran::lower::pft::Evaluation &e : getEval().getNestedEvaluations())
3111	genFIR(e);
3112	}
3113
3114	void genFIR(const Fortran::parser::OpenACCRoutineConstruct &acc) {
3115	// Handled by genFIR(const Fortran::parser::OpenACCDeclarativeConstruct &)
3116	}
3117
3118	void genFIR(const Fortran::parser::CUFKernelDoConstruct &kernel) {
3119	Fortran::lower::SymMapScope scope(localSymbols);
3120	const Fortran::parser::CUFKernelDoConstruct::Directive &dir =
3121	std::get<Fortran::parser::CUFKernelDoConstruct::Directive>(kernel.t);
3122
3123	mlir::Location loc = genLocation(dir.source);
3124
3125	Fortran::lower::StatementContext stmtCtx;
3126
3127	unsigned nestedLoops = 1;
3128
3129	const auto &nLoops =
3130	std::get<std::optional<Fortran::parser::ScalarIntConstantExpr>>(dir.t);
3131	if (nLoops)
3132	nestedLoops = *Fortran::semantics::GetIntValue(*nLoops);
3133
3134	mlir::IntegerAttr n;
3135	if (nestedLoops > 1)
3136	n = builder->getIntegerAttr(builder->getI64Type(), nestedLoops);
3137
3138	const auto &launchConfig = std::get<std::optional<
3139	Fortran::parser::CUFKernelDoConstruct::LaunchConfiguration>>(dir.t);
3140
3141	const std::list<Fortran::parser::CUFReduction> &cufreds =
3142	std::get<2>(dir.t);
3143
3144	llvm::SmallVector<mlir::Value> reduceOperands;
3145	llvm::SmallVector<mlir::Attribute> reduceAttrs;
3146
3147	for (const Fortran::parser::CUFReduction &cufred : cufreds) {
3148	fir::ReduceOperationEnum redOpEnum = getReduceOperationEnum(
3149	std::get<Fortran::parser::ReductionOperator>(cufred.t));
3150	const std::list<Fortran::parser::Scalar<Fortran::parser::Variable>>
3151	&scalarvars = std::get<1>(cufred.t);
3152	for (const Fortran::parser::Scalar<Fortran::parser::Variable> &scalarvar :
3153	scalarvars) {
3154	auto reduce_attr =
3155	fir::ReduceAttr::get(builder->getContext(), redOpEnum);
3156	reduceAttrs.push_back(reduce_attr);
3157	const Fortran::parser::Variable &var = scalarvar.thing;
3158	if (const auto *iDesignator = std::get_if<
3159	Fortran::common::Indirection<Fortran::parser::Designator>>(
3160	&var.u)) {
3161	const Fortran::parser::Designator &designator = iDesignator->value();
3162	if (const auto *name =
3163	Fortran::semantics::getDesignatorNameIfDataRef(designator)) {
3164	auto val = getSymbolAddress(*name->symbol);
3165	reduceOperands.push_back(val);
3166	}
3167	}
3168	}
3169	}
3170
3171	auto isOnlyStars =
3172	[&](const std::list<Fortran::parser::CUFKernelDoConstruct::StarOrExpr>
3173	&list) -> bool {
3174	for (const Fortran::parser::CUFKernelDoConstruct::StarOrExpr &expr :
3175	list) {
3176	if (expr.v)
3177	return false;
3178	}
3179	return true;
3180	};
3181
3182	mlir::Value zero =
3183	builder->createIntegerConstant(loc, builder->getI32Type(), 0);
3184
3185	llvm::SmallVector<mlir::Value> gridValues;
3186	llvm::SmallVector<mlir::Value> blockValues;
3187	mlir::Value streamAddr;
3188
3189	if (launchConfig) {
3190	const std::list<Fortran::parser::CUFKernelDoConstruct::StarOrExpr> &grid =
3191	std::get<0>(launchConfig->t);
3192	const std::list<Fortran::parser::CUFKernelDoConstruct::StarOrExpr>
3193	&block = std::get<1>(launchConfig->t);
3194	const std::optional<Fortran::parser::ScalarIntExpr> &stream =
3195	std::get<2>(launchConfig->t);
3196	if (!isOnlyStars(grid)) {
3197	for (const Fortran::parser::CUFKernelDoConstruct::StarOrExpr &expr :
3198	grid) {
3199	if (expr.v) {
3200	gridValues.push_back(fir::getBase(
3201	genExprValue(*Fortran::semantics::GetExpr(*expr.v), stmtCtx)));
3202	} else {
3203	gridValues.push_back(zero);
3204	}
3205	}
3206	}
3207	if (!isOnlyStars(block)) {
3208	for (const Fortran::parser::CUFKernelDoConstruct::StarOrExpr &expr :
3209	block) {
3210	if (expr.v) {
3211	blockValues.push_back(fir::getBase(
3212	genExprValue(*Fortran::semantics::GetExpr(*expr.v), stmtCtx)));
3213	} else {
3214	blockValues.push_back(zero);
3215	}
3216	}
3217	}
3218
3219	if (stream)
3220	streamAddr = fir::getBase(
3221	genExprAddr(*Fortran::semantics::GetExpr(*stream), stmtCtx));
3222	}
3223
3224	const auto &outerDoConstruct =
3225	std::get<std::optional<Fortran::parser::DoConstruct>>(kernel.t);
3226
3227	llvm::SmallVector<mlir::Location> locs;
3228	locs.push_back(loc);
3229	llvm::SmallVector<mlir::Value> lbs, ubs, steps;
3230
3231	mlir::Type idxTy = builder->getIndexType();
3232
3233	llvm::SmallVector<mlir::Type> ivTypes;
3234	llvm::SmallVector<mlir::Location> ivLocs;
3235	llvm::SmallVector<mlir::Value> ivValues;
3236	Fortran::lower::pft::Evaluation *loopEval =
3237	&getEval().getFirstNestedEvaluation();
3238	if (outerDoConstruct->IsDoConcurrent()) {
3239	// Handle DO CONCURRENT
3240	locs.push_back(
3241	genLocation(Fortran::parser::FindSourceLocation(outerDoConstruct)));
3242	const Fortran::parser::LoopControl *loopControl =
3243	&*outerDoConstruct->GetLoopControl();
3244	const auto &concurrent =
3245	std::get<Fortran::parser::LoopControl::Concurrent>(loopControl->u);
3246
3247	if (!std::get<std::list<Fortran::parser::LocalitySpec>>(concurrent.t)
3248	.empty())
3249	TODO(loc, "DO CONCURRENT with locality spec");
3250
3251	const auto &concurrentHeader =
3252	std::get<Fortran::parser::ConcurrentHeader>(concurrent.t);
3253	const auto &controls =
3254	std::get<std::list<Fortran::parser::ConcurrentControl>>(
3255	concurrentHeader.t);
3256
3257	for (const auto &control : controls) {
3258	mlir::Value lb = fir::getBase(genExprValue(
3259	*Fortran::semantics::GetExpr(std::get<1>(control.t)), stmtCtx));
3260	mlir::Value ub = fir::getBase(genExprValue(
3261	*Fortran::semantics::GetExpr(std::get<2>(control.t)), stmtCtx));
3262	mlir::Value step;
3263
3264	if (const auto &expr =
3265	std::get<std::optional<Fortran::parser::ScalarIntExpr>>(
3266	control.t))
3267	step = fir::getBase(
3268	genExprValue(*Fortran::semantics::GetExpr(*expr), stmtCtx));
3269	else
3270	step = builder->create<mlir::arith::ConstantIndexOp>(
3271	loc, 1); // Use index type directly
3272
3273	// Ensure lb, ub, and step are of index type using fir.convert
3274	lb = builder->create<fir::ConvertOp>(loc, idxTy, lb);
3275	ub = builder->create<fir::ConvertOp>(loc, idxTy, ub);
3276	step = builder->create<fir::ConvertOp>(loc, idxTy, step);
3277
3278	lbs.push_back(lb);
3279	ubs.push_back(ub);
3280	steps.push_back(step);
3281
3282	const auto &name = std::get<Fortran::parser::Name>(control.t);
3283
3284	// Handle induction variable
3285	mlir::Value ivValue = getSymbolAddress(*name.symbol);
3286
3287	if (!ivValue) {
3288	// DO CONCURRENT induction variables are not mapped yet since they are
3289	// local to the DO CONCURRENT scope.
3290	mlir::OpBuilder::InsertPoint insPt = builder->saveInsertionPoint();
3291	builder->setInsertionPointToStart(builder->getAllocaBlock());
3292	ivValue = builder->createTemporaryAlloc(
3293	loc, idxTy, toStringRef(name.symbol->name()));
3294	builder->restoreInsertionPoint(insPt);
3295	}
3296
3297	// Bind the symbol to the declared variable
3298	bindSymbol(*name.symbol, ivValue);
3299	Fortran::lower::SymbolBox hsb = localSymbols.lookupSymbol(*name.symbol);
3300	fir::ExtendedValue extIvValue = symBoxToExtendedValue(hsb);
3301	ivValue = fir::getBase(extIvValue);
3302	ivValues.push_back(ivValue);
3303	ivTypes.push_back(idxTy);
3304	ivLocs.push_back(loc);
3305	}
3306	} else {
3307	for (unsigned i = 0; i < nestedLoops; ++i) {
3308	const Fortran::parser::LoopControl *loopControl;
3309	mlir::Location crtLoc = loc;
3310	if (i == 0) {
3311	loopControl = &*outerDoConstruct->GetLoopControl();
3312	crtLoc = genLocation(
3313	Fortran::parser::FindSourceLocation(outerDoConstruct));
3314	} else {
3315	auto *doCons = loopEval->getIf<Fortran::parser::DoConstruct>();
3316	assert(doCons && "expect do construct");
3317	loopControl = &*doCons->GetLoopControl();
3318	crtLoc = genLocation(Fortran::parser::FindSourceLocation(*doCons));
3319	}
3320
3321	locs.push_back(crtLoc);
3322
3323	const Fortran::parser::LoopControl::Bounds *bounds =
3324	std::get_if<Fortran::parser::LoopControl::Bounds>(&loopControl->u);
3325	assert(bounds && "Expected bounds on the loop construct");
3326
3327	Fortran::semantics::Symbol &ivSym =
3328	bounds->name.thing.symbol->GetUltimate();
3329	ivValues.push_back(getSymbolAddress(ivSym));
3330
3331	lbs.push_back(builder->createConvert(
3332	crtLoc, idxTy,
3333	fir::getBase(genExprValue(
3334	*Fortran::semantics::GetExpr(bounds->lower), stmtCtx))));
3335	ubs.push_back(builder->createConvert(
3336	crtLoc, idxTy,
3337	fir::getBase(genExprValue(
3338	*Fortran::semantics::GetExpr(bounds->upper), stmtCtx))));
3339	if (bounds->step)
3340	steps.push_back(builder->createConvert(
3341	crtLoc, idxTy,
3342	fir::getBase(genExprValue(
3343	*Fortran::semantics::GetExpr(bounds->step), stmtCtx))));
3344	else // If `step` is not present, assume it is `1`.
3345	steps.push_back(builder->createIntegerConstant(loc, idxTy, 1));
3346
3347	ivTypes.push_back(idxTy);
3348	ivLocs.push_back(crtLoc);
3349	if (i < nestedLoops - 1)
3350	loopEval = &*std::next(loopEval->getNestedEvaluations().begin());
3351	}
3352	}
3353
3354	auto op = builder->create<cuf::KernelOp>(
3355	loc, gridValues, blockValues, streamAddr, lbs, ubs, steps, n,
3356	mlir::ValueRange(reduceOperands), builder->getArrayAttr(reduceAttrs));
3357	builder->createBlock(&op.getRegion(), op.getRegion().end(), ivTypes,
3358	ivLocs);
3359	mlir::Block &b = op.getRegion().back();
3360	builder->setInsertionPointToStart(&b);
3361
3362	Fortran::lower::pft::Evaluation *crtEval = &getEval();
3363	if (crtEval->lowerAsUnstructured())
3364	Fortran::lower::createEmptyRegionBlocks<fir::FirEndOp>(
3365	*builder, crtEval->getNestedEvaluations());
3366	builder->setInsertionPointToStart(&b);
3367
3368	for (auto [arg, value] : llvm::zip(
3369	op.getLoopRegions().front()->front().getArguments(), ivValues)) {
3370	mlir::Value convArg =
3371	builder->createConvert(loc, fir::unwrapRefType(value.getType()), arg);
3372	builder->create<fir::StoreOp>(loc, convArg, value);
3373	}
3374
3375	if (crtEval->lowerAsStructured()) {
3376	crtEval = &crtEval->getFirstNestedEvaluation();
3377	for (int64_t i = 1; i < nestedLoops; i++)
3378	crtEval = &*std::next(crtEval->getNestedEvaluations().begin());
3379	}
3380
3381	// Generate loop body
3382	for (Fortran::lower::pft::Evaluation &e : crtEval->getNestedEvaluations())
3383	genFIR(e);
3384
3385	builder->create<fir::FirEndOp>(loc);
3386	builder->setInsertionPointAfter(op);
3387	}
3388
3389	void genFIR(const Fortran::parser::OpenMPConstruct &omp) {
3390	mlir::OpBuilder::InsertPoint insertPt = builder->saveInsertionPoint();
3391	genOpenMPConstruct(*this, localSymbols, bridge.getSemanticsContext(),
3392	getEval(), omp);
3393	builder->restoreInsertionPoint(insertPt);
3394
3395	// Register if a target region was found
3396	ompDeviceCodeFound =
3397	ompDeviceCodeFound || Fortran::lower::isOpenMPTargetConstruct(omp);
3398	}
3399
3400	void genFIR(const Fortran::parser::OpenMPDeclarativeConstruct &ompDecl) {
3401	mlir::OpBuilder::InsertPoint insertPt = builder->saveInsertionPoint();
3402	// Register if a declare target construct intended for a target device was
3403	// found
3404	ompDeviceCodeFound =
3405	ompDeviceCodeFound ||
3406	Fortran::lower::isOpenMPDeviceDeclareTarget(
3407	*this, bridge.getSemanticsContext(), getEval(), ompDecl);
3408	Fortran::lower::gatherOpenMPDeferredDeclareTargets(
3409	*this, bridge.getSemanticsContext(), getEval(), ompDecl,
3410	ompDeferredDeclareTarget);
3411	genOpenMPDeclarativeConstruct(
3412	*this, localSymbols, bridge.getSemanticsContext(), getEval(), ompDecl);
3413	builder->restoreInsertionPoint(insertPt);
3414	}
3415
3416	/// Generate FIR for a SELECT CASE statement.
3417	/// The selector may have CHARACTER, INTEGER, UNSIGNED, or LOGICAL type.
3418	void genFIR(const Fortran::parser::SelectCaseStmt &stmt) {
3419	Fortran::lower::pft::Evaluation &eval = getEval();
3420	Fortran::lower::pft::Evaluation *parentConstruct = eval.parentConstruct;
3421	assert(!activeConstructStack.empty() &&
3422	&activeConstructStack.back().eval == parentConstruct &&
3423	"select case construct is not active");
3424	Fortran::lower::StatementContext &stmtCtx =
3425	activeConstructStack.back().stmtCtx;
3426	const Fortran::lower::SomeExpr *expr = Fortran::semantics::GetExpr(
3427	std::get<Fortran::parser::Scalar<Fortran::parser::Expr>>(stmt.t));
3428	bool isCharSelector = isCharacterCategory(expr->GetType()->category());
3429	bool isLogicalSelector = isLogicalCategory(expr->GetType()->category());
3430	mlir::MLIRContext *context = builder->getContext();
3431	mlir::Location loc = toLocation();
3432	auto charValue = [&](const Fortran::lower::SomeExpr *expr) {
3433	fir::ExtendedValue exv = genExprAddr(*expr, stmtCtx, &loc);
3434	return exv.match(
3435	[&](const fir::CharBoxValue &cbv) {
3436	return fir::factory::CharacterExprHelper{*builder, loc}
3437	.createEmboxChar(cbv.getAddr(), cbv.getLen());
3438	},
3439	[&](auto) {
3440	fir::emitFatalError(loc, "not a character");
3441	return mlir::Value{};
3442	});
3443	};
3444	mlir::Value selector;
3445	if (isCharSelector) {
3446	selector = charValue(expr);
3447	} else {
3448	selector = createFIRExpr(loc, expr, stmtCtx);
3449	if (isLogicalSelector)
3450	selector = builder->createConvert(loc, builder->getI1Type(), selector);
3451	}
3452	mlir::Type selectType = selector.getType();
3453	if (selectType.isUnsignedInteger())
3454	selectType = mlir::IntegerType::get(
3455	builder->getContext(), selectType.getIntOrFloatBitWidth(),
3456	mlir::IntegerType::SignednessSemantics::Signless);
3457	llvm::SmallVector<mlir::Attribute> attrList;
3458	llvm::SmallVector<mlir::Value> valueList;
3459	llvm::SmallVector<mlir::Block *> blockList;
3460	mlir::Block *defaultBlock = parentConstruct->constructExit->block;
3461	using CaseValue = Fortran::parser::Scalar<Fortran::parser::ConstantExpr>;
3462	auto addValue = [&](const CaseValue &caseValue) {
3463	const Fortran::lower::SomeExpr *expr =
3464	Fortran::semantics::GetExpr(caseValue.thing);
3465	if (isCharSelector)
3466	valueList.push_back(charValue(expr));
3467	else if (isLogicalSelector)
3468	valueList.push_back(builder->createConvert(
3469	loc, selectType, createFIRExpr(toLocation(), expr, stmtCtx)));
3470	else {
3471	valueList.push_back(builder->createIntegerConstant(
3472	loc, selectType, *Fortran::evaluate::ToInt64(*expr)));
3473	}
3474	};
3475	for (Fortran::lower::pft::Evaluation *e = eval.controlSuccessor; e;
3476	e = e->controlSuccessor) {
3477	const auto &caseStmt = e->getIf<Fortran::parser::CaseStmt>();
3478	assert(e->block && "missing CaseStmt block");
3479	const auto &caseSelector =
3480	std::get<Fortran::parser::CaseSelector>(caseStmt->t);
3481	const auto *caseValueRangeList =
3482	std::get_if<std::list<Fortran::parser::CaseValueRange>>(
3483	&caseSelector.u);
3484	if (!caseValueRangeList) {
3485	defaultBlock = e->block;
3486	continue;
3487	}
3488	for (const Fortran::parser::CaseValueRange &caseValueRange :
3489	*caseValueRangeList) {
3490	blockList.push_back(e->block);
3491	if (const auto *caseValue = std::get_if<CaseValue>(&caseValueRange.u)) {
3492	attrList.push_back(fir::PointIntervalAttr::get(context));
3493	addValue(*caseValue);
3494	continue;
3495	}
3496	const auto &caseRange =
3497	std::get<Fortran::parser::CaseValueRange::Range>(caseValueRange.u);
3498	if (caseRange.lower && caseRange.upper) {
3499	attrList.push_back(fir::ClosedIntervalAttr::get(context));
3500	addValue(*caseRange.lower);
3501	addValue(*caseRange.upper);
3502	} else if (caseRange.lower) {
3503	attrList.push_back(fir::LowerBoundAttr::get(context));
3504	addValue(*caseRange.lower);
3505	} else {
3506	attrList.push_back(fir::UpperBoundAttr::get(context));
3507	addValue(*caseRange.upper);
3508	}
3509	}
3510	}
3511	// Skip a logical default block that can never be referenced.
3512	if (isLogicalSelector && attrList.size() == 2)
3513	defaultBlock = parentConstruct->constructExit->block;
3514	attrList.push_back(mlir::UnitAttr::get(context));
3515	blockList.push_back(defaultBlock);
3516
3517	// Generate a fir::SelectCaseOp. Explicit branch code is better for the
3518	// LOGICAL type. The CHARACTER type does not have downstream SelectOp
3519	// support. The -no-structured-fir option can be used to force generation
3520	// of INTEGER type branch code.
3521	if (!isLogicalSelector && !isCharSelector &&
3522	!getEval().forceAsUnstructured()) {
3523	// The selector is in an ssa register. Any temps that may have been
3524	// generated while evaluating it can be cleaned up now.
3525	stmtCtx.finalizeAndReset();
3526	builder->create<fir::SelectCaseOp>(loc, selector, attrList, valueList,
3527	blockList);
3528	return;
3529	}
3530
3531	// Generate a sequence of case value comparisons and branches.
3532	auto caseValue = valueList.begin();
3533	auto caseBlock = blockList.begin();
3534	for (mlir::Attribute attr : attrList) {
3535	if (mlir::isa<mlir::UnitAttr>(attr)) {
3536	genBranch(*caseBlock++);
3537	break;
3538	}
3539	auto genCond = [&](mlir::Value rhs,
3540	mlir::arith::CmpIPredicate pred) -> mlir::Value {
3541	if (!isCharSelector)
3542	return builder->create<mlir::arith::CmpIOp>(loc, pred, selector, rhs);
3543	fir::factory::CharacterExprHelper charHelper{*builder, loc};
3544	std::pair<mlir::Value, mlir::Value> lhsVal =
3545	charHelper.createUnboxChar(selector);
3546	std::pair<mlir::Value, mlir::Value> rhsVal =
3547	charHelper.createUnboxChar(rhs);
3548	return fir::runtime::genCharCompare(*builder, loc, pred, lhsVal.first,
3549	lhsVal.second, rhsVal.first,
3550	rhsVal.second);
3551	};
3552	mlir::Block *newBlock = insertBlock(*caseBlock);
3553	if (mlir::isa<fir::ClosedIntervalAttr>(attr)) {
3554	mlir::Block *newBlock2 = insertBlock(*caseBlock);
3555	mlir::Value cond =
3556	genCond(*caseValue++, mlir::arith::CmpIPredicate::sge);
3557	genConditionalBranch(cond, newBlock, newBlock2);
3558	builder->setInsertionPointToEnd(newBlock);
3559	mlir::Value cond2 =
3560	genCond(*caseValue++, mlir::arith::CmpIPredicate::sle);
3561	genConditionalBranch(cond2, *caseBlock++, newBlock2);
3562	builder->setInsertionPointToEnd(newBlock2);
3563	continue;
3564	}
3565	mlir::arith::CmpIPredicate pred;
3566	if (mlir::isa<fir::PointIntervalAttr>(attr)) {
3567	pred = mlir::arith::CmpIPredicate::eq;
3568	} else if (mlir::isa<fir::LowerBoundAttr>(attr)) {
3569	pred = mlir::arith::CmpIPredicate::sge;
3570	} else {
3571	assert(mlir::isa<fir::UpperBoundAttr>(attr) && "unexpected predicate");
3572	pred = mlir::arith::CmpIPredicate::sle;
3573	}
3574	mlir::Value cond = genCond(*caseValue++, pred);
3575	genConditionalBranch(cond, *caseBlock++, newBlock);
3576	builder->setInsertionPointToEnd(newBlock);
3577	}
3578	assert(caseValue == valueList.end() && caseBlock == blockList.end() &&
3579	"select case list mismatch");
3580	}
3581
3582	fir::ExtendedValue
3583	genAssociateSelector(const Fortran::lower::SomeExpr &selector,
3584	Fortran::lower::StatementContext &stmtCtx) {
3585	if (lowerToHighLevelFIR())
3586	return genExprAddr(selector, stmtCtx);
3587	return Fortran::lower::isArraySectionWithoutVectorSubscript(selector)
3588	? Fortran::lower::createSomeArrayBox(*this, selector,
3589	localSymbols, stmtCtx)
3590	: genExprAddr(selector, stmtCtx);
3591	}
3592
3593	void genFIR(const Fortran::parser::AssociateConstruct &) {
3594	Fortran::lower::pft::Evaluation &eval = getEval();
3595	Fortran::lower::StatementContext stmtCtx;
3596	pushActiveConstruct(eval, stmtCtx);
3597	for (Fortran::lower::pft::Evaluation &e : eval.getNestedEvaluations()) {
3598	setCurrentPosition(e.position);
3599	if (auto *stmt = e.getIf<Fortran::parser::AssociateStmt>()) {
3600	if (eval.lowerAsUnstructured())
3601	maybeStartBlock(e.block);
3602	localSymbols.pushScope();
3603	for (const Fortran::parser::Association &assoc :
3604	std::get<std::list<Fortran::parser::Association>>(stmt->t)) {
3605	Fortran::semantics::Symbol &sym =
3606	*std::get<Fortran::parser::Name>(assoc.t).symbol;
3607	const Fortran::lower::SomeExpr &selector =
3608	*sym.get<Fortran::semantics::AssocEntityDetails>().expr();
3609	addSymbol(sym, genAssociateSelector(selector, stmtCtx));
3610	}
3611	} else if (e.getIf<Fortran::parser::EndAssociateStmt>()) {
3612	if (eval.lowerAsUnstructured())
3613	maybeStartBlock(e.block);
3614	localSymbols.popScope();
3615	} else {
3616	genFIR(e);
3617	}
3618	}
3619	popActiveConstruct();
3620	}
3621
3622	void genFIR(const Fortran::parser::BlockConstruct &blockConstruct) {
3623	Fortran::lower::pft::Evaluation &eval = getEval();
3624	Fortran::lower::StatementContext stmtCtx;
3625	pushActiveConstruct(eval, stmtCtx);
3626	for (Fortran::lower::pft::Evaluation &e : eval.getNestedEvaluations()) {
3627	setCurrentPosition(e.position);
3628	if (e.getIf<Fortran::parser::BlockStmt>()) {
3629	if (eval.lowerAsUnstructured())
3630	maybeStartBlock(e.block);
3631	const Fortran::parser::CharBlock &endPosition =
3632	eval.getLastNestedEvaluation().position;
3633	localSymbols.pushScope();
3634	mlir::Value stackPtr = builder->genStackSave(toLocation());
3635	mlir::Location endLoc = genLocation(endPosition);
3636	stmtCtx.attachCleanup(
3637	[=]() { builder->genStackRestore(endLoc, stackPtr); });
3638	Fortran::semantics::Scope &scope =
3639	bridge.getSemanticsContext().FindScope(endPosition);
3640	scopeBlockIdMap.try_emplace(&scope, ++blockId);
3641	Fortran::lower::AggregateStoreMap storeMap;
3642	for (const Fortran::lower::pft::Variable &var :
3643	Fortran::lower::pft::getScopeVariableList(scope)) {
3644	// Do no instantiate again variables from the block host
3645	// that appears in specification of block variables.
3646	if (!var.hasSymbol() || !lookupSymbol(var.getSymbol()))
3647	instantiateVar(var, storeMap);
3648	}
3649	} else if (e.getIf<Fortran::parser::EndBlockStmt>()) {
3650	if (eval.lowerAsUnstructured())
3651	maybeStartBlock(e.block);
3652	localSymbols.popScope();
3653	} else {
3654	genFIR(e);
3655	}
3656	}
3657	popActiveConstruct();
3658	}
3659
3660	void genFIR(const Fortran::parser::ChangeTeamConstruct &construct) {
3661	TODO(toLocation(), "coarray: ChangeTeamConstruct");
3662	}
3663	void genFIR(const Fortran::parser::ChangeTeamStmt &stmt) {
3664	TODO(toLocation(), "coarray: ChangeTeamStmt");
3665	}
3666	void genFIR(const Fortran::parser::EndChangeTeamStmt &stmt) {
3667	TODO(toLocation(), "coarray: EndChangeTeamStmt");
3668	}
3669
3670	void genFIR(const Fortran::parser::CriticalConstruct &criticalConstruct) {
3671	setCurrentPositionAt(criticalConstruct);
3672	TODO(toLocation(), "coarray: CriticalConstruct");
3673	}
3674	void genFIR(const Fortran::parser::CriticalStmt &) {
3675	TODO(toLocation(), "coarray: CriticalStmt");
3676	}
3677	void genFIR(const Fortran::parser::EndCriticalStmt &) {
3678	TODO(toLocation(), "coarray: EndCriticalStmt");
3679	}
3680
3681	void genFIR(const Fortran::parser::SelectRankConstruct &selectRankConstruct) {
3682	setCurrentPositionAt(selectRankConstruct);
3683	genCaseOrRankConstruct();
3684	}
3685
3686	void genFIR(const Fortran::parser::SelectRankStmt &selectRankStmt) {
3687	// Generate a fir.select_case with the selector rank. The RANK(*) case,
3688	// if any, is handles with a conditional branch before the fir.select_case.
3689	mlir::Type rankType = builder->getIntegerType(8);
3690	mlir::MLIRContext *context = builder->getContext();
3691	mlir::Location loc = toLocation();
3692	// Build block list for fir.select_case, and identify RANK(*) block, if any.
3693	// Default block must be placed last in the fir.select_case block list.
3694	mlir::Block *rankStarBlock = nullptr;
3695	Fortran::lower::pft::Evaluation &eval = getEval();
3696	mlir::Block *defaultBlock = eval.parentConstruct->constructExit->block;
3697	llvm::SmallVector<mlir::Attribute> attrList;
3698	llvm::SmallVector<mlir::Value> valueList;
3699	llvm::SmallVector<mlir::Block *> blockList;
3700	for (Fortran::lower::pft::Evaluation *e = eval.controlSuccessor; e;
3701	e = e->controlSuccessor) {
3702	if (const auto *rankCaseStmt =
3703	e->getIf<Fortran::parser::SelectRankCaseStmt>()) {
3704	const auto &rank = std::get<Fortran::parser::SelectRankCaseStmt::Rank>(
3705	rankCaseStmt->t);
3706	assert(e->block && "missing SelectRankCaseStmt block");
3707	Fortran::common::visit(
3708	Fortran::common::visitors{
3709	[&](const Fortran::parser::ScalarIntConstantExpr &rankExpr) {
3710	blockList.emplace_back(e->block);
3711	attrList.emplace_back(fir::PointIntervalAttr::get(context));
3712	std::optional<std::int64_t> rankCst =
3713	Fortran::evaluate::ToInt64(
3714	Fortran::semantics::GetExpr(rankExpr));
3715	assert(rankCst.has_value() &&
3716	"rank expr must be constant integer");
3717	valueList.emplace_back(
3718	builder->createIntegerConstant(loc, rankType, *rankCst));
3719	},
3720	[&](const Fortran::parser::Star &) {
3721	rankStarBlock = e->block;
3722	},
3723	[&](const Fortran::parser::Default &) {
3724	defaultBlock = e->block;
3725	}},
3726	rank.u);
3727	}
3728	}
3729	attrList.push_back(mlir::UnitAttr::get(context));
3730	blockList.push_back(defaultBlock);
3731
3732	// Lower selector.
3733	assert(!activeConstructStack.empty() && "must be inside construct");
3734	assert(!activeConstructStack.back().selector &&
3735	"selector should not yet be set");
3736	Fortran::lower::StatementContext &stmtCtx =
3737	activeConstructStack.back().stmtCtx;
3738	const Fortran::lower::SomeExpr *selectorExpr = Fortran::common::visit(
3739	[](const auto &x) { return Fortran::semantics::GetExpr(x); },
3740	std::get<Fortran::parser::Selector>(selectRankStmt.t).u);
3741	assert(selectorExpr && "failed to retrieve selector expr");
3742	hlfir::Entity selector = Fortran::lower::convertExprToHLFIR(
3743	loc, *this, *selectorExpr, localSymbols, stmtCtx);
3744	activeConstructStack.back().selector = selector;
3745
3746	// Deal with assumed-size first. They must fall into RANK(*) if present, or
3747	// the default case (F'2023 11.1.10.2.). The selector cannot be an
3748	// assumed-size if it is allocatable or pointer, so the check is skipped.
3749	if (!Fortran::evaluate::IsAllocatableOrPointerObject(*selectorExpr)) {
3750	mlir::Value isAssumedSize = builder->create<fir::IsAssumedSizeOp>(
3751	loc, builder->getI1Type(), selector);
3752	// Create new block to hold the fir.select_case for the non assumed-size
3753	// cases.
3754	mlir::Block *selectCaseBlock = insertBlock(blockList[0]);
3755	mlir::Block *assumedSizeBlock =
3756	rankStarBlock ? rankStarBlock : defaultBlock;
3757	builder->create<mlir::cf::CondBranchOp>(loc, isAssumedSize,
3758	assumedSizeBlock, std::nullopt,
3759	selectCaseBlock, std::nullopt);
3760	startBlock(selectCaseBlock);
3761	}
3762	// Create fir.select_case for the other rank cases.
3763	mlir::Value rank = builder->create<fir::BoxRankOp>(loc, rankType, selector);
3764	stmtCtx.finalizeAndReset();
3765	builder->create<fir::SelectCaseOp>(loc, rank, attrList, valueList,
3766	blockList);
3767	}
3768
3769	// Get associating entity symbol inside case statement scope.
3770	static const Fortran::semantics::Symbol &
3771	getAssociatingEntitySymbol(const Fortran::semantics::Scope &scope) {
3772	const Fortran::semantics::Symbol *assocSym = nullptr;
3773	for (const auto &sym : scope.GetSymbols()) {
3774	if (sym->has<Fortran::semantics::AssocEntityDetails>()) {
3775	assert(!assocSym &&
3776	"expect only one associating entity symbol in this scope");
3777	assocSym = &*sym;
3778	}
3779	}
3780	assert(assocSym && "should contain associating entity symbol");
3781	return *assocSym;
3782	}
3783
3784	void genFIR(const Fortran::parser::SelectRankCaseStmt &stmt) {
3785	assert(!activeConstructStack.empty() &&
3786	"must be inside select rank construct");
3787	// Pop previous associating entity mapping, if any, and push scope for new
3788	// mapping.
3789	if (activeConstructStack.back().pushedScope)
3790	localSymbols.popScope();
3791	localSymbols.pushScope();
3792	activeConstructStack.back().pushedScope = true;
3793	const Fortran::semantics::Symbol &assocEntitySymbol =
3794	getAssociatingEntitySymbol(
3795	bridge.getSemanticsContext().FindScope(getEval().position));
3796	const auto &details =
3797	assocEntitySymbol.get<Fortran::semantics::AssocEntityDetails>();
3798	assert(!activeConstructStack.empty() &&
3799	activeConstructStack.back().selector.has_value() &&
3800	"selector must have been created");
3801	// Get lowered value for the selector.
3802	hlfir::Entity selector = *activeConstructStack.back().selector;
3803	assert(selector.isVariable() && "assumed-rank selector are variables");
3804	// Cook selector mlir::Value according to rank case and map it to
3805	// associating entity symbol.
3806	Fortran::lower::StatementContext stmtCtx;
3807	mlir::Location loc = toLocation();
3808	if (details.IsAssumedRank()) {
3809	fir::ExtendedValue selectorExv = Fortran::lower::translateToExtendedValue(
3810	loc, *builder, selector, stmtCtx);
3811	addSymbol(assocEntitySymbol, selectorExv);
3812	} else if (details.IsAssumedSize()) {
3813	// Create rank-1 assumed-size from descriptor. Assumed-size are contiguous
3814	// so a new entity can be built from scratch using the base address, type
3815	// parameters and dynamic type. The selector cannot be a
3816	// POINTER/ALLOCATBLE as per F'2023 C1160.
3817	fir::ExtendedValue newExv;
3818	llvm::SmallVector assumeSizeExtents{
3819	builder->createMinusOneInteger(loc, builder->getIndexType())};
3820	mlir::Value baseAddr =
3821	hlfir::genVariableRawAddress(loc, *builder, selector);
3822	const bool isVolatile = fir::isa_volatile_type(selector.getType());
3823	mlir::Type eleType =
3824	fir::unwrapSequenceType(fir::unwrapRefType(baseAddr.getType()));
3825	mlir::Type rank1Type = fir::ReferenceType::get(
3826	builder->getVarLenSeqTy(eleType, 1), isVolatile);
3827	baseAddr = builder->createConvert(loc, rank1Type, baseAddr);
3828	if (selector.isCharacter()) {
3829	mlir::Value len = hlfir::genCharLength(loc, *builder, selector);
3830	newExv = fir::CharArrayBoxValue{baseAddr, len, assumeSizeExtents};
3831	} else if (selector.isDerivedWithLengthParameters()) {
3832	TODO(loc, "RANK(*) with parameterized derived type selector");
3833	} else if (selector.isPolymorphic()) {
3834	TODO(loc, "RANK(*) with polymorphic selector");
3835	} else {
3836	// Simple intrinsic or derived type.
3837	newExv = fir::ArrayBoxValue{baseAddr, assumeSizeExtents};
3838	}
3839	addSymbol(assocEntitySymbol, newExv);
3840	} else {
3841	int rank = details.rank().value();
3842	auto boxTy =
3843	mlir::cast<fir::BaseBoxType>(fir::unwrapRefType(selector.getType()));
3844	mlir::Type newBoxType = boxTy.getBoxTypeWithNewShape(rank);
3845	if (fir::isa_ref_type(selector.getType()))
3846	newBoxType = fir::ReferenceType::get(
3847	newBoxType, fir::isa_volatile_type(selector.getType()));
3848	// Give rank info to value via cast, and get rid of the box if not needed
3849	// (simple scalars, contiguous arrays... This is done by
3850	// translateVariableToExtendedValue).
3851	hlfir::Entity rankedBox{
3852	builder->createConvert(loc, newBoxType, selector)};
3853	bool isSimplyContiguous = Fortran::evaluate::IsSimplyContiguous(
3854	assocEntitySymbol, getFoldingContext());
3855	fir::ExtendedValue newExv = Fortran::lower::translateToExtendedValue(
3856	loc, *builder, rankedBox, stmtCtx, isSimplyContiguous);
3857
3858	// Non deferred length parameters of character allocatable/pointer
3859	// MutableBoxValue should be properly set before binding it to a symbol in
3860	// order to get correct assignment semantics.
3861	if (const fir::MutableBoxValue *mutableBox =
3862	newExv.getBoxOf<fir::MutableBoxValue>()) {
3863	if (selector.isCharacter()) {
3864	auto dynamicType =
3865	Fortran::evaluate::DynamicType::From(assocEntitySymbol);
3866	if (!dynamicType.value().HasDeferredTypeParameter()) {
3867	llvm::SmallVector<mlir::Value> lengthParams;
3868	hlfir::genLengthParameters(loc, *builder, selector, lengthParams);
3869	newExv = fir::MutableBoxValue{rankedBox, lengthParams,
3870	mutableBox->getMutableProperties()};
3871	}
3872	}
3873	}
3874	addSymbol(assocEntitySymbol, newExv);
3875	}
3876	// Statements inside rank case are lowered by SelectRankConstruct visit.
3877	}
3878
3879	void genFIR(const Fortran::parser::SelectTypeConstruct &selectTypeConstruct) {
3880	mlir::MLIRContext *context = builder->getContext();
3881	Fortran::lower::StatementContext stmtCtx;
3882	fir::ExtendedValue selector;
3883	llvm::SmallVector<mlir::Attribute> attrList;
3884	llvm::SmallVector<mlir::Block *> blockList;
3885	unsigned typeGuardIdx = 0;
3886	std::size_t defaultAttrPos = std::numeric_limits<size_t>::max();
3887	bool hasLocalScope = false;
3888	llvm::SmallVector<const Fortran::semantics::Scope *> typeCaseScopes;
3889
3890	const auto selectorIsVolatile = [&selector]() {
3891	return fir::isa_volatile_type(fir::getBase(selector).getType());
3892	};
3893
3894	const auto &typeCaseList =
3895	std::get<std::list<Fortran::parser::SelectTypeConstruct::TypeCase>>(
3896	selectTypeConstruct.t);
3897	for (const auto &typeCase : typeCaseList) {
3898	const auto &stmt =
3899	std::get<Fortran::parser::Statement<Fortran::parser::TypeGuardStmt>>(
3900	typeCase.t);
3901	const Fortran::semantics::Scope &scope =
3902	bridge.getSemanticsContext().FindScope(stmt.source);
3903	typeCaseScopes.push_back(&scope);
3904	}
3905
3906	pushActiveConstruct(getEval(), stmtCtx);
3907	llvm::SmallVector<Fortran::lower::pft::Evaluation *> exits, fallThroughs;
3908	collectFinalEvaluations(getEval(), exits, fallThroughs);
3909	Fortran::lower::pft::Evaluation &constructExit = *getEval().constructExit;
3910
3911	for (Fortran::lower::pft::Evaluation &eval :
3912	getEval().getNestedEvaluations()) {
3913	setCurrentPosition(eval.position);
3914	mlir::Location loc = toLocation();
3915	if (auto *selectTypeStmt =
3916	eval.getIf<Fortran::parser::SelectTypeStmt>()) {
3917	// A genFIR(SelectTypeStmt) call would have unwanted side effects.
3918	maybeStartBlock(eval.block);
3919	// Retrieve the selector
3920	const auto &s = std::get<Fortran::parser::Selector>(selectTypeStmt->t);
3921	if (const auto *v = std::get_if<Fortran::parser::Variable>(&s.u))
3922	selector = genExprBox(loc, *Fortran::semantics::GetExpr(*v), stmtCtx);
3923	else if (const auto *e = std::get_if<Fortran::parser::Expr>(&s.u))
3924	selector = genExprBox(loc, *Fortran::semantics::GetExpr(*e), stmtCtx);
3925
3926	// Going through the controlSuccessor first to create the
3927	// fir.select_type operation.
3928	mlir::Block *defaultBlock = eval.parentConstruct->constructExit->block;
3929	for (Fortran::lower::pft::Evaluation *e = eval.controlSuccessor; e;
3930	e = e->controlSuccessor) {
3931	const auto &typeGuardStmt =
3932	e->getIf<Fortran::parser::TypeGuardStmt>();
3933	const auto &guard =
3934	std::get<Fortran::parser::TypeGuardStmt::Guard>(typeGuardStmt->t);
3935	assert(e->block && "missing TypeGuardStmt block");
3936	// CLASS DEFAULT
3937	if (std::holds_alternative<Fortran::parser::Default>(guard.u)) {
3938	defaultBlock = e->block;
3939	// Keep track of the actual position of the CLASS DEFAULT type guard
3940	// in the SELECT TYPE construct.
3941	defaultAttrPos = attrList.size();
3942	continue;
3943	}
3944
3945	blockList.push_back(e->block);
3946	if (const auto *typeSpec =
3947	std::get_if<Fortran::parser::TypeSpec>(&guard.u)) {
3948	// TYPE IS
3949	mlir::Type ty;
3950	if (std::holds_alternative<Fortran::parser::IntrinsicTypeSpec>(
3951	typeSpec->u)) {
3952	const Fortran::semantics::IntrinsicTypeSpec *intrinsic =
3953	typeSpec->declTypeSpec->AsIntrinsic();
3954	int kind =
3955	Fortran::evaluate::ToInt64(intrinsic->kind()).value_or(kind);
3956	llvm::SmallVector<Fortran::lower::LenParameterTy> params;
3957	ty = genType(intrinsic->category(), kind, params);
3958	} else {
3959	const Fortran::semantics::DerivedTypeSpec *derived =
3960	typeSpec->declTypeSpec->AsDerived();
3961	ty = genType(*derived);
3962	}
3963	attrList.push_back(fir::ExactTypeAttr::get(ty));
3964	} else if (const auto *derived =
3965	std::get_if<Fortran::parser::DerivedTypeSpec>(
3966	&guard.u)) {
3967	// CLASS IS
3968	assert(derived->derivedTypeSpec && "derived type spec is null");
3969	mlir::Type ty = genType(*(derived->derivedTypeSpec));
3970	attrList.push_back(fir::SubclassAttr::get(ty));
3971	}
3972	}
3973	attrList.push_back(mlir::UnitAttr::get(context));
3974	blockList.push_back(defaultBlock);
3975	builder->create<fir::SelectTypeOp>(loc, fir::getBase(selector),
3976	attrList, blockList);
3977
3978	// If the actual position of CLASS DEFAULT type guard is not the last
3979	// one, it needs to be put back at its correct position for the rest of
3980	// the processing. TypeGuardStmt are processed in the same order they
3981	// appear in the Fortran code.
3982	if (defaultAttrPos < attrList.size() - 1) {
3983	auto attrIt = attrList.begin();
3984	attrIt = attrIt + defaultAttrPos;
3985	auto blockIt = blockList.begin();
3986	blockIt = blockIt + defaultAttrPos;
3987	attrList.insert(attrIt, mlir::UnitAttr::get(context));
3988	blockList.insert(blockIt, defaultBlock);
3989	attrList.pop_back();
3990	blockList.pop_back();
3991	}
3992	} else if (auto *typeGuardStmt =
3993	eval.getIf<Fortran::parser::TypeGuardStmt>()) {
3994	// Map the type guard local symbol for the selector to a more precise
3995	// typed entity in the TypeGuardStmt when necessary.
3996	genFIR(eval);
3997	const auto &guard =
3998	std::get<Fortran::parser::TypeGuardStmt::Guard>(typeGuardStmt->t);
3999	if (hasLocalScope)
4000	localSymbols.popScope();
4001	localSymbols.pushScope();
4002	hasLocalScope = true;
4003	assert(attrList.size() >= typeGuardIdx &&
4004	"TypeGuard attribute missing");
4005	mlir::Attribute typeGuardAttr = attrList[typeGuardIdx];
4006	mlir::Block *typeGuardBlock = blockList[typeGuardIdx];
4007	mlir::OpBuilder::InsertPoint crtInsPt = builder->saveInsertionPoint();
4008	builder->setInsertionPointToStart(typeGuardBlock);
4009
4010	auto addAssocEntitySymbol = [&](fir::ExtendedValue exv) {
4011	for (auto &symbol : typeCaseScopes[typeGuardIdx]->GetSymbols()) {
4012	if (symbol->GetUltimate()
4013	.detailsIf<Fortran::semantics::AssocEntityDetails>()) {
4014	addSymbol(symbol, exv);
4015	break;
4016	}
4017	}
4018	};
4019
4020	mlir::Type baseTy = fir::getBase(selector).getType();
4021	bool isPointer = fir::isPointerType(baseTy);
4022	bool isAllocatable = fir::isAllocatableType(baseTy);
4023	bool isArray =
4024	mlir::isa<fir::SequenceType>(fir::dyn_cast_ptrOrBoxEleTy(baseTy));
4025	const fir::BoxValue *selectorBox = selector.getBoxOf<fir::BoxValue>();
4026	if (std::holds_alternative<Fortran::parser::Default>(guard.u)) {
4027	// CLASS DEFAULT
4028	addAssocEntitySymbol(selector);
4029	} else if (const auto *typeSpec =
4030	std::get_if<Fortran::parser::TypeSpec>(&guard.u)) {
4031	// TYPE IS
4032	fir::ExactTypeAttr attr =
4033	mlir::dyn_cast<fir::ExactTypeAttr>(typeGuardAttr);
4034	mlir::Value exactValue;
4035	mlir::Type addrTy = attr.getType();
4036	if (isArray) {
4037	auto seqTy = mlir::dyn_cast<fir::SequenceType>(
4038	fir::dyn_cast_ptrOrBoxEleTy(baseTy));
4039	addrTy = fir::SequenceType::get(seqTy.getShape(), attr.getType());
4040	}
4041	if (isPointer)
4042	addrTy = fir::PointerType::get(addrTy);
4043	if (isAllocatable)
4044	addrTy = fir::HeapType::get(addrTy);
4045	if (std::holds_alternative<Fortran::parser::IntrinsicTypeSpec>(
4046	typeSpec->u)) {
4047	mlir::Type refTy =
4048	fir::ReferenceType::get(addrTy, selectorIsVolatile());
4049	if (isPointer || isAllocatable)
4050	refTy = addrTy;
4051	exactValue = builder->create<fir::BoxAddrOp>(
4052	loc, refTy, fir::getBase(selector));
4053	const Fortran::semantics::IntrinsicTypeSpec *intrinsic =
4054	typeSpec->declTypeSpec->AsIntrinsic();
4055	if (isArray) {
4056	mlir::Value exact = builder->create<fir::ConvertOp>(
4057	loc, fir::BoxType::get(addrTy, selectorIsVolatile()),
4058	fir::getBase(selector));
4059	addAssocEntitySymbol(selectorBox->clone(exact));
4060	} else if (intrinsic->category() ==
4061	Fortran::common::TypeCategory::Character) {
4062	auto charTy = mlir::dyn_cast<fir::CharacterType>(attr.getType());
4063	mlir::Value charLen =
4064	fir::factory::CharacterExprHelper(*builder, loc)
4065	.readLengthFromBox(fir::getBase(selector), charTy);
4066	addAssocEntitySymbol(fir::CharBoxValue(exactValue, charLen));
4067	} else {
4068	addAssocEntitySymbol(exactValue);
4069	}
4070	} else if (std::holds_alternative<Fortran::parser::DerivedTypeSpec>(
4071	typeSpec->u)) {
4072	exactValue = builder->create<fir::ConvertOp>(
4073	loc, fir::BoxType::get(addrTy, selectorIsVolatile()),
4074	fir::getBase(selector));
4075	addAssocEntitySymbol(selectorBox->clone(exactValue));
4076	}
4077	} else if (std::holds_alternative<Fortran::parser::DerivedTypeSpec>(
4078	guard.u)) {
4079	// CLASS IS
4080	fir::SubclassAttr attr =
4081	mlir::dyn_cast<fir::SubclassAttr>(typeGuardAttr);
4082	mlir::Type addrTy = attr.getType();
4083	if (isArray) {
4084	auto seqTy = mlir::dyn_cast<fir::SequenceType>(
4085	fir::dyn_cast_ptrOrBoxEleTy(baseTy));
4086	addrTy = fir::SequenceType::get(seqTy.getShape(), attr.getType());
4087	}
4088	if (isPointer)
4089	addrTy = fir::PointerType::get(addrTy);
4090	if (isAllocatable)
4091	addrTy = fir::HeapType::get(addrTy);
4092	mlir::Type classTy =
4093	fir::ClassType::get(addrTy, selectorIsVolatile());
4094	if (classTy == baseTy) {
4095	addAssocEntitySymbol(selector);
4096	} else {
4097	mlir::Value derived = builder->create<fir::ConvertOp>(
4098	loc, classTy, fir::getBase(selector));
4099	addAssocEntitySymbol(selectorBox->clone(derived));
4100	}
4101	}
4102	builder->restoreInsertionPoint(crtInsPt);
4103	++typeGuardIdx;
4104	} else if (eval.getIf<Fortran::parser::EndSelectStmt>()) {
4105	maybeStartBlock(eval.block);
4106	if (hasLocalScope)
4107	localSymbols.popScope();
4108	} else {
4109	genFIR(eval);
4110	}
4111	if (blockIsUnterminated()) {
4112	if (llvm::is_contained(exits, &eval))
4113	genConstructExitBranch(constructExit);
4114	else if (llvm::is_contained(fallThroughs, &eval))
4115	genBranch(eval.lexicalSuccessor->block);
4116	}
4117	}
4118	popActiveConstruct();
4119	}
4120
4121	//===--------------------------------------------------------------------===//
4122	// IO statements (see io.h)
4123	//===--------------------------------------------------------------------===//
4124
4125	void genFIR(const Fortran::parser::BackspaceStmt &stmt) {
4126	mlir::Value iostat = genBackspaceStatement(*this, stmt);
4127	genIoConditionBranches(getEval(), stmt.v, iostat);
4128	}
4129	void genFIR(const Fortran::parser::CloseStmt &stmt) {
4130	mlir::Value iostat = genCloseStatement(*this, stmt);
4131	genIoConditionBranches(getEval(), stmt.v, iostat);
4132	}
4133	void genFIR(const Fortran::parser::EndfileStmt &stmt) {
4134	mlir::Value iostat = genEndfileStatement(*this, stmt);
4135	genIoConditionBranches(getEval(), stmt.v, iostat);
4136	}
4137	void genFIR(const Fortran::parser::FlushStmt &stmt) {
4138	mlir::Value iostat = genFlushStatement(*this, stmt);
4139	genIoConditionBranches(getEval(), stmt.v, iostat);
4140	}
4141	void genFIR(const Fortran::parser::InquireStmt &stmt) {
4142	mlir::Value iostat = genInquireStatement(*this, stmt);
4143	if (const auto *specs =
4144	std::get_if<std::list<Fortran::parser::InquireSpec>>(&stmt.u))
4145	genIoConditionBranches(getEval(), *specs, iostat);
4146	}
4147	void genFIR(const Fortran::parser::OpenStmt &stmt) {
4148	mlir::Value iostat = genOpenStatement(*this, stmt);
4149	genIoConditionBranches(getEval(), stmt.v, iostat);
4150	}
4151	void genFIR(const Fortran::parser::PrintStmt &stmt) {
4152	genPrintStatement(*this, stmt);
4153	}
4154	void genFIR(const Fortran::parser::ReadStmt &stmt) {
4155	mlir::Value iostat = genReadStatement(*this, stmt);
4156	genIoConditionBranches(getEval(), stmt.controls, iostat);
4157	}
4158	void genFIR(const Fortran::parser::RewindStmt &stmt) {
4159	mlir::Value iostat = genRewindStatement(*this, stmt);
4160	genIoConditionBranches(getEval(), stmt.v, iostat);
4161	}
4162	void genFIR(const Fortran::parser::WaitStmt &stmt) {
4163	mlir::Value iostat = genWaitStatement(*this, stmt);
4164	genIoConditionBranches(getEval(), stmt.v, iostat);
4165	}
4166	void genFIR(const Fortran::parser::WriteStmt &stmt) {
4167	mlir::Value iostat = genWriteStatement(*this, stmt);
4168	genIoConditionBranches(getEval(), stmt.controls, iostat);
4169	}
4170
4171	template <typename A>
4172	void genIoConditionBranches(Fortran::lower::pft::Evaluation &eval,
4173	const A &specList, mlir::Value iostat) {
4174	if (!iostat)
4175	return;
4176
4177	Fortran::parser::Label endLabel{};
4178	Fortran::parser::Label eorLabel{};
4179	Fortran::parser::Label errLabel{};
4180	bool hasIostat{};
4181	for (const auto &spec : specList) {
4182	Fortran::common::visit(
4183	Fortran::common::visitors{
4184	[&](const Fortran::parser::EndLabel &label) {
4185	endLabel = label.v;
4186	},
4187	[&](const Fortran::parser::EorLabel &label) {
4188	eorLabel = label.v;
4189	},
4190	[&](const Fortran::parser::ErrLabel &label) {
4191	errLabel = label.v;
4192	},
4193	[&](const Fortran::parser::StatVariable &) { hasIostat = true; },
4194	[](const auto &) {}},
4195	spec.u);
4196	}
4197	if (!endLabel && !eorLabel && !errLabel)
4198	return;
4199
4200	// An ERR specifier branch is taken on any positive error value rather than
4201	// some single specific value. If ERR and IOSTAT specifiers are given and
4202	// END and EOR specifiers are allowed, the latter two specifiers must have
4203	// explicit branch targets to allow the ERR branch to be implemented as a
4204	// default/else target. A label=0 target for an absent END or EOR specifier
4205	// indicates that these specifiers have a fallthrough target. END and EOR
4206	// specifiers may appear on READ and WAIT statements.
4207	bool allSpecifiersRequired = errLabel && hasIostat &&
4208	(eval.isA<Fortran::parser::ReadStmt>() ||
4209	eval.isA<Fortran::parser::WaitStmt>());
4210	mlir::Value selector =
4211	builder->createConvert(toLocation(), builder->getIndexType(), iostat);
4212	llvm::SmallVector<int64_t> valueList;
4213	llvm::SmallVector<Fortran::parser::Label> labelList;
4214	if (eorLabel || allSpecifiersRequired) {
4215	valueList.push_back(Fortran::runtime::io::IostatEor);
4216	labelList.push_back(eorLabel ? eorLabel : 0);
4217	}
4218	if (endLabel || allSpecifiersRequired) {
4219	valueList.push_back(Fortran::runtime::io::IostatEnd);
4220	labelList.push_back(endLabel ? endLabel : 0);
4221	}
4222	if (errLabel) {
4223	// Must be last. Value 0 is interpreted as any positive value, or
4224	// equivalently as any value other than 0, IostatEor, or IostatEnd.
4225	valueList.push_back(Elt: 0);
4226	labelList.push_back(errLabel);
4227	}
4228	genMultiwayBranch(selector, valueList, labelList, eval.nonNopSuccessor());
4229	}
4230
4231	//===--------------------------------------------------------------------===//
4232	// Memory allocation and deallocation
4233	//===--------------------------------------------------------------------===//
4234
4235	void genFIR(const Fortran::parser::AllocateStmt &stmt) {
4236	Fortran::lower::genAllocateStmt(*this, stmt, toLocation());
4237	}
4238
4239	void genFIR(const Fortran::parser::DeallocateStmt &stmt) {
4240	Fortran::lower::genDeallocateStmt(*this, stmt, toLocation());
4241	}
4242
4243	/// Nullify pointer object list
4244	///
4245	/// For each pointer object, reset the pointer to a disassociated status.
4246	/// We do this by setting each pointer to null.
4247	void genFIR(const Fortran::parser::NullifyStmt &stmt) {
4248	mlir::Location loc = toLocation();
4249	for (auto &pointerObject : stmt.v) {
4250	const Fortran::lower::SomeExpr *expr =
4251	Fortran::semantics::GetExpr(pointerObject);
4252	assert(expr);
4253	if (Fortran::evaluate::IsProcedurePointer(*expr)) {
4254	Fortran::lower::StatementContext stmtCtx;
4255	hlfir::Entity pptr = Fortran::lower::convertExprToHLFIR(
4256	loc, *this, *expr, localSymbols, stmtCtx);
4257	auto boxTy{
4258	Fortran::lower::getUntypedBoxProcType(builder->getContext())};
4259	hlfir::Entity nullBoxProc(
4260	fir::factory::createNullBoxProc(*builder, loc, boxTy));
4261	builder->createStoreWithConvert(loc, nullBoxProc, pptr);
4262	} else {
4263	fir::MutableBoxValue box = genExprMutableBox(loc, *expr);
4264	fir::factory::disassociateMutableBox(*builder, loc, box);
4265	cuf::genPointerSync(box.getAddr(), *builder);
4266	}
4267	}
4268	}
4269
4270	//===--------------------------------------------------------------------===//
4271
4272	void genFIR(const Fortran::parser::NotifyWaitStmt &stmt) {
4273	genNotifyWaitStatement(*this, stmt);
4274	}
4275
4276	void genFIR(const Fortran::parser::EventPostStmt &stmt) {
4277	genEventPostStatement(*this, stmt);
4278	}
4279
4280	void genFIR(const Fortran::parser::EventWaitStmt &stmt) {
4281	genEventWaitStatement(*this, stmt);
4282	}
4283
4284	void genFIR(const Fortran::parser::FormTeamStmt &stmt) {
4285	genFormTeamStatement(*this, getEval(), stmt);
4286	}
4287
4288	void genFIR(const Fortran::parser::LockStmt &stmt) {
4289	genLockStatement(*this, stmt);
4290	}
4291
4292	fir::ExtendedValue
4293	genInitializerExprValue(const Fortran::lower::SomeExpr &expr,
4294	Fortran::lower::StatementContext &stmtCtx) {
4295	return Fortran::lower::createSomeInitializerExpression(
4296	toLocation(), *this, expr, localSymbols, stmtCtx);
4297	}
4298
4299	/// Return true if the current context is a conditionalized and implied
4300	/// iteration space.
4301	bool implicitIterationSpace() { return !implicitIterSpace.empty(); }
4302
4303	/// Return true if context is currently an explicit iteration space. A scalar
4304	/// assignment expression may be contextually within a user-defined iteration
4305	/// space, transforming it into an array expression.
4306	bool explicitIterationSpace() { return explicitIterSpace.isActive(); }
4307
4308	/// Generate an array assignment.
4309	/// This is an assignment expression with rank > 0. The assignment may or may
4310	/// not be in a WHERE and/or FORALL context.
4311	/// In a FORALL context, the assignment may be a pointer assignment and the \p
4312	/// lbounds and \p ubounds parameters should only be used in such a pointer
4313	/// assignment case. (If both are None then the array assignment cannot be a
4314	/// pointer assignment.)
4315	void genArrayAssignment(
4316	const Fortran::evaluate::Assignment &assign,
4317	Fortran::lower::StatementContext &localStmtCtx,
4318	std::optional<llvm::SmallVector<mlir::Value>> lbounds = std::nullopt,
4319	std::optional<llvm::SmallVector<mlir::Value>> ubounds = std::nullopt) {
4320
4321	Fortran::lower::StatementContext &stmtCtx =
4322	explicitIterationSpace()
4323	? explicitIterSpace.stmtContext()
4324	: (implicitIterationSpace() ? implicitIterSpace.stmtContext()
4325	: localStmtCtx);
4326	if (Fortran::lower::isWholeAllocatable(assign.lhs)) {
4327	// Assignment to allocatables may require the lhs to be
4328	// deallocated/reallocated. See Fortran 2018 10.2.1.3 p3
4329	Fortran::lower::createAllocatableArrayAssignment(
4330	*this, assign.lhs, assign.rhs, explicitIterSpace, implicitIterSpace,
4331	localSymbols, stmtCtx);
4332	return;
4333	}
4334
4335	if (lbounds) {
4336	// Array of POINTER entities, with elemental assignment.
4337	if (!Fortran::lower::isWholePointer(assign.lhs))
4338	fir::emitFatalError(toLocation(), "pointer assignment to non-pointer");
4339
4340	Fortran::lower::createArrayOfPointerAssignment(
4341	*this, assign.lhs, assign.rhs, explicitIterSpace, implicitIterSpace,
4342	*lbounds, ubounds, localSymbols, stmtCtx);
4343	return;
4344	}
4345
4346	if (!implicitIterationSpace() && !explicitIterationSpace()) {
4347	// No masks and the iteration space is implied by the array, so create a
4348	// simple array assignment.
4349	Fortran::lower::createSomeArrayAssignment(*this, assign.lhs, assign.rhs,
4350	localSymbols, stmtCtx);
4351	return;
4352	}
4353
4354	// If there is an explicit iteration space, generate an array assignment
4355	// with a user-specified iteration space and possibly with masks. These
4356	// assignments may *appear* to be scalar expressions, but the scalar
4357	// expression is evaluated at all points in the user-defined space much like
4358	// an ordinary array assignment. More specifically, the semantics inside the
4359	// FORALL much more closely resembles that of WHERE than a scalar
4360	// assignment.
4361	// Otherwise, generate a masked array assignment. The iteration space is
4362	// implied by the lhs array expression.
4363	Fortran::lower::createAnyMaskedArrayAssignment(
4364	*this, assign.lhs, assign.rhs, explicitIterSpace, implicitIterSpace,
4365	localSymbols, stmtCtx);
4366	}
4367
4368	#if !defined(NDEBUG)
4369	static bool isFuncResultDesignator(const Fortran::lower::SomeExpr &expr) {
4370	const Fortran::semantics::Symbol *sym =
4371	Fortran::evaluate::GetFirstSymbol(expr);
4372	return sym && sym->IsFuncResult();
4373	}
4374	#endif
4375
4376	inline fir::MutableBoxValue
4377	genExprMutableBox(mlir::Location loc,
4378	const Fortran::lower::SomeExpr &expr) override final {
4379	if (lowerToHighLevelFIR())
4380	return Fortran::lower::convertExprToMutableBox(loc, *this, expr,
4381	localSymbols);
4382	return Fortran::lower::createMutableBox(loc, *this, expr, localSymbols);
4383	}
4384
4385	// Create the [newRank] array with the lower bounds to be passed to the
4386	// runtime as a descriptor.
4387	mlir::Value createLboundArray(llvm::ArrayRef<mlir::Value> lbounds,
4388	mlir::Location loc) {
4389	mlir::Type indexTy = builder->getIndexType();
4390	mlir::Type boundArrayTy = fir::SequenceType::get(
4391	{static_cast<int64_t>(lbounds.size())}, builder->getI64Type());
4392	mlir::Value boundArray = builder->create<fir::AllocaOp>(loc, boundArrayTy);
4393	mlir::Value array = builder->create<fir::UndefOp>(loc, boundArrayTy);
4394	for (unsigned i = 0; i < lbounds.size(); ++i) {
4395	array = builder->create<fir::InsertValueOp>(
4396	loc, boundArrayTy, array, lbounds[i],
4397	builder->getArrayAttr({builder->getIntegerAttr(
4398	builder->getIndexType(), static_cast<int>(i))}));
4399	}
4400	builder->create<fir::StoreOp>(loc, array, boundArray);
4401	mlir::Type boxTy = fir::BoxType::get(boundArrayTy);
4402	mlir::Value ext =
4403	builder->createIntegerConstant(loc, indexTy, lbounds.size());
4404	llvm::SmallVector<mlir::Value> shapes = {ext};
4405	mlir::Value shapeOp = builder->genShape(loc, shapes);
4406	return builder->create<fir::EmboxOp>(loc, boxTy, boundArray, shapeOp);
4407	}
4408
4409	// Generate pointer assignment with possibly empty bounds-spec. R1035: a
4410	// bounds-spec is a lower bound value.
4411	void genPointerAssignment(
4412	mlir::Location loc, const Fortran::evaluate::Assignment &assign,
4413	const Fortran::evaluate::Assignment::BoundsSpec &lbExprs) {
4414	Fortran::lower::StatementContext stmtCtx;
4415
4416	if (!lowerToHighLevelFIR() &&
4417	Fortran::evaluate::IsProcedureDesignator(assign.rhs))
4418	TODO(loc, "procedure pointer assignment");
4419	if (Fortran::evaluate::IsProcedurePointer(assign.lhs)) {
4420	hlfir::Entity lhs = Fortran::lower::convertExprToHLFIR(
4421	loc, *this, assign.lhs, localSymbols, stmtCtx);
4422	if (Fortran::evaluate::UnwrapExpr<Fortran::evaluate::NullPointer>(
4423	assign.rhs)) {
4424	// rhs is null(). rhs being null(pptr) is handled in genNull.
4425	auto boxTy{
4426	Fortran::lower::getUntypedBoxProcType(builder->getContext())};
4427	hlfir::Entity rhs(
4428	fir::factory::createNullBoxProc(*builder, loc, boxTy));
4429	builder->createStoreWithConvert(loc, rhs, lhs);
4430	return;
4431	}
4432	hlfir::Entity rhs(getBase(Fortran::lower::convertExprToAddress(
4433	loc, *this, assign.rhs, localSymbols, stmtCtx)));
4434	builder->createStoreWithConvert(loc, rhs, lhs);
4435	return;
4436	}
4437
4438	std::optional<Fortran::evaluate::DynamicType> lhsType =
4439	assign.lhs.GetType();
4440	// Delegate pointer association to unlimited polymorphic pointer
4441	// to the runtime. element size, type code, attribute and of
4442	// course base_addr might need to be updated.
4443	if (lhsType && lhsType->IsPolymorphic()) {
4444	if (!lowerToHighLevelFIR() && explicitIterationSpace())
4445	TODO(loc, "polymorphic pointer assignment in FORALL");
4446	llvm::SmallVector<mlir::Value> lbounds;
4447	for (const Fortran::evaluate::ExtentExpr &lbExpr : lbExprs)
4448	lbounds.push_back(
4449	fir::getBase(genExprValue(toEvExpr(lbExpr), stmtCtx)));
4450	fir::MutableBoxValue lhsMutableBox = genExprMutableBox(loc, assign.lhs);
4451	if (Fortran::evaluate::UnwrapExpr<Fortran::evaluate::NullPointer>(
4452	assign.rhs)) {
4453	fir::factory::disassociateMutableBox(*builder, loc, lhsMutableBox);
4454	return;
4455	}
4456	mlir::Value lhs = lhsMutableBox.getAddr();
4457	mlir::Value rhs = fir::getBase(genExprBox(loc, assign.rhs, stmtCtx));
4458	if (!lbounds.empty()) {
4459	mlir::Value boundsDesc = createLboundArray(lbounds, loc);
4460	Fortran::lower::genPointerAssociateLowerBounds(*builder, loc, lhs, rhs,
4461	boundsDesc);
4462	return;
4463	}
4464	Fortran::lower::genPointerAssociate(*builder, loc, lhs, rhs);
4465	return;
4466	}
4467
4468	llvm::SmallVector<mlir::Value> lbounds;
4469	for (const Fortran::evaluate::ExtentExpr &lbExpr : lbExprs)
4470	lbounds.push_back(fir::getBase(genExprValue(toEvExpr(lbExpr), stmtCtx)));
4471	if (!lowerToHighLevelFIR() && explicitIterationSpace()) {
4472	// Pointer assignment in FORALL context. Copy the rhs box value
4473	// into the lhs box variable.
4474	genArrayAssignment(assign, stmtCtx, lbounds);
4475	return;
4476	}
4477	fir::MutableBoxValue lhs = genExprMutableBox(loc, assign.lhs);
4478	Fortran::lower::associateMutableBox(*this, loc, lhs, assign.rhs, lbounds,
4479	stmtCtx);
4480	}
4481
4482	void genForallPointerAssignment(mlir::Location loc,
4483	const Fortran::evaluate::Assignment &assign) {
4484	// Lower pointer assignment inside forall with hlfir.region_assign with
4485	// descriptor address/value and later implemented with a store.
4486	// The RHS is fully prepared in lowering, so that all that is left
4487	// in hlfir.region_assign code generation is the store.
4488	auto regionAssignOp = builder->create<hlfir::RegionAssignOp>(loc);
4489
4490	// Lower LHS in its own region.
4491	builder->createBlock(&regionAssignOp.getLhsRegion());
4492	Fortran::lower::StatementContext lhsContext;
4493	hlfir::Entity lhs = Fortran::lower::convertExprToHLFIR(
4494	loc, *this, assign.lhs, localSymbols, lhsContext);
4495	auto lhsYieldOp = builder->create<hlfir::YieldOp>(loc, lhs);
4496	Fortran::lower::genCleanUpInRegionIfAny(
4497	loc, *builder, lhsYieldOp.getCleanup(), lhsContext);
4498
4499	// Lower RHS in its own region.
4500	builder->createBlock(&regionAssignOp.getRhsRegion());
4501	Fortran::lower::StatementContext rhsContext;
4502	mlir::Value rhs =
4503	genForallPointerAssignmentRhs(loc, lhs, assign, rhsContext);
4504	auto rhsYieldOp = builder->create<hlfir::YieldOp>(loc, rhs);
4505	Fortran::lower::genCleanUpInRegionIfAny(
4506	loc, *builder, rhsYieldOp.getCleanup(), rhsContext);
4507
4508	builder->setInsertionPointAfter(regionAssignOp);
4509	}
4510
4511	mlir::Value lowerToIndexValue(mlir::Location loc,
4512	const Fortran::evaluate::ExtentExpr &expr,
4513	Fortran::lower::StatementContext &stmtCtx) {
4514	mlir::Value val = fir::getBase(genExprValue(toEvExpr(expr), stmtCtx));
4515	return builder->createConvert(loc, builder->getIndexType(), val);
4516	}
4517
4518	mlir::Value
4519	genForallPointerAssignmentRhs(mlir::Location loc, mlir::Value lhs,
4520	const Fortran::evaluate::Assignment &assign,
4521	Fortran::lower::StatementContext &rhsContext) {
4522	if (Fortran::evaluate::IsProcedureDesignator(assign.lhs)) {
4523	if (Fortran::evaluate::UnwrapExpr<Fortran::evaluate::NullPointer>(
4524	assign.rhs))
4525	return fir::factory::createNullBoxProc(
4526	*builder, loc, fir::unwrapRefType(lhs.getType()));
4527	return fir::getBase(Fortran::lower::convertExprToAddress(
4528	loc, *this, assign.rhs, localSymbols, rhsContext));
4529	}
4530	// Data target.
4531	auto lhsBoxType =
4532	llvm::cast<fir::BaseBoxType>(fir::unwrapRefType(lhs.getType()));
4533	// For NULL, create disassociated descriptor whose dynamic type is
4534	// the static type of the LHS.
4535	if (Fortran::evaluate::UnwrapExpr<Fortran::evaluate::NullPointer>(
4536	assign.rhs))
4537	return fir::factory::createUnallocatedBox(*builder, loc, lhsBoxType,
4538	std::nullopt);
4539	hlfir::Entity rhs = Fortran::lower::convertExprToHLFIR(
4540	loc, *this, assign.rhs, localSymbols, rhsContext);
4541	// Create pointer descriptor value from the RHS.
4542	if (rhs.isMutableBox())
4543	rhs = hlfir::Entity{builder->create<fir::LoadOp>(loc, rhs)};
4544	mlir::Value rhsBox = hlfir::genVariableBox(
4545	loc, *builder, rhs, lhsBoxType.getBoxTypeWithNewShape(rhs.getRank()));
4546	// Apply lower bounds or reshaping if any.
4547	if (const auto *lbExprs =
4548	std::get_if<Fortran::evaluate::Assignment::BoundsSpec>(&assign.u);
4549	lbExprs && !lbExprs->empty()) {
4550	// Override target lower bounds with the LHS bounds spec.
4551	llvm::SmallVector<mlir::Value> lbounds;
4552	for (const Fortran::evaluate::ExtentExpr &lbExpr : *lbExprs)
4553	lbounds.push_back(lowerToIndexValue(loc, lbExpr, rhsContext));
4554	mlir::Value shift = builder->genShift(loc, lbounds);
4555	rhsBox = builder->create<fir::ReboxOp>(loc, lhsBoxType, rhsBox, shift,
4556	/*slice=*/mlir::Value{});
4557	} else if (const auto *boundExprs =
4558	std::get_if<Fortran::evaluate::Assignment::BoundsRemapping>(
4559	&assign.u);
4560	boundExprs && !boundExprs->empty()) {
4561	// Reshape the target according to the LHS bounds remapping.
4562	llvm::SmallVector<mlir::Value> lbounds;
4563	llvm::SmallVector<mlir::Value> extents;
4564	mlir::Type indexTy = builder->getIndexType();
4565	mlir::Value zero = builder->createIntegerConstant(loc, indexTy, 0);
4566	mlir::Value one = builder->createIntegerConstant(loc, indexTy, 1);
4567	for (const auto &[lbExpr, ubExpr] : *boundExprs) {
4568	lbounds.push_back(lowerToIndexValue(loc, lbExpr, rhsContext));
4569	mlir::Value ub = lowerToIndexValue(loc, ubExpr, rhsContext);
4570	extents.push_back(fir::factory::computeExtent(
4571	*builder, loc, lbounds.back(), ub, zero, one));
4572	}
4573	mlir::Value shape = builder->genShape(loc, lbounds, extents);
4574	rhsBox = builder->create<fir::ReboxOp>(loc, lhsBoxType, rhsBox, shape,
4575	/*slice=*/mlir::Value{});
4576	}
4577	return rhsBox;
4578	}
4579
4580	// Create the 2 x newRank array with the bounds to be passed to the runtime as
4581	// a descriptor.
4582	mlir::Value createBoundArray(llvm::ArrayRef<mlir::Value> lbounds,
4583	llvm::ArrayRef<mlir::Value> ubounds,
4584	mlir::Location loc) {
4585	assert(lbounds.size() && ubounds.size());
4586	mlir::Type indexTy = builder->getIndexType();
4587	mlir::Type boundArrayTy = fir::SequenceType::get(
4588	{2, static_cast<int64_t>(lbounds.size())}, builder->getI64Type());
4589	mlir::Value boundArray = builder->create<fir::AllocaOp>(loc, boundArrayTy);
4590	mlir::Value array = builder->create<fir::UndefOp>(loc, boundArrayTy);
4591	for (unsigned i = 0; i < lbounds.size(); ++i) {
4592	array = builder->create<fir::InsertValueOp>(
4593	loc, boundArrayTy, array, lbounds[i],
4594	builder->getArrayAttr(
4595	{builder->getIntegerAttr(builder->getIndexType(), 0),
4596	builder->getIntegerAttr(builder->getIndexType(),
4597	static_cast<int>(i))}));
4598	array = builder->create<fir::InsertValueOp>(
4599	loc, boundArrayTy, array, ubounds[i],
4600	builder->getArrayAttr(
4601	{builder->getIntegerAttr(builder->getIndexType(), 1),
4602	builder->getIntegerAttr(builder->getIndexType(),
4603	static_cast<int>(i))}));
4604	}
4605	builder->create<fir::StoreOp>(loc, array, boundArray);
4606	mlir::Type boxTy = fir::BoxType::get(boundArrayTy);
4607	mlir::Value ext =
4608	builder->createIntegerConstant(loc, indexTy, lbounds.size());
4609	mlir::Value c2 = builder->createIntegerConstant(loc, indexTy, 2);
4610	llvm::SmallVector<mlir::Value> shapes = {c2, ext};
4611	mlir::Value shapeOp = builder->genShape(loc, shapes);
4612	return builder->create<fir::EmboxOp>(loc, boxTy, boundArray, shapeOp);
4613	}
4614
4615	// Pointer assignment with bounds-remapping. R1036: a bounds-remapping is a
4616	// pair, lower bound and upper bound.
4617	void genPointerAssignment(
4618	mlir::Location loc, const Fortran::evaluate::Assignment &assign,
4619	const Fortran::evaluate::Assignment::BoundsRemapping &boundExprs) {
4620	Fortran::lower::StatementContext stmtCtx;
4621	llvm::SmallVector<mlir::Value> lbounds;
4622	llvm::SmallVector<mlir::Value> ubounds;
4623	for (const std::pair<Fortran::evaluate::ExtentExpr,
4624	Fortran::evaluate::ExtentExpr> &pair : boundExprs) {
4625	const Fortran::evaluate::ExtentExpr &lbExpr = pair.first;
4626	const Fortran::evaluate::ExtentExpr &ubExpr = pair.second;
4627	lbounds.push_back(fir::getBase(genExprValue(toEvExpr(lbExpr), stmtCtx)));
4628	ubounds.push_back(fir::getBase(genExprValue(toEvExpr(ubExpr), stmtCtx)));
4629	}
4630
4631	std::optional<Fortran::evaluate::DynamicType> lhsType =
4632	assign.lhs.GetType();
4633	std::optional<Fortran::evaluate::DynamicType> rhsType =
4634	assign.rhs.GetType();
4635	// Polymorphic lhs/rhs need more care. See F2018 10.2.2.3.
4636	if ((lhsType && lhsType->IsPolymorphic()) ||
4637	(rhsType && rhsType->IsPolymorphic())) {
4638	if (!lowerToHighLevelFIR() && explicitIterationSpace())
4639	TODO(loc, "polymorphic pointer assignment in FORALL");
4640
4641	fir::MutableBoxValue lhsMutableBox = genExprMutableBox(loc, assign.lhs);
4642	if (Fortran::evaluate::UnwrapExpr<Fortran::evaluate::NullPointer>(
4643	assign.rhs)) {
4644	fir::factory::disassociateMutableBox(*builder, loc, lhsMutableBox);
4645	return;
4646	}
4647	mlir::Value lhs = lhsMutableBox.getAddr();
4648	mlir::Value rhs = fir::getBase(genExprBox(loc, assign.rhs, stmtCtx));
4649	mlir::Value boundsDesc = createBoundArray(lbounds, ubounds, loc);
4650	Fortran::lower::genPointerAssociateRemapping(*builder, loc, lhs, rhs,
4651	boundsDesc);
4652	return;
4653	}
4654	if (!lowerToHighLevelFIR() && explicitIterationSpace()) {
4655	// Pointer assignment in FORALL context. Copy the rhs box value
4656	// into the lhs box variable.
4657	genArrayAssignment(assign, stmtCtx, lbounds, ubounds);
4658	return;
4659	}
4660	fir::MutableBoxValue lhs = genExprMutableBox(loc, assign.lhs);
4661	if (Fortran::evaluate::UnwrapExpr<Fortran::evaluate::NullPointer>(
4662	assign.rhs)) {
4663	fir::factory::disassociateMutableBox(*builder, loc, lhs);
4664	return;
4665	}
4666	if (lowerToHighLevelFIR()) {
4667	fir::ExtendedValue rhs = genExprAddr(assign.rhs, stmtCtx);
4668	fir::factory::associateMutableBoxWithRemap(*builder, loc, lhs, rhs,
4669	lbounds, ubounds);
4670	return;
4671	}
4672	// Legacy lowering below.
4673	// Do not generate a temp in case rhs is an array section.
4674	fir::ExtendedValue rhs =
4675	Fortran::lower::isArraySectionWithoutVectorSubscript(assign.rhs)
4676	? Fortran::lower::createSomeArrayBox(*this, assign.rhs,
4677	localSymbols, stmtCtx)
4678	: genExprAddr(assign.rhs, stmtCtx);
4679	fir::factory::associateMutableBoxWithRemap(*builder, loc, lhs, rhs, lbounds,
4680	ubounds);
4681	if (explicitIterationSpace()) {
4682	mlir::ValueRange inners = explicitIterSpace.getInnerArgs();
4683	if (!inners.empty())
4684	builder->create<fir::ResultOp>(loc, inners);
4685	}
4686	}
4687
4688	/// Given converted LHS and RHS of the assignment, materialize any
4689	/// implicit conversion of the RHS to the LHS type. The front-end
4690	/// usually already makes those explicit, except for non-standard
4691	/// LOGICAL <-> INTEGER, or if the LHS is a whole allocatable
4692	/// (making the conversion explicit in the front-end would prevent
4693	/// propagation of the LHS lower bound in the reallocation).
4694	/// If array temporaries or values are created, the cleanups are
4695	/// added in the statement context.
4696	hlfir::Entity genImplicitConvert(const Fortran::evaluate::Assignment &assign,
4697	hlfir::Entity rhs, bool preserveLowerBounds,
4698	Fortran::lower::StatementContext &stmtCtx) {
4699	mlir::Location loc = toLocation();
4700	auto &builder = getFirOpBuilder();
4701	mlir::Type toType = genType(assign.lhs);
4702	auto valueAndPair = hlfir::genTypeAndKindConvert(loc, builder, rhs, toType,
4703	preserveLowerBounds);
4704	if (valueAndPair.second)
4705	stmtCtx.attachCleanup(*valueAndPair.second);
4706	return hlfir::Entity{valueAndPair.first};
4707	}
4708
4709	bool firstDummyIsPointerOrAllocatable(
4710	const Fortran::evaluate::ProcedureRef &userDefinedAssignment) {
4711	using DummyAttr = Fortran::evaluate::characteristics::DummyDataObject::Attr;
4712	if (auto procedure =
4713	Fortran::evaluate::characteristics::Procedure::Characterize(
4714	userDefinedAssignment.proc(), getFoldingContext(),
4715	/*emitError=*/false))
4716	if (!procedure->dummyArguments.empty())
4717	if (const auto *dataArg = std::get_if<
4718	Fortran::evaluate::characteristics::DummyDataObject>(
4719	&procedure->dummyArguments[0].u))
4720	return dataArg->attrs.test(DummyAttr::Pointer) ||
4721	dataArg->attrs.test(DummyAttr::Allocatable);
4722	return false;
4723	}
4724
4725	void genCUDADataTransfer(fir::FirOpBuilder &builder, mlir::Location loc,
4726	const Fortran::evaluate::Assignment &assign,
4727	hlfir::Entity &lhs, hlfir::Entity &rhs) {
4728	bool lhsIsDevice = Fortran::evaluate::HasCUDADeviceAttrs(assign.lhs);
4729	bool rhsIsDevice = Fortran::evaluate::HasCUDADeviceAttrs(assign.rhs);
4730
4731	auto getRefFromValue = [](mlir::Value val) -> mlir::Value {
4732	if (auto loadOp =
4733	mlir::dyn_cast_or_null<fir::LoadOp>(val.getDefiningOp()))
4734	return loadOp.getMemref();
4735	if (!mlir::isa<fir::BaseBoxType>(val.getType()))
4736	return val;
4737	if (auto declOp =
4738	mlir::dyn_cast_or_null<hlfir::DeclareOp>(val.getDefiningOp())) {
4739	if (!declOp.getShape())
4740	return val;
4741	if (mlir::isa<fir::ReferenceType>(declOp.getMemref().getType()))
4742	return declOp.getResults()[1];
4743	}
4744	return val;
4745	};
4746
4747	auto getShapeFromDecl = [](mlir::Value val) -> mlir::Value {
4748	if (!mlir::isa<fir::BaseBoxType>(val.getType()))
4749	return {};
4750	if (auto declOp =
4751	mlir::dyn_cast_or_null<hlfir::DeclareOp>(val.getDefiningOp()))
4752	return declOp.getShape();
4753	return {};
4754	};
4755
4756	mlir::Value rhsVal = getRefFromValue(rhs.getBase());
4757	mlir::Value lhsVal = getRefFromValue(lhs.getBase());
4758	// Get shape from the rhs if available otherwise get it from lhs.
4759	mlir::Value shape = getShapeFromDecl(rhs.getBase());
4760	if (!shape)
4761	shape = getShapeFromDecl(lhs.getBase());
4762
4763	// device = host
4764	if (lhsIsDevice && !rhsIsDevice) {
4765	auto transferKindAttr = cuf::DataTransferKindAttr::get(
4766	builder.getContext(), cuf::DataTransferKind::HostDevice);
4767	if (!rhs.isVariable()) {
4768	mlir::Value base = rhs;
4769	if (auto convertOp =
4770	mlir::dyn_cast<fir::ConvertOp>(rhs.getDefiningOp()))
4771	base = convertOp.getValue();
4772	// Special case if the rhs is a constant.
4773	if (matchPattern(base.getDefiningOp(), mlir::m_Constant())) {
4774	builder.create<cuf::DataTransferOp>(loc, base, lhsVal, shape,
4775	transferKindAttr);
4776	} else {
4777	auto associate = hlfir::genAssociateExpr(
4778	loc, builder, rhs, rhs.getType(), ".cuf_host_tmp");
4779	builder.create<cuf::DataTransferOp>(loc, associate.getBase(), lhsVal,
4780	shape, transferKindAttr);
4781	builder.create<hlfir::EndAssociateOp>(loc, associate);
4782	}
4783	} else {
4784	builder.create<cuf::DataTransferOp>(loc, rhsVal, lhsVal, shape,
4785	transferKindAttr);
4786	}
4787	return;
4788	}
4789
4790	// host = device
4791	if (!lhsIsDevice && rhsIsDevice) {
4792	auto transferKindAttr = cuf::DataTransferKindAttr::get(
4793	builder.getContext(), cuf::DataTransferKind::DeviceHost);
4794	builder.create<cuf::DataTransferOp>(loc, rhsVal, lhsVal, shape,
4795	transferKindAttr);
4796	return;
4797	}
4798
4799	// device = device
4800	if (lhsIsDevice && rhsIsDevice) {
4801	assert(rhs.isVariable() && "CUDA Fortran assignment rhs is not legal");
4802	auto transferKindAttr = cuf::DataTransferKindAttr::get(
4803	builder.getContext(), cuf::DataTransferKind::DeviceDevice);
4804	builder.create<cuf::DataTransferOp>(loc, rhsVal, lhsVal, shape,
4805	transferKindAttr);
4806	return;
4807	}
4808	llvm_unreachable("Unhandled CUDA data transfer");
4809	}
4810
4811	llvm::SmallVector<mlir::Value>
4812	genCUDAImplicitDataTransfer(fir::FirOpBuilder &builder, mlir::Location loc,
4813	const Fortran::evaluate::Assignment &assign) {
4814	llvm::SmallVector<mlir::Value> temps;
4815	localSymbols.pushScope();
4816	auto transferKindAttr = cuf::DataTransferKindAttr::get(
4817	builder.getContext(), cuf::DataTransferKind::DeviceHost);
4818	[[maybe_unused]] unsigned nbDeviceResidentObject = 0;
4819	for (const Fortran::semantics::Symbol &sym :
4820	Fortran::evaluate::CollectSymbols(assign.rhs)) {
4821	if (const auto *details =
4822	sym.GetUltimate()
4823	.detailsIf<Fortran::semantics::ObjectEntityDetails>()) {
4824	if (details->cudaDataAttr() &&
4825	*details->cudaDataAttr() != Fortran::common::CUDADataAttr::Pinned) {
4826	if (sym.owner().IsDerivedType() && IsAllocatable(sym.GetUltimate()))
4827	TODO(loc, "Device resident allocatable derived-type component");
4828	// TODO: This should probably being checked in semantic and give a
4829	// proper error.
4830	assert(
4831	nbDeviceResidentObject <= 1 &&
4832	"Only one reference to the device resident object is supported");
4833	auto addr = getSymbolAddress(sym);
4834	mlir::Value baseValue;
4835	if (auto declareOp =
4836	llvm::dyn_cast<hlfir::DeclareOp>(addr.getDefiningOp()))
4837	baseValue = declareOp.getBase();
4838	else
4839	baseValue = addr;
4840
4841	hlfir::Entity entity{baseValue};
4842	auto [temp, cleanup] =
4843	hlfir::createTempFromMold(loc, builder, entity);
4844	auto needCleanup = fir::getIntIfConstant(cleanup);
4845	if (needCleanup && *needCleanup) {
4846	if (auto declareOp =
4847	mlir::dyn_cast<hlfir::DeclareOp>(temp.getDefiningOp()))
4848	temps.push_back(declareOp.getMemref());
4849	else
4850	temps.push_back(temp);
4851	}
4852	addSymbol(sym,
4853	hlfir::translateToExtendedValue(loc, builder, temp).first,
4854	/*forced=*/true);
4855	builder.create<cuf::DataTransferOp>(
4856	loc, addr, temp, /*shape=*/mlir::Value{}, transferKindAttr);
4857	++nbDeviceResidentObject;
4858	}
4859	}
4860	}
4861	return temps;
4862	}
4863
4864	void genDataAssignment(
4865	const Fortran::evaluate::Assignment &assign,
4866	const Fortran::evaluate::ProcedureRef *userDefinedAssignment) {
4867	mlir::Location loc = getCurrentLocation();
4868	fir::FirOpBuilder &builder = getFirOpBuilder();
4869
4870	bool isInDeviceContext = cuf::isCUDADeviceContext(builder.getRegion());
4871
4872	bool isCUDATransfer =
4873	IsCUDADataTransfer(assign.lhs, assign.rhs) && !isInDeviceContext;
4874	bool hasCUDAImplicitTransfer =
4875	isCUDATransfer &&
4876	Fortran::evaluate::HasCUDAImplicitTransfer(assign.rhs);
4877	llvm::SmallVector<mlir::Value> implicitTemps;
4878
4879	if (hasCUDAImplicitTransfer && !isInDeviceContext)
4880	implicitTemps = genCUDAImplicitDataTransfer(builder, loc, assign);
4881
4882	// Gather some information about the assignment that will impact how it is
4883	// lowered.
4884	const bool isWholeAllocatableAssignment =
4885	!userDefinedAssignment && !isInsideHlfirWhere() &&
4886	Fortran::lower::isWholeAllocatable(assign.lhs) &&
4887	bridge.getLoweringOptions().getReallocateLHS();
4888	const bool isUserDefAssignToPointerOrAllocatable =
4889	userDefinedAssignment &&
4890	firstDummyIsPointerOrAllocatable(*userDefinedAssignment);
4891	std::optional<Fortran::evaluate::DynamicType> lhsType =
4892	assign.lhs.GetType();
4893	const bool keepLhsLengthInAllocatableAssignment =
4894	isWholeAllocatableAssignment && lhsType.has_value() &&
4895	lhsType->category() == Fortran::common::TypeCategory::Character &&
4896	!lhsType->HasDeferredTypeParameter();
4897	const bool lhsHasVectorSubscripts =
4898	Fortran::evaluate::HasVectorSubscript(assign.lhs);
4899
4900	// Helper to generate the code evaluating the right-hand side.
4901	auto evaluateRhs = [&](Fortran::lower::StatementContext &stmtCtx) {
4902	hlfir::Entity rhs = Fortran::lower::convertExprToHLFIR(
4903	loc, *this, assign.rhs, localSymbols, stmtCtx);
4904	// Load trivial scalar RHS to allow the loads to be hoisted outside of
4905	// loops early if possible. This also dereferences pointer and
4906	// allocatable RHS: the target is being assigned from.
4907	rhs = hlfir::loadTrivialScalar(loc, builder, rhs);
4908	// In intrinsic assignments, the LHS type may not match the RHS type, in
4909	// which case an implicit conversion of the LHS must be done. The
4910	// front-end usually makes it explicit, unless it cannot (whole
4911	// allocatable LHS or Logical<->Integer assignment extension). Recognize
4912	// any type mismatches here and insert explicit scalar convert or
4913	// ElementalOp for array assignment. Preserve the RHS lower bounds on the
4914	// converted entity in case of assignment to whole allocatables so to
4915	// propagate the lower bounds to the LHS in case of reallocation.
4916	if (!userDefinedAssignment)
4917	rhs = genImplicitConvert(assign, rhs, isWholeAllocatableAssignment,
4918	stmtCtx);
4919	return rhs;
4920	};
4921
4922	// Helper to generate the code evaluating the left-hand side.
4923	auto evaluateLhs = [&](Fortran::lower::StatementContext &stmtCtx) {
4924	hlfir::Entity lhs = Fortran::lower::convertExprToHLFIR(
4925	loc, *this, assign.lhs, localSymbols, stmtCtx);
4926	// Dereference pointer LHS: the target is being assigned to.
4927	// Same for allocatables outside of whole allocatable assignments.
4928	if (!isWholeAllocatableAssignment &&
4929	!isUserDefAssignToPointerOrAllocatable)
4930	lhs = hlfir::derefPointersAndAllocatables(loc, builder, lhs);
4931	return lhs;
4932	};
4933
4934	if (!isInsideHlfirForallOrWhere() && !lhsHasVectorSubscripts &&
4935	!userDefinedAssignment) {
4936	Fortran::lower::StatementContext localStmtCtx;
4937	hlfir::Entity rhs = evaluateRhs(localStmtCtx);
4938	hlfir::Entity lhs = evaluateLhs(localStmtCtx);
4939	if (isCUDATransfer && !hasCUDAImplicitTransfer)
4940	genCUDADataTransfer(builder, loc, assign, lhs, rhs);
4941	else
4942	builder.create<hlfir::AssignOp>(loc, rhs, lhs,
4943	isWholeAllocatableAssignment,
4944	keepLhsLengthInAllocatableAssignment);
4945	if (hasCUDAImplicitTransfer && !isInDeviceContext) {
4946	localSymbols.popScope();
4947	for (mlir::Value temp : implicitTemps)
4948	builder.create<fir::FreeMemOp>(loc, temp);
4949	}
4950	return;
4951	}
4952	// Assignments inside Forall, Where, or assignments to a vector subscripted
4953	// left-hand side requires using an hlfir.region_assign in HLFIR. The
4954	// right-hand side and left-hand side must be evaluated inside the
4955	// hlfir.region_assign regions.
4956	auto regionAssignOp = builder.create<hlfir::RegionAssignOp>(loc);
4957
4958	// Lower RHS in its own region.
4959	builder.createBlock(&regionAssignOp.getRhsRegion());
4960	Fortran::lower::StatementContext rhsContext;
4961	hlfir::Entity rhs = evaluateRhs(rhsContext);
4962	auto rhsYieldOp = builder.create<hlfir::YieldOp>(loc, rhs);
4963	Fortran::lower::genCleanUpInRegionIfAny(
4964	loc, builder, rhsYieldOp.getCleanup(), rhsContext);
4965	// Lower LHS in its own region.
4966	builder.createBlock(&regionAssignOp.getLhsRegion());
4967	Fortran::lower::StatementContext lhsContext;
4968	mlir::Value lhsYield = nullptr;
4969	if (!lhsHasVectorSubscripts) {
4970	hlfir::Entity lhs = evaluateLhs(lhsContext);
4971	auto lhsYieldOp = builder.create<hlfir::YieldOp>(loc, lhs);
4972	Fortran::lower::genCleanUpInRegionIfAny(
4973	loc, builder, lhsYieldOp.getCleanup(), lhsContext);
4974	lhsYield = lhs;
4975	} else {
4976	hlfir::ElementalAddrOp elementalAddr =
4977	Fortran::lower::convertVectorSubscriptedExprToElementalAddr(
4978	loc, *this, assign.lhs, localSymbols, lhsContext);
4979	Fortran::lower::genCleanUpInRegionIfAny(
4980	loc, builder, elementalAddr.getCleanup(), lhsContext);
4981	lhsYield = elementalAddr.getYieldOp().getEntity();
4982	}
4983	assert(lhsYield && "must have been set");
4984
4985	// Add "realloc" flag to hlfir.region_assign.
4986	if (isWholeAllocatableAssignment)
4987	TODO(loc, "assignment to a whole allocatable inside FORALL");
4988
4989	// Generate the hlfir.region_assign userDefinedAssignment region.
4990	if (userDefinedAssignment) {
4991	mlir::Type rhsType = rhs.getType();
4992	mlir::Type lhsType = lhsYield.getType();
4993	if (userDefinedAssignment->IsElemental()) {
4994	rhsType = hlfir::getEntityElementType(rhs);
4995	lhsType = hlfir::getEntityElementType(hlfir::Entity{lhsYield});
4996	}
4997	builder.createBlock(&regionAssignOp.getUserDefinedAssignment(),
4998	mlir::Region::iterator{}, {rhsType, lhsType},
4999	{loc, loc});
5000	auto end = builder.create<fir::FirEndOp>(loc);
5001	builder.setInsertionPoint(end);
5002	hlfir::Entity lhsBlockArg{regionAssignOp.getUserAssignmentLhs()};
5003	hlfir::Entity rhsBlockArg{regionAssignOp.getUserAssignmentRhs()};
5004	Fortran::lower::convertUserDefinedAssignmentToHLFIR(
5005	loc, *this, *userDefinedAssignment, lhsBlockArg, rhsBlockArg,
5006	localSymbols);
5007	}
5008	builder.setInsertionPointAfter(regionAssignOp);
5009	}
5010
5011	/// Shared for both assignments and pointer assignments.
5012	void genAssignment(const Fortran::evaluate::Assignment &assign) {
5013	mlir::Location loc = toLocation();
5014	if (lowerToHighLevelFIR()) {
5015	Fortran::common::visit(
5016	Fortran::common::visitors{
5017	[&](const Fortran::evaluate::Assignment::Intrinsic &) {
5018	genDataAssignment(assign, /*userDefinedAssignment=*/nullptr);
5019	},
5020	[&](const Fortran::evaluate::ProcedureRef &procRef) {
5021	genDataAssignment(assign, /*userDefinedAssignment=*/&procRef);
5022	},
5023	[&](const Fortran::evaluate::Assignment::BoundsSpec &lbExprs) {
5024	if (isInsideHlfirForallOrWhere())
5025	genForallPointerAssignment(loc, assign);
5026	else
5027	genPointerAssignment(loc, assign, lbExprs);
5028	},
5029	[&](const Fortran::evaluate::Assignment::BoundsRemapping
5030	&boundExprs) {
5031	if (isInsideHlfirForallOrWhere())
5032	genForallPointerAssignment(loc, assign);
5033	else
5034	genPointerAssignment(loc, assign, boundExprs);
5035	},
5036	},
5037	assign.u);
5038	return;
5039	}
5040	if (explicitIterationSpace()) {
5041	Fortran::lower::createArrayLoads(*this, explicitIterSpace, localSymbols);
5042	explicitIterSpace.genLoopNest();
5043	}
5044	Fortran::lower::StatementContext stmtCtx;
5045	Fortran::common::visit(
5046	Fortran::common::visitors{
5047	// [1] Plain old assignment.
5048	[&](const Fortran::evaluate::Assignment::Intrinsic &) {
5049	const Fortran::semantics::Symbol *sym =
5050	Fortran::evaluate::GetLastSymbol(assign.lhs);
5051
5052	if (!sym)
5053	TODO(loc, "assignment to pointer result of function reference");
5054
5055	std::optional<Fortran::evaluate::DynamicType> lhsType =
5056	assign.lhs.GetType();
5057	assert(lhsType && "lhs cannot be typeless");
5058	std::optional<Fortran::evaluate::DynamicType> rhsType =
5059	assign.rhs.GetType();
5060
5061	// Assignment to/from polymorphic entities are done with the
5062	// runtime.
5063	if (lhsType->IsPolymorphic() ||
5064	lhsType->IsUnlimitedPolymorphic() ||
5065	(rhsType && (rhsType->IsPolymorphic() ||
5066	rhsType->IsUnlimitedPolymorphic()))) {
5067	mlir::Value lhs;
5068	if (Fortran::lower::isWholeAllocatable(assign.lhs))
5069	lhs = genExprMutableBox(loc, assign.lhs).getAddr();
5070	else
5071	lhs = fir::getBase(genExprBox(loc, assign.lhs, stmtCtx));
5072	mlir::Value rhs =
5073	fir::getBase(genExprBox(loc, assign.rhs, stmtCtx));
5074	if ((lhsType->IsPolymorphic() ||
5075	lhsType->IsUnlimitedPolymorphic()) &&
5076	Fortran::lower::isWholeAllocatable(assign.lhs))
5077	fir::runtime::genAssignPolymorphic(*builder, loc, lhs, rhs);
5078	else
5079	fir::runtime::genAssign(*builder, loc, lhs, rhs);
5080	return;
5081	}
5082
5083	// Note: No ad-hoc handling for pointers is required here. The
5084	// target will be assigned as per 2018 10.2.1.3 p2. genExprAddr
5085	// on a pointer returns the target address and not the address of
5086	// the pointer variable.
5087
5088	if (assign.lhs.Rank() > 0 || explicitIterationSpace()) {
5089	if (isDerivedCategory(lhsType->category()) &&
5090	Fortran::semantics::IsFinalizable(
5091	lhsType->GetDerivedTypeSpec()))
5092	TODO(loc, "derived-type finalization with array assignment");
5093	// Array assignment
5094	// See Fortran 2018 10.2.1.3 p5, p6, and p7
5095	genArrayAssignment(assign, stmtCtx);
5096	return;
5097	}
5098
5099	// Scalar assignment
5100	const bool isNumericScalar =
5101	isNumericScalarCategory(lhsType->category());
5102	const bool isVector =
5103	isDerivedCategory(lhsType->category()) &&
5104	lhsType->GetDerivedTypeSpec().IsVectorType();
5105	fir::ExtendedValue rhs = (isNumericScalar || isVector)
5106	? genExprValue(assign.rhs, stmtCtx)
5107	: genExprAddr(assign.rhs, stmtCtx);
5108	const bool lhsIsWholeAllocatable =
5109	Fortran::lower::isWholeAllocatable(assign.lhs);
5110	std::optional<fir::factory::MutableBoxReallocation> lhsRealloc;
5111	std::optional<fir::MutableBoxValue> lhsMutableBox;
5112
5113	// Set flag to know if the LHS needs finalization. Polymorphic,
5114	// unlimited polymorphic assignment will be done with genAssign.
5115	// Assign runtime function performs the finalization.
5116	bool needFinalization = !lhsType->IsPolymorphic() &&
5117	!lhsType->IsUnlimitedPolymorphic() &&
5118	(isDerivedCategory(lhsType->category()) &&
5119	Fortran::semantics::IsFinalizable(
5120	lhsType->GetDerivedTypeSpec()));
5121
5122	auto lhs = [&]() -> fir::ExtendedValue {
5123	if (lhsIsWholeAllocatable) {
5124	lhsMutableBox = genExprMutableBox(loc, assign.lhs);
5125	// Finalize if needed.
5126	if (needFinalization) {
5127	mlir::Value isAllocated =
5128	fir::factory::genIsAllocatedOrAssociatedTest(
5129	*builder, loc, *lhsMutableBox);
5130	builder->genIfThen(loc, isAllocated)
5131	.genThen([&]() {
5132	fir::runtime::genDerivedTypeDestroy(
5133	*builder, loc, fir::getBase(*lhsMutableBox));
5134	})
5135	.end();
5136	needFinalization = false;
5137	}
5138
5139	llvm::SmallVector<mlir::Value> lengthParams;
5140	if (const fir::CharBoxValue *charBox = rhs.getCharBox())
5141	lengthParams.push_back(charBox->getLen());
5142	else if (fir::isDerivedWithLenParameters(rhs))
5143	TODO(loc, "assignment to derived type allocatable with "
5144	"LEN parameters");
5145	lhsRealloc = fir::factory::genReallocIfNeeded(
5146	*builder, loc, *lhsMutableBox,
5147	/*shape=*/std::nullopt, lengthParams);
5148	return lhsRealloc->newValue;
5149	}
5150	return genExprAddr(assign.lhs, stmtCtx);
5151	}();
5152
5153	if (isNumericScalar || isVector) {
5154	// Fortran 2018 10.2.1.3 p8 and p9
5155	// Conversions should have been inserted by semantic analysis,
5156	// but they can be incorrect between the rhs and lhs. Correct
5157	// that here.
5158	mlir::Value addr = fir::getBase(lhs);
5159	mlir::Value val = fir::getBase(rhs);
5160	// A function with multiple entry points returning different
5161	// types tags all result variables with one of the largest
5162	// types to allow them to share the same storage. Assignment
5163	// to a result variable of one of the other types requires
5164	// conversion to the actual type.
5165	mlir::Type toTy = genType(assign.lhs);
5166
5167	// If Cray pointee, need to handle the address
5168	// Array is handled in genCoordinateOp.
5169	if (sym->test(Fortran::semantics::Symbol::Flag::CrayPointee) &&
5170	sym->Rank() == 0) {
5171	// get the corresponding Cray pointer
5172
5173	const Fortran::semantics::Symbol &ptrSym =
5174	Fortran::semantics::GetCrayPointer(*sym);
5175	fir::ExtendedValue ptr =
5176	getSymbolExtendedValue(ptrSym, nullptr);
5177	mlir::Value ptrVal = fir::getBase(ptr);
5178	mlir::Type ptrTy = genType(ptrSym);
5179
5180	fir::ExtendedValue pte =
5181	getSymbolExtendedValue(*sym, nullptr);
5182	mlir::Value pteVal = fir::getBase(pte);
5183	mlir::Value cnvrt = Fortran::lower::addCrayPointerInst(
5184	loc, *builder, ptrVal, ptrTy, pteVal.getType());
5185	addr = builder->create<fir::LoadOp>(loc, cnvrt);
5186	}
5187	mlir::Value cast =
5188	isVector ? val
5189	: builder->convertWithSemantics(loc, toTy, val);
5190	if (fir::dyn_cast_ptrEleTy(addr.getType()) != toTy) {
5191	assert(isFuncResultDesignator(assign.lhs) && "type mismatch");
5192	addr = builder->createConvert(
5193	toLocation(), builder->getRefType(toTy), addr);
5194	}
5195	builder->create<fir::StoreOp>(loc, cast, addr);
5196	} else if (isCharacterCategory(lhsType->category())) {
5197	// Fortran 2018 10.2.1.3 p10 and p11
5198	fir::factory::CharacterExprHelper{*builder, loc}.createAssign(
5199	lhs, rhs);
5200	} else if (isDerivedCategory(lhsType->category())) {
5201	// Handle parent component.
5202	if (Fortran::lower::isParentComponent(assign.lhs)) {
5203	if (!mlir::isa<fir::BaseBoxType>(fir::getBase(lhs).getType()))
5204	lhs = fir::getBase(builder->createBox(loc, lhs));
5205	lhs = Fortran::lower::updateBoxForParentComponent(*this, lhs,
5206	assign.lhs);
5207	}
5208
5209	// Fortran 2018 10.2.1.3 p13 and p14
5210	// Recursively gen an assignment on each element pair.
5211	fir::factory::genRecordAssignment(*builder, loc, lhs, rhs,
5212	needFinalization);
5213	} else {
5214	llvm_unreachable("unknown category");
5215	}
5216	if (lhsIsWholeAllocatable) {
5217	assert(lhsRealloc.has_value());
5218	fir::factory::finalizeRealloc(*builder, loc, *lhsMutableBox,
5219	/*lbounds=*/std::nullopt,
5220	/*takeLboundsIfRealloc=*/false,
5221	*lhsRealloc);
5222	}
5223	},
5224
5225	// [2] User defined assignment. If the context is a scalar
5226	// expression then call the procedure.
5227	[&](const Fortran::evaluate::ProcedureRef &procRef) {
5228	Fortran::lower::StatementContext &ctx =
5229	explicitIterationSpace() ? explicitIterSpace.stmtContext()
5230	: stmtCtx;
5231	Fortran::lower::createSubroutineCall(
5232	*this, procRef, explicitIterSpace, implicitIterSpace,
5233	localSymbols, ctx, /*isUserDefAssignment=*/true);
5234	},
5235
5236	[&](const Fortran::evaluate::Assignment::BoundsSpec &lbExprs) {
5237	return genPointerAssignment(loc, assign, lbExprs);
5238	},
5239	[&](const Fortran::evaluate::Assignment::BoundsRemapping
5240	&boundExprs) {
5241	return genPointerAssignment(loc, assign, boundExprs);
5242	},
5243	},
5244	assign.u);
5245	if (explicitIterationSpace())
5246	Fortran::lower::createArrayMergeStores(*this, explicitIterSpace);
5247	}
5248
5249	// Is the insertion point of the builder directly or indirectly set
5250	// inside any operation of type "Op"?
5251	template <typename... Op>
5252	bool isInsideOp() const {
5253	mlir::Block *block = builder->getInsertionBlock();
5254	mlir::Operation *op = block ? block->getParentOp() : nullptr;
5255	while (op) {
5256	if (mlir::isa<Op...>(op))
5257	return true;
5258	op = op->getParentOp();
5259	}
5260	return false;
5261	}
5262	bool isInsideHlfirForallOrWhere() const {
5263	return isInsideOp<hlfir::ForallOp, hlfir::WhereOp>();
5264	}
5265	bool isInsideHlfirWhere() const { return isInsideOp<hlfir::WhereOp>(); }
5266
5267	void genFIR(const Fortran::parser::WhereConstruct &c) {
5268	mlir::Location loc = getCurrentLocation();
5269	hlfir::WhereOp whereOp;
5270
5271	if (!lowerToHighLevelFIR()) {
5272	implicitIterSpace.growStack();
5273	} else {
5274	whereOp = builder->create<hlfir::WhereOp>(loc);
5275	builder->createBlock(&whereOp.getMaskRegion());
5276	}
5277
5278	// Lower the where mask. For HLFIR, this is done in the hlfir.where mask
5279	// region.
5280	genNestedStatement(
5281	std::get<
5282	Fortran::parser::Statement<Fortran::parser::WhereConstructStmt>>(
5283	c.t));
5284
5285	// Lower WHERE body. For HLFIR, this is done in the hlfir.where body
5286	// region.
5287	if (whereOp)
5288	builder->createBlock(&whereOp.getBody());
5289
5290	for (const auto &body :
5291	std::get<std::list<Fortran::parser::WhereBodyConstruct>>(c.t))
5292	genFIR(body);
5293	for (const auto &e :
5294	std::get<std::list<Fortran::parser::WhereConstruct::MaskedElsewhere>>(
5295	c.t))
5296	genFIR(e);
5297	if (const auto &e =
5298	std::get<std::optional<Fortran::parser::WhereConstruct::Elsewhere>>(
5299	c.t);
5300	e.has_value())
5301	genFIR(*e);
5302	genNestedStatement(
5303	std::get<Fortran::parser::Statement<Fortran::parser::EndWhereStmt>>(
5304	c.t));
5305
5306	if (whereOp) {
5307	// For HLFIR, create fir.end terminator in the last hlfir.elsewhere, or
5308	// in the hlfir.where if it had no elsewhere.
5309	builder->create<fir::FirEndOp>(loc);
5310	builder->setInsertionPointAfter(whereOp);
5311	}
5312	}
5313	void genFIR(const Fortran::parser::WhereBodyConstruct &body) {
5314	Fortran::common::visit(
5315	Fortran::common::visitors{
5316	[&](const Fortran::parser::Statement<
5317	Fortran::parser::AssignmentStmt> &stmt) {
5318	genNestedStatement(stmt);
5319	},
5320	[&](const Fortran::parser::Statement<Fortran::parser::WhereStmt>
5321	&stmt) { genNestedStatement(stmt); },
5322	[&](const Fortran::common::Indirection<
5323	Fortran::parser::WhereConstruct> &c) { genFIR(c.value()); },
5324	},
5325	body.u);
5326	}
5327
5328	/// Lower a Where or Elsewhere mask into an hlfir mask region.
5329	void lowerWhereMaskToHlfir(mlir::Location loc,
5330	const Fortran::semantics::SomeExpr *maskExpr) {
5331	assert(maskExpr && "mask semantic analysis failed");
5332	Fortran::lower::StatementContext maskContext;
5333	hlfir::Entity mask = Fortran::lower::convertExprToHLFIR(
5334	loc, *this, *maskExpr, localSymbols, maskContext);
5335	mask = hlfir::loadTrivialScalar(loc, *builder, mask);
5336	auto yieldOp = builder->create<hlfir::YieldOp>(loc, mask);
5337	Fortran::lower::genCleanUpInRegionIfAny(loc, *builder, yieldOp.getCleanup(),
5338	maskContext);
5339	}
5340	void genFIR(const Fortran::parser::WhereConstructStmt &stmt) {
5341	const Fortran::semantics::SomeExpr *maskExpr = Fortran::semantics::GetExpr(
5342	std::get<Fortran::parser::LogicalExpr>(stmt.t));
5343	if (lowerToHighLevelFIR())
5344	lowerWhereMaskToHlfir(getCurrentLocation(), maskExpr);
5345	else
5346	implicitIterSpace.append(maskExpr);
5347	}
5348	void genFIR(const Fortran::parser::WhereConstruct::MaskedElsewhere &ew) {
5349	mlir::Location loc = getCurrentLocation();
5350	hlfir::ElseWhereOp elsewhereOp;
5351	if (lowerToHighLevelFIR()) {
5352	elsewhereOp = builder->create<hlfir::ElseWhereOp>(loc);
5353	// Lower mask in the mask region.
5354	builder->createBlock(&elsewhereOp.getMaskRegion());
5355	}
5356	genNestedStatement(
5357	std::get<
5358	Fortran::parser::Statement<Fortran::parser::MaskedElsewhereStmt>>(
5359	ew.t));
5360
5361	// For HLFIR, lower the body in the hlfir.elsewhere body region.
5362	if (elsewhereOp)
5363	builder->createBlock(&elsewhereOp.getBody());
5364
5365	for (const auto &body :
5366	std::get<std::list<Fortran::parser::WhereBodyConstruct>>(ew.t))
5367	genFIR(body);
5368	}
5369	void genFIR(const Fortran::parser::MaskedElsewhereStmt &stmt) {
5370	const auto *maskExpr = Fortran::semantics::GetExpr(
5371	std::get<Fortran::parser::LogicalExpr>(stmt.t));
5372	if (lowerToHighLevelFIR())
5373	lowerWhereMaskToHlfir(getCurrentLocation(), maskExpr);
5374	else
5375	implicitIterSpace.append(maskExpr);
5376	}
5377	void genFIR(const Fortran::parser::WhereConstruct::Elsewhere &ew) {
5378	if (lowerToHighLevelFIR()) {
5379	auto elsewhereOp =
5380	builder->create<hlfir::ElseWhereOp>(getCurrentLocation());
5381	builder->createBlock(&elsewhereOp.getBody());
5382	}
5383	genNestedStatement(
5384	std::get<Fortran::parser::Statement<Fortran::parser::ElsewhereStmt>>(
5385	ew.t));
5386	for (const auto &body :
5387	std::get<std::list<Fortran::parser::WhereBodyConstruct>>(ew.t))
5388	genFIR(body);
5389	}
5390	void genFIR(const Fortran::parser::ElsewhereStmt &stmt) {
5391	if (!lowerToHighLevelFIR())
5392	implicitIterSpace.append(nullptr);
5393	}
5394	void genFIR(const Fortran::parser::EndWhereStmt &) {
5395	if (!lowerToHighLevelFIR())
5396	implicitIterSpace.shrinkStack();
5397	}
5398
5399	void genFIR(const Fortran::parser::WhereStmt &stmt) {
5400	Fortran::lower::StatementContext stmtCtx;
5401	const auto &assign = std::get<Fortran::parser::AssignmentStmt>(stmt.t);
5402	const auto *mask = Fortran::semantics::GetExpr(
5403	std::get<Fortran::parser::LogicalExpr>(stmt.t));
5404	if (lowerToHighLevelFIR()) {
5405	mlir::Location loc = getCurrentLocation();
5406	auto whereOp = builder->create<hlfir::WhereOp>(loc);
5407	builder->createBlock(&whereOp.getMaskRegion());
5408	lowerWhereMaskToHlfir(loc, mask);
5409	builder->createBlock(&whereOp.getBody());
5410	genAssignment(*assign.typedAssignment->v);
5411	builder->create<fir::FirEndOp>(loc);
5412	builder->setInsertionPointAfter(whereOp);
5413	return;
5414	}
5415	implicitIterSpace.growStack();
5416	implicitIterSpace.append(mask);
5417	genAssignment(*assign.typedAssignment->v);
5418	implicitIterSpace.shrinkStack();
5419	}
5420
5421	void genFIR(const Fortran::parser::PointerAssignmentStmt &stmt) {
5422	genAssignment(*stmt.typedAssignment->v);
5423	}
5424
5425	void genFIR(const Fortran::parser::AssignmentStmt &stmt) {
5426	genAssignment(*stmt.typedAssignment->v);
5427	}
5428
5429	void genFIR(const Fortran::parser::SyncAllStmt &stmt) {
5430	genSyncAllStatement(*this, stmt);
5431	}
5432
5433	void genFIR(const Fortran::parser::SyncImagesStmt &stmt) {
5434	genSyncImagesStatement(*this, stmt);
5435	}
5436
5437	void genFIR(const Fortran::parser::SyncMemoryStmt &stmt) {
5438	genSyncMemoryStatement(*this, stmt);
5439	}
5440
5441	void genFIR(const Fortran::parser::SyncTeamStmt &stmt) {
5442	genSyncTeamStatement(*this, stmt);
5443	}
5444
5445	void genFIR(const Fortran::parser::UnlockStmt &stmt) {
5446	genUnlockStatement(*this, stmt);
5447	}
5448
5449	void genFIR(const Fortran::parser::AssignStmt &stmt) {
5450	const Fortran::semantics::Symbol &symbol =
5451	*std::get<Fortran::parser::Name>(stmt.t).symbol;
5452	mlir::Location loc = toLocation();
5453	mlir::Value labelValue = builder->createIntegerConstant(
5454	loc, genType(symbol), std::get<Fortran::parser::Label>(stmt.t));
5455	builder->create<fir::StoreOp>(loc, labelValue, getSymbolAddress(symbol));
5456	}
5457
5458	void genFIR(const Fortran::parser::FormatStmt &) {
5459	// do nothing.
5460
5461	// FORMAT statements have no semantics. They may be lowered if used by a
5462	// data transfer statement.
5463	}
5464
5465	void genFIR(const Fortran::parser::PauseStmt &stmt) {
5466	genPauseStatement(*this, stmt);
5467	}
5468
5469	// call FAIL IMAGE in runtime
5470	void genFIR(const Fortran::parser::FailImageStmt &stmt) {
5471	genFailImageStatement(*this);
5472	}
5473
5474	// call STOP, ERROR STOP in runtime
5475	void genFIR(const Fortran::parser::StopStmt &stmt) {
5476	genStopStatement(*this, stmt);
5477	}
5478
5479	void genFIR(const Fortran::parser::ReturnStmt &stmt) {
5480	Fortran::lower::pft::FunctionLikeUnit *funit =
5481	getEval().getOwningProcedure();
5482	assert(funit && "not inside main program, function or subroutine");
5483	for (auto it = activeConstructStack.rbegin(),
5484	rend = activeConstructStack.rend();
5485	it != rend; ++it) {
5486	it->stmtCtx.finalizeAndKeep();
5487	}
5488	if (funit->isMainProgram()) {
5489	genExitRoutine(true);
5490	return;
5491	}
5492	mlir::Location loc = toLocation();
5493	if (stmt.v) {
5494	// Alternate return statement - If this is a subroutine where some
5495	// alternate entries have alternate returns, but the active entry point
5496	// does not, ignore the alternate return value. Otherwise, assign it
5497	// to the compiler-generated result variable.
5498	const Fortran::semantics::Symbol &symbol = funit->getSubprogramSymbol();
5499	if (Fortran::semantics::HasAlternateReturns(symbol)) {
5500	Fortran::lower::StatementContext stmtCtx;
5501	const Fortran::lower::SomeExpr *expr =
5502	Fortran::semantics::GetExpr(*stmt.v);
5503	assert(expr && "missing alternate return expression");
5504	mlir::Value altReturnIndex = builder->createConvert(
5505	loc, builder->getIndexType(), createFIRExpr(loc, expr, stmtCtx));
5506	builder->create<fir::StoreOp>(loc, altReturnIndex,
5507	getAltReturnResult(symbol));
5508	}
5509	}
5510	// Branch to the last block of the SUBROUTINE, which has the actual return.
5511	if (!funit->finalBlock) {
5512	mlir::OpBuilder::InsertPoint insPt = builder->saveInsertionPoint();
5513	Fortran::lower::setInsertionPointAfterOpenACCLoopIfInside(*builder);
5514	funit->finalBlock = builder->createBlock(&builder->getRegion());
5515	builder->restoreInsertionPoint(insPt);
5516	}
5517
5518	if (Fortran::lower::isInOpenACCLoop(*builder))
5519	Fortran::lower::genEarlyReturnInOpenACCLoop(*builder, loc);
5520	else
5521	builder->create<mlir::cf::BranchOp>(loc, funit->finalBlock);
5522	}
5523
5524	void genFIR(const Fortran::parser::CycleStmt &) {
5525	genConstructExitBranch(*getEval().controlSuccessor);
5526	}
5527	void genFIR(const Fortran::parser::ExitStmt &) {
5528	genConstructExitBranch(*getEval().controlSuccessor);
5529	}
5530	void genFIR(const Fortran::parser::GotoStmt &) {
5531	genConstructExitBranch(*getEval().controlSuccessor);
5532	}
5533
5534	// Nop statements - No code, or code is generated at the construct level.
5535	// But note that the genFIR call immediately below that wraps one of these
5536	// calls does block management, possibly starting a new block, and possibly
5537	// generating a branch to end a block. So these calls may still be required
5538	// for that functionality.
5539	void genFIR(const Fortran::parser::AssociateStmt &) {} // nop
5540	void genFIR(const Fortran::parser::BlockStmt &) {} // nop
5541	void genFIR(const Fortran::parser::CaseStmt &) {} // nop
5542	void genFIR(const Fortran::parser::ContinueStmt &) {} // nop
5543	void genFIR(const Fortran::parser::ElseIfStmt &) {} // nop
5544	void genFIR(const Fortran::parser::ElseStmt &) {} // nop
5545	void genFIR(const Fortran::parser::EndAssociateStmt &) {} // nop
5546	void genFIR(const Fortran::parser::EndBlockStmt &) {} // nop
5547	void genFIR(const Fortran::parser::EndDoStmt &) {} // nop
5548	void genFIR(const Fortran::parser::EndFunctionStmt &) {} // nop
5549	void genFIR(const Fortran::parser::EndIfStmt &) {} // nop
5550	void genFIR(const Fortran::parser::EndMpSubprogramStmt &) {} // nop
5551	void genFIR(const Fortran::parser::EndProgramStmt &) {} // nop
5552	void genFIR(const Fortran::parser::EndSelectStmt &) {} // nop
5553	void genFIR(const Fortran::parser::EndSubroutineStmt &) {} // nop
5554	void genFIR(const Fortran::parser::EntryStmt &) {} // nop
5555	void genFIR(const Fortran::parser::IfStmt &) {} // nop
5556	void genFIR(const Fortran::parser::IfThenStmt &) {} // nop
5557	void genFIR(const Fortran::parser::NonLabelDoStmt &) {} // nop
5558	void genFIR(const Fortran::parser::OmpEndLoopDirective &) {} // nop
5559	void genFIR(const Fortran::parser::SelectTypeStmt &) {} // nop
5560	void genFIR(const Fortran::parser::TypeGuardStmt &) {} // nop
5561
5562	/// Generate FIR for Evaluation \p eval.
5563	void genFIR(Fortran::lower::pft::Evaluation &eval,
5564	bool unstructuredContext = true) {
5565	// Start a new unstructured block when applicable. When transitioning
5566	// from unstructured to structured code, unstructuredContext is true,
5567	// which accounts for the possibility that the structured code could be
5568	// a target that starts a new block.
5569	if (unstructuredContext)
5570	maybeStartBlock(eval.isConstruct() && eval.lowerAsStructured()
5571	? eval.getFirstNestedEvaluation().block
5572	: eval.block);
5573
5574	// Generate evaluation specific code. Even nop calls should usually reach
5575	// here in case they start a new block or require generation of a generic
5576	// end-of-block branch. An alternative is to add special case code
5577	// elsewhere, such as in the genFIR code for a parent construct.
5578	setCurrentEval(eval);
5579	setCurrentPosition(eval.position);
5580	eval.visit([&](const auto &stmt) { genFIR(stmt); });
5581	}
5582
5583	/// Map mlir function block arguments to the corresponding Fortran dummy
5584	/// variables. When the result is passed as a hidden argument, the Fortran
5585	/// result is also mapped. The symbol map is used to hold this mapping.
5586	void mapDummiesAndResults(Fortran::lower::pft::FunctionLikeUnit &funit,
5587	const Fortran::lower::CalleeInterface &callee) {
5588	assert(builder && "require a builder object at this point");
5589	using PassBy = Fortran::lower::CalleeInterface::PassEntityBy;
5590	auto mapPassedEntity = [&](const auto arg, bool isResult = false) {
5591	if (arg.passBy == PassBy::AddressAndLength) {
5592	if (callee.characterize().IsBindC())
5593	return;
5594	// TODO: now that fir call has some attributes regarding character
5595	// return, PassBy::AddressAndLength should be retired.
5596	mlir::Location loc = toLocation();
5597	fir::factory::CharacterExprHelper charHelp{*builder, loc};
5598	mlir::Value casted =
5599	builder->createVolatileCast(loc, false, arg.firArgument);
5600	mlir::Value box = charHelp.createEmboxChar(casted, arg.firLength);
5601	mapBlockArgToDummyOrResult(arg.entity->get(), box, isResult);
5602	} else {
5603	if (arg.entity.has_value()) {
5604	mapBlockArgToDummyOrResult(arg.entity->get(), arg.firArgument,
5605	isResult);
5606	} else {
5607	assert(funit.parentHasTupleHostAssoc() && "expect tuple argument");
5608	}
5609	}
5610	};
5611	for (const Fortran::lower::CalleeInterface::PassedEntity &arg :
5612	callee.getPassedArguments())
5613	mapPassedEntity(arg);
5614
5615	// Always generate fir.dummy_scope even if there are no arguments.
5616	// It is currently used to create proper TBAA forest.
5617	if (lowerToHighLevelFIR()) {
5618	mlir::Value scopeOp = builder->create<fir::DummyScopeOp>(toLocation());
5619	setDummyArgsScope(scopeOp);
5620	}
5621	if (std::optional<Fortran::lower::CalleeInterface::PassedEntity>
5622	passedResult = callee.getPassedResult()) {
5623	mapPassedEntity(*passedResult, /*isResult=*/true);
5624	// FIXME: need to make sure things are OK here. addSymbol may not be OK
5625	if (funit.primaryResult &&
5626	passedResult->entity->get() != *funit.primaryResult)
5627	mapBlockArgToDummyOrResult(
5628	*funit.primaryResult, getSymbolAddress(passedResult->entity->get()),
5629	/*isResult=*/true);
5630	}
5631	}
5632
5633	/// Instantiate variable \p var and add it to the symbol map.
5634	/// See ConvertVariable.cpp.
5635	void instantiateVar(const Fortran::lower::pft::Variable &var,
5636	Fortran::lower::AggregateStoreMap &storeMap) {
5637	Fortran::lower::instantiateVariable(*this, var, localSymbols, storeMap);
5638	if (var.hasSymbol())
5639	genOpenMPSymbolProperties(*this, var);
5640	}
5641
5642	/// Where applicable, save the exception state and halting, rounding, and
5643	/// underflow modes at function entry, and restore them at function exits.
5644	void manageFPEnvironment(Fortran::lower::pft::FunctionLikeUnit &funit) {
5645	mlir::Location loc = toLocation();
5646	mlir::Location endLoc =
5647	toLocation(Fortran::lower::pft::stmtSourceLoc(funit.endStmt));
5648	if (funit.hasIeeeAccess) {
5649	// Subject to F18 Clause 17.1p3, 17.3p3 states: If a flag is signaling
5650	// on entry to a procedure [...], the processor will set it to quiet
5651	// on entry and restore it to signaling on return. If a flag signals
5652	// during execution of a procedure, the processor shall not set it to
5653	// quiet on return.
5654	mlir::func::FuncOp testExcept = fir::factory::getFetestexcept(*builder);
5655	mlir::func::FuncOp clearExcept = fir::factory::getFeclearexcept(*builder);
5656	mlir::func::FuncOp raiseExcept = fir::factory::getFeraiseexcept(*builder);
5657	mlir::Value ones = builder->createIntegerConstant(
5658	loc, testExcept.getFunctionType().getInput(0), -1);
5659	mlir::Value exceptSet =
5660	builder->create<fir::CallOp>(loc, testExcept, ones).getResult(0);
5661	builder->create<fir::CallOp>(loc, clearExcept, exceptSet);
5662	bridge.fctCtx().attachCleanup([=]() {
5663	builder->create<fir::CallOp>(endLoc, raiseExcept, exceptSet);
5664	});
5665	}
5666	if (funit.mayModifyHaltingMode) {
5667	// F18 Clause 17.6p1: In a procedure [...], the processor shall not
5668	// change the halting mode on entry, and on return shall ensure that
5669	// the halting mode is the same as it was on entry.
5670	mlir::func::FuncOp getExcept = fir::factory::getFegetexcept(*builder);
5671	mlir::func::FuncOp disableExcept =
5672	fir::factory::getFedisableexcept(*builder);
5673	mlir::func::FuncOp enableExcept =
5674	fir::factory::getFeenableexcept(*builder);
5675	mlir::Value exceptSet =
5676	builder->create<fir::CallOp>(loc, getExcept).getResult(0);
5677	mlir::Value ones = builder->createIntegerConstant(
5678	loc, disableExcept.getFunctionType().getInput(0), -1);
5679	bridge.fctCtx().attachCleanup([=]() {
5680	builder->create<fir::CallOp>(endLoc, disableExcept, ones);
5681	builder->create<fir::CallOp>(endLoc, enableExcept, exceptSet);
5682	});
5683	}
5684	if (funit.mayModifyRoundingMode) {
5685	// F18 Clause 17.4p5: In a procedure [...], the processor shall not
5686	// change the rounding modes on entry, and on return shall ensure that
5687	// the rounding modes are the same as they were on entry.
5688	mlir::func::FuncOp getRounding =
5689	fir::factory::getLlvmGetRounding(*builder);
5690	mlir::func::FuncOp setRounding =
5691	fir::factory::getLlvmSetRounding(*builder);
5692	mlir::Value roundingMode =
5693	builder->create<fir::CallOp>(loc, getRounding).getResult(0);
5694	bridge.fctCtx().attachCleanup([=]() {
5695	builder->create<fir::CallOp>(endLoc, setRounding, roundingMode);
5696	});
5697	}
5698	if ((funit.mayModifyUnderflowMode) &&
5699	(bridge.getTargetCharacteristics().hasSubnormalFlushingControl(
5700	/*any=*/true))) {
5701	// F18 Clause 17.5p2: In a procedure [...], the processor shall not
5702	// change the underflow mode on entry, and on return shall ensure that
5703	// the underflow mode is the same as it was on entry.
5704	mlir::Value underflowMode =
5705	fir::runtime::genGetUnderflowMode(*builder, loc);
5706	bridge.fctCtx().attachCleanup([=]() {
5707	fir::runtime::genSetUnderflowMode(*builder, loc, {underflowMode});
5708	});
5709	}
5710	}
5711
5712	/// Start translation of a function.
5713	void startNewFunction(Fortran::lower::pft::FunctionLikeUnit &funit) {
5714	assert(!builder && "expected nullptr");
5715	bridge.fctCtx().pushScope();
5716	bridge.openAccCtx().pushScope();
5717	const Fortran::semantics::Scope &scope = funit.getScope();
5718	LLVM_DEBUG(llvm::dbgs() << "\n[bridge - startNewFunction]";
5719	if (auto *sym = scope.symbol()) llvm::dbgs() << " " << *sym;
5720	llvm::dbgs() << "\n");
5721	// Setting the builder is not necessary here, because callee
5722	// always looks up the FuncOp from the module. If there was a function that
5723	// was not declared yet, this call to callee will cause an assertion
5724	// failure.
5725	Fortran::lower::CalleeInterface callee(funit, *this);
5726	mlir::func::FuncOp func = callee.addEntryBlockAndMapArguments();
5727	builder =
5728	new fir::FirOpBuilder(func, bridge.getKindMap(), &mlirSymbolTable);
5729	assert(builder && "FirOpBuilder did not instantiate");
5730	builder->setFastMathFlags(bridge.getLoweringOptions().getMathOptions());
5731	builder->setInsertionPointToStart(&func.front());
5732	if (funit.parent.isA<Fortran::lower::pft::FunctionLikeUnit>()) {
5733	// Give internal linkage to internal functions. There are no name clash
5734	// risks, but giving global linkage to internal procedure will break the
5735	// static link register in shared libraries because of the system calls.
5736	// Also, it should be possible to eliminate the procedure code if all the
5737	// uses have been inlined.
5738	fir::factory::setInternalLinkage(func);
5739	} else {
5740	func.setVisibility(mlir::SymbolTable::Visibility::Public);
5741	}
5742	assert(blockId == 0 && "invalid blockId");
5743	assert(activeConstructStack.empty() && "invalid construct stack state");
5744
5745	// Manage floating point exception, halting mode, and rounding mode
5746	// settings at function entry and exit.
5747	if (!funit.isMainProgram())
5748	manageFPEnvironment(funit);
5749
5750	mapDummiesAndResults(funit, callee);
5751
5752	// Map host associated symbols from parent procedure if any.
5753	if (funit.parentHasHostAssoc())
5754	funit.parentHostAssoc().internalProcedureBindings(*this, localSymbols);
5755
5756	// Non-primary results of a function with multiple entry points.
5757	// These result values share storage with the primary result.
5758	llvm::SmallVector<Fortran::lower::pft::Variable> deferredFuncResultList;
5759
5760	// Backup actual argument for entry character results with different
5761	// lengths. It needs to be added to the non-primary results symbol before
5762	// mapSymbolAttributes is called.
5763	Fortran::lower::SymbolBox resultArg;
5764	if (std::optional<Fortran::lower::CalleeInterface::PassedEntity>
5765	passedResult = callee.getPassedResult())
5766	resultArg = lookupSymbol(passedResult->entity->get());
5767
5768	Fortran::lower::AggregateStoreMap storeMap;
5769
5770	// Map all containing submodule and module equivalences and variables, in
5771	// case they are referenced. It might be better to limit this to variables
5772	// that are actually referenced, although that is more complicated when
5773	// there are equivalenced variables.
5774	auto &scopeVariableListMap =
5775	Fortran::lower::pft::getScopeVariableListMap(funit);
5776	for (auto *scp = &scope.parent(); !scp->IsGlobal(); scp = &scp->parent())
5777	if (scp->kind() == Fortran::semantics::Scope::Kind::Module)
5778	for (const auto &var : Fortran::lower::pft::getScopeVariableList(
5779	*scp, scopeVariableListMap))
5780	if (!var.isRuntimeTypeInfoData())
5781	instantiateVar(var, storeMap);
5782
5783	// Map function equivalences and variables.
5784	mlir::Value primaryFuncResultStorage;
5785	for (const Fortran::lower::pft::Variable &var :
5786	Fortran::lower::pft::getScopeVariableList(scope)) {
5787	// Always instantiate aggregate storage blocks.
5788	if (var.isAggregateStore()) {
5789	instantiateVar(var, storeMap);
5790	continue;
5791	}
5792	const Fortran::semantics::Symbol &sym = var.getSymbol();
5793	if (funit.parentHasHostAssoc()) {
5794	// Never instantiate host associated variables, as they are already
5795	// instantiated from an argument tuple. Instead, just bind the symbol
5796	// to the host variable, which must be in the map.
5797	const Fortran::semantics::Symbol &ultimate = sym.GetUltimate();
5798	if (funit.parentHostAssoc().isAssociated(ultimate)) {
5799	copySymbolBinding(ultimate, sym);
5800	continue;
5801	}
5802	}
5803	if (!sym.IsFuncResult() || !funit.primaryResult) {
5804	instantiateVar(var, storeMap);
5805	} else if (&sym == funit.primaryResult) {
5806	instantiateVar(var, storeMap);
5807	primaryFuncResultStorage = getSymbolAddress(sym);
5808	} else {
5809	deferredFuncResultList.push_back(var);
5810	}
5811	}
5812
5813	// TODO: should use same mechanism as equivalence?
5814	// One blocking point is character entry returns that need special handling
5815	// since they are not locally allocated but come as argument. CHARACTER(*)
5816	// is not something that fits well with equivalence lowering.
5817	for (const Fortran::lower::pft::Variable &altResult :
5818	deferredFuncResultList) {
5819	Fortran::lower::StatementContext stmtCtx;
5820	if (std::optional<Fortran::lower::CalleeInterface::PassedEntity>
5821	passedResult = callee.getPassedResult()) {
5822	mapBlockArgToDummyOrResult(altResult.getSymbol(), resultArg.getAddr(),
5823	/*isResult=*/true);
5824	Fortran::lower::mapSymbolAttributes(*this, altResult, localSymbols,
5825	stmtCtx);
5826	} else {
5827	// catch cases where the allocation for the function result storage type
5828	// doesn't match the type of this symbol
5829	mlir::Value preAlloc = primaryFuncResultStorage;
5830	mlir::Type resTy = primaryFuncResultStorage.getType();
5831	mlir::Type symTy = genType(altResult);
5832	mlir::Type wrappedSymTy = fir::ReferenceType::get(symTy);
5833	if (resTy != wrappedSymTy) {
5834	// check size of the pointed to type so we can't overflow by writing
5835	// double precision to a single precision allocation, etc
5836	LLVM_ATTRIBUTE_UNUSED auto getBitWidth = [this](mlir::Type ty) {
5837	// 15.6.2.6.3: differering result types should be integer, real,
5838	// complex or logical
5839	if (auto cmplx = mlir::dyn_cast_or_null<mlir::ComplexType>(ty))
5840	return 2 * cmplx.getElementType().getIntOrFloatBitWidth();
5841	if (auto logical = mlir::dyn_cast_or_null<fir::LogicalType>(ty)) {
5842	fir::KindTy kind = logical.getFKind();
5843	return builder->getKindMap().getLogicalBitsize(kind);
5844	}
5845	return ty.getIntOrFloatBitWidth();
5846	};
5847	assert(getBitWidth(fir::unwrapRefType(resTy)) >= getBitWidth(symTy));
5848
5849	// convert the storage to the symbol type so that the hlfir.declare
5850	// gets the correct type for this symbol
5851	preAlloc = builder->create<fir::ConvertOp>(getCurrentLocation(),
5852	wrappedSymTy, preAlloc);
5853	}
5854
5855	Fortran::lower::mapSymbolAttributes(*this, altResult, localSymbols,
5856	stmtCtx, preAlloc);
5857	}
5858	}
5859
5860	// If this is a host procedure with host associations, then create the tuple
5861	// of pointers for passing to the internal procedures.
5862	if (!funit.getHostAssoc().empty())
5863	funit.getHostAssoc().hostProcedureBindings(*this, localSymbols);
5864
5865	// Unregister all dummy symbols, so that their cloning (e.g. for OpenMP
5866	// privatization) does not create the cloned hlfir.declare operations
5867	// with dummy_scope operands.
5868	resetRegisteredDummySymbols();
5869
5870	// Create most function blocks in advance.
5871	createEmptyBlocks(funit.evaluationList);
5872
5873	// Reinstate entry block as the current insertion point.
5874	builder->setInsertionPointToEnd(&func.front());
5875
5876	if (callee.hasAlternateReturns()) {
5877	// Create a local temp to hold the alternate return index.
5878	// Give it an integer index type and the subroutine name (for dumps).
5879	// Attach it to the subroutine symbol in the localSymbols map.
5880	// Initialize it to zero, the "fallthrough" alternate return value.
5881	const Fortran::semantics::Symbol &symbol = funit.getSubprogramSymbol();
5882	mlir::Location loc = toLocation();
5883	mlir::Type idxTy = builder->getIndexType();
5884	mlir::Value altResult =
5885	builder->createTemporary(loc, idxTy, toStringRef(symbol.name()));
5886	addSymbol(symbol, altResult);
5887	mlir::Value zero = builder->createIntegerConstant(loc, idxTy, 0);
5888	builder->create<fir::StoreOp>(loc, zero, altResult);
5889	}
5890
5891	if (Fortran::lower::pft::Evaluation *alternateEntryEval =
5892	funit.getEntryEval())
5893	genBranch(alternateEntryEval->lexicalSuccessor->block);
5894	}
5895
5896	/// Create global blocks for the current function. This eliminates the
5897	/// distinction between forward and backward targets when generating
5898	/// branches. A block is "global" if it can be the target of a GOTO or
5899	/// other source code branch. A block that can only be targeted by a
5900	/// compiler generated branch is "local". For example, a DO loop preheader
5901	/// block containing loop initialization code is global. A loop header
5902	/// block, which is the target of the loop back edge, is local. Blocks
5903	/// belong to a region. Any block within a nested region must be replaced
5904	/// with a block belonging to that region. Branches may not cross region
5905	/// boundaries.
5906	void createEmptyBlocks(
5907	std::list<Fortran::lower::pft::Evaluation> &evaluationList) {
5908	mlir::Region *region = &builder->getRegion();
5909	for (Fortran::lower::pft::Evaluation &eval : evaluationList) {
5910	if (eval.isNewBlock)
5911	eval.block = builder->createBlock(region);
5912	if (eval.isConstruct() || eval.isDirective()) {
5913	if (eval.lowerAsUnstructured()) {
5914	createEmptyBlocks(eval.getNestedEvaluations());
5915	} else if (eval.hasNestedEvaluations()) {
5916	// A structured construct that is a target starts a new block.
5917	Fortran::lower::pft::Evaluation &constructStmt =
5918	eval.getFirstNestedEvaluation();
5919	if (constructStmt.isNewBlock)
5920	constructStmt.block = builder->createBlock(region);
5921	}
5922	}
5923	}
5924	}
5925
5926	/// Return the predicate: "current block does not have a terminator branch".
5927	bool blockIsUnterminated() {
5928	mlir::Block *currentBlock = builder->getBlock();
5929	return currentBlock->empty() ||
5930	!currentBlock->back().hasTrait<mlir::OpTrait::IsTerminator>();
5931	}
5932
5933	/// Unconditionally switch code insertion to a new block.
5934	void startBlock(mlir::Block *newBlock) {
5935	assert(newBlock && "missing block");
5936	// Default termination for the current block is a fallthrough branch to
5937	// the new block.
5938	if (blockIsUnterminated())
5939	genBranch(newBlock);
5940	// Some blocks may be re/started more than once, and might not be empty.
5941	// If the new block already has (only) a terminator, set the insertion
5942	// point to the start of the block. Otherwise set it to the end.
5943	builder->setInsertionPointToStart(newBlock);
5944	if (blockIsUnterminated())
5945	builder->setInsertionPointToEnd(newBlock);
5946	}
5947
5948	/// Conditionally switch code insertion to a new block.
5949	void maybeStartBlock(mlir::Block *newBlock) {
5950	if (newBlock)
5951	startBlock(newBlock);
5952	}
5953
5954	void eraseDeadCodeAndBlocks(mlir::RewriterBase &rewriter,
5955	llvm::MutableArrayRef<mlir::Region> regions) {
5956	// WARNING: Do not add passes that can do folding or code motion here
5957	// because they might cross omp.target region boundaries, which can result
5958	// in incorrect code. Optimization passes like these must be added after
5959	// OMP early outlining has been done.
5960	(void)mlir::eraseUnreachableBlocks(rewriter, regions);
5961	(void)mlir::runRegionDCE(rewriter, regions);
5962	}
5963
5964	/// Finish translation of a function.
5965	void endNewFunction(Fortran::lower::pft::FunctionLikeUnit &funit) {
5966	setCurrentPosition(Fortran::lower::pft::stmtSourceLoc(funit.endStmt));
5967	if (funit.isMainProgram()) {
5968	genExitRoutine(false);
5969	} else {
5970	genFIRProcedureExit(funit, funit.getSubprogramSymbol());
5971	}
5972	funit.finalBlock = nullptr;
5973	LLVM_DEBUG(llvm::dbgs() << "\n[bridge - endNewFunction";
5974	if (auto *sym = funit.scope->symbol()) llvm::dbgs()
5975	<< " " << sym->name();
5976	llvm::dbgs() << "] generated IR:\n\n"
5977	<< *builder->getFunction() << '\n');
5978	// Eliminate dead code as a prerequisite to calling other IR passes.
5979	// FIXME: This simplification should happen in a normal pass, not here.
5980	mlir::IRRewriter rewriter(*builder);
5981	(void)eraseDeadCodeAndBlocks(rewriter, {builder->getRegion()});
5982	delete builder;
5983	builder = nullptr;
5984	hostAssocTuple = mlir::Value{};
5985	localSymbols.clear();
5986	blockId = 0;
5987	dummyArgsScope = mlir::Value{};
5988	resetRegisteredDummySymbols();
5989	}
5990
5991	/// Helper to generate GlobalOps when the builder is not positioned in any
5992	/// region block. This is required because the FirOpBuilder assumes it is
5993	/// always positioned inside a region block when creating globals, the easiest
5994	/// way to comply is to create a dummy function and to throw it away
5995	/// afterwards.
5996	void createBuilderOutsideOfFuncOpAndDo(
5997	const std::function<void()> &createGlobals) {
5998	// FIXME: get rid of the bogus function context and instantiate the
5999	// globals directly into the module.
6000	mlir::MLIRContext *context = &getMLIRContext();
6001	mlir::SymbolTable *symbolTable = getMLIRSymbolTable();
6002	mlir::func::FuncOp func = fir::FirOpBuilder::createFunction(
6003	mlir::UnknownLoc::get(context), getModuleOp(),
6004	fir::NameUniquer::doGenerated("Sham"),
6005	mlir::FunctionType::get(context, std::nullopt, std::nullopt),
6006	symbolTable);
6007	func.addEntryBlock();
6008	CHECK(!builder && "Expected builder to be uninitialized");
6009	builder = new fir::FirOpBuilder(func, bridge.getKindMap(), symbolTable);
6010	assert(builder && "FirOpBuilder did not instantiate");
6011	builder->setFastMathFlags(bridge.getLoweringOptions().getMathOptions());
6012	createGlobals();
6013	if (mlir::Region *region = func.getCallableRegion())
6014	region->dropAllReferences();
6015	func.erase();
6016	delete builder;
6017	builder = nullptr;
6018	localSymbols.clear();
6019	resetRegisteredDummySymbols();
6020	}
6021
6022	/// Instantiate the data from a BLOCK DATA unit.
6023	void lowerBlockData(Fortran::lower::pft::BlockDataUnit &bdunit) {
6024	createBuilderOutsideOfFuncOpAndDo(createGlobals: [&]() {
6025	Fortran::lower::AggregateStoreMap fakeMap;
6026	for (const auto &[_, sym] : bdunit.symTab) {
6027	if (sym->has<Fortran::semantics::ObjectEntityDetails>()) {
6028	Fortran::lower::pft::Variable var(*sym, true);
6029	instantiateVar(var, fakeMap);
6030	}
6031	}
6032	});
6033	}
6034
6035	/// Create fir::Global for all the common blocks that appear in the program.
6036	void
6037	lowerCommonBlocks(const Fortran::semantics::CommonBlockList &commonBlocks) {
6038	createBuilderOutsideOfFuncOpAndDo(
6039	createGlobals: [&]() { Fortran::lower::defineCommonBlocks(*this, commonBlocks); });
6040	}
6041
6042	/// Create intrinsic module array constant definitions.
6043	void createIntrinsicModuleDefinitions(Fortran::lower::pft::Program &pft) {
6044	// The intrinsic module scope, if present, is the first scope.
6045	const Fortran::semantics::Scope *intrinsicModuleScope = nullptr;
6046	for (Fortran::lower::pft::Program::Units &u : pft.getUnits()) {
6047	Fortran::common::visit(
6048	Fortran::common::visitors{
6049	[&](Fortran::lower::pft::FunctionLikeUnit &f) {
6050	intrinsicModuleScope = &f.getScope().parent();
6051	},
6052	[&](Fortran::lower::pft::ModuleLikeUnit &m) {
6053	intrinsicModuleScope = &m.getScope().parent();
6054	},
6055	[&](Fortran::lower::pft::BlockDataUnit &b) {},
6056	[&](Fortran::lower::pft::CompilerDirectiveUnit &d) {},
6057	[&](Fortran::lower::pft::OpenACCDirectiveUnit &d) {},
6058	},
6059	u);
6060	if (intrinsicModuleScope) {
6061	while (!intrinsicModuleScope->IsGlobal())
6062	intrinsicModuleScope = &intrinsicModuleScope->parent();
6063	intrinsicModuleScope = &intrinsicModuleScope->children().front();
6064	break;
6065	}
6066	}
6067	if (!intrinsicModuleScope || !intrinsicModuleScope->IsIntrinsicModules())
6068	return;
6069	for (const auto &scope : intrinsicModuleScope->children()) {
6070	llvm::StringRef modName = toStringRef(scope.symbol()->name());
6071	if (modName != "__fortran_ieee_exceptions")
6072	continue;
6073	for (auto &var : Fortran::lower::pft::getScopeVariableList(scope)) {
6074	const Fortran::semantics::Symbol &sym = var.getSymbol();
6075	if (sym.test(Fortran::semantics::Symbol::Flag::CompilerCreated))
6076	continue;
6077	const auto *object =
6078	sym.detailsIf<Fortran::semantics::ObjectEntityDetails>();
6079	if (object && object->IsArray() && object->init())
6080	Fortran::lower::createIntrinsicModuleGlobal(*this, var);
6081	}
6082	}
6083	}
6084
6085	/// Lower a procedure (nest).
6086	void lowerFunc(Fortran::lower::pft::FunctionLikeUnit &funit) {
6087	setCurrentPosition(funit.getStartingSourceLoc());
6088	setCurrentFunctionUnit(&funit);
6089	for (int entryIndex = 0, last = funit.entryPointList.size();
6090	entryIndex < last; ++entryIndex) {
6091	funit.setActiveEntry(entryIndex);
6092	startNewFunction(funit); // the entry point for lowering this procedure
6093	for (Fortran::lower::pft::Evaluation &eval : funit.evaluationList)
6094	genFIR(eval);
6095	endNewFunction(funit);
6096	}
6097	funit.setActiveEntry(0);
6098	setCurrentFunctionUnit(nullptr);
6099	for (Fortran::lower::pft::ContainedUnit &unit : funit.containedUnitList)
6100	if (auto *f = std::get_if<Fortran::lower::pft::FunctionLikeUnit>(&unit))
6101	lowerFunc(*f); // internal procedure
6102	}
6103
6104	/// Lower module variable definitions to fir::globalOp and OpenMP/OpenACC
6105	/// declarative construct.
6106	void lowerModuleDeclScope(Fortran::lower::pft::ModuleLikeUnit &mod) {
6107	setCurrentPosition(mod.getStartingSourceLoc());
6108	auto &scopeVariableListMap =
6109	Fortran::lower::pft::getScopeVariableListMap(mod);
6110	for (const auto &var : Fortran::lower::pft::getScopeVariableList(
6111	mod.getScope(), scopeVariableListMap)) {
6112
6113	// Only define the variables owned by this module.
6114	const Fortran::semantics::Scope *owningScope = var.getOwningScope();
6115	if (owningScope && mod.getScope() != *owningScope)
6116	continue;
6117
6118	// Very special case: The value of numeric_storage_size depends on
6119	// compilation options and therefore its value is not yet known when
6120	// building the builtins runtime. Instead, the parameter is folding a
6121	// __numeric_storage_size() expression which is loaded into the user
6122	// program. For the iso_fortran_env object file, omit the symbol as it
6123	// is never used.
6124	if (var.hasSymbol()) {
6125	const Fortran::semantics::Symbol &sym = var.getSymbol();
6126	const Fortran::semantics::Scope &owner = sym.owner();
6127	if (sym.name() == "numeric_storage_size" && owner.IsModule() &&
6128	DEREF(owner.symbol()).name() == "iso_fortran_env")
6129	continue;
6130	}
6131
6132	Fortran::lower::defineModuleVariable(*this, var);
6133	}
6134	for (auto &eval : mod.evaluationList)
6135	genFIR(eval);
6136	}
6137
6138	/// Lower functions contained in a module.
6139	void lowerMod(Fortran::lower::pft::ModuleLikeUnit &mod) {
6140	for (Fortran::lower::pft::ContainedUnit &unit : mod.containedUnitList)
6141	if (auto *f = std::get_if<Fortran::lower::pft::FunctionLikeUnit>(&unit))
6142	lowerFunc(*f);
6143	}
6144
6145	void setCurrentPosition(const Fortran::parser::CharBlock &position) {
6146	if (position != Fortran::parser::CharBlock{})
6147	currentPosition = position;
6148	}
6149
6150	/// Set current position at the location of \p parseTreeNode. Note that the
6151	/// position is updated automatically when visiting statements, but not when
6152	/// entering higher level nodes like constructs or procedures. This helper is
6153	/// intended to cover the latter cases.
6154	template <typename A>
6155	void setCurrentPositionAt(const A &parseTreeNode) {
6156	setCurrentPosition(Fortran::parser::FindSourceLocation(parseTreeNode));
6157	}
6158
6159	//===--------------------------------------------------------------------===//
6160	// Utility methods
6161	//===--------------------------------------------------------------------===//
6162
6163	/// Convert a parser CharBlock to a Location
6164	mlir::Location toLocation(const Fortran::parser::CharBlock &cb) {
6165	return genLocation(cb);
6166	}
6167
6168	mlir::Location toLocation() { return toLocation(currentPosition); }
6169	void setCurrentEval(Fortran::lower::pft::Evaluation &eval) {
6170	evalPtr = &eval;
6171	}
6172	Fortran::lower::pft::Evaluation &getEval() {
6173	assert(evalPtr);
6174	return *evalPtr;
6175	}
6176
6177	std::optional<Fortran::evaluate::Shape>
6178	getShape(const Fortran::lower::SomeExpr &expr) {
6179	return Fortran::evaluate::GetShape(foldingContext, expr);
6180	}
6181
6182	//===--------------------------------------------------------------------===//
6183	// Analysis on a nested explicit iteration space.
6184	//===--------------------------------------------------------------------===//
6185
6186	void analyzeExplicitSpace(const Fortran::parser::ConcurrentHeader &header) {
6187	explicitIterSpace.pushLevel();
6188	for (const Fortran::parser::ConcurrentControl &ctrl :
6189	std::get<std::list<Fortran::parser::ConcurrentControl>>(header.t)) {
6190	const Fortran::semantics::Symbol *ctrlVar =
6191	std::get<Fortran::parser::Name>(ctrl.t).symbol;
6192	explicitIterSpace.addSymbol(ctrlVar);
6193	}
6194	if (const auto &mask =
6195	std::get<std::optional<Fortran::parser::ScalarLogicalExpr>>(
6196	header.t);
6197	mask.has_value())
6198	analyzeExplicitSpace(*Fortran::semantics::GetExpr(*mask));
6199	}
6200	template <bool LHS = false, typename A>
6201	void analyzeExplicitSpace(const Fortran::evaluate::Expr<A> &e) {
6202	explicitIterSpace.exprBase(&e, LHS);
6203	}
6204	void analyzeExplicitSpace(const Fortran::evaluate::Assignment *assign) {
6205	auto analyzeAssign = [&](const Fortran::lower::SomeExpr &lhs,
6206	const Fortran::lower::SomeExpr &rhs) {
6207	analyzeExplicitSpace</*LHS=*/true>(lhs);
6208	analyzeExplicitSpace(rhs);
6209	};
6210	Fortran::common::visit(
6211	Fortran::common::visitors{
6212	[&](const Fortran::evaluate::ProcedureRef &procRef) {
6213	// Ensure the procRef expressions are the one being visited.
6214	assert(procRef.arguments().size() == 2);
6215	const Fortran::lower::SomeExpr *lhs =
6216	procRef.arguments()[0].value().UnwrapExpr();
6217	const Fortran::lower::SomeExpr *rhs =
6218	procRef.arguments()[1].value().UnwrapExpr();
6219	assert(lhs && rhs &&
6220	"user defined assignment arguments must be expressions");
6221	analyzeAssign(*lhs, *rhs);
6222	},
6223	[&](const auto &) { analyzeAssign(assign->lhs, assign->rhs); }},
6224	assign->u);
6225	explicitIterSpace.endAssign();
6226	}
6227	void analyzeExplicitSpace(const Fortran::parser::ForallAssignmentStmt &stmt) {
6228	Fortran::common::visit([&](const auto &s) { analyzeExplicitSpace(s); },
6229	stmt.u);
6230	}
6231	void analyzeExplicitSpace(const Fortran::parser::AssignmentStmt &s) {
6232	analyzeExplicitSpace(s.typedAssignment->v.operator->());
6233	}
6234	void analyzeExplicitSpace(const Fortran::parser::PointerAssignmentStmt &s) {
6235	analyzeExplicitSpace(s.typedAssignment->v.operator->());
6236	}
6237	void analyzeExplicitSpace(const Fortran::parser::WhereConstruct &c) {
6238	analyzeExplicitSpace(
6239	std::get<
6240	Fortran::parser::Statement<Fortran::parser::WhereConstructStmt>>(
6241	c.t)
6242	.statement);
6243	for (const Fortran::parser::WhereBodyConstruct &body :
6244	std::get<std::list<Fortran::parser::WhereBodyConstruct>>(c.t))
6245	analyzeExplicitSpace(body);
6246	for (const Fortran::parser::WhereConstruct::MaskedElsewhere &e :
6247	std::get<std::list<Fortran::parser::WhereConstruct::MaskedElsewhere>>(
6248	c.t))
6249	analyzeExplicitSpace(e);
6250	if (const auto &e =
6251	std::get<std::optional<Fortran::parser::WhereConstruct::Elsewhere>>(
6252	c.t);
6253	e.has_value())
6254	analyzeExplicitSpace(e.operator->());
6255	}
6256	void analyzeExplicitSpace(const Fortran::parser::WhereConstructStmt &ws) {
6257	const Fortran::lower::SomeExpr *exp = Fortran::semantics::GetExpr(
6258	std::get<Fortran::parser::LogicalExpr>(ws.t));
6259	addMaskVariable(exp);
6260	analyzeExplicitSpace(*exp);
6261	}
6262	void analyzeExplicitSpace(
6263	const Fortran::parser::WhereConstruct::MaskedElsewhere &ew) {
6264	analyzeExplicitSpace(
6265	std::get<
6266	Fortran::parser::Statement<Fortran::parser::MaskedElsewhereStmt>>(
6267	ew.t)
6268	.statement);
6269	for (const Fortran::parser::WhereBodyConstruct &e :
6270	std::get<std::list<Fortran::parser::WhereBodyConstruct>>(ew.t))
6271	analyzeExplicitSpace(e);
6272	}
6273	void analyzeExplicitSpace(const Fortran::parser::WhereBodyConstruct &body) {
6274	Fortran::common::visit(
6275	Fortran::common::visitors{
6276	[&](const Fortran::common::Indirection<
6277	Fortran::parser::WhereConstruct> &wc) {
6278	analyzeExplicitSpace(wc.value());
6279	},
6280	[&](const auto &s) { analyzeExplicitSpace(s.statement); }},
6281	body.u);
6282	}
6283	void analyzeExplicitSpace(const Fortran::parser::MaskedElsewhereStmt &stmt) {
6284	const Fortran::lower::SomeExpr *exp = Fortran::semantics::GetExpr(
6285	std::get<Fortran::parser::LogicalExpr>(stmt.t));
6286	addMaskVariable(exp);
6287	analyzeExplicitSpace(*exp);
6288	}
6289	void
6290	analyzeExplicitSpace(const Fortran::parser::WhereConstruct::Elsewhere *ew) {
6291	for (const Fortran::parser::WhereBodyConstruct &e :
6292	std::get<std::list<Fortran::parser::WhereBodyConstruct>>(ew->t))
6293	analyzeExplicitSpace(e);
6294	}
6295	void analyzeExplicitSpace(const Fortran::parser::WhereStmt &stmt) {
6296	const Fortran::lower::SomeExpr *exp = Fortran::semantics::GetExpr(
6297	std::get<Fortran::parser::LogicalExpr>(stmt.t));
6298	addMaskVariable(exp);
6299	analyzeExplicitSpace(*exp);
6300	const std::optional<Fortran::evaluate::Assignment> &assign =
6301	std::get<Fortran::parser::AssignmentStmt>(stmt.t).typedAssignment->v;
6302	assert(assign.has_value() && "WHERE has no statement");
6303	analyzeExplicitSpace(assign.operator->());
6304	}
6305	void analyzeExplicitSpace(const Fortran::parser::ForallStmt &forall) {
6306	analyzeExplicitSpace(
6307	std::get<
6308	Fortran::common::Indirection<Fortran::parser::ConcurrentHeader>>(
6309	forall.t)
6310	.value());
6311	analyzeExplicitSpace(std::get<Fortran::parser::UnlabeledStatement<
6312	Fortran::parser::ForallAssignmentStmt>>(forall.t)
6313	.statement);
6314	analyzeExplicitSpacePop();
6315	}
6316	void
6317	analyzeExplicitSpace(const Fortran::parser::ForallConstructStmt &forall) {
6318	analyzeExplicitSpace(
6319	std::get<
6320	Fortran::common::Indirection<Fortran::parser::ConcurrentHeader>>(
6321	forall.t)
6322	.value());
6323	}
6324	void analyzeExplicitSpace(const Fortran::parser::ForallConstruct &forall) {
6325	analyzeExplicitSpace(
6326	std::get<
6327	Fortran::parser::Statement<Fortran::parser::ForallConstructStmt>>(
6328	forall.t)
6329	.statement);
6330	for (const Fortran::parser::ForallBodyConstruct &s :
6331	std::get<std::list<Fortran::parser::ForallBodyConstruct>>(forall.t)) {
6332	Fortran::common::visit(
6333	Fortran::common::visitors{
6334	[&](const Fortran::common::Indirection<
6335	Fortran::parser::ForallConstruct> &b) {
6336	analyzeExplicitSpace(b.value());
6337	},
6338	[&](const Fortran::parser::WhereConstruct &w) {
6339	analyzeExplicitSpace(w);
6340	},
6341	[&](const auto &b) { analyzeExplicitSpace(b.statement); }},
6342	s.u);
6343	}
6344	analyzeExplicitSpacePop();
6345	}
6346
6347	void analyzeExplicitSpacePop() { explicitIterSpace.popLevel(); }
6348
6349	void addMaskVariable(Fortran::lower::FrontEndExpr exp) {
6350	// Note: use i8 to store bool values. This avoids round-down behavior found
6351	// with sequences of i1. That is, an array of i1 will be truncated in size
6352	// and be too small. For example, a buffer of type fir.array<7xi1> will have
6353	// 0 size.
6354	mlir::Type i64Ty = builder->getIntegerType(64);
6355	mlir::TupleType ty = fir::factory::getRaggedArrayHeaderType(*builder);
6356	mlir::Type buffTy = ty.getType(1);
6357	mlir::Type shTy = ty.getType(2);
6358	mlir::Location loc = toLocation();
6359	mlir::Value hdr = builder->createTemporary(loc, ty);
6360	// FIXME: Is there a way to create a `zeroinitializer` in LLVM-IR dialect?
6361	// For now, explicitly set lazy ragged header to all zeros.
6362	// auto nilTup = builder->createNullConstant(loc, ty);
6363	// builder->create<fir::StoreOp>(loc, nilTup, hdr);
6364	mlir::Type i32Ty = builder->getIntegerType(32);
6365	mlir::Value zero = builder->createIntegerConstant(loc, i32Ty, 0);
6366	mlir::Value zero64 = builder->createIntegerConstant(loc, i64Ty, 0);
6367	mlir::Value flags = builder->create<fir::CoordinateOp>(
6368	loc, builder->getRefType(i64Ty), hdr, zero);
6369	builder->create<fir::StoreOp>(loc, zero64, flags);
6370	mlir::Value one = builder->createIntegerConstant(loc, i32Ty, 1);
6371	mlir::Value nullPtr1 = builder->createNullConstant(loc, buffTy);
6372	mlir::Value var = builder->create<fir::CoordinateOp>(
6373	loc, builder->getRefType(buffTy), hdr, one);
6374	builder->create<fir::StoreOp>(loc, nullPtr1, var);
6375	mlir::Value two = builder->createIntegerConstant(loc, i32Ty, 2);
6376	mlir::Value nullPtr2 = builder->createNullConstant(loc, shTy);
6377	mlir::Value shape = builder->create<fir::CoordinateOp>(
6378	loc, builder->getRefType(shTy), hdr, two);
6379	builder->create<fir::StoreOp>(loc, nullPtr2, shape);
6380	implicitIterSpace.addMaskVariable(exp, var, shape, hdr);
6381	explicitIterSpace.outermostContext().attachCleanup(
6382	[builder = this->builder, hdr, loc]() {
6383	fir::runtime::genRaggedArrayDeallocate(loc, *builder, hdr);
6384	});
6385	}
6386
6387	void createRuntimeTypeInfoGlobals() {}
6388
6389	bool lowerToHighLevelFIR() const {
6390	return bridge.getLoweringOptions().getLowerToHighLevelFIR();
6391	}
6392
6393	// Returns the mangling prefix for the given constant expression.
6394	std::string getConstantExprManglePrefix(mlir::Location loc,
6395	const Fortran::lower::SomeExpr &expr,
6396	mlir::Type eleTy) {
6397	return Fortran::common::visit(
6398	[&](const auto &x) -> std::string {
6399	using T = std::decay_t<decltype(x)>;
6400	if constexpr (Fortran::common::HasMember<
6401	T, Fortran::lower::CategoryExpression>) {
6402	if constexpr (T::Result::category ==
6403	Fortran::common::TypeCategory::Derived) {
6404	if (const auto *constant =
6405	std::get_if<Fortran::evaluate::Constant<
6406	Fortran::evaluate::SomeDerived>>(&x.u))
6407	return Fortran::lower::mangle::mangleArrayLiteral(eleTy,
6408	*constant);
6409	fir::emitFatalError(loc,
6410	"non a constant derived type expression");
6411	} else {
6412	return Fortran::common::visit(
6413	[&](const auto &someKind) -> std::string {
6414	using T = std::decay_t<decltype(someKind)>;
6415	using TK = Fortran::evaluate::Type<T::Result::category,
6416	T::Result::kind>;
6417	if (const auto *constant =
6418	std::get_if<Fortran::evaluate::Constant<TK>>(
6419	&someKind.u)) {
6420	return Fortran::lower::mangle::mangleArrayLiteral(
6421	nullptr, *constant);
6422	}
6423	fir::emitFatalError(
6424	loc, "not a Fortran::evaluate::Constant<T> expression");
6425	return {};
6426	},
6427	x.u);
6428	}
6429	} else {
6430	fir::emitFatalError(loc, "unexpected expression");
6431	}
6432	},
6433	expr.u);
6434	}
6435
6436	/// Performing OpenMP lowering actions that were deferred to the end of
6437	/// lowering.
6438	void finalizeOpenMPLowering(
6439	const Fortran::semantics::Symbol *globalOmpRequiresSymbol) {
6440	if (!ompDeferredDeclareTarget.empty()) {
6441	bool deferredDeviceFuncFound =
6442	Fortran::lower::markOpenMPDeferredDeclareTargetFunctions(
6443	getModuleOp().getOperation(), ompDeferredDeclareTarget, *this);
6444	ompDeviceCodeFound = ompDeviceCodeFound || deferredDeviceFuncFound;
6445	}
6446
6447	// Set the module attribute related to OpenMP requires directives
6448	if (ompDeviceCodeFound)
6449	Fortran::lower::genOpenMPRequires(getModuleOp().getOperation(),
6450	globalOmpRequiresSymbol);
6451	}
6452
6453	/// Record fir.dummy_scope operation for this function.
6454	/// It will be used to set dummy_scope operand of the hlfir.declare
6455	/// operations.
6456	void setDummyArgsScope(mlir::Value val) {
6457	assert(!dummyArgsScope && val);
6458	dummyArgsScope = val;
6459	}
6460
6461	/// Record the given symbol as a dummy argument of this function.
6462	void registerDummySymbol(Fortran::semantics::SymbolRef symRef) {
6463	auto *sym = &*symRef;
6464	registeredDummySymbols.insert(sym);
6465	}
6466
6467	/// Reset all registered dummy symbols.
6468	void resetRegisteredDummySymbols() { registeredDummySymbols.clear(); }
6469
6470	void setCurrentFunctionUnit(Fortran::lower::pft::FunctionLikeUnit *unit) {
6471	currentFunctionUnit = unit;
6472	}
6473
6474	//===--------------------------------------------------------------------===//
6475
6476	Fortran::lower::LoweringBridge &bridge;
6477	Fortran::evaluate::FoldingContext foldingContext;
6478	fir::FirOpBuilder *builder = nullptr;
6479	Fortran::lower::pft::Evaluation *evalPtr = nullptr;
6480	Fortran::lower::pft::FunctionLikeUnit *currentFunctionUnit = nullptr;
6481	Fortran::lower::SymMap localSymbols;
6482	Fortran::parser::CharBlock currentPosition;
6483	TypeInfoConverter typeInfoConverter;
6484
6485	// Stack to manage object deallocation and finalization at construct exits.
6486	llvm::SmallVector<ConstructContext> activeConstructStack;
6487
6488	/// BLOCK name mangling component map
6489	int blockId = 0;
6490	Fortran::lower::mangle::ScopeBlockIdMap scopeBlockIdMap;
6491
6492	/// FORALL statement/construct context
6493	Fortran::lower::ExplicitIterSpace explicitIterSpace;
6494
6495	/// WHERE statement/construct mask expression stack
6496	Fortran::lower::ImplicitIterSpace implicitIterSpace;
6497
6498	/// Tuple of host associated variables
6499	mlir::Value hostAssocTuple;
6500
6501	/// Value of fir.dummy_scope operation for this function.
6502	mlir::Value dummyArgsScope;
6503
6504	/// A set of dummy argument symbols for this function.
6505	/// The set is only preserved during the instatiation
6506	/// of variables for this function.
6507	llvm::SmallPtrSet<const Fortran::semantics::Symbol *, 16>
6508	registeredDummySymbols;
6509
6510	/// A map of unique names for constant expressions.
6511	/// The names are used for representing the constant expressions
6512	/// with global constant initialized objects.
6513	/// The names are usually prefixed by a mangling string based
6514	/// on the element type of the constant expression, but the element
6515	/// type is not used as a key into the map (so the assumption is that
6516	/// the equivalent constant expressions are prefixed using the same
6517	/// element type).
6518	llvm::DenseMap<const Fortran::lower::SomeExpr *, std::string> literalNamesMap;
6519
6520	/// Storage for Constant expressions used as keys for literalNamesMap.
6521	llvm::SmallVector<std::unique_ptr<Fortran::lower::SomeExpr>>
6522	literalExprsStorage;
6523
6524	/// A counter for uniquing names in `literalNamesMap`.
6525	std::uint64_t uniqueLitId = 0;
6526
6527	/// Whether an OpenMP target region or declare target function/subroutine
6528	/// intended for device offloading has been detected
6529	bool ompDeviceCodeFound = false;
6530
6531	/// Keeps track of symbols defined as declare target that could not be
6532	/// processed at the time of lowering the declare target construct, such
6533	/// as certain cases where interfaces are declared but not defined within
6534	/// a module.
6535	llvm::SmallVector<Fortran::lower::OMPDeferredDeclareTargetInfo>
6536	ompDeferredDeclareTarget;
6537
6538	const Fortran::lower::ExprToValueMap *exprValueOverrides{nullptr};
6539
6540	/// Stack of derived type under construction to avoid infinite loops when
6541	/// dealing with recursive derived types. This is held in the bridge because
6542	/// the state needs to be maintained between data and function type lowering
6543	/// utilities to deal with procedure pointer components whose arguments have
6544	/// the type of the containing derived type.
6545	Fortran::lower::TypeConstructionStack typeConstructionStack;
6546	/// MLIR symbol table of the fir.global/func.func operations. Note that it is
6547	/// not guaranteed to contain all operations of the ModuleOp with Symbol
6548	/// attribute since mlirSymbolTable must pro-actively be maintained when
6549	/// new Symbol operations are created.
6550	mlir::SymbolTable mlirSymbolTable;
6551	};
6552
6553	} // namespace
6554
6555	Fortran::evaluate::FoldingContext
6556	Fortran::lower::LoweringBridge::createFoldingContext() {
6557	return {getDefaultKinds(), getIntrinsicTable(), getTargetCharacteristics(),
6558	getLanguageFeatures(), tempNames};
6559	}
6560
6561	void Fortran::lower::LoweringBridge::lower(
6562	const Fortran::parser::Program &prg,
6563	const Fortran::semantics::SemanticsContext &semanticsContext) {
6564	std::unique_ptr<Fortran::lower::pft::Program> pft =
6565	Fortran::lower::createPFT(prg, semanticsContext);
6566	if (dumpBeforeFir)
6567	Fortran::lower::dumpPFT(llvm::errs(), *pft);
6568	FirConverter converter{*this};
6569	converter.run(*pft);
6570	}
6571
6572	void Fortran::lower::LoweringBridge::parseSourceFile(llvm::SourceMgr &srcMgr) {
6573	module = mlir::parseSourceFile<mlir::ModuleOp>(srcMgr, &context);
6574	}
6575
6576	Fortran::lower::LoweringBridge::LoweringBridge(
6577	mlir::MLIRContext &context,
6578	Fortran::semantics::SemanticsContext &semanticsContext,
6579	const Fortran::common::IntrinsicTypeDefaultKinds &defaultKinds,
6580	const Fortran::evaluate::IntrinsicProcTable &intrinsics,
6581	const Fortran::evaluate::TargetCharacteristics &targetCharacteristics,
6582	const Fortran::parser::AllCookedSources &cooked, llvm::StringRef triple,
6583	fir::KindMapping &kindMap,
6584	const Fortran::lower::LoweringOptions &loweringOptions,
6585	const std::vector<Fortran::lower::EnvironmentDefault> &envDefaults,
6586	const Fortran::common::LanguageFeatureControl &languageFeatures,
6587	const llvm::TargetMachine &targetMachine,
6588	const Fortran::frontend::TargetOptions &targetOpts,
6589	const Fortran::frontend::CodeGenOptions &cgOpts)
6590	: semanticsContext{semanticsContext}, defaultKinds{defaultKinds},
6591	intrinsics{intrinsics}, targetCharacteristics{targetCharacteristics},
6592	cooked{&cooked}, context{context}, kindMap{kindMap},
6593	loweringOptions{loweringOptions}, envDefaults{envDefaults},
6594	languageFeatures{languageFeatures} {
6595	// Register the diagnostic handler.
6596	context.getDiagEngine().registerHandler([](mlir::Diagnostic &diag) {
6597	llvm::raw_ostream &os = llvm::errs();
6598	switch (diag.getSeverity()) {
6599	case mlir::DiagnosticSeverity::Error:
6600	os << "error: ";
6601	break;
6602	case mlir::DiagnosticSeverity::Remark:
6603	os << "info: ";
6604	break;
6605	case mlir::DiagnosticSeverity::Warning:
6606	os << "warning: ";
6607	break;
6608	default:
6609	break;
6610	}
6611	if (!mlir::isa<mlir::UnknownLoc>(diag.getLocation()))
6612	os << diag.getLocation() << ": ";
6613	os << diag << '\n';
6614	os.flush();
6615	return mlir::success();
6616	});
6617
6618	auto getPathLocation = [&semanticsContext, &context]() -> mlir::Location {
6619	std::optional<std::string> path;
6620	const auto &allSources{semanticsContext.allCookedSources().allSources()};
6621	if (auto initial{allSources.GetFirstFileProvenance()};
6622	initial && !initial->empty()) {
6623	if (const auto *sourceFile{allSources.GetSourceFile(initial->start())}) {
6624	path = sourceFile->path();
6625	}
6626	}
6627
6628	if (path.has_value()) {
6629	llvm::SmallString<256> curPath(*path);
6630	llvm::sys::fs::make_absolute(curPath);
6631	llvm::sys::path::remove_dots(curPath);
6632	return mlir::FileLineColLoc::get(&context, curPath.str(), /*line=*/0,
6633	/*col=*/0);
6634	} else {
6635	return mlir::UnknownLoc::get(&context);
6636	}
6637	};
6638
6639	// Create the module and attach the attributes.
6640	module = mlir::OwningOpRef<mlir::ModuleOp>(
6641	mlir::ModuleOp::create(getPathLocation()));
6642	assert(*module && "module was not created");
6643	fir::setTargetTriple(*module, triple);
6644	fir::setKindMapping(*module, kindMap);
6645	fir::setTargetCPU(*module, targetMachine.getTargetCPU());
6646	fir::setTuneCPU(*module, targetOpts.cpuToTuneFor);
6647	fir::setTargetFeatures(*module, targetMachine.getTargetFeatureString());
6648	fir::support::setMLIRDataLayout(*module, targetMachine.createDataLayout());
6649	fir::setIdent(*module, Fortran::common::getFlangFullVersion());
6650	if (cgOpts.RecordCommandLine)
6651	fir::setCommandline(*module, *cgOpts.RecordCommandLine);
6652	}
6653
6654	void Fortran::lower::genCleanUpInRegionIfAny(
6655	mlir::Location loc, fir::FirOpBuilder &builder, mlir::Region &region,
6656	Fortran::lower::StatementContext &context) {
6657	if (!context.hasCode())
6658	return;
6659	mlir::OpBuilder::InsertPoint insertPt = builder.saveInsertionPoint();
6660	if (region.empty())
6661	builder.createBlock(&region);
6662	else
6663	builder.setInsertionPointToEnd(&region.front());
6664	context.finalizeAndPop();
6665	hlfir::YieldOp::ensureTerminator(region, builder, loc);
6666	builder.restoreInsertionPoint(insertPt);
6667	}
6668