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