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

Provided by KDAB

Privacy Policy
Learn to use CMake with our Intro Training
Find out more

source code of flang/lib/Lower/Bridge.cpp