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