1 | //===-- Bridge.cpp -- bridge to lower to MLIR -----------------------------===// |
---|---|
2 | // |
3 | // Part of the LLVM Project, under the Apache License v2.0 with LLVM Exceptions. |
4 | // See https://llvm.org/LICENSE.txt for license information. |
5 | // SPDX-License-Identifier: Apache-2.0 WITH LLVM-exception |
6 | // |
7 | //===----------------------------------------------------------------------===// |
8 | // |
9 | // Coding style: https://mlir.llvm.org/getting_started/DeveloperGuide/ |
10 | // |
11 | //===----------------------------------------------------------------------===// |
12 | |
13 | #include "flang/Lower/Bridge.h" |
14 | |
15 | #include "flang/Lower/Allocatable.h" |
16 | #include "flang/Lower/CallInterface.h" |
17 | #include "flang/Lower/Coarray.h" |
18 | #include "flang/Lower/ConvertCall.h" |
19 | #include "flang/Lower/ConvertExpr.h" |
20 | #include "flang/Lower/ConvertExprToHLFIR.h" |
21 | #include "flang/Lower/ConvertType.h" |
22 | #include "flang/Lower/ConvertVariable.h" |
23 | #include "flang/Lower/Cuda.h" |
24 | #include "flang/Lower/DirectivesCommon.h" |
25 | #include "flang/Lower/HostAssociations.h" |
26 | #include "flang/Lower/IO.h" |
27 | #include "flang/Lower/IterationSpace.h" |
28 | #include "flang/Lower/Mangler.h" |
29 | #include "flang/Lower/OpenACC.h" |
30 | #include "flang/Lower/OpenMP.h" |
31 | #include "flang/Lower/PFTBuilder.h" |
32 | #include "flang/Lower/Runtime.h" |
33 | #include "flang/Lower/StatementContext.h" |
34 | #include "flang/Lower/Support/Utils.h" |
35 | #include "flang/Optimizer/Builder/BoxValue.h" |
36 | #include "flang/Optimizer/Builder/CUFCommon.h" |
37 | #include "flang/Optimizer/Builder/Character.h" |
38 | #include "flang/Optimizer/Builder/FIRBuilder.h" |
39 | #include "flang/Optimizer/Builder/Runtime/Assign.h" |
40 | #include "flang/Optimizer/Builder/Runtime/Character.h" |
41 | #include "flang/Optimizer/Builder/Runtime/Derived.h" |
42 | #include "flang/Optimizer/Builder/Runtime/EnvironmentDefaults.h" |
43 | #include "flang/Optimizer/Builder/Runtime/Exceptions.h" |
44 | #include "flang/Optimizer/Builder/Runtime/Main.h" |
45 | #include "flang/Optimizer/Builder/Runtime/Ragged.h" |
46 | #include "flang/Optimizer/Builder/Runtime/Stop.h" |
47 | #include "flang/Optimizer/Builder/Todo.h" |
48 | #include "flang/Optimizer/Dialect/CUF/Attributes/CUFAttr.h" |
49 | #include "flang/Optimizer/Dialect/CUF/CUFOps.h" |
50 | #include "flang/Optimizer/Dialect/FIRAttr.h" |
51 | #include "flang/Optimizer/Dialect/FIRDialect.h" |
52 | #include "flang/Optimizer/Dialect/FIROps.h" |
53 | #include "flang/Optimizer/Dialect/Support/FIRContext.h" |
54 | #include "flang/Optimizer/HLFIR/HLFIROps.h" |
55 | #include "flang/Optimizer/Support/DataLayout.h" |
56 | #include "flang/Optimizer/Support/FatalError.h" |
57 | #include "flang/Optimizer/Support/InternalNames.h" |
58 | #include "flang/Optimizer/Transforms/Passes.h" |
59 | #include "flang/Parser/parse-tree.h" |
60 | #include "flang/Runtime/iostat-consts.h" |
61 | #include "flang/Semantics/openmp-dsa.h" |
62 | #include "flang/Semantics/runtime-type-info.h" |
63 | #include "flang/Semantics/symbol.h" |
64 | #include "flang/Semantics/tools.h" |
65 | #include "flang/Support/Flags.h" |
66 | #include "flang/Support/Version.h" |
67 | #include "mlir/Dialect/ControlFlow/IR/ControlFlowOps.h" |
68 | #include "mlir/IR/BuiltinAttributes.h" |
69 | #include "mlir/IR/Matchers.h" |
70 | #include "mlir/IR/PatternMatch.h" |
71 | #include "mlir/Parser/Parser.h" |
72 | #include "mlir/Transforms/RegionUtils.h" |
73 | #include "llvm/ADT/SmallVector.h" |
74 | #include "llvm/ADT/StringSet.h" |
75 | #include "llvm/Support/CommandLine.h" |
76 | #include "llvm/Support/Debug.h" |
77 | #include "llvm/Support/ErrorHandling.h" |
78 | #include "llvm/Support/FileSystem.h" |
79 | #include "llvm/Support/Path.h" |
80 | #include "llvm/Target/TargetMachine.h" |
81 | #include <optional> |
82 | |
83 | #define DEBUG_TYPE "flang-lower-bridge" |
84 | |
85 | static llvm::cl::opt<bool> dumpBeforeFir( |
86 | "fdebug-dump-pre-fir", llvm::cl::init(Val: false), |
87 | llvm::cl::desc("dump the Pre-FIR tree prior to FIR generation")); |
88 | |
89 | static llvm::cl::opt<bool> forceLoopToExecuteOnce( |
90 | "always-execute-loop-body", llvm::cl::init(Val: false), |
91 | llvm::cl::desc("force the body of a loop to execute at least once")); |
92 | |
93 | namespace { |
94 | /// Information for generating a structured or unstructured increment loop. |
95 | struct IncrementLoopInfo { |
96 | template <typename T> |
97 | explicit IncrementLoopInfo(Fortran::semantics::Symbol &sym, const T &lower, |
98 | const T &upper, const std::optional<T> &step, |
99 | bool isConcurrent = false) |
100 | : loopVariableSym{&sym}, lowerExpr{Fortran::semantics::GetExpr(lower)}, |
101 | upperExpr{Fortran::semantics::GetExpr(upper)}, |
102 | stepExpr{Fortran::semantics::GetExpr(step)}, |
103 | isConcurrent{isConcurrent} {} |
104 | |
105 | IncrementLoopInfo(IncrementLoopInfo &&) = default; |
106 | IncrementLoopInfo &operator=(IncrementLoopInfo &&x) = default; |
107 | |
108 | bool isStructured() const { return !headerBlock; } |
109 | |
110 | mlir::Type getLoopVariableType() const { |
111 | assert(loopVariable && "must be set"); |
112 | return fir::unwrapRefType(loopVariable.getType()); |
113 | } |
114 | |
115 | bool hasLocalitySpecs() const { |
116 | return !localSymList.empty() || !localInitSymList.empty() || |
117 | !reduceSymList.empty() || !sharedSymList.empty(); |
118 | } |
119 | |
120 | // Data members common to both structured and unstructured loops. |
121 | const Fortran::semantics::Symbol *loopVariableSym; |
122 | const Fortran::lower::SomeExpr *lowerExpr; |
123 | const Fortran::lower::SomeExpr *upperExpr; |
124 | const Fortran::lower::SomeExpr *stepExpr; |
125 | const Fortran::lower::SomeExpr *maskExpr = nullptr; |
126 | bool isConcurrent; |
127 | llvm::SmallVector<const Fortran::semantics::Symbol *> localSymList; |
128 | llvm::SmallVector<const Fortran::semantics::Symbol *> localInitSymList; |
129 | llvm::SmallVector< |
130 | std::pair<fir::ReduceOperationEnum, const Fortran::semantics::Symbol *>> |
131 | reduceSymList; |
132 | llvm::SmallVector<const Fortran::semantics::Symbol *> sharedSymList; |
133 | mlir::Value loopVariable = nullptr; |
134 | |
135 | // Data members for structured loops. |
136 | mlir::Operation *loopOp = nullptr; |
137 | |
138 | // Data members for unstructured loops. |
139 | bool hasRealControl = false; |
140 | mlir::Value tripVariable = nullptr; |
141 | mlir::Value stepVariable = nullptr; |
142 | mlir::Block *headerBlock = nullptr; // loop entry and test block |
143 | mlir::Block *maskBlock = nullptr; // concurrent loop mask block |
144 | mlir::Block *bodyBlock = nullptr; // first loop body block |
145 | mlir::Block *exitBlock = nullptr; // loop exit target block |
146 | }; |
147 | |
148 | /// Information to support stack management, object deallocation, and |
149 | /// object finalization at early and normal construct exits. |
150 | struct ConstructContext { |
151 | explicit ConstructContext(Fortran::lower::pft::Evaluation &eval, |
152 | Fortran::lower::StatementContext &stmtCtx) |
153 | : eval{eval}, stmtCtx{stmtCtx} {} |
154 | |
155 | Fortran::lower::pft::Evaluation &eval; // construct eval |
156 | Fortran::lower::StatementContext &stmtCtx; // construct exit code |
157 | std::optional<hlfir::Entity> selector; // construct selector, if any. |
158 | bool pushedScope = false; // was a scoped pushed for this construct? |
159 | }; |
160 | |
161 | /// Helper to gather the lower bounds of array components with non deferred |
162 | /// shape when they are not all ones. Return an empty array attribute otherwise. |
163 | static mlir::DenseI64ArrayAttr |
164 | gatherComponentNonDefaultLowerBounds(mlir::Location loc, |
165 | mlir::MLIRContext *mlirContext, |
166 | const Fortran::semantics::Symbol &sym) { |
167 | if (Fortran::semantics::IsAllocatableOrObjectPointer(&sym)) |
168 | return {}; |
169 | mlir::DenseI64ArrayAttr lbs_attr; |
170 | if (const auto *objDetails = |
171 | sym.detailsIf<Fortran::semantics::ObjectEntityDetails>()) { |
172 | llvm::SmallVector<std::int64_t> lbs; |
173 | bool hasNonDefaultLbs = false; |
174 | for (const Fortran::semantics::ShapeSpec &bounds : objDetails->shape()) |
175 | if (auto lb = bounds.lbound().GetExplicit()) { |
176 | if (auto constant = Fortran::evaluate::ToInt64(*lb)) { |
177 | hasNonDefaultLbs |= (*constant != 1); |
178 | lbs.push_back(*constant); |
179 | } else { |
180 | TODO(loc, "generate fir.dt_component for length parametrized derived " |
181 | "types"); |
182 | } |
183 | } |
184 | if (hasNonDefaultLbs) { |
185 | assert(static_cast<int>(lbs.size()) == sym.Rank() && |
186 | "expected component bounds to be constant or deferred"); |
187 | lbs_attr = mlir::DenseI64ArrayAttr::get(mlirContext, lbs); |
188 | } |
189 | } |
190 | return lbs_attr; |
191 | } |
192 | |
193 | // Helper class to generate name of fir.global containing component explicit |
194 | // default value for objects, and initial procedure target for procedure pointer |
195 | // components. |
196 | static mlir::FlatSymbolRefAttr gatherComponentInit( |
197 | mlir::Location loc, Fortran::lower::AbstractConverter &converter, |
198 | const Fortran::semantics::Symbol &sym, fir::RecordType derivedType) { |
199 | mlir::MLIRContext *mlirContext = &converter.getMLIRContext(); |
200 | // Return procedure target mangled name for procedure pointer components. |
201 | if (const auto *procPtr = |
202 | sym.detailsIf<Fortran::semantics::ProcEntityDetails>()) { |
203 | if (std::optional<const Fortran::semantics::Symbol *> maybeInitSym = |
204 | procPtr->init()) { |
205 | // So far, do not make distinction between p => NULL() and p without init, |
206 | // f18 always initialize pointers to NULL anyway. |
207 | if (!*maybeInitSym) |
208 | return {}; |
209 | return mlir::FlatSymbolRefAttr::get(mlirContext, |
210 | converter.mangleName(**maybeInitSym)); |
211 | } |
212 | } |
213 | |
214 | const auto *objDetails = |
215 | sym.detailsIf<Fortran::semantics::ObjectEntityDetails>(); |
216 | if (!objDetails || !objDetails->init().has_value()) |
217 | return {}; |
218 | // Object component initial value. Semantic package component object default |
219 | // value into compiler generated symbols that are lowered as read-only |
220 | // fir.global. Get the name of this global. |
221 | std::string name = fir::NameUniquer::getComponentInitName( |
222 | derivedType.getName(), toStringRef(sym.name())); |
223 | return mlir::FlatSymbolRefAttr::get(mlirContext, name); |
224 | } |
225 | |
226 | /// Helper class to generate the runtime type info global data and the |
227 | /// fir.type_info operations that contain the dipatch tables (if any). |
228 | /// The type info global data is required to describe the derived type to the |
229 | /// runtime so that it can operate over it. |
230 | /// It must be ensured these operations will be generated for every derived type |
231 | /// lowered in the current translated unit. However, these operations |
232 | /// cannot be generated before FuncOp have been created for functions since the |
233 | /// initializers may take their address (e.g for type bound procedures). This |
234 | /// class allows registering all the required type info while it is not |
235 | /// possible to create GlobalOp/TypeInfoOp, and to generate this data afte |
236 | /// function lowering. |
237 | class TypeInfoConverter { |
238 | /// Store the location and symbols of derived type info to be generated. |
239 | /// The location of the derived type instantiation is also stored because |
240 | /// runtime type descriptor symbols are compiler generated and cannot be |
241 | /// mapped to user code on their own. |
242 | struct TypeInfo { |
243 | Fortran::semantics::SymbolRef symbol; |
244 | const Fortran::semantics::DerivedTypeSpec &typeSpec; |
245 | fir::RecordType type; |
246 | mlir::Location loc; |
247 | }; |
248 | |
249 | public: |
250 | void registerTypeInfo(Fortran::lower::AbstractConverter &converter, |
251 | mlir::Location loc, |
252 | Fortran::semantics::SymbolRef typeInfoSym, |
253 | const Fortran::semantics::DerivedTypeSpec &typeSpec, |
254 | fir::RecordType type) { |
255 | if (seen.contains(typeInfoSym)) |
256 | return; |
257 | seen.insert(typeInfoSym); |
258 | currentTypeInfoStack->emplace_back( |
259 | Args: TypeInfo{typeInfoSym, typeSpec, type, loc}); |
260 | return; |
261 | } |
262 | |
263 | void createTypeInfo(Fortran::lower::AbstractConverter &converter) { |
264 | while (!registeredTypeInfoA.empty()) { |
265 | currentTypeInfoStack = ®isteredTypeInfoB; |
266 | for (const TypeInfo &info : registeredTypeInfoA) |
267 | createTypeInfoOpAndGlobal(converter, info); |
268 | registeredTypeInfoA.clear(); |
269 | currentTypeInfoStack = ®isteredTypeInfoA; |
270 | for (const TypeInfo &info : registeredTypeInfoB) |
271 | createTypeInfoOpAndGlobal(converter, info); |
272 | registeredTypeInfoB.clear(); |
273 | } |
274 | } |
275 | |
276 | private: |
277 | void createTypeInfoOpAndGlobal(Fortran::lower::AbstractConverter &converter, |
278 | const TypeInfo &info) { |
279 | Fortran::lower::createRuntimeTypeInfoGlobal(converter, info.symbol.get()); |
280 | createTypeInfoOp(converter, info); |
281 | } |
282 | |
283 | void createTypeInfoOp(Fortran::lower::AbstractConverter &converter, |
284 | const TypeInfo &info) { |
285 | fir::RecordType parentType{}; |
286 | if (const Fortran::semantics::DerivedTypeSpec *parent = |
287 | Fortran::evaluate::GetParentTypeSpec(info.typeSpec)) |
288 | parentType = mlir::cast<fir::RecordType>(converter.genType(*parent)); |
289 | |
290 | fir::FirOpBuilder &builder = converter.getFirOpBuilder(); |
291 | fir::TypeInfoOp dt; |
292 | mlir::OpBuilder::InsertPoint insertPointIfCreated; |
293 | std::tie(dt, insertPointIfCreated) = |
294 | builder.createTypeInfoOp(info.loc, info.type, parentType); |
295 | if (!insertPointIfCreated.isSet()) |
296 | return; // fir.type_info was already built in a previous call. |
297 | |
298 | // Set init, destroy, and nofinal attributes. |
299 | if (!info.typeSpec.HasDefaultInitialization(/*ignoreAllocatable=*/false, |
300 | /*ignorePointer=*/false)) |
301 | dt->setAttr(dt.getNoInitAttrName(), builder.getUnitAttr()); |
302 | if (!info.typeSpec.HasDestruction()) |
303 | dt->setAttr(dt.getNoDestroyAttrName(), builder.getUnitAttr()); |
304 | if (!Fortran::semantics::MayRequireFinalization(info.typeSpec)) |
305 | dt->setAttr(dt.getNoFinalAttrName(), builder.getUnitAttr()); |
306 | |
307 | const Fortran::semantics::Scope &derivedScope = |
308 | DEREF(info.typeSpec.GetScope()); |
309 | |
310 | // Fill binding table region if the derived type has bindings. |
311 | Fortran::semantics::SymbolVector bindings = |
312 | Fortran::semantics::CollectBindings(derivedScope); |
313 | if (!bindings.empty()) { |
314 | builder.createBlock(&dt.getDispatchTable()); |
315 | for (const Fortran::semantics::SymbolRef &binding : bindings) { |
316 | const auto &details = |
317 | binding.get().get<Fortran::semantics::ProcBindingDetails>(); |
318 | std::string tbpName = binding.get().name().ToString(); |
319 | if (details.numPrivatesNotOverridden() > 0) |
320 | tbpName += "."s+ std::to_string(details.numPrivatesNotOverridden()); |
321 | std::string bindingName = converter.mangleName(details.symbol()); |
322 | builder.create<fir::DTEntryOp>( |
323 | info.loc, mlir::StringAttr::get(builder.getContext(), tbpName), |
324 | mlir::SymbolRefAttr::get(builder.getContext(), bindingName)); |
325 | } |
326 | builder.create<fir::FirEndOp>(info.loc); |
327 | } |
328 | // Gather info about components that is not reflected in fir.type and may be |
329 | // needed later: component initial values and array component non default |
330 | // lower bounds. |
331 | mlir::Block *componentInfo = nullptr; |
332 | for (const auto &componentName : |
333 | info.typeSpec.typeSymbol() |
334 | .get<Fortran::semantics::DerivedTypeDetails>() |
335 | .componentNames()) { |
336 | auto scopeIter = derivedScope.find(componentName); |
337 | assert(scopeIter != derivedScope.cend() && |
338 | "failed to find derived type component symbol"); |
339 | const Fortran::semantics::Symbol &component = scopeIter->second.get(); |
340 | mlir::FlatSymbolRefAttr init_val = |
341 | gatherComponentInit(info.loc, converter, component, info.type); |
342 | mlir::DenseI64ArrayAttr lbs = gatherComponentNonDefaultLowerBounds( |
343 | info.loc, builder.getContext(), component); |
344 | if (init_val || lbs) { |
345 | if (!componentInfo) |
346 | componentInfo = builder.createBlock(&dt.getComponentInfo()); |
347 | auto compName = mlir::StringAttr::get(builder.getContext(), |
348 | toStringRef(component.name())); |
349 | builder.create<fir::DTComponentOp>(info.loc, compName, lbs, init_val); |
350 | } |
351 | } |
352 | if (componentInfo) |
353 | builder.create<fir::FirEndOp>(info.loc); |
354 | builder.restoreInsertionPoint(insertPointIfCreated); |
355 | } |
356 | |
357 | /// Store the front-end data that will be required to generate the type info |
358 | /// for the derived types that have been converted to fir.type<>. There are |
359 | /// two stacks since the type info may visit new types, so the new types must |
360 | /// be added to a new stack. |
361 | llvm::SmallVector<TypeInfo> registeredTypeInfoA; |
362 | llvm::SmallVector<TypeInfo> registeredTypeInfoB; |
363 | llvm::SmallVector<TypeInfo> *currentTypeInfoStack = ®isteredTypeInfoA; |
364 | /// Track symbols symbols processed during and after the registration |
365 | /// to avoid infinite loops between type conversions and global variable |
366 | /// creation. |
367 | llvm::SmallSetVector<Fortran::semantics::SymbolRef, 32> seen; |
368 | }; |
369 | |
370 | using IncrementLoopNestInfo = llvm::SmallVector<IncrementLoopInfo, 8>; |
371 | } // namespace |
372 | |
373 | //===----------------------------------------------------------------------===// |
374 | // FirConverter |
375 | //===----------------------------------------------------------------------===// |
376 | |
377 | namespace { |
378 | |
379 | /// Traverse the pre-FIR tree (PFT) to generate the FIR dialect of MLIR. |
380 | class FirConverter : public Fortran::lower::AbstractConverter { |
381 | public: |
382 | explicit FirConverter(Fortran::lower::LoweringBridge &bridge) |
383 | : Fortran::lower::AbstractConverter(bridge.getLoweringOptions()), |
384 | bridge{bridge}, foldingContext{bridge.createFoldingContext()}, |
385 | mlirSymbolTable{bridge.getModule()} {} |
386 | virtual ~FirConverter() = default; |
387 | |
388 | /// Convert the PFT to FIR. |
389 | void run(Fortran::lower::pft::Program &pft) { |
390 | // Preliminary translation pass. |
391 | |
392 | // Lower common blocks, taking into account initialization and the largest |
393 | // size of all instances of each common block. This is done before lowering |
394 | // since the global definition may differ from any one local definition. |
395 | lowerCommonBlocks(pft.getCommonBlocks()); |
396 | |
397 | // - Declare all functions that have definitions so that definition |
398 | // signatures prevail over call site signatures. |
399 | // - Define module variables and OpenMP/OpenACC declarative constructs so |
400 | // they are available before lowering any function that may use them. |
401 | bool hasMainProgram = false; |
402 | const Fortran::semantics::Symbol *globalOmpRequiresSymbol = nullptr; |
403 | createBuilderOutsideOfFuncOpAndDo(createGlobals: [&]() { |
404 | for (Fortran::lower::pft::Program::Units &u : pft.getUnits()) { |
405 | Fortran::common::visit( |
406 | Fortran::common::visitors{ |
407 | [&](Fortran::lower::pft::FunctionLikeUnit &f) { |
408 | if (f.isMainProgram()) |
409 | hasMainProgram = true; |
410 | declareFunction(f); |
411 | if (!globalOmpRequiresSymbol) |
412 | globalOmpRequiresSymbol = f.getScope().symbol(); |
413 | }, |
414 | [&](Fortran::lower::pft::ModuleLikeUnit &m) { |
415 | lowerModuleDeclScope(m); |
416 | for (Fortran::lower::pft::ContainedUnit &unit : |
417 | m.containedUnitList) |
418 | if (auto *f = |
419 | std::get_if<Fortran::lower::pft::FunctionLikeUnit>( |
420 | &unit)) |
421 | declareFunction(*f); |
422 | }, |
423 | [&](Fortran::lower::pft::BlockDataUnit &b) { |
424 | if (!globalOmpRequiresSymbol) |
425 | globalOmpRequiresSymbol = b.symTab.symbol(); |
426 | }, |
427 | [&](Fortran::lower::pft::CompilerDirectiveUnit &d) {}, |
428 | [&](Fortran::lower::pft::OpenACCDirectiveUnit &d) {}, |
429 | }, |
430 | u); |
431 | } |
432 | }); |
433 | |
434 | // Create definitions of intrinsic module constants. |
435 | createBuilderOutsideOfFuncOpAndDo( |
436 | createGlobals: [&]() { createIntrinsicModuleDefinitions(pft); }); |
437 | |
438 | // Primary translation pass. |
439 | for (Fortran::lower::pft::Program::Units &u : pft.getUnits()) { |
440 | Fortran::common::visit( |
441 | Fortran::common::visitors{ |
442 | [&](Fortran::lower::pft::FunctionLikeUnit &f) { lowerFunc(f); }, |
443 | [&](Fortran::lower::pft::ModuleLikeUnit &m) { lowerMod(m); }, |
444 | [&](Fortran::lower::pft::BlockDataUnit &b) {}, |
445 | [&](Fortran::lower::pft::CompilerDirectiveUnit &d) {}, |
446 | [&](Fortran::lower::pft::OpenACCDirectiveUnit &d) {}, |
447 | }, |
448 | u); |
449 | } |
450 | |
451 | // Once all the code has been translated, create global runtime type info |
452 | // data structures for the derived types that have been processed, as well |
453 | // as fir.type_info operations for the dispatch tables. |
454 | createBuilderOutsideOfFuncOpAndDo( |
455 | createGlobals: [&]() { typeInfoConverter.createTypeInfo(*this); }); |
456 | |
457 | // Generate the `main` entry point if necessary |
458 | if (hasMainProgram) |
459 | createBuilderOutsideOfFuncOpAndDo(createGlobals: [&]() { |
460 | fir::runtime::genMain(*builder, toLocation(), |
461 | bridge.getEnvironmentDefaults(), |
462 | getFoldingContext().languageFeatures().IsEnabled( |
463 | Fortran::common::LanguageFeature::CUDA)); |
464 | }); |
465 | |
466 | finalizeOpenMPLowering(globalOmpRequiresSymbol); |
467 | } |
468 | |
469 | /// Declare a function. |
470 | void declareFunction(Fortran::lower::pft::FunctionLikeUnit &funit) { |
471 | CHECK(builder && "declareFunction called with uninitialized builder"); |
472 | setCurrentPosition(funit.getStartingSourceLoc()); |
473 | for (int entryIndex = 0, last = funit.entryPointList.size(); |
474 | entryIndex < last; ++entryIndex) { |
475 | funit.setActiveEntry(entryIndex); |
476 | // Calling CalleeInterface ctor will build a declaration |
477 | // mlir::func::FuncOp with no other side effects. |
478 | // TODO: when doing some compiler profiling on real apps, it may be worth |
479 | // to check it's better to save the CalleeInterface instead of recomputing |
480 | // it later when lowering the body. CalleeInterface ctor should be linear |
481 | // with the number of arguments, so it is not awful to do it that way for |
482 | // now, but the linear coefficient might be non negligible. Until |
483 | // measured, stick to the solution that impacts the code less. |
484 | Fortran::lower::CalleeInterface{funit, *this}; |
485 | } |
486 | funit.setActiveEntry(0); |
487 | |
488 | // Compute the set of host associated entities from the nested functions. |
489 | llvm::SetVector<const Fortran::semantics::Symbol *> escapeHost; |
490 | for (Fortran::lower::pft::ContainedUnit &unit : funit.containedUnitList) |
491 | if (auto *f = std::get_if<Fortran::lower::pft::FunctionLikeUnit>(&unit)) |
492 | collectHostAssociatedVariables(*f, escapeHost); |
493 | funit.setHostAssociatedSymbols(escapeHost); |
494 | |
495 | // Declare internal procedures |
496 | for (Fortran::lower::pft::ContainedUnit &unit : funit.containedUnitList) |
497 | if (auto *f = std::get_if<Fortran::lower::pft::FunctionLikeUnit>(&unit)) |
498 | declareFunction(*f); |
499 | } |
500 | |
501 | /// Get the scope that is defining or using \p sym. The returned scope is not |
502 | /// the ultimate scope, since this helper does not traverse use association. |
503 | /// This allows capturing module variables that are referenced in an internal |
504 | /// procedure but whose use statement is inside the host program. |
505 | const Fortran::semantics::Scope & |
506 | getSymbolHostScope(const Fortran::semantics::Symbol &sym) { |
507 | const Fortran::semantics::Symbol *hostSymbol = &sym; |
508 | while (const auto *details = |
509 | hostSymbol->detailsIf<Fortran::semantics::HostAssocDetails>()) |
510 | hostSymbol = &details->symbol(); |
511 | return hostSymbol->owner(); |
512 | } |
513 | |
514 | /// Collects the canonical list of all host associated symbols. These bindings |
515 | /// must be aggregated into a tuple which can then be added to each of the |
516 | /// internal procedure declarations and passed at each call site. |
517 | void collectHostAssociatedVariables( |
518 | Fortran::lower::pft::FunctionLikeUnit &funit, |
519 | llvm::SetVector<const Fortran::semantics::Symbol *> &escapees) { |
520 | const Fortran::semantics::Scope *internalScope = |
521 | funit.getSubprogramSymbol().scope(); |
522 | assert(internalScope && "internal procedures symbol must create a scope"); |
523 | auto addToListIfEscapee = [&](const Fortran::semantics::Symbol &sym) { |
524 | const Fortran::semantics::Symbol &ultimate = sym.GetUltimate(); |
525 | const auto *namelistDetails = |
526 | ultimate.detailsIf<Fortran::semantics::NamelistDetails>(); |
527 | if (ultimate.has<Fortran::semantics::ObjectEntityDetails>() || |
528 | Fortran::semantics::IsProcedurePointer(ultimate) || |
529 | Fortran::semantics::IsDummy(sym) || namelistDetails) { |
530 | const Fortran::semantics::Scope &symbolScope = getSymbolHostScope(sym); |
531 | if (symbolScope.kind() == |
532 | Fortran::semantics::Scope::Kind::MainProgram || |
533 | symbolScope.kind() == Fortran::semantics::Scope::Kind::Subprogram) |
534 | if (symbolScope != *internalScope && |
535 | symbolScope.Contains(*internalScope)) { |
536 | if (namelistDetails) { |
537 | // So far, namelist symbols are processed on the fly in IO and |
538 | // the related namelist data structure is not added to the symbol |
539 | // map, so it cannot be passed to the internal procedures. |
540 | // Instead, all the symbols of the host namelist used in the |
541 | // internal procedure must be considered as host associated so |
542 | // that IO lowering can find them when needed. |
543 | for (const auto &namelistObject : namelistDetails->objects()) |
544 | escapees.insert(&*namelistObject); |
545 | } else { |
546 | escapees.insert(&ultimate); |
547 | } |
548 | } |
549 | } |
550 | }; |
551 | Fortran::lower::pft::visitAllSymbols(funit, addToListIfEscapee); |
552 | } |
553 | |
554 | //===--------------------------------------------------------------------===// |
555 | // AbstractConverter overrides |
556 | //===--------------------------------------------------------------------===// |
557 | |
558 | mlir::Value getSymbolAddress(Fortran::lower::SymbolRef sym) override final { |
559 | return lookupSymbol(sym).getAddr(); |
560 | } |
561 | |
562 | fir::ExtendedValue symBoxToExtendedValue( |
563 | const Fortran::lower::SymbolBox &symBox) override final { |
564 | return symBox.match( |
565 | [](const Fortran::lower::SymbolBox::Intrinsic &box) |
566 | -> fir::ExtendedValue { return box.getAddr(); }, |
567 | [](const Fortran::lower::SymbolBox::None &) -> fir::ExtendedValue { |
568 | llvm::report_fatal_error("symbol not mapped"); |
569 | }, |
570 | [&](const fir::FortranVariableOpInterface &x) -> fir::ExtendedValue { |
571 | return hlfir::translateToExtendedValue(getCurrentLocation(), |
572 | getFirOpBuilder(), x); |
573 | }, |
574 | [](const auto &box) -> fir::ExtendedValue { return box; }); |
575 | } |
576 | |
577 | fir::ExtendedValue |
578 | getSymbolExtendedValue(const Fortran::semantics::Symbol &sym, |
579 | Fortran::lower::SymMap *symMap) override final { |
580 | Fortran::lower::SymbolBox sb = lookupSymbol(sym, symMap); |
581 | if (!sb) { |
582 | LLVM_DEBUG(llvm::dbgs() << "unknown symbol: "<< sym << "\nmap: " |
583 | << (symMap ? *symMap : localSymbols) << '\n'); |
584 | fir::emitFatalError(getCurrentLocation(), |
585 | "symbol is not mapped to any IR value"); |
586 | } |
587 | return symBoxToExtendedValue(sb); |
588 | } |
589 | |
590 | mlir::Value impliedDoBinding(llvm::StringRef name) override final { |
591 | mlir::Value val = localSymbols.lookupImpliedDo(name); |
592 | if (!val) |
593 | fir::emitFatalError(toLocation(), "ac-do-variable has no binding"); |
594 | return val; |
595 | } |
596 | |
597 | void copySymbolBinding(Fortran::lower::SymbolRef src, |
598 | Fortran::lower::SymbolRef target) override final { |
599 | localSymbols.copySymbolBinding(src, target); |
600 | } |
601 | |
602 | /// Add the symbol binding to the inner-most level of the symbol map and |
603 | /// return true if it is not already present. Otherwise, return false. |
604 | bool bindIfNewSymbol(Fortran::lower::SymbolRef sym, |
605 | const fir::ExtendedValue &exval) { |
606 | if (shallowLookupSymbol(sym)) |
607 | return false; |
608 | bindSymbol(sym, exval); |
609 | return true; |
610 | } |
611 | |
612 | void bindSymbol(Fortran::lower::SymbolRef sym, |
613 | const fir::ExtendedValue &exval) override final { |
614 | addSymbol(sym, exval, /*forced=*/true); |
615 | } |
616 | |
617 | void |
618 | overrideExprValues(const Fortran::lower::ExprToValueMap *map) override final { |
619 | exprValueOverrides = map; |
620 | } |
621 | |
622 | const Fortran::lower::ExprToValueMap *getExprOverrides() override final { |
623 | return exprValueOverrides; |
624 | } |
625 | |
626 | bool lookupLabelSet(Fortran::lower::SymbolRef sym, |
627 | Fortran::lower::pft::LabelSet &labelSet) override final { |
628 | Fortran::lower::pft::FunctionLikeUnit &owningProc = |
629 | *getEval().getOwningProcedure(); |
630 | auto iter = owningProc.assignSymbolLabelMap.find(sym); |
631 | if (iter == owningProc.assignSymbolLabelMap.end()) |
632 | return false; |
633 | labelSet = iter->second; |
634 | return true; |
635 | } |
636 | |
637 | Fortran::lower::pft::Evaluation * |
638 | lookupLabel(Fortran::lower::pft::Label label) override final { |
639 | Fortran::lower::pft::FunctionLikeUnit &owningProc = |
640 | *getEval().getOwningProcedure(); |
641 | return owningProc.labelEvaluationMap.lookup(label); |
642 | } |
643 | |
644 | fir::ExtendedValue |
645 | genExprAddr(const Fortran::lower::SomeExpr &expr, |
646 | Fortran::lower::StatementContext &context, |
647 | mlir::Location *locPtr = nullptr) override final { |
648 | mlir::Location loc = locPtr ? *locPtr : toLocation(); |
649 | if (lowerToHighLevelFIR()) |
650 | return Fortran::lower::convertExprToAddress(loc, *this, expr, |
651 | localSymbols, context); |
652 | return Fortran::lower::createSomeExtendedAddress(loc, *this, expr, |
653 | localSymbols, context); |
654 | } |
655 | |
656 | fir::ExtendedValue |
657 | genExprValue(const Fortran::lower::SomeExpr &expr, |
658 | Fortran::lower::StatementContext &context, |
659 | mlir::Location *locPtr = nullptr) override final { |
660 | mlir::Location loc = locPtr ? *locPtr : toLocation(); |
661 | if (lowerToHighLevelFIR()) |
662 | return Fortran::lower::convertExprToValue(loc, *this, expr, localSymbols, |
663 | context); |
664 | return Fortran::lower::createSomeExtendedExpression(loc, *this, expr, |
665 | localSymbols, context); |
666 | } |
667 | |
668 | fir::ExtendedValue |
669 | genExprBox(mlir::Location loc, const Fortran::lower::SomeExpr &expr, |
670 | Fortran::lower::StatementContext &stmtCtx) override final { |
671 | if (lowerToHighLevelFIR()) |
672 | return Fortran::lower::convertExprToBox(loc, *this, expr, localSymbols, |
673 | stmtCtx); |
674 | return Fortran::lower::createBoxValue(loc, *this, expr, localSymbols, |
675 | stmtCtx); |
676 | } |
677 | |
678 | Fortran::evaluate::FoldingContext &getFoldingContext() override final { |
679 | return foldingContext; |
680 | } |
681 | |
682 | mlir::Type genType(const Fortran::lower::SomeExpr &expr) override final { |
683 | return Fortran::lower::translateSomeExprToFIRType(*this, expr); |
684 | } |
685 | mlir::Type genType(const Fortran::lower::pft::Variable &var) override final { |
686 | return Fortran::lower::translateVariableToFIRType(*this, var); |
687 | } |
688 | mlir::Type genType(Fortran::lower::SymbolRef sym) override final { |
689 | return Fortran::lower::translateSymbolToFIRType(*this, sym); |
690 | } |
691 | mlir::Type |
692 | genType(Fortran::common::TypeCategory tc, int kind, |
693 | llvm::ArrayRef<std::int64_t> lenParameters) override final { |
694 | return Fortran::lower::getFIRType(&getMLIRContext(), tc, kind, |
695 | lenParameters); |
696 | } |
697 | mlir::Type |
698 | genType(const Fortran::semantics::DerivedTypeSpec &tySpec) override final { |
699 | return Fortran::lower::translateDerivedTypeToFIRType(*this, tySpec); |
700 | } |
701 | mlir::Type genType(Fortran::common::TypeCategory tc) override final { |
702 | return Fortran::lower::getFIRType( |
703 | &getMLIRContext(), tc, bridge.getDefaultKinds().GetDefaultKind(tc), |
704 | std::nullopt); |
705 | } |
706 | |
707 | Fortran::lower::TypeConstructionStack & |
708 | getTypeConstructionStack() override final { |
709 | return typeConstructionStack; |
710 | } |
711 | |
712 | bool |
713 | isPresentShallowLookup(const Fortran::semantics::Symbol &sym) override final { |
714 | return bool(shallowLookupSymbol(sym)); |
715 | } |
716 | |
717 | bool createHostAssociateVarClone(const Fortran::semantics::Symbol &sym, |
718 | bool skipDefaultInit) override final { |
719 | mlir::Location loc = genLocation(sym.name()); |
720 | mlir::Type symType = genType(sym); |
721 | const auto *details = sym.detailsIf<Fortran::semantics::HostAssocDetails>(); |
722 | assert(details && "No host-association found"); |
723 | const Fortran::semantics::Symbol &hsym = details->symbol(); |
724 | mlir::Type hSymType = genType(hsym.GetUltimate()); |
725 | Fortran::lower::SymbolBox hsb = |
726 | lookupSymbol(hsym, /*symMap=*/nullptr, /*forceHlfirBase=*/true); |
727 | |
728 | auto allocate = [&](llvm::ArrayRef<mlir::Value> shape, |
729 | llvm::ArrayRef<mlir::Value> typeParams) -> mlir::Value { |
730 | mlir::Value allocVal = builder->allocateLocal( |
731 | loc, |
732 | Fortran::semantics::IsAllocatableOrObjectPointer(&hsym.GetUltimate()) |
733 | ? hSymType |
734 | : symType, |
735 | mangleName(sym), toStringRef(sym.GetUltimate().name()), |
736 | /*pinned=*/true, shape, typeParams, |
737 | sym.GetUltimate().attrs().test(Fortran::semantics::Attr::TARGET)); |
738 | return allocVal; |
739 | }; |
740 | |
741 | fir::ExtendedValue hexv = symBoxToExtendedValue(hsb); |
742 | fir::ExtendedValue exv = hexv.match( |
743 | [&](const fir::BoxValue &box) -> fir::ExtendedValue { |
744 | const Fortran::semantics::DeclTypeSpec *type = sym.GetType(); |
745 | if (type && type->IsPolymorphic()) |
746 | TODO(loc, "create polymorphic host associated copy"); |
747 | // Create a contiguous temp with the same shape and length as |
748 | // the original variable described by a fir.box. |
749 | llvm::SmallVector<mlir::Value> extents = |
750 | fir::factory::getExtents(loc, *builder, hexv); |
751 | if (box.isDerivedWithLenParameters()) |
752 | TODO(loc, "get length parameters from derived type BoxValue"); |
753 | if (box.isCharacter()) { |
754 | mlir::Value len = fir::factory::readCharLen(*builder, loc, box); |
755 | mlir::Value temp = allocate(extents, {len}); |
756 | return fir::CharArrayBoxValue{temp, len, extents}; |
757 | } |
758 | return fir::ArrayBoxValue{allocate(extents, {}), extents}; |
759 | }, |
760 | [&](const fir::MutableBoxValue &box) -> fir::ExtendedValue { |
761 | // Allocate storage for a pointer/allocatble descriptor. |
762 | // No shape/lengths to be passed to the alloca. |
763 | return fir::MutableBoxValue(allocate({}, {}), {}, {}); |
764 | }, |
765 | [&](const auto &) -> fir::ExtendedValue { |
766 | mlir::Value temp = |
767 | allocate(fir::factory::getExtents(loc, *builder, hexv), |
768 | fir::factory::getTypeParams(loc, *builder, hexv)); |
769 | return fir::substBase(hexv, temp); |
770 | }); |
771 | |
772 | // Initialise cloned allocatable |
773 | hexv.match( |
774 | [&](const fir::MutableBoxValue &box) -> void { |
775 | const auto new_box = exv.getBoxOf<fir::MutableBoxValue>(); |
776 | if (Fortran::semantics::IsPointer(sym.GetUltimate())) { |
777 | // Establish the pointer descriptors. The rank and type code/size |
778 | // at least must be set properly for later inquiry of the pointer |
779 | // to work, and new pointers are always given disassociated status |
780 | // by flang for safety, even if this is not required by the |
781 | // language. |
782 | auto empty = fir::factory::createUnallocatedBox( |
783 | *builder, loc, new_box->getBoxTy(), box.nonDeferredLenParams(), |
784 | {}); |
785 | builder->create<fir::StoreOp>(loc, empty, new_box->getAddr()); |
786 | return; |
787 | } |
788 | // Copy allocation status of Allocatables, creating new storage if |
789 | // needed. |
790 | |
791 | // allocate if allocated |
792 | mlir::Value isAllocated = |
793 | fir::factory::genIsAllocatedOrAssociatedTest(*builder, loc, box); |
794 | auto if_builder = builder->genIfThenElse(loc, isAllocated); |
795 | if_builder.genThen([&]() { |
796 | std::string name = mangleName(name&: sym) + ".alloc"; |
797 | fir::ExtendedValue read = fir::factory::genMutableBoxRead( |
798 | *builder, loc, box, /*mayBePolymorphic=*/false); |
799 | if (auto read_arr_box = read.getBoxOf<fir::ArrayBoxValue>()) { |
800 | fir::factory::genInlinedAllocation( |
801 | *builder, loc, *new_box, read_arr_box->getLBounds(), |
802 | read_arr_box->getExtents(), |
803 | /*lenParams=*/std::nullopt, name, |
804 | /*mustBeHeap=*/true); |
805 | } else if (auto read_char_arr_box = |
806 | read.getBoxOf<fir::CharArrayBoxValue>()) { |
807 | fir::factory::genInlinedAllocation( |
808 | *builder, loc, *new_box, read_char_arr_box->getLBounds(), |
809 | read_char_arr_box->getExtents(), read_char_arr_box->getLen(), |
810 | name, |
811 | /*mustBeHeap=*/true); |
812 | } else if (auto read_char_box = |
813 | read.getBoxOf<fir::CharBoxValue>()) { |
814 | fir::factory::genInlinedAllocation(*builder, loc, *new_box, |
815 | /*lbounds=*/std::nullopt, |
816 | /*extents=*/std::nullopt, |
817 | read_char_box->getLen(), name, |
818 | /*mustBeHeap=*/true); |
819 | } else { |
820 | fir::factory::genInlinedAllocation( |
821 | *builder, loc, *new_box, box.getMutableProperties().lbounds, |
822 | box.getMutableProperties().extents, |
823 | box.nonDeferredLenParams(), name, |
824 | /*mustBeHeap=*/true); |
825 | } |
826 | }); |
827 | if_builder.genElse([&]() { |
828 | // nullify box |
829 | auto empty = fir::factory::createUnallocatedBox( |
830 | *builder, loc, new_box->getBoxTy(), |
831 | new_box->nonDeferredLenParams(), {}); |
832 | builder->create<fir::StoreOp>(loc, empty, new_box->getAddr()); |
833 | }); |
834 | if_builder.end(); |
835 | }, |
836 | [&](const auto &) -> void { |
837 | // Always initialize allocatable component descriptor, even when the |
838 | // value is later copied from the host (e.g. firstprivate) because the |
839 | // assignment from the host to the copy will fail if the component |
840 | // descriptors are not initialized. |
841 | if (skipDefaultInit && !hlfir::mayHaveAllocatableComponent(hSymType)) |
842 | return; |
843 | // Initialize local/private derived types with default |
844 | // initialization (Fortran 2023 section 11.1.7.5 and OpenMP 5.2 |
845 | // section 5.3). Pointer and allocatable components, when allowed, |
846 | // also need to be established so that flang runtime can later work |
847 | // with them. |
848 | if (const Fortran::semantics::DeclTypeSpec *declTypeSpec = |
849 | sym.GetType()) |
850 | if (const Fortran::semantics::DerivedTypeSpec *derivedTypeSpec = |
851 | declTypeSpec->AsDerived()) |
852 | if (derivedTypeSpec->HasDefaultInitialization( |
853 | /*ignoreAllocatable=*/false, /*ignorePointer=*/false)) { |
854 | mlir::Value box = builder->createBox(loc, exv); |
855 | fir::runtime::genDerivedTypeInitialize(*builder, loc, box); |
856 | } |
857 | }); |
858 | |
859 | return bindIfNewSymbol(sym, exv); |
860 | } |
861 | |
862 | void createHostAssociateVarCloneDealloc( |
863 | const Fortran::semantics::Symbol &sym) override final { |
864 | mlir::Location loc = genLocation(sym.name()); |
865 | Fortran::lower::SymbolBox hsb = |
866 | lookupSymbol(sym, /*symMap=*/nullptr, /*forceHlfirBase=*/true); |
867 | |
868 | fir::ExtendedValue hexv = symBoxToExtendedValue(hsb); |
869 | hexv.match( |
870 | [&](const fir::MutableBoxValue &new_box) -> void { |
871 | // Do not process pointers |
872 | if (Fortran::semantics::IsPointer(sym.GetUltimate())) { |
873 | return; |
874 | } |
875 | // deallocate allocated in createHostAssociateVarClone value |
876 | Fortran::lower::genDeallocateIfAllocated(*this, new_box, loc); |
877 | }, |
878 | [&](const auto &) -> void { |
879 | // Do nothing |
880 | }); |
881 | } |
882 | |
883 | void copyVar(mlir::Location loc, mlir::Value dst, mlir::Value src, |
884 | fir::FortranVariableFlagsEnum attrs) override final { |
885 | bool isAllocatable = |
886 | bitEnumContainsAny(attrs, fir::FortranVariableFlagsEnum::allocatable); |
887 | bool isPointer = |
888 | bitEnumContainsAny(attrs, fir::FortranVariableFlagsEnum::pointer); |
889 | |
890 | copyVarHLFIR(loc, Fortran::lower::SymbolBox::Intrinsic{dst}, |
891 | Fortran::lower::SymbolBox::Intrinsic{src}, isAllocatable, |
892 | isPointer, Fortran::semantics::Symbol::Flags()); |
893 | } |
894 | |
895 | void |
896 | copyHostAssociateVar(const Fortran::semantics::Symbol &sym, |
897 | mlir::OpBuilder::InsertPoint *copyAssignIP = nullptr, |
898 | bool hostIsSource = true) override final { |
899 | // 1) Fetch the original copy of the variable. |
900 | assert(sym.has<Fortran::semantics::HostAssocDetails>() && |
901 | "No host-association found"); |
902 | const Fortran::semantics::Symbol &hsym = sym.GetUltimate(); |
903 | Fortran::lower::SymbolBox hsb = lookupOneLevelUpSymbol(hsym); |
904 | assert(hsb && "Host symbol box not found"); |
905 | |
906 | // 2) Fetch the copied one that will mask the original. |
907 | Fortran::lower::SymbolBox sb = shallowLookupSymbol(sym); |
908 | assert(sb && "Host-associated symbol box not found"); |
909 | assert(hsb.getAddr() != sb.getAddr() && |
910 | "Host and associated symbol boxes are the same"); |
911 | |
912 | // 3) Perform the assignment. |
913 | mlir::OpBuilder::InsertionGuard guard(*builder); |
914 | if (copyAssignIP && copyAssignIP->isSet()) |
915 | builder->restoreInsertionPoint(*copyAssignIP); |
916 | else |
917 | builder->setInsertionPointAfter(sb.getAddr().getDefiningOp()); |
918 | |
919 | Fortran::lower::SymbolBox *lhs_sb, *rhs_sb; |
920 | if (!hostIsSource) { |
921 | lhs_sb = &hsb; |
922 | rhs_sb = &sb; |
923 | } else { |
924 | lhs_sb = &sb; |
925 | rhs_sb = &hsb; |
926 | } |
927 | |
928 | copyVar(sym, *lhs_sb, *rhs_sb, sym.flags()); |
929 | } |
930 | |
931 | void genEval(Fortran::lower::pft::Evaluation &eval, |
932 | bool unstructuredContext) override final { |
933 | genFIR(eval, unstructuredContext); |
934 | } |
935 | |
936 | //===--------------------------------------------------------------------===// |
937 | // Utility methods |
938 | //===--------------------------------------------------------------------===// |
939 | |
940 | void collectSymbolSet( |
941 | Fortran::lower::pft::Evaluation &eval, |
942 | llvm::SetVector<const Fortran::semantics::Symbol *> &symbolSet, |
943 | Fortran::semantics::Symbol::Flag flag, bool collectSymbols, |
944 | bool checkHostAssociatedSymbols) override final { |
945 | auto addToList = [&](const Fortran::semantics::Symbol &sym) { |
946 | std::function<void(const Fortran::semantics::Symbol &, bool)> |
947 | insertSymbols = [&](const Fortran::semantics::Symbol &oriSymbol, |
948 | bool collectSymbol) { |
949 | if (collectSymbol && oriSymbol.test(flag)) { |
950 | symbolSet.insert(&oriSymbol); |
951 | } else if (const auto *commonDetails = |
952 | oriSymbol.detailsIf< |
953 | Fortran::semantics::CommonBlockDetails>()) { |
954 | for (const auto &mem : commonDetails->objects()) |
955 | if (collectSymbol && mem->test(flag)) |
956 | symbolSet.insert(&(*mem).GetUltimate()); |
957 | } else if (checkHostAssociatedSymbols) { |
958 | if (const auto *details{ |
959 | oriSymbol |
960 | .detailsIf<Fortran::semantics::HostAssocDetails>()}) |
961 | insertSymbols(details->symbol(), true); |
962 | } |
963 | }; |
964 | insertSymbols(sym, collectSymbols); |
965 | }; |
966 | Fortran::lower::pft::visitAllSymbols(eval, addToList); |
967 | } |
968 | |
969 | mlir::Location getCurrentLocation() override final { return toLocation(); } |
970 | |
971 | /// Generate a dummy location. |
972 | mlir::Location genUnknownLocation() override final { |
973 | // Note: builder may not be instantiated yet |
974 | return mlir::UnknownLoc::get(&getMLIRContext()); |
975 | } |
976 | |
977 | static mlir::Location genLocation(Fortran::parser::SourcePosition pos, |
978 | mlir::MLIRContext &ctx) { |
979 | llvm::SmallString<256> path(*pos.path); |
980 | llvm::sys::fs::make_absolute(path); |
981 | llvm::sys::path::remove_dots(path); |
982 | return mlir::FileLineColLoc::get(&ctx, path.str(), pos.line, pos.column); |
983 | } |
984 | |
985 | /// Generate a `Location` from the `CharBlock`. |
986 | mlir::Location |
987 | genLocation(const Fortran::parser::CharBlock &block) override final { |
988 | mlir::Location mainLocation = genUnknownLocation(); |
989 | if (const Fortran::parser::AllCookedSources *cooked = |
990 | bridge.getCookedSource()) { |
991 | if (std::optional<Fortran::parser::ProvenanceRange> provenance = |
992 | cooked->GetProvenanceRange(block)) { |
993 | if (std::optional<Fortran::parser::SourcePosition> filePos = |
994 | cooked->allSources().GetSourcePosition(provenance->start())) |
995 | mainLocation = genLocation(*filePos, getMLIRContext()); |
996 | |
997 | llvm::SmallVector<mlir::Location> locs; |
998 | locs.push_back(mainLocation); |
999 | |
1000 | llvm::SmallVector<fir::LocationKindAttr> locAttrs; |
1001 | locAttrs.push_back(fir::LocationKindAttr::get(&getMLIRContext(), |
1002 | fir::LocationKind::Base)); |
1003 | |
1004 | // Gather include location information if any. |
1005 | Fortran::parser::ProvenanceRange *prov = &*provenance; |
1006 | while (prov) { |
1007 | if (std::optional<Fortran::parser::ProvenanceRange> include = |
1008 | cooked->allSources().GetInclusionInfo(*prov)) { |
1009 | if (std::optional<Fortran::parser::SourcePosition> incPos = |
1010 | cooked->allSources().GetSourcePosition(include->start())) { |
1011 | locs.push_back(genLocation(*incPos, getMLIRContext())); |
1012 | locAttrs.push_back(fir::LocationKindAttr::get( |
1013 | &getMLIRContext(), fir::LocationKind::Inclusion)); |
1014 | } |
1015 | prov = &*include; |
1016 | } else { |
1017 | prov = nullptr; |
1018 | } |
1019 | } |
1020 | if (locs.size() > 1) { |
1021 | assert(locs.size() == locAttrs.size() && |
1022 | "expect as many attributes as locations"); |
1023 | return mlir::FusedLocWith<fir::LocationKindArrayAttr>::get( |
1024 | &getMLIRContext(), locs, |
1025 | fir::LocationKindArrayAttr::get(&getMLIRContext(), locAttrs)); |
1026 | } |
1027 | } |
1028 | } |
1029 | return mainLocation; |
1030 | } |
1031 | |
1032 | const Fortran::semantics::Scope &getCurrentScope() override final { |
1033 | return bridge.getSemanticsContext().FindScope(currentPosition); |
1034 | } |
1035 | |
1036 | fir::FirOpBuilder &getFirOpBuilder() override final { |
1037 | CHECK(builder && "builder is not set before calling getFirOpBuilder"); |
1038 | return *builder; |
1039 | } |
1040 | |
1041 | mlir::ModuleOp getModuleOp() override final { return bridge.getModule(); } |
1042 | |
1043 | mlir::MLIRContext &getMLIRContext() override final { |
1044 | return bridge.getMLIRContext(); |
1045 | } |
1046 | std::string |
1047 | mangleName(const Fortran::semantics::Symbol &symbol) override final { |
1048 | return Fortran::lower::mangle::mangleName( |
1049 | symbol, scopeBlockIdMap, /*keepExternalInScope=*/false, |
1050 | getLoweringOptions().getUnderscoring()); |
1051 | } |
1052 | std::string mangleName( |
1053 | const Fortran::semantics::DerivedTypeSpec &derivedType) override final { |
1054 | return Fortran::lower::mangle::mangleName(derivedType, scopeBlockIdMap); |
1055 | } |
1056 | std::string mangleName(std::string &name) override final { |
1057 | return Fortran::lower::mangle::mangleName(name, getCurrentScope(), |
1058 | scopeBlockIdMap); |
1059 | } |
1060 | std::string |
1061 | mangleName(std::string &name, |
1062 | const Fortran::semantics::Scope &myScope) override final { |
1063 | return Fortran::lower::mangle::mangleName(name, myScope, scopeBlockIdMap); |
1064 | } |
1065 | std::string getRecordTypeFieldName( |
1066 | const Fortran::semantics::Symbol &component) override final { |
1067 | return Fortran::lower::mangle::getRecordTypeFieldName(component, |
1068 | scopeBlockIdMap); |
1069 | } |
1070 | const fir::KindMapping &getKindMap() override final { |
1071 | return bridge.getKindMap(); |
1072 | } |
1073 | |
1074 | /// Return the current function context, which may be a nested BLOCK context |
1075 | /// or a full subprogram context. |
1076 | Fortran::lower::StatementContext &getFctCtx() override final { |
1077 | if (!activeConstructStack.empty() && |
1078 | activeConstructStack.back().eval.isA<Fortran::parser::BlockConstruct>()) |
1079 | return activeConstructStack.back().stmtCtx; |
1080 | return bridge.fctCtx(); |
1081 | } |
1082 | |
1083 | mlir::Value hostAssocTupleValue() override final { return hostAssocTuple; } |
1084 | |
1085 | /// Record a binding for the ssa-value of the tuple for this function. |
1086 | void bindHostAssocTuple(mlir::Value val) override final { |
1087 | assert(!hostAssocTuple && val); |
1088 | hostAssocTuple = val; |
1089 | } |
1090 | |
1091 | mlir::Value dummyArgsScopeValue() const override final { |
1092 | return dummyArgsScope; |
1093 | } |
1094 | |
1095 | bool isRegisteredDummySymbol( |
1096 | Fortran::semantics::SymbolRef symRef) const override final { |
1097 | auto *sym = &*symRef; |
1098 | return registeredDummySymbols.contains(sym); |
1099 | } |
1100 | |
1101 | const Fortran::lower::pft::FunctionLikeUnit * |
1102 | getCurrentFunctionUnit() const override final { |
1103 | return currentFunctionUnit; |
1104 | } |
1105 | |
1106 | void registerTypeInfo(mlir::Location loc, |
1107 | Fortran::lower::SymbolRef typeInfoSym, |
1108 | const Fortran::semantics::DerivedTypeSpec &typeSpec, |
1109 | fir::RecordType type) override final { |
1110 | typeInfoConverter.registerTypeInfo(*this, loc, typeInfoSym, typeSpec, type); |
1111 | } |
1112 | |
1113 | llvm::StringRef |
1114 | getUniqueLitName(mlir::Location loc, |
1115 | std::unique_ptr<Fortran::lower::SomeExpr> expr, |
1116 | mlir::Type eleTy) override final { |
1117 | std::string namePrefix = |
1118 | getConstantExprManglePrefix(loc, *expr.get(), eleTy); |
1119 | auto [it, inserted] = literalNamesMap.try_emplace( |
1120 | expr.get(), namePrefix + std::to_string(uniqueLitId)); |
1121 | const auto &name = it->second; |
1122 | if (inserted) { |
1123 | // Keep ownership of the expr key. |
1124 | literalExprsStorage.push_back(std::move(expr)); |
1125 | |
1126 | // If we've just added a new name, we have to make sure |
1127 | // there is no global object with the same name in the module. |
1128 | fir::GlobalOp global = builder->getNamedGlobal(name); |
1129 | if (global) |
1130 | fir::emitFatalError(loc, llvm::Twine("global object with name '") + |
1131 | llvm::Twine(name) + |
1132 | llvm::Twine("' already exists")); |
1133 | ++uniqueLitId; |
1134 | return name; |
1135 | } |
1136 | |
1137 | // The name already exists. Verify that the prefix is the same. |
1138 | if (!llvm::StringRef(name).starts_with(namePrefix)) |
1139 | fir::emitFatalError(loc, llvm::Twine("conflicting prefixes: '") + |
1140 | llvm::Twine(name) + |
1141 | llvm::Twine("' does not start with '") + |
1142 | llvm::Twine(namePrefix) + llvm::Twine("'")); |
1143 | |
1144 | return name; |
1145 | } |
1146 | |
1147 | /// Find the symbol in the inner-most level of the local map or return null. |
1148 | Fortran::lower::SymbolBox |
1149 | shallowLookupSymbol(const Fortran::semantics::Symbol &sym) override { |
1150 | if (Fortran::lower::SymbolBox v = localSymbols.shallowLookupSymbol(sym)) |
1151 | return v; |
1152 | return {}; |
1153 | } |
1154 | |
1155 | private: |
1156 | FirConverter() = delete; |
1157 | FirConverter(const FirConverter &) = delete; |
1158 | FirConverter &operator=(const FirConverter &) = delete; |
1159 | |
1160 | //===--------------------------------------------------------------------===// |
1161 | // Helper member functions |
1162 | //===--------------------------------------------------------------------===// |
1163 | |
1164 | mlir::Value createFIRExpr(mlir::Location loc, |
1165 | const Fortran::lower::SomeExpr *expr, |
1166 | Fortran::lower::StatementContext &stmtCtx) { |
1167 | return fir::getBase(genExprValue(*expr, stmtCtx, &loc)); |
1168 | } |
1169 | |
1170 | /// Find the symbol in the local map or return null. |
1171 | Fortran::lower::SymbolBox |
1172 | lookupSymbol(const Fortran::semantics::Symbol &sym, |
1173 | Fortran::lower::SymMap *symMap = nullptr, |
1174 | bool forceHlfirBase = false) { |
1175 | symMap = symMap ? symMap : &localSymbols; |
1176 | if (lowerToHighLevelFIR()) { |
1177 | if (std::optional<fir::FortranVariableOpInterface> var = |
1178 | symMap->lookupVariableDefinition(sym)) { |
1179 | auto exv = hlfir::translateToExtendedValue(toLocation(), *builder, *var, |
1180 | forceHlfirBase); |
1181 | return exv.match( |
1182 | [](mlir::Value x) -> Fortran::lower::SymbolBox { |
1183 | return Fortran::lower::SymbolBox::Intrinsic{x}; |
1184 | }, |
1185 | [](auto x) -> Fortran::lower::SymbolBox { return x; }); |
1186 | } |
1187 | |
1188 | // Entry character result represented as an argument pair |
1189 | // needs to be represented in the symbol table even before |
1190 | // we can create DeclareOp for it. The temporary mapping |
1191 | // is EmboxCharOp that conveys the address and length information. |
1192 | // After mapSymbolAttributes is done, the mapping is replaced |
1193 | // with the new DeclareOp, and the following table lookups |
1194 | // do not reach here. |
1195 | if (sym.IsFuncResult()) |
1196 | if (const Fortran::semantics::DeclTypeSpec *declTy = sym.GetType()) |
1197 | if (declTy->category() == |
1198 | Fortran::semantics::DeclTypeSpec::Category::Character) |
1199 | return symMap->lookupSymbol(sym); |
1200 | |
1201 | // Procedure dummies are not mapped with an hlfir.declare because |
1202 | // they are not "variable" (cannot be assigned to), and it would |
1203 | // make hlfir.declare more complex than it needs to to allow this. |
1204 | // Do a regular lookup. |
1205 | if (Fortran::semantics::IsProcedure(sym)) |
1206 | return symMap->lookupSymbol(sym); |
1207 | |
1208 | // Commonblock names are not variables, but in some lowerings (like |
1209 | // OpenMP) it is useful to maintain the address of the commonblock in an |
1210 | // MLIR value and query it. hlfir.declare need not be created for these. |
1211 | if (sym.detailsIf<Fortran::semantics::CommonBlockDetails>()) |
1212 | return symMap->lookupSymbol(sym); |
1213 | |
1214 | // For symbols to be privatized in OMP, the symbol is mapped to an |
1215 | // instance of `SymbolBox::Intrinsic` (i.e. a direct mapping to an MLIR |
1216 | // SSA value). This MLIR SSA value is the block argument to the |
1217 | // `omp.private`'s `alloc` block. If this is the case, we return this |
1218 | // `SymbolBox::Intrinsic` value. |
1219 | if (Fortran::lower::SymbolBox v = symMap->lookupSymbol(sym)) |
1220 | return v; |
1221 | |
1222 | return {}; |
1223 | } |
1224 | if (Fortran::lower::SymbolBox v = symMap->lookupSymbol(sym)) |
1225 | return v; |
1226 | return {}; |
1227 | } |
1228 | |
1229 | /// Find the symbol in one level up of symbol map such as for host-association |
1230 | /// in OpenMP code or return null. |
1231 | Fortran::lower::SymbolBox |
1232 | lookupOneLevelUpSymbol(const Fortran::semantics::Symbol &sym) override { |
1233 | if (Fortran::lower::SymbolBox v = localSymbols.lookupOneLevelUpSymbol(sym)) |
1234 | return v; |
1235 | return {}; |
1236 | } |
1237 | |
1238 | mlir::SymbolTable *getMLIRSymbolTable() override { return &mlirSymbolTable; } |
1239 | |
1240 | /// Add the symbol to the local map and return `true`. If the symbol is |
1241 | /// already in the map and \p forced is `false`, the map is not updated. |
1242 | /// Instead the value `false` is returned. |
1243 | bool addSymbol(const Fortran::semantics::SymbolRef sym, |
1244 | fir::ExtendedValue val, bool forced = false) { |
1245 | if (!forced && lookupSymbol(sym)) |
1246 | return false; |
1247 | if (lowerToHighLevelFIR()) { |
1248 | Fortran::lower::genDeclareSymbol(*this, localSymbols, sym, val, |
1249 | fir::FortranVariableFlagsEnum::None, |
1250 | forced); |
1251 | } else { |
1252 | localSymbols.addSymbol(sym, val, forced); |
1253 | } |
1254 | return true; |
1255 | } |
1256 | |
1257 | void copyVar(const Fortran::semantics::Symbol &sym, |
1258 | const Fortran::lower::SymbolBox &lhs_sb, |
1259 | const Fortran::lower::SymbolBox &rhs_sb, |
1260 | Fortran::semantics::Symbol::Flags flags) { |
1261 | mlir::Location loc = genLocation(sym.name()); |
1262 | if (lowerToHighLevelFIR()) |
1263 | copyVarHLFIR(loc, lhs_sb, rhs_sb, flags); |
1264 | else |
1265 | copyVarFIR(loc, sym, lhs_sb, rhs_sb); |
1266 | } |
1267 | |
1268 | void copyVarHLFIR(mlir::Location loc, Fortran::lower::SymbolBox dst, |
1269 | Fortran::lower::SymbolBox src, |
1270 | Fortran::semantics::Symbol::Flags flags) { |
1271 | assert(lowerToHighLevelFIR()); |
1272 | |
1273 | bool isBoxAllocatable = dst.match( |
1274 | [](const fir::MutableBoxValue &box) { return box.isAllocatable(); }, |
1275 | [](const fir::FortranVariableOpInterface &box) { |
1276 | return fir::FortranVariableOpInterface(box).isAllocatable(); |
1277 | }, |
1278 | [](const auto &box) { return false; }); |
1279 | |
1280 | bool isBoxPointer = dst.match( |
1281 | [](const fir::MutableBoxValue &box) { return box.isPointer(); }, |
1282 | [](const fir::FortranVariableOpInterface &box) { |
1283 | return fir::FortranVariableOpInterface(box).isPointer(); |
1284 | }, |
1285 | [](const fir::AbstractBox &box) { |
1286 | return fir::isBoxProcAddressType(box.getAddr().getType()); |
1287 | }, |
1288 | [](const auto &box) { return false; }); |
1289 | |
1290 | copyVarHLFIR(loc, dst, src, isBoxAllocatable, isBoxPointer, flags); |
1291 | } |
1292 | |
1293 | void copyVarHLFIR(mlir::Location loc, Fortran::lower::SymbolBox dst, |
1294 | Fortran::lower::SymbolBox src, bool isAllocatable, |
1295 | bool isPointer, Fortran::semantics::Symbol::Flags flags) { |
1296 | assert(lowerToHighLevelFIR()); |
1297 | hlfir::Entity lhs{dst.getAddr()}; |
1298 | hlfir::Entity rhs{src.getAddr()}; |
1299 | |
1300 | auto copyData = [&](hlfir::Entity l, hlfir::Entity r) { |
1301 | // Dereference RHS and load it if trivial scalar. |
1302 | r = hlfir::loadTrivialScalar(loc, *builder, r); |
1303 | builder->create<hlfir::AssignOp>(loc, r, l, isAllocatable); |
1304 | }; |
1305 | |
1306 | if (isPointer) { |
1307 | // Set LHS target to the target of RHS (do not copy the RHS |
1308 | // target data into the LHS target storage). |
1309 | auto loadVal = builder->create<fir::LoadOp>(loc, rhs); |
1310 | builder->create<fir::StoreOp>(loc, loadVal, lhs); |
1311 | } else if (isAllocatable && |
1312 | flags.test(Fortran::semantics::Symbol::Flag::OmpCopyIn)) { |
1313 | // For copyin allocatable variables, RHS must be copied to lhs |
1314 | // only when rhs is allocated. |
1315 | hlfir::Entity temp = |
1316 | hlfir::derefPointersAndAllocatables(loc, *builder, rhs); |
1317 | mlir::Value addr = hlfir::genVariableRawAddress(loc, *builder, temp); |
1318 | mlir::Value isAllocated = builder->genIsNotNullAddr(loc, addr); |
1319 | builder->genIfThenElse(loc, isAllocated) |
1320 | .genThen([&]() { copyData(lhs, rhs); }) |
1321 | .genElse([&]() { |
1322 | fir::ExtendedValue hexv = symBoxToExtendedValue(dst); |
1323 | hexv.match( |
1324 | [&](const fir::MutableBoxValue &new_box) -> void { |
1325 | // if the allocation status of original list item is |
1326 | // unallocated, unallocate the copy if it is allocated, else |
1327 | // do nothing. |
1328 | Fortran::lower::genDeallocateIfAllocated(*this, new_box, loc); |
1329 | }, |
1330 | [&](const auto &) -> void {}); |
1331 | }) |
1332 | .end(); |
1333 | } else if (isAllocatable && |
1334 | flags.test(Fortran::semantics::Symbol::Flag::OmpFirstPrivate)) { |
1335 | // For firstprivate allocatable variables, RHS must be copied |
1336 | // only when LHS is allocated. |
1337 | hlfir::Entity temp = |
1338 | hlfir::derefPointersAndAllocatables(loc, *builder, lhs); |
1339 | mlir::Value addr = hlfir::genVariableRawAddress(loc, *builder, temp); |
1340 | mlir::Value isAllocated = builder->genIsNotNullAddr(loc, addr); |
1341 | builder->genIfThen(loc, isAllocated) |
1342 | .genThen([&]() { copyData(lhs, rhs); }) |
1343 | .end(); |
1344 | } else { |
1345 | copyData(lhs, rhs); |
1346 | } |
1347 | } |
1348 | |
1349 | void copyVarFIR(mlir::Location loc, const Fortran::semantics::Symbol &sym, |
1350 | const Fortran::lower::SymbolBox &lhs_sb, |
1351 | const Fortran::lower::SymbolBox &rhs_sb) { |
1352 | assert(!lowerToHighLevelFIR()); |
1353 | fir::ExtendedValue lhs = symBoxToExtendedValue(lhs_sb); |
1354 | fir::ExtendedValue rhs = symBoxToExtendedValue(rhs_sb); |
1355 | mlir::Type symType = genType(sym); |
1356 | if (auto seqTy = mlir::dyn_cast<fir::SequenceType>(symType)) { |
1357 | Fortran::lower::StatementContext stmtCtx; |
1358 | Fortran::lower::createSomeArrayAssignment(*this, lhs, rhs, localSymbols, |
1359 | stmtCtx); |
1360 | stmtCtx.finalizeAndReset(); |
1361 | } else if (lhs.getBoxOf<fir::CharBoxValue>()) { |
1362 | fir::factory::CharacterExprHelper{*builder, loc}.createAssign(lhs, rhs); |
1363 | } else { |
1364 | auto loadVal = builder->create<fir::LoadOp>(loc, fir::getBase(rhs)); |
1365 | builder->create<fir::StoreOp>(loc, loadVal, fir::getBase(lhs)); |
1366 | } |
1367 | } |
1368 | |
1369 | /// Map a block argument to a result or dummy symbol. This is not the |
1370 | /// definitive mapping. The specification expression have not been lowered |
1371 | /// yet. The final mapping will be done using this pre-mapping in |
1372 | /// Fortran::lower::mapSymbolAttributes. |
1373 | bool mapBlockArgToDummyOrResult(const Fortran::semantics::SymbolRef sym, |
1374 | mlir::Value val, bool isResult) { |
1375 | localSymbols.addSymbol(sym, val); |
1376 | if (!isResult) |
1377 | registerDummySymbol(sym); |
1378 | |
1379 | return true; |
1380 | } |
1381 | |
1382 | /// Generate the address of loop variable \p sym. |
1383 | /// If \p sym is not mapped yet, allocate local storage for it. |
1384 | mlir::Value genLoopVariableAddress(mlir::Location loc, |
1385 | const Fortran::semantics::Symbol &sym, |
1386 | bool isUnordered) { |
1387 | if (isUnordered || sym.has<Fortran::semantics::HostAssocDetails>() || |
1388 | sym.has<Fortran::semantics::UseDetails>()) { |
1389 | if (!shallowLookupSymbol(sym) && |
1390 | !GetSymbolDSA(sym).test( |
1391 | Fortran::semantics::Symbol::Flag::OmpShared)) { |
1392 | // Do concurrent loop variables are not mapped yet since they are local |
1393 | // to the Do concurrent scope (same for OpenMP loops). |
1394 | mlir::OpBuilder::InsertPoint insPt = builder->saveInsertionPoint(); |
1395 | builder->setInsertionPointToStart(builder->getAllocaBlock()); |
1396 | mlir::Type tempTy = genType(sym); |
1397 | mlir::Value temp = |
1398 | builder->createTemporaryAlloc(loc, tempTy, toStringRef(sym.name())); |
1399 | bindIfNewSymbol(sym, temp); |
1400 | builder->restoreInsertionPoint(insPt); |
1401 | } |
1402 | } |
1403 | auto entry = lookupSymbol(sym); |
1404 | (void)entry; |
1405 | assert(entry && "loop control variable must already be in map"); |
1406 | Fortran::lower::StatementContext stmtCtx; |
1407 | return fir::getBase( |
1408 | genExprAddr(Fortran::evaluate::AsGenericExpr(sym).value(), stmtCtx)); |
1409 | } |
1410 | |
1411 | static bool isNumericScalarCategory(Fortran::common::TypeCategory cat) { |
1412 | return cat == Fortran::common::TypeCategory::Integer || |
1413 | cat == Fortran::common::TypeCategory::Real || |
1414 | cat == Fortran::common::TypeCategory::Complex || |
1415 | cat == Fortran::common::TypeCategory::Logical; |
1416 | } |
1417 | static bool isLogicalCategory(Fortran::common::TypeCategory cat) { |
1418 | return cat == Fortran::common::TypeCategory::Logical; |
1419 | } |
1420 | static bool isCharacterCategory(Fortran::common::TypeCategory cat) { |
1421 | return cat == Fortran::common::TypeCategory::Character; |
1422 | } |
1423 | static bool isDerivedCategory(Fortran::common::TypeCategory cat) { |
1424 | return cat == Fortran::common::TypeCategory::Derived; |
1425 | } |
1426 | |
1427 | /// Insert a new block before \p block. Leave the insertion point unchanged. |
1428 | mlir::Block *insertBlock(mlir::Block *block) { |
1429 | mlir::OpBuilder::InsertPoint insertPt = builder->saveInsertionPoint(); |
1430 | mlir::Block *newBlock = builder->createBlock(block); |
1431 | builder->restoreInsertionPoint(insertPt); |
1432 | return newBlock; |
1433 | } |
1434 | |
1435 | Fortran::lower::pft::Evaluation &evalOfLabel(Fortran::parser::Label label) { |
1436 | const Fortran::lower::pft::LabelEvalMap &labelEvaluationMap = |
1437 | getEval().getOwningProcedure()->labelEvaluationMap; |
1438 | const auto iter = labelEvaluationMap.find(label); |
1439 | assert(iter != labelEvaluationMap.end() && "label missing from map"); |
1440 | return *iter->second; |
1441 | } |
1442 | |
1443 | void genBranch(mlir::Block *targetBlock) { |
1444 | assert(targetBlock && "missing unconditional target block"); |
1445 | builder->create<mlir::cf::BranchOp>(toLocation(), targetBlock); |
1446 | } |
1447 | |
1448 | void genConditionalBranch(mlir::Value cond, mlir::Block *trueTarget, |
1449 | mlir::Block *falseTarget) { |
1450 | assert(trueTarget && "missing conditional branch true block"); |
1451 | assert(falseTarget && "missing conditional branch false block"); |
1452 | mlir::Location loc = toLocation(); |
1453 | mlir::Value bcc = builder->createConvert(loc, builder->getI1Type(), cond); |
1454 | builder->create<mlir::cf::CondBranchOp>(loc, bcc, trueTarget, std::nullopt, |
1455 | falseTarget, std::nullopt); |
1456 | } |
1457 | void genConditionalBranch(mlir::Value cond, |
1458 | Fortran::lower::pft::Evaluation *trueTarget, |
1459 | Fortran::lower::pft::Evaluation *falseTarget) { |
1460 | genConditionalBranch(cond, trueTarget->block, falseTarget->block); |
1461 | } |
1462 | void genConditionalBranch(const Fortran::parser::ScalarLogicalExpr &expr, |
1463 | mlir::Block *trueTarget, mlir::Block *falseTarget) { |
1464 | Fortran::lower::StatementContext stmtCtx; |
1465 | mlir::Value cond = |
1466 | createFIRExpr(toLocation(), Fortran::semantics::GetExpr(expr), stmtCtx); |
1467 | stmtCtx.finalizeAndReset(); |
1468 | genConditionalBranch(cond, trueTarget, falseTarget); |
1469 | } |
1470 | void genConditionalBranch(const Fortran::parser::ScalarLogicalExpr &expr, |
1471 | Fortran::lower::pft::Evaluation *trueTarget, |
1472 | Fortran::lower::pft::Evaluation *falseTarget) { |
1473 | Fortran::lower::StatementContext stmtCtx; |
1474 | mlir::Value cond = |
1475 | createFIRExpr(toLocation(), Fortran::semantics::GetExpr(expr), stmtCtx); |
1476 | stmtCtx.finalizeAndReset(); |
1477 | genConditionalBranch(cond, trueTarget->block, falseTarget->block); |
1478 | } |
1479 | |
1480 | /// Return the nearest active ancestor construct of \p eval, or nullptr. |
1481 | Fortran::lower::pft::Evaluation * |
1482 | getActiveAncestor(const Fortran::lower::pft::Evaluation &eval) { |
1483 | Fortran::lower::pft::Evaluation *ancestor = eval.parentConstruct; |
1484 | for (; ancestor; ancestor = ancestor->parentConstruct) |
1485 | if (ancestor->activeConstruct) |
1486 | break; |
1487 | return ancestor; |
1488 | } |
1489 | |
1490 | /// Return the predicate: "a branch to \p targetEval has exit code". |
1491 | bool hasExitCode(const Fortran::lower::pft::Evaluation &targetEval) { |
1492 | Fortran::lower::pft::Evaluation *activeAncestor = |
1493 | getActiveAncestor(targetEval); |
1494 | for (auto it = activeConstructStack.rbegin(), |
1495 | rend = activeConstructStack.rend(); |
1496 | it != rend; ++it) { |
1497 | if (&it->eval == activeAncestor) |
1498 | break; |
1499 | if (it->stmtCtx.hasCode()) |
1500 | return true; |
1501 | } |
1502 | return false; |
1503 | } |
1504 | |
1505 | /// Generate a branch to \p targetEval after generating on-exit code for |
1506 | /// any enclosing construct scopes that are exited by taking the branch. |
1507 | void |
1508 | genConstructExitBranch(const Fortran::lower::pft::Evaluation &targetEval) { |
1509 | Fortran::lower::pft::Evaluation *activeAncestor = |
1510 | getActiveAncestor(targetEval); |
1511 | for (auto it = activeConstructStack.rbegin(), |
1512 | rend = activeConstructStack.rend(); |
1513 | it != rend; ++it) { |
1514 | if (&it->eval == activeAncestor) |
1515 | break; |
1516 | it->stmtCtx.finalizeAndKeep(); |
1517 | } |
1518 | genBranch(targetEval.block); |
1519 | } |
1520 | |
1521 | /// A construct contains nested evaluations. Some of these evaluations |
1522 | /// may start a new basic block, others will add code to an existing |
1523 | /// block. |
1524 | /// Collect the list of nested evaluations that are last in their block, |
1525 | /// organize them into two sets: |
1526 | /// 1. Exiting evaluations: they may need a branch exiting from their |
1527 | /// parent construct, |
1528 | /// 2. Fall-through evaluations: they will continue to the following |
1529 | /// evaluation. They may still need a branch, but they do not exit |
1530 | /// the construct. They appear in cases where the following evaluation |
1531 | /// is a target of some branch. |
1532 | void collectFinalEvaluations( |
1533 | Fortran::lower::pft::Evaluation &construct, |
1534 | llvm::SmallVector<Fortran::lower::pft::Evaluation *> &exits, |
1535 | llvm::SmallVector<Fortran::lower::pft::Evaluation *> &fallThroughs) { |
1536 | Fortran::lower::pft::EvaluationList &nested = |
1537 | construct.getNestedEvaluations(); |
1538 | if (nested.empty()) |
1539 | return; |
1540 | |
1541 | Fortran::lower::pft::Evaluation *exit = construct.constructExit; |
1542 | Fortran::lower::pft::Evaluation *previous = &nested.front(); |
1543 | |
1544 | for (auto it = ++nested.begin(), end = nested.end(); it != end; |
1545 | previous = &*it++) { |
1546 | if (it->block == nullptr) |
1547 | continue; |
1548 | // "*it" starts a new block, check what to do with "previous" |
1549 | if (it->isIntermediateConstructStmt() && previous != exit) |
1550 | exits.push_back(previous); |
1551 | else if (previous->lexicalSuccessor && previous->lexicalSuccessor->block) |
1552 | fallThroughs.push_back(previous); |
1553 | } |
1554 | if (previous != exit) |
1555 | exits.push_back(previous); |
1556 | } |
1557 | |
1558 | /// Generate a SelectOp or branch sequence that compares \p selector against |
1559 | /// values in \p valueList and targets corresponding labels in \p labelList. |
1560 | /// If no value matches the selector, branch to \p defaultEval. |
1561 | /// |
1562 | /// Three cases require special processing. |
1563 | /// |
1564 | /// An empty \p valueList indicates an ArithmeticIfStmt context that requires |
1565 | /// two comparisons against 0 or 0.0. The selector may have either INTEGER |
1566 | /// or REAL type. |
1567 | /// |
1568 | /// A nonpositive \p valuelist value indicates an IO statement context |
1569 | /// (0 for ERR, -1 for END, -2 for EOR). An ERR branch must be taken for |
1570 | /// any positive (IOSTAT) value. A missing (zero) label requires a branch |
1571 | /// to \p defaultEval for that value. |
1572 | /// |
1573 | /// A non-null \p errorBlock indicates an AssignedGotoStmt context that |
1574 | /// must always branch to an explicit target. There is no valid defaultEval |
1575 | /// in this case. Generate a branch to \p errorBlock for an AssignedGotoStmt |
1576 | /// that violates this program requirement. |
1577 | /// |
1578 | /// If this is not an ArithmeticIfStmt and no targets have exit code, |
1579 | /// generate a SelectOp. Otherwise, for each target, if it has exit code, |
1580 | /// branch to a new block, insert exit code, and then branch to the target. |
1581 | /// Otherwise, branch directly to the target. |
1582 | void genMultiwayBranch(mlir::Value selector, |
1583 | llvm::SmallVector<int64_t> valueList, |
1584 | llvm::SmallVector<Fortran::parser::Label> labelList, |
1585 | const Fortran::lower::pft::Evaluation &defaultEval, |
1586 | mlir::Block *errorBlock = nullptr) { |
1587 | bool inArithmeticIfContext = valueList.empty(); |
1588 | assert(((inArithmeticIfContext && labelList.size() == 2) || |
1589 | (valueList.size() && labelList.size() == valueList.size())) && |
1590 | "mismatched multiway branch targets"); |
1591 | mlir::Block *defaultBlock = errorBlock ? errorBlock : defaultEval.block; |
1592 | bool defaultHasExitCode = !errorBlock && hasExitCode(defaultEval); |
1593 | bool hasAnyExitCode = defaultHasExitCode; |
1594 | if (!hasAnyExitCode) |
1595 | for (auto label : labelList) |
1596 | if (label && hasExitCode(evalOfLabel(label))) { |
1597 | hasAnyExitCode = true; |
1598 | break; |
1599 | } |
1600 | mlir::Location loc = toLocation(); |
1601 | size_t branchCount = labelList.size(); |
1602 | if (!inArithmeticIfContext && !hasAnyExitCode && |
1603 | !getEval().forceAsUnstructured()) { // from -no-structured-fir option |
1604 | // Generate a SelectOp. |
1605 | llvm::SmallVector<mlir::Block *> blockList; |
1606 | for (auto label : labelList) { |
1607 | mlir::Block *block = |
1608 | label ? evalOfLabel(label).block : defaultEval.block; |
1609 | assert(block && "missing multiway branch block"); |
1610 | blockList.push_back(block); |
1611 | } |
1612 | blockList.push_back(defaultBlock); |
1613 | if (valueList[branchCount - 1] == 0) // Swap IO ERR and default blocks. |
1614 | std::swap(blockList[branchCount - 1], blockList[branchCount]); |
1615 | builder->create<fir::SelectOp>(loc, selector, valueList, blockList); |
1616 | return; |
1617 | } |
1618 | mlir::Type selectorType = selector.getType(); |
1619 | bool realSelector = mlir::isa<mlir::FloatType>(selectorType); |
1620 | assert((inArithmeticIfContext || !realSelector) && "invalid selector type"); |
1621 | mlir::Value zero; |
1622 | if (inArithmeticIfContext) |
1623 | zero = |
1624 | realSelector |
1625 | ? builder->create<mlir::arith::ConstantOp>( |
1626 | loc, selectorType, builder->getFloatAttr(selectorType, 0.0)) |
1627 | : builder->createIntegerConstant(loc, selectorType, 0); |
1628 | for (auto label : llvm::enumerate(labelList)) { |
1629 | mlir::Value cond; |
1630 | if (realSelector) // inArithmeticIfContext |
1631 | cond = builder->create<mlir::arith::CmpFOp>( |
1632 | loc, |
1633 | label.index() == 0 ? mlir::arith::CmpFPredicate::OLT |
1634 | : mlir::arith::CmpFPredicate::OGT, |
1635 | selector, zero); |
1636 | else if (inArithmeticIfContext) // INTEGER selector |
1637 | cond = builder->create<mlir::arith::CmpIOp>( |
1638 | loc, |
1639 | label.index() == 0 ? mlir::arith::CmpIPredicate::slt |
1640 | : mlir::arith::CmpIPredicate::sgt, |
1641 | selector, zero); |
1642 | else // A value of 0 is an IO ERR branch: invert comparison. |
1643 | cond = builder->create<mlir::arith::CmpIOp>( |
1644 | loc, |
1645 | valueList[label.index()] == 0 ? mlir::arith::CmpIPredicate::ne |
1646 | : mlir::arith::CmpIPredicate::eq, |
1647 | selector, |
1648 | builder->createIntegerConstant(loc, selectorType, |
1649 | valueList[label.index()])); |
1650 | // Branch to a new block with exit code and then to the target, or branch |
1651 | // directly to the target. defaultBlock is the "else" target. |
1652 | bool lastBranch = label.index() == branchCount - 1; |
1653 | mlir::Block *nextBlock = |
1654 | lastBranch && !defaultHasExitCode |
1655 | ? defaultBlock |
1656 | : builder->getBlock()->splitBlock(builder->getInsertionPoint()); |
1657 | const Fortran::lower::pft::Evaluation &targetEval = |
1658 | label.value() ? evalOfLabel(label.value()) : defaultEval; |
1659 | if (hasExitCode(targetEval)) { |
1660 | mlir::Block *jumpBlock = |
1661 | builder->getBlock()->splitBlock(builder->getInsertionPoint()); |
1662 | genConditionalBranch(cond, jumpBlock, nextBlock); |
1663 | startBlock(jumpBlock); |
1664 | genConstructExitBranch(targetEval); |
1665 | } else { |
1666 | genConditionalBranch(cond, targetEval.block, nextBlock); |
1667 | } |
1668 | if (!lastBranch) { |
1669 | startBlock(nextBlock); |
1670 | } else if (defaultHasExitCode) { |
1671 | startBlock(nextBlock); |
1672 | genConstructExitBranch(defaultEval); |
1673 | } |
1674 | } |
1675 | } |
1676 | |
1677 | void pushActiveConstruct(Fortran::lower::pft::Evaluation &eval, |
1678 | Fortran::lower::StatementContext &stmtCtx) { |
1679 | activeConstructStack.push_back(Elt: ConstructContext{eval, stmtCtx}); |
1680 | eval.activeConstruct = true; |
1681 | } |
1682 | void popActiveConstruct() { |
1683 | assert(!activeConstructStack.empty() && "invalid active construct stack"); |
1684 | activeConstructStack.back().eval.activeConstruct = false; |
1685 | if (activeConstructStack.back().pushedScope) |
1686 | localSymbols.popScope(); |
1687 | activeConstructStack.pop_back(); |
1688 | } |
1689 | |
1690 | //===--------------------------------------------------------------------===// |
1691 | // Termination of symbolically referenced execution units |
1692 | //===--------------------------------------------------------------------===// |
1693 | |
1694 | /// Exit of a routine |
1695 | /// |
1696 | /// Generate the cleanup block before the routine exits |
1697 | void genExitRoutine(bool earlyReturn, mlir::ValueRange retval = {}) { |
1698 | if (blockIsUnterminated()) { |
1699 | bridge.openAccCtx().finalizeAndKeep(); |
1700 | bridge.fctCtx().finalizeAndKeep(); |
1701 | builder->create<mlir::func::ReturnOp>(toLocation(), retval); |
1702 | } |
1703 | if (!earlyReturn) { |
1704 | bridge.openAccCtx().pop(); |
1705 | bridge.fctCtx().pop(); |
1706 | } |
1707 | } |
1708 | |
1709 | /// END of procedure-like constructs |
1710 | /// |
1711 | /// Generate the cleanup block before the procedure exits |
1712 | void genReturnSymbol(const Fortran::semantics::Symbol &functionSymbol) { |
1713 | const Fortran::semantics::Symbol &resultSym = |
1714 | functionSymbol.get<Fortran::semantics::SubprogramDetails>().result(); |
1715 | Fortran::lower::SymbolBox resultSymBox = lookupSymbol(resultSym); |
1716 | mlir::Location loc = toLocation(); |
1717 | if (!resultSymBox) { |
1718 | mlir::emitError(loc, "internal error when processing function return"); |
1719 | return; |
1720 | } |
1721 | mlir::Value resultVal = resultSymBox.match( |
1722 | [&](const fir::CharBoxValue &x) -> mlir::Value { |
1723 | if (Fortran::semantics::IsBindCProcedure(functionSymbol)) |
1724 | return builder->create<fir::LoadOp>(loc, x.getBuffer()); |
1725 | return fir::factory::CharacterExprHelper{*builder, loc} |
1726 | .createEmboxChar(x.getBuffer(), x.getLen()); |
1727 | }, |
1728 | [&](const fir::MutableBoxValue &x) -> mlir::Value { |
1729 | mlir::Value resultRef = resultSymBox.getAddr(); |
1730 | mlir::Value load = builder->create<fir::LoadOp>(loc, resultRef); |
1731 | unsigned rank = x.rank(); |
1732 | if (x.isAllocatable() && rank > 0) { |
1733 | // ALLOCATABLE array result must have default lower bounds. |
1734 | // At the call site the result box of a function reference |
1735 | // might be considered having default lower bounds, but |
1736 | // the runtime box should probably comply with this assumption |
1737 | // as well. If the result box has proper lbounds in runtime, |
1738 | // this may improve the debugging experience of Fortran apps. |
1739 | // We may consider removing this, if the overhead of setting |
1740 | // default lower bounds is too big. |
1741 | mlir::Value one = |
1742 | builder->createIntegerConstant(loc, builder->getIndexType(), 1); |
1743 | llvm::SmallVector<mlir::Value> lbounds{rank, one}; |
1744 | auto shiftTy = fir::ShiftType::get(builder->getContext(), rank); |
1745 | mlir::Value shiftOp = |
1746 | builder->create<fir::ShiftOp>(loc, shiftTy, lbounds); |
1747 | load = builder->create<fir::ReboxOp>( |
1748 | loc, load.getType(), load, shiftOp, /*slice=*/mlir::Value{}); |
1749 | } |
1750 | return load; |
1751 | }, |
1752 | [&](const auto &) -> mlir::Value { |
1753 | mlir::Value resultRef = resultSymBox.getAddr(); |
1754 | mlir::Type resultType = genType(resultSym); |
1755 | mlir::Type resultRefType = builder->getRefType(resultType); |
1756 | // A function with multiple entry points returning different types |
1757 | // tags all result variables with one of the largest types to allow |
1758 | // them to share the same storage. Convert this to the actual type. |
1759 | if (resultRef.getType() != resultRefType) |
1760 | resultRef = builder->createConvertWithVolatileCast( |
1761 | loc, resultRefType, resultRef); |
1762 | return builder->create<fir::LoadOp>(loc, resultRef); |
1763 | }); |
1764 | genExitRoutine(false, resultVal); |
1765 | } |
1766 | |
1767 | /// Get the return value of a call to \p symbol, which is a subroutine entry |
1768 | /// point that has alternative return specifiers. |
1769 | const mlir::Value |
1770 | getAltReturnResult(const Fortran::semantics::Symbol &symbol) { |
1771 | assert(Fortran::semantics::HasAlternateReturns(symbol) && |
1772 | "subroutine does not have alternate returns"); |
1773 | return getSymbolAddress(symbol); |
1774 | } |
1775 | |
1776 | void genFIRProcedureExit(Fortran::lower::pft::FunctionLikeUnit &funit, |
1777 | const Fortran::semantics::Symbol &symbol) { |
1778 | if (mlir::Block *finalBlock = funit.finalBlock) { |
1779 | // The current block must end with a terminator. |
1780 | if (blockIsUnterminated()) |
1781 | builder->create<mlir::cf::BranchOp>(toLocation(), finalBlock); |
1782 | // Set insertion point to final block. |
1783 | builder->setInsertionPoint(finalBlock, finalBlock->end()); |
1784 | } |
1785 | if (Fortran::semantics::IsFunction(symbol)) { |
1786 | genReturnSymbol(symbol); |
1787 | } else if (Fortran::semantics::HasAlternateReturns(symbol)) { |
1788 | mlir::Value retval = builder->create<fir::LoadOp>( |
1789 | toLocation(), getAltReturnResult(symbol)); |
1790 | genExitRoutine(false, retval); |
1791 | } else { |
1792 | genExitRoutine(false); |
1793 | } |
1794 | } |
1795 | |
1796 | // |
1797 | // Statements that have control-flow semantics |
1798 | // |
1799 | |
1800 | /// Generate an If[Then]Stmt condition or its negation. |
1801 | template <typename A> |
1802 | mlir::Value genIfCondition(const A *stmt, bool negate = false) { |
1803 | mlir::Location loc = toLocation(); |
1804 | Fortran::lower::StatementContext stmtCtx; |
1805 | mlir::Value condExpr = createFIRExpr( |
1806 | loc, |
1807 | Fortran::semantics::GetExpr( |
1808 | std::get<Fortran::parser::ScalarLogicalExpr>(stmt->t)), |
1809 | stmtCtx); |
1810 | stmtCtx.finalizeAndReset(); |
1811 | mlir::Value cond = |
1812 | builder->createConvert(loc, builder->getI1Type(), condExpr); |
1813 | if (negate) |
1814 | cond = builder->create<mlir::arith::XOrIOp>( |
1815 | loc, cond, builder->createIntegerConstant(loc, cond.getType(), 1)); |
1816 | return cond; |
1817 | } |
1818 | |
1819 | mlir::func::FuncOp getFunc(llvm::StringRef name, mlir::FunctionType ty) { |
1820 | if (mlir::func::FuncOp func = builder->getNamedFunction(name)) { |
1821 | assert(func.getFunctionType() == ty); |
1822 | return func; |
1823 | } |
1824 | return builder->createFunction(toLocation(), name, ty); |
1825 | } |
1826 | |
1827 | /// Lowering of CALL statement |
1828 | void genFIR(const Fortran::parser::CallStmt &stmt) { |
1829 | Fortran::lower::StatementContext stmtCtx; |
1830 | Fortran::lower::pft::Evaluation &eval = getEval(); |
1831 | setCurrentPosition(stmt.source); |
1832 | assert(stmt.typedCall && "Call was not analyzed"); |
1833 | mlir::Value res{}; |
1834 | if (lowerToHighLevelFIR()) { |
1835 | std::optional<mlir::Type> resultType; |
1836 | if (stmt.typedCall->hasAlternateReturns()) |
1837 | resultType = builder->getIndexType(); |
1838 | auto hlfirRes = Fortran::lower::convertCallToHLFIR( |
1839 | toLocation(), *this, *stmt.typedCall, resultType, localSymbols, |
1840 | stmtCtx); |
1841 | if (hlfirRes) |
1842 | res = *hlfirRes; |
1843 | } else { |
1844 | // Call statement lowering shares code with function call lowering. |
1845 | res = Fortran::lower::createSubroutineCall( |
1846 | *this, *stmt.typedCall, explicitIterSpace, implicitIterSpace, |
1847 | localSymbols, stmtCtx, /*isUserDefAssignment=*/false); |
1848 | } |
1849 | stmtCtx.finalizeAndReset(); |
1850 | if (!res) |
1851 | return; // "Normal" subroutine call. |
1852 | // Call with alternate return specifiers. |
1853 | // The call returns an index that selects an alternate return branch target. |
1854 | llvm::SmallVector<int64_t> indexList; |
1855 | llvm::SmallVector<Fortran::parser::Label> labelList; |
1856 | int64_t index = 0; |
1857 | for (const Fortran::parser::ActualArgSpec &arg : |
1858 | std::get<std::list<Fortran::parser::ActualArgSpec>>(stmt.call.t)) { |
1859 | const auto &actual = std::get<Fortran::parser::ActualArg>(arg.t); |
1860 | if (const auto *altReturn = |
1861 | std::get_if<Fortran::parser::AltReturnSpec>(&actual.u)) { |
1862 | indexList.push_back(++index); |
1863 | labelList.push_back(altReturn->v); |
1864 | } |
1865 | } |
1866 | genMultiwayBranch(res, indexList, labelList, eval.nonNopSuccessor()); |
1867 | } |
1868 | |
1869 | void genFIR(const Fortran::parser::ComputedGotoStmt &stmt) { |
1870 | Fortran::lower::StatementContext stmtCtx; |
1871 | Fortran::lower::pft::Evaluation &eval = getEval(); |
1872 | mlir::Value selectExpr = |
1873 | createFIRExpr(toLocation(), |
1874 | Fortran::semantics::GetExpr( |
1875 | std::get<Fortran::parser::ScalarIntExpr>(stmt.t)), |
1876 | stmtCtx); |
1877 | stmtCtx.finalizeAndReset(); |
1878 | llvm::SmallVector<int64_t> indexList; |
1879 | llvm::SmallVector<Fortran::parser::Label> labelList; |
1880 | int64_t index = 0; |
1881 | for (Fortran::parser::Label label : |
1882 | std::get<std::list<Fortran::parser::Label>>(stmt.t)) { |
1883 | indexList.push_back(++index); |
1884 | labelList.push_back(label); |
1885 | } |
1886 | genMultiwayBranch(selectExpr, indexList, labelList, eval.nonNopSuccessor()); |
1887 | } |
1888 | |
1889 | void genFIR(const Fortran::parser::ArithmeticIfStmt &stmt) { |
1890 | Fortran::lower::StatementContext stmtCtx; |
1891 | mlir::Value expr = createFIRExpr( |
1892 | toLocation(), |
1893 | Fortran::semantics::GetExpr(std::get<Fortran::parser::Expr>(stmt.t)), |
1894 | stmtCtx); |
1895 | stmtCtx.finalizeAndReset(); |
1896 | // Raise an exception if REAL expr is a NaN. |
1897 | if (mlir::isa<mlir::FloatType>(expr.getType())) |
1898 | expr = builder->create<mlir::arith::AddFOp>(toLocation(), expr, expr); |
1899 | // An empty valueList indicates to genMultiwayBranch that the branch is |
1900 | // an ArithmeticIfStmt that has two branches on value 0 or 0.0. |
1901 | llvm::SmallVector<int64_t> valueList; |
1902 | llvm::SmallVector<Fortran::parser::Label> labelList; |
1903 | labelList.push_back(std::get<1>(stmt.t)); |
1904 | labelList.push_back(std::get<3>(stmt.t)); |
1905 | const Fortran::lower::pft::LabelEvalMap &labelEvaluationMap = |
1906 | getEval().getOwningProcedure()->labelEvaluationMap; |
1907 | const auto iter = labelEvaluationMap.find(std::get<2>(stmt.t)); |
1908 | assert(iter != labelEvaluationMap.end() && "label missing from map"); |
1909 | genMultiwayBranch(expr, valueList, labelList, *iter->second); |
1910 | } |
1911 | |
1912 | void genFIR(const Fortran::parser::AssignedGotoStmt &stmt) { |
1913 | // See Fortran 90 Clause 8.2.4. |
1914 | // Relax the requirement that the GOTO variable must have a value in the |
1915 | // label list when a list is present, and allow a branch to any non-format |
1916 | // target that has an ASSIGN statement for the variable. |
1917 | mlir::Location loc = toLocation(); |
1918 | Fortran::lower::pft::Evaluation &eval = getEval(); |
1919 | Fortran::lower::pft::FunctionLikeUnit &owningProc = |
1920 | *eval.getOwningProcedure(); |
1921 | const Fortran::lower::pft::SymbolLabelMap &symbolLabelMap = |
1922 | owningProc.assignSymbolLabelMap; |
1923 | const Fortran::lower::pft::LabelEvalMap &labelEvalMap = |
1924 | owningProc.labelEvaluationMap; |
1925 | const Fortran::semantics::Symbol &symbol = |
1926 | *std::get<Fortran::parser::Name>(stmt.t).symbol; |
1927 | auto labelSetIter = symbolLabelMap.find(symbol); |
1928 | llvm::SmallVector<int64_t> valueList; |
1929 | llvm::SmallVector<Fortran::parser::Label> labelList; |
1930 | if (labelSetIter != symbolLabelMap.end()) { |
1931 | for (auto &label : labelSetIter->second) { |
1932 | const auto evalIter = labelEvalMap.find(label); |
1933 | assert(evalIter != labelEvalMap.end() && "assigned goto label missing"); |
1934 | if (evalIter->second->block) { // non-format statement |
1935 | valueList.push_back(label); // label as an integer |
1936 | labelList.push_back(label); |
1937 | } |
1938 | } |
1939 | } |
1940 | if (!labelList.empty()) { |
1941 | auto selectExpr = |
1942 | builder->create<fir::LoadOp>(loc, getSymbolAddress(symbol)); |
1943 | // Add a default error target in case the goto is nonconforming. |
1944 | mlir::Block *errorBlock = |
1945 | builder->getBlock()->splitBlock(builder->getInsertionPoint()); |
1946 | genMultiwayBranch(selectExpr, valueList, labelList, |
1947 | eval.nonNopSuccessor(), errorBlock); |
1948 | startBlock(errorBlock); |
1949 | } |
1950 | fir::runtime::genReportFatalUserError( |
1951 | *builder, loc, |
1952 | "Assigned GOTO variable '"+ symbol.name().ToString() + |
1953 | "' does not have a valid target label value"); |
1954 | builder->create<fir::UnreachableOp>(loc); |
1955 | } |
1956 | |
1957 | fir::ReduceOperationEnum |
1958 | getReduceOperationEnum(const Fortran::parser::ReductionOperator &rOpr) { |
1959 | switch (rOpr.v) { |
1960 | case Fortran::parser::ReductionOperator::Operator::Plus: |
1961 | return fir::ReduceOperationEnum::Add; |
1962 | case Fortran::parser::ReductionOperator::Operator::Multiply: |
1963 | return fir::ReduceOperationEnum::Multiply; |
1964 | case Fortran::parser::ReductionOperator::Operator::And: |
1965 | return fir::ReduceOperationEnum::AND; |
1966 | case Fortran::parser::ReductionOperator::Operator::Or: |
1967 | return fir::ReduceOperationEnum::OR; |
1968 | case Fortran::parser::ReductionOperator::Operator::Eqv: |
1969 | return fir::ReduceOperationEnum::EQV; |
1970 | case Fortran::parser::ReductionOperator::Operator::Neqv: |
1971 | return fir::ReduceOperationEnum::NEQV; |
1972 | case Fortran::parser::ReductionOperator::Operator::Max: |
1973 | return fir::ReduceOperationEnum::MAX; |
1974 | case Fortran::parser::ReductionOperator::Operator::Min: |
1975 | return fir::ReduceOperationEnum::MIN; |
1976 | case Fortran::parser::ReductionOperator::Operator::Iand: |
1977 | return fir::ReduceOperationEnum::IAND; |
1978 | case Fortran::parser::ReductionOperator::Operator::Ior: |
1979 | return fir::ReduceOperationEnum::IOR; |
1980 | case Fortran::parser::ReductionOperator::Operator::Ieor: |
1981 | return fir::ReduceOperationEnum::EIOR; |
1982 | } |
1983 | llvm_unreachable("illegal reduction operator"); |
1984 | } |
1985 | |
1986 | /// Collect DO CONCURRENT loop control information. |
1987 | IncrementLoopNestInfo getConcurrentControl( |
1988 | const Fortran::parser::ConcurrentHeader &header, |
1989 | const std::list<Fortran::parser::LocalitySpec> &localityList = {}) { |
1990 | IncrementLoopNestInfo incrementLoopNestInfo; |
1991 | for (const Fortran::parser::ConcurrentControl &control : |
1992 | std::get<std::list<Fortran::parser::ConcurrentControl>>(header.t)) |
1993 | incrementLoopNestInfo.emplace_back( |
1994 | *std::get<0>(control.t).symbol, std::get<1>(control.t), |
1995 | std::get<2>(control.t), std::get<3>(control.t), /*isUnordered=*/true); |
1996 | IncrementLoopInfo &info = incrementLoopNestInfo.back(); |
1997 | info.maskExpr = Fortran::semantics::GetExpr( |
1998 | std::get<std::optional<Fortran::parser::ScalarLogicalExpr>>(header.t)); |
1999 | for (const Fortran::parser::LocalitySpec &x : localityList) { |
2000 | if (const auto *localList = |
2001 | std::get_if<Fortran::parser::LocalitySpec::Local>(&x.u)) |
2002 | for (const Fortran::parser::Name &x : localList->v) |
2003 | info.localSymList.push_back(x.symbol); |
2004 | if (const auto *localInitList = |
2005 | std::get_if<Fortran::parser::LocalitySpec::LocalInit>(&x.u)) |
2006 | for (const Fortran::parser::Name &x : localInitList->v) |
2007 | info.localInitSymList.push_back(x.symbol); |
2008 | for (IncrementLoopInfo &info : incrementLoopNestInfo) { |
2009 | if (const auto *reduceList = |
2010 | std::get_if<Fortran::parser::LocalitySpec::Reduce>(&x.u)) { |
2011 | fir::ReduceOperationEnum reduce_operation = getReduceOperationEnum( |
2012 | std::get<Fortran::parser::ReductionOperator>(reduceList->t)); |
2013 | for (const Fortran::parser::Name &x : |
2014 | std::get<std::list<Fortran::parser::Name>>(reduceList->t)) { |
2015 | info.reduceSymList.push_back( |
2016 | std::make_pair(reduce_operation, x.symbol)); |
2017 | } |
2018 | } |
2019 | } |
2020 | if (const auto *sharedList = |
2021 | std::get_if<Fortran::parser::LocalitySpec::Shared>(&x.u)) |
2022 | for (const Fortran::parser::Name &x : sharedList->v) |
2023 | info.sharedSymList.push_back(x.symbol); |
2024 | } |
2025 | return incrementLoopNestInfo; |
2026 | } |
2027 | |
2028 | /// Create DO CONCURRENT construct symbol bindings and generate LOCAL_INIT |
2029 | /// assignments. |
2030 | void handleLocalitySpecs(const IncrementLoopInfo &info) { |
2031 | Fortran::semantics::SemanticsContext &semanticsContext = |
2032 | bridge.getSemanticsContext(); |
2033 | fir::LocalitySpecifierOperands privateClauseOps; |
2034 | auto doConcurrentLoopOp = |
2035 | mlir::dyn_cast_if_present<fir::DoConcurrentLoopOp>(info.loopOp); |
2036 | bool useDelayedPriv = enableDelayedPrivatization && doConcurrentLoopOp; |
2037 | llvm::SetVector<const Fortran::semantics::Symbol *> allPrivatizedSymbols; |
2038 | llvm::SmallSet<const Fortran::semantics::Symbol *, 16> mightHaveReadHostSym; |
2039 | |
2040 | for (const Fortran::semantics::Symbol *symToPrivatize : info.localSymList) { |
2041 | if (useDelayedPriv) { |
2042 | Fortran::lower::privatizeSymbol<fir::LocalitySpecifierOp>( |
2043 | *this, this->getFirOpBuilder(), localSymbols, allPrivatizedSymbols, |
2044 | mightHaveReadHostSym, symToPrivatize, &privateClauseOps); |
2045 | continue; |
2046 | } |
2047 | |
2048 | createHostAssociateVarClone(*symToPrivatize, /*skipDefaultInit=*/false); |
2049 | } |
2050 | |
2051 | for (const Fortran::semantics::Symbol *symToPrivatize : |
2052 | info.localInitSymList) { |
2053 | if (useDelayedPriv) { |
2054 | Fortran::lower::privatizeSymbol<fir::LocalitySpecifierOp>( |
2055 | *this, this->getFirOpBuilder(), localSymbols, allPrivatizedSymbols, |
2056 | mightHaveReadHostSym, symToPrivatize, &privateClauseOps); |
2057 | continue; |
2058 | } |
2059 | |
2060 | createHostAssociateVarClone(*symToPrivatize, /*skipDefaultInit=*/true); |
2061 | const auto *hostDetails = |
2062 | symToPrivatize->detailsIf<Fortran::semantics::HostAssocDetails>(); |
2063 | assert(hostDetails && "missing locality spec host symbol"); |
2064 | const Fortran::semantics::Symbol *hostSym = &hostDetails->symbol(); |
2065 | Fortran::evaluate::ExpressionAnalyzer ea{semanticsContext}; |
2066 | Fortran::evaluate::Assignment assign{ |
2067 | ea.Designate(Fortran::evaluate::DataRef{*symToPrivatize}).value(), |
2068 | ea.Designate(Fortran::evaluate::DataRef{*hostSym}).value()}; |
2069 | if (Fortran::semantics::IsPointer(*symToPrivatize)) |
2070 | assign.u = Fortran::evaluate::Assignment::BoundsSpec{}; |
2071 | genAssignment(assign); |
2072 | } |
2073 | for (const Fortran::semantics::Symbol *sym : info.sharedSymList) { |
2074 | const auto *hostDetails = |
2075 | sym->detailsIf<Fortran::semantics::HostAssocDetails>(); |
2076 | copySymbolBinding(hostDetails->symbol(), *sym); |
2077 | } |
2078 | |
2079 | if (useDelayedPriv) { |
2080 | doConcurrentLoopOp.getLocalVarsMutable().assign( |
2081 | privateClauseOps.privateVars); |
2082 | doConcurrentLoopOp.setLocalSymsAttr( |
2083 | builder->getArrayAttr(privateClauseOps.privateSyms)); |
2084 | |
2085 | for (auto [sym, privateVar] : llvm::zip_equal( |
2086 | allPrivatizedSymbols, privateClauseOps.privateVars)) { |
2087 | auto arg = doConcurrentLoopOp.getRegion().begin()->addArgument( |
2088 | privateVar.getType(), doConcurrentLoopOp.getLoc()); |
2089 | bindSymbol(*sym, hlfir::translateToExtendedValue( |
2090 | privateVar.getLoc(), *builder, hlfir::Entity{arg}, |
2091 | /*contiguousHint=*/true) |
2092 | .first); |
2093 | } |
2094 | } |
2095 | |
2096 | // Note that allocatable, types with ultimate components, and type |
2097 | // requiring finalization are forbidden in LOCAL/LOCAL_INIT (F2023 C1130), |
2098 | // so no clean-up needs to be generated for these entities. |
2099 | } |
2100 | |
2101 | /// Generate FIR for a DO construct. There are six variants: |
2102 | /// - unstructured infinite and while loops |
2103 | /// - structured and unstructured increment loops |
2104 | /// - structured and unstructured concurrent loops |
2105 | void genFIR(const Fortran::parser::DoConstruct &doConstruct) { |
2106 | setCurrentPositionAt(doConstruct); |
2107 | // Collect loop nest information. |
2108 | // Generate begin loop code directly for infinite and while loops. |
2109 | Fortran::lower::pft::Evaluation &eval = getEval(); |
2110 | bool unstructuredContext = eval.lowerAsUnstructured(); |
2111 | Fortran::lower::pft::Evaluation &doStmtEval = |
2112 | eval.getFirstNestedEvaluation(); |
2113 | auto *doStmt = doStmtEval.getIf<Fortran::parser::NonLabelDoStmt>(); |
2114 | const auto &loopControl = |
2115 | std::get<std::optional<Fortran::parser::LoopControl>>(doStmt->t); |
2116 | mlir::Block *preheaderBlock = doStmtEval.block; |
2117 | mlir::Block *beginBlock = |
2118 | preheaderBlock ? preheaderBlock : builder->getBlock(); |
2119 | auto createNextBeginBlock = [&]() { |
2120 | // Step beginBlock through unstructured preheader, header, and mask |
2121 | // blocks, created in outermost to innermost order. |
2122 | return beginBlock = beginBlock->splitBlock(beginBlock->end()); |
2123 | }; |
2124 | mlir::Block *headerBlock = |
2125 | unstructuredContext ? createNextBeginBlock() : nullptr; |
2126 | mlir::Block *bodyBlock = doStmtEval.lexicalSuccessor->block; |
2127 | mlir::Block *exitBlock = doStmtEval.parentConstruct->constructExit->block; |
2128 | IncrementLoopNestInfo incrementLoopNestInfo; |
2129 | const Fortran::parser::ScalarLogicalExpr *whileCondition = nullptr; |
2130 | bool infiniteLoop = !loopControl.has_value(); |
2131 | if (infiniteLoop) { |
2132 | assert(unstructuredContext && "infinite loop must be unstructured"); |
2133 | startBlock(headerBlock); |
2134 | } else if ((whileCondition = |
2135 | std::get_if<Fortran::parser::ScalarLogicalExpr>( |
2136 | &loopControl->u))) { |
2137 | assert(unstructuredContext && "while loop must be unstructured"); |
2138 | maybeStartBlock(preheaderBlock); // no block or empty block |
2139 | startBlock(headerBlock); |
2140 | genConditionalBranch(*whileCondition, bodyBlock, exitBlock); |
2141 | } else if (const auto *bounds = |
2142 | std::get_if<Fortran::parser::LoopControl::Bounds>( |
2143 | &loopControl->u)) { |
2144 | // Non-concurrent increment loop. |
2145 | IncrementLoopInfo &info = incrementLoopNestInfo.emplace_back( |
2146 | *bounds->name.thing.symbol, bounds->lower, bounds->upper, |
2147 | bounds->step); |
2148 | if (unstructuredContext) { |
2149 | maybeStartBlock(preheaderBlock); |
2150 | info.hasRealControl = info.loopVariableSym->GetType()->IsNumeric( |
2151 | Fortran::common::TypeCategory::Real); |
2152 | info.headerBlock = headerBlock; |
2153 | info.bodyBlock = bodyBlock; |
2154 | info.exitBlock = exitBlock; |
2155 | } |
2156 | } else { |
2157 | const auto *concurrent = |
2158 | std::get_if<Fortran::parser::LoopControl::Concurrent>( |
2159 | &loopControl->u); |
2160 | assert(concurrent && "invalid DO loop variant"); |
2161 | incrementLoopNestInfo = getConcurrentControl( |
2162 | std::get<Fortran::parser::ConcurrentHeader>(concurrent->t), |
2163 | std::get<std::list<Fortran::parser::LocalitySpec>>(concurrent->t)); |
2164 | if (unstructuredContext) { |
2165 | maybeStartBlock(preheaderBlock); |
2166 | for (IncrementLoopInfo &info : incrementLoopNestInfo) { |
2167 | // The original loop body provides the body and latch blocks of the |
2168 | // innermost dimension. The (first) body block of a non-innermost |
2169 | // dimension is the preheader block of the immediately enclosed |
2170 | // dimension. The latch block of a non-innermost dimension is the |
2171 | // exit block of the immediately enclosed dimension. |
2172 | auto createNextExitBlock = [&]() { |
2173 | // Create unstructured loop exit blocks, outermost to innermost. |
2174 | return exitBlock = insertBlock(exitBlock); |
2175 | }; |
2176 | bool isInnermost = &info == &incrementLoopNestInfo.back(); |
2177 | bool isOutermost = &info == &incrementLoopNestInfo.front(); |
2178 | info.headerBlock = isOutermost ? headerBlock : createNextBeginBlock(); |
2179 | info.bodyBlock = isInnermost ? bodyBlock : createNextBeginBlock(); |
2180 | info.exitBlock = isOutermost ? exitBlock : createNextExitBlock(); |
2181 | if (info.maskExpr) |
2182 | info.maskBlock = createNextBeginBlock(); |
2183 | } |
2184 | } |
2185 | } |
2186 | |
2187 | // Increment loop begin code. (Infinite/while code was already generated.) |
2188 | if (!infiniteLoop && !whileCondition) |
2189 | genFIRIncrementLoopBegin(incrementLoopNestInfo, doStmtEval.dirs); |
2190 | |
2191 | // Loop body code. |
2192 | auto iter = eval.getNestedEvaluations().begin(); |
2193 | for (auto end = --eval.getNestedEvaluations().end(); iter != end; ++iter) |
2194 | genFIR(*iter, unstructuredContext); |
2195 | |
2196 | // An EndDoStmt in unstructured code may start a new block. |
2197 | Fortran::lower::pft::Evaluation &endDoEval = *iter; |
2198 | assert(endDoEval.getIf<Fortran::parser::EndDoStmt>() && "no enddo stmt"); |
2199 | if (unstructuredContext) |
2200 | maybeStartBlock(endDoEval.block); |
2201 | |
2202 | // Loop end code. |
2203 | if (infiniteLoop || whileCondition) |
2204 | genBranch(headerBlock); |
2205 | else |
2206 | genFIRIncrementLoopEnd(incrementLoopNestInfo); |
2207 | |
2208 | // This call may generate a branch in some contexts. |
2209 | genFIR(endDoEval, unstructuredContext); |
2210 | } |
2211 | |
2212 | /// Generate FIR to evaluate loop control values (lower, upper and step). |
2213 | mlir::Value genControlValue(const Fortran::lower::SomeExpr *expr, |
2214 | const IncrementLoopInfo &info, |
2215 | bool *isConst = nullptr) { |
2216 | mlir::Location loc = toLocation(); |
2217 | mlir::Type controlType = info.isStructured() ? builder->getIndexType() |
2218 | : info.getLoopVariableType(); |
2219 | Fortran::lower::StatementContext stmtCtx; |
2220 | if (expr) { |
2221 | if (isConst) |
2222 | *isConst = Fortran::evaluate::IsConstantExpr(*expr); |
2223 | return builder->createConvert(loc, controlType, |
2224 | createFIRExpr(loc, expr, stmtCtx)); |
2225 | } |
2226 | |
2227 | if (isConst) |
2228 | *isConst = true; |
2229 | if (info.hasRealControl) |
2230 | return builder->createRealConstant(loc, controlType, 1u); |
2231 | return builder->createIntegerConstant(loc, controlType, 1); // step |
2232 | } |
2233 | |
2234 | // For unroll directives without a value, force full unrolling. |
2235 | // For unroll directives with a value, if the value is greater than 1, |
2236 | // force unrolling with the given factor. Otherwise, disable unrolling. |
2237 | mlir::LLVM::LoopUnrollAttr |
2238 | genLoopUnrollAttr(std::optional<std::uint64_t> directiveArg) { |
2239 | mlir::BoolAttr falseAttr = |
2240 | mlir::BoolAttr::get(builder->getContext(), false); |
2241 | mlir::BoolAttr trueAttr = mlir::BoolAttr::get(builder->getContext(), true); |
2242 | mlir::IntegerAttr countAttr; |
2243 | mlir::BoolAttr fullUnrollAttr; |
2244 | bool shouldUnroll = true; |
2245 | if (directiveArg.has_value()) { |
2246 | auto unrollingFactor = directiveArg.value(); |
2247 | if (unrollingFactor == 0 || unrollingFactor == 1) { |
2248 | shouldUnroll = false; |
2249 | } else { |
2250 | countAttr = |
2251 | builder->getIntegerAttr(builder->getI64Type(), unrollingFactor); |
2252 | } |
2253 | } else { |
2254 | fullUnrollAttr = trueAttr; |
2255 | } |
2256 | |
2257 | mlir::BoolAttr disableAttr = shouldUnroll ? falseAttr : trueAttr; |
2258 | return mlir::LLVM::LoopUnrollAttr::get( |
2259 | builder->getContext(), /*disable=*/disableAttr, /*count=*/countAttr, {}, |
2260 | /*full=*/fullUnrollAttr, {}, {}, {}); |
2261 | } |
2262 | |
2263 | // Enabling unroll and jamming directive without a value. |
2264 | // For directives with a value, if the value is greater than 1, |
2265 | // force unrolling with the given factor. Otherwise, disable unrolling and |
2266 | // jamming. |
2267 | mlir::LLVM::LoopUnrollAndJamAttr |
2268 | genLoopUnrollAndJamAttr(std::optional<std::uint64_t> count) { |
2269 | mlir::BoolAttr falseAttr = |
2270 | mlir::BoolAttr::get(builder->getContext(), false); |
2271 | mlir::BoolAttr trueAttr = mlir::BoolAttr::get(builder->getContext(), true); |
2272 | mlir::IntegerAttr countAttr; |
2273 | bool shouldUnroll = true; |
2274 | if (count.has_value()) { |
2275 | auto unrollingFactor = count.value(); |
2276 | if (unrollingFactor == 0 || unrollingFactor == 1) { |
2277 | shouldUnroll = false; |
2278 | } else { |
2279 | countAttr = |
2280 | builder->getIntegerAttr(builder->getI64Type(), unrollingFactor); |
2281 | } |
2282 | } |
2283 | |
2284 | mlir::BoolAttr disableAttr = shouldUnroll ? falseAttr : trueAttr; |
2285 | return mlir::LLVM::LoopUnrollAndJamAttr::get( |
2286 | builder->getContext(), /*disable=*/disableAttr, /*count*/ countAttr, {}, |
2287 | {}, {}, {}, {}); |
2288 | } |
2289 | |
2290 | void addLoopAnnotationAttr( |
2291 | IncrementLoopInfo &info, |
2292 | llvm::SmallVectorImpl<const Fortran::parser::CompilerDirective *> &dirs) { |
2293 | mlir::LLVM::LoopVectorizeAttr va; |
2294 | mlir::LLVM::LoopUnrollAttr ua; |
2295 | mlir::LLVM::LoopUnrollAndJamAttr uja; |
2296 | bool has_attrs = false; |
2297 | for (const auto *dir : dirs) { |
2298 | Fortran::common::visit( |
2299 | Fortran::common::visitors{ |
2300 | [&](const Fortran::parser::CompilerDirective::VectorAlways &) { |
2301 | mlir::BoolAttr falseAttr = |
2302 | mlir::BoolAttr::get(builder->getContext(), false); |
2303 | va = mlir::LLVM::LoopVectorizeAttr::get(builder->getContext(), |
2304 | /*disable=*/falseAttr, |
2305 | {}, {}, {}, {}, {}, {}); |
2306 | has_attrs = true; |
2307 | }, |
2308 | [&](const Fortran::parser::CompilerDirective::Unroll &u) { |
2309 | ua = genLoopUnrollAttr(u.v); |
2310 | has_attrs = true; |
2311 | }, |
2312 | [&](const Fortran::parser::CompilerDirective::UnrollAndJam &u) { |
2313 | uja = genLoopUnrollAndJamAttr(u.v); |
2314 | has_attrs = true; |
2315 | }, |
2316 | [&](const Fortran::parser::CompilerDirective::NoVector &u) { |
2317 | mlir::BoolAttr trueAttr = |
2318 | mlir::BoolAttr::get(builder->getContext(), true); |
2319 | va = mlir::LLVM::LoopVectorizeAttr::get(builder->getContext(), |
2320 | /*disable=*/trueAttr, |
2321 | {}, {}, {}, {}, {}, {}); |
2322 | has_attrs = true; |
2323 | }, |
2324 | [&](const Fortran::parser::CompilerDirective::NoUnroll &u) { |
2325 | ua = genLoopUnrollAttr(/*unrollingFactor=*/0); |
2326 | has_attrs = true; |
2327 | }, |
2328 | [&](const Fortran::parser::CompilerDirective::NoUnrollAndJam &u) { |
2329 | uja = genLoopUnrollAndJamAttr(/*unrollingFactor=*/0); |
2330 | has_attrs = true; |
2331 | }, |
2332 | |
2333 | [&](const auto &) {}}, |
2334 | dir->u); |
2335 | } |
2336 | mlir::LLVM::LoopAnnotationAttr la = mlir::LLVM::LoopAnnotationAttr::get( |
2337 | builder->getContext(), {}, /*vectorize=*/va, {}, /*unroll*/ ua, |
2338 | /*unroll_and_jam*/ uja, {}, {}, {}, {}, {}, {}, {}, {}, {}, {}); |
2339 | if (has_attrs) { |
2340 | if (auto loopOp = mlir::dyn_cast<fir::DoLoopOp>(info.loopOp)) |
2341 | loopOp.setLoopAnnotationAttr(la); |
2342 | |
2343 | if (auto doConcurrentOp = |
2344 | mlir::dyn_cast<fir::DoConcurrentLoopOp>(info.loopOp)) |
2345 | doConcurrentOp.setLoopAnnotationAttr(la); |
2346 | } |
2347 | } |
2348 | |
2349 | /// Generate FIR to begin a structured or unstructured increment loop nest. |
2350 | void genFIRIncrementLoopBegin( |
2351 | IncrementLoopNestInfo &incrementLoopNestInfo, |
2352 | llvm::SmallVectorImpl<const Fortran::parser::CompilerDirective *> &dirs) { |
2353 | assert(!incrementLoopNestInfo.empty() && "empty loop nest"); |
2354 | mlir::Location loc = toLocation(); |
2355 | mlir::arith::IntegerOverflowFlags iofBackup{}; |
2356 | |
2357 | llvm::SmallVector<mlir::Value> nestLBs; |
2358 | llvm::SmallVector<mlir::Value> nestUBs; |
2359 | llvm::SmallVector<mlir::Value> nestSts; |
2360 | llvm::SmallVector<mlir::Value> nestReduceOperands; |
2361 | llvm::SmallVector<mlir::Attribute> nestReduceAttrs; |
2362 | bool genDoConcurrent = false; |
2363 | |
2364 | for (IncrementLoopInfo &info : incrementLoopNestInfo) { |
2365 | genDoConcurrent = info.isStructured() && info.isConcurrent; |
2366 | |
2367 | if (!genDoConcurrent) |
2368 | info.loopVariable = genLoopVariableAddress(loc, *info.loopVariableSym, |
2369 | info.isConcurrent); |
2370 | |
2371 | if (!getLoweringOptions().getIntegerWrapAround()) { |
2372 | iofBackup = builder->getIntegerOverflowFlags(); |
2373 | builder->setIntegerOverflowFlags( |
2374 | mlir::arith::IntegerOverflowFlags::nsw); |
2375 | } |
2376 | |
2377 | nestLBs.push_back(genControlValue(info.lowerExpr, info)); |
2378 | nestUBs.push_back(genControlValue(info.upperExpr, info)); |
2379 | bool isConst = true; |
2380 | nestSts.push_back(genControlValue( |
2381 | info.stepExpr, info, info.isStructured() ? nullptr : &isConst)); |
2382 | |
2383 | if (!getLoweringOptions().getIntegerWrapAround()) |
2384 | builder->setIntegerOverflowFlags(iofBackup); |
2385 | |
2386 | // Use a temp variable for unstructured loops with non-const step. |
2387 | if (!isConst) { |
2388 | mlir::Value stepValue = nestSts.back(); |
2389 | info.stepVariable = builder->createTemporary(loc, stepValue.getType()); |
2390 | builder->create<fir::StoreOp>(loc, stepValue, info.stepVariable); |
2391 | } |
2392 | |
2393 | if (genDoConcurrent && nestReduceOperands.empty()) { |
2394 | // Create DO CONCURRENT reduce operands and attributes |
2395 | for (const auto &reduceSym : info.reduceSymList) { |
2396 | const fir::ReduceOperationEnum reduceOperation = reduceSym.first; |
2397 | const Fortran::semantics::Symbol *sym = reduceSym.second; |
2398 | fir::ExtendedValue exv = getSymbolExtendedValue(*sym, nullptr); |
2399 | nestReduceOperands.push_back(fir::getBase(exv)); |
2400 | auto reduceAttr = |
2401 | fir::ReduceAttr::get(builder->getContext(), reduceOperation); |
2402 | nestReduceAttrs.push_back(reduceAttr); |
2403 | } |
2404 | } |
2405 | } |
2406 | |
2407 | for (auto [info, lowerValue, upperValue, stepValue] : |
2408 | llvm::zip_equal(incrementLoopNestInfo, nestLBs, nestUBs, nestSts)) { |
2409 | // Structured loop - generate fir.do_loop. |
2410 | if (info.isStructured()) { |
2411 | if (genDoConcurrent) |
2412 | continue; |
2413 | |
2414 | // The loop variable is a doLoop op argument. |
2415 | mlir::Type loopVarType = info.getLoopVariableType(); |
2416 | auto loopOp = builder->create<fir::DoLoopOp>( |
2417 | loc, lowerValue, upperValue, stepValue, /*unordered=*/false, |
2418 | /*finalCountValue=*/true, |
2419 | builder->createConvert(loc, loopVarType, lowerValue)); |
2420 | info.loopOp = loopOp; |
2421 | builder->setInsertionPointToStart(loopOp.getBody()); |
2422 | mlir::Value loopValue = loopOp.getRegionIterArgs()[0]; |
2423 | |
2424 | // Update the loop variable value in case it has non-index references. |
2425 | builder->create<fir::StoreOp>(loc, loopValue, info.loopVariable); |
2426 | addLoopAnnotationAttr(info, dirs); |
2427 | continue; |
2428 | } |
2429 | |
2430 | // Unstructured loop preheader - initialize tripVariable and loopVariable. |
2431 | mlir::Value tripCount; |
2432 | if (info.hasRealControl) { |
2433 | auto diff1 = |
2434 | builder->create<mlir::arith::SubFOp>(loc, upperValue, lowerValue); |
2435 | auto diff2 = |
2436 | builder->create<mlir::arith::AddFOp>(loc, diff1, stepValue); |
2437 | tripCount = builder->create<mlir::arith::DivFOp>(loc, diff2, stepValue); |
2438 | tripCount = |
2439 | builder->createConvert(loc, builder->getIndexType(), tripCount); |
2440 | } else { |
2441 | auto diff1 = |
2442 | builder->create<mlir::arith::SubIOp>(loc, upperValue, lowerValue); |
2443 | auto diff2 = |
2444 | builder->create<mlir::arith::AddIOp>(loc, diff1, stepValue); |
2445 | tripCount = |
2446 | builder->create<mlir::arith::DivSIOp>(loc, diff2, stepValue); |
2447 | } |
2448 | if (forceLoopToExecuteOnce) { // minimum tripCount is 1 |
2449 | mlir::Value one = |
2450 | builder->createIntegerConstant(loc, tripCount.getType(), 1); |
2451 | auto cond = builder->create<mlir::arith::CmpIOp>( |
2452 | loc, mlir::arith::CmpIPredicate::slt, tripCount, one); |
2453 | tripCount = |
2454 | builder->create<mlir::arith::SelectOp>(loc, cond, one, tripCount); |
2455 | } |
2456 | info.tripVariable = builder->createTemporary(loc, tripCount.getType()); |
2457 | builder->create<fir::StoreOp>(loc, tripCount, info.tripVariable); |
2458 | builder->create<fir::StoreOp>(loc, lowerValue, info.loopVariable); |
2459 | |
2460 | // Unstructured loop header - generate loop condition and mask. |
2461 | // Note - Currently there is no way to tag a loop as a concurrent loop. |
2462 | startBlock(info.headerBlock); |
2463 | tripCount = builder->create<fir::LoadOp>(loc, info.tripVariable); |
2464 | mlir::Value zero = |
2465 | builder->createIntegerConstant(loc, tripCount.getType(), 0); |
2466 | auto cond = builder->create<mlir::arith::CmpIOp>( |
2467 | loc, mlir::arith::CmpIPredicate::sgt, tripCount, zero); |
2468 | if (info.maskExpr) { |
2469 | genConditionalBranch(cond, info.maskBlock, info.exitBlock); |
2470 | startBlock(info.maskBlock); |
2471 | mlir::Block *latchBlock = getEval().getLastNestedEvaluation().block; |
2472 | assert(latchBlock && "missing masked concurrent loop latch block"); |
2473 | Fortran::lower::StatementContext stmtCtx; |
2474 | mlir::Value maskCond = createFIRExpr(loc, info.maskExpr, stmtCtx); |
2475 | stmtCtx.finalizeAndReset(); |
2476 | genConditionalBranch(maskCond, info.bodyBlock, latchBlock); |
2477 | } else { |
2478 | genConditionalBranch(cond, info.bodyBlock, info.exitBlock); |
2479 | if (&info != &incrementLoopNestInfo.back()) // not innermost |
2480 | startBlock(info.bodyBlock); // preheader block of enclosed dimension |
2481 | } |
2482 | if (info.hasLocalitySpecs()) { |
2483 | mlir::OpBuilder::InsertPoint insertPt = builder->saveInsertionPoint(); |
2484 | builder->setInsertionPointToStart(info.bodyBlock); |
2485 | handleLocalitySpecs(info); |
2486 | builder->restoreInsertionPoint(insertPt); |
2487 | } |
2488 | } |
2489 | |
2490 | if (genDoConcurrent) { |
2491 | auto loopWrapperOp = builder->create<fir::DoConcurrentOp>(loc); |
2492 | builder->setInsertionPointToStart( |
2493 | builder->createBlock(&loopWrapperOp.getRegion())); |
2494 | |
2495 | for (IncrementLoopInfo &info : llvm::reverse(C&: incrementLoopNestInfo)) { |
2496 | info.loopVariable = genLoopVariableAddress(loc, *info.loopVariableSym, |
2497 | info.isConcurrent); |
2498 | } |
2499 | |
2500 | builder->setInsertionPointToEnd(loopWrapperOp.getBody()); |
2501 | auto loopOp = builder->create<fir::DoConcurrentLoopOp>( |
2502 | loc, nestLBs, nestUBs, nestSts, nestReduceOperands, |
2503 | nestReduceAttrs.empty() |
2504 | ? nullptr |
2505 | : mlir::ArrayAttr::get(builder->getContext(), nestReduceAttrs), |
2506 | nullptr, /*local_vars=*/std::nullopt, /*local_syms=*/nullptr); |
2507 | |
2508 | llvm::SmallVector<mlir::Type> loopBlockArgTypes( |
2509 | incrementLoopNestInfo.size(), builder->getIndexType()); |
2510 | llvm::SmallVector<mlir::Location> loopBlockArgLocs( |
2511 | incrementLoopNestInfo.size(), loc); |
2512 | mlir::Region &loopRegion = loopOp.getRegion(); |
2513 | mlir::Block *loopBlock = builder->createBlock( |
2514 | &loopRegion, loopRegion.begin(), loopBlockArgTypes, loopBlockArgLocs); |
2515 | builder->setInsertionPointToStart(loopBlock); |
2516 | |
2517 | for (auto [info, blockArg] : |
2518 | llvm::zip_equal(incrementLoopNestInfo, loopBlock->getArguments())) { |
2519 | info.loopOp = loopOp; |
2520 | mlir::Value loopValue = |
2521 | builder->createConvert(loc, info.getLoopVariableType(), blockArg); |
2522 | builder->create<fir::StoreOp>(loc, loopValue, info.loopVariable); |
2523 | |
2524 | if (info.maskExpr) { |
2525 | Fortran::lower::StatementContext stmtCtx; |
2526 | mlir::Value maskCond = createFIRExpr(loc, info.maskExpr, stmtCtx); |
2527 | stmtCtx.finalizeAndReset(); |
2528 | mlir::Value maskCondCast = |
2529 | builder->createConvert(loc, builder->getI1Type(), maskCond); |
2530 | auto ifOp = builder->create<fir::IfOp>(loc, maskCondCast, |
2531 | /*withElseRegion=*/false); |
2532 | builder->setInsertionPointToStart(&ifOp.getThenRegion().front()); |
2533 | } |
2534 | } |
2535 | |
2536 | IncrementLoopInfo &innermostInfo = incrementLoopNestInfo.back(); |
2537 | |
2538 | if (innermostInfo.hasLocalitySpecs()) |
2539 | handleLocalitySpecs(info: innermostInfo); |
2540 | |
2541 | addLoopAnnotationAttr(innermostInfo, dirs); |
2542 | } |
2543 | } |
2544 | |
2545 | /// Generate FIR to end a structured or unstructured increment loop nest. |
2546 | void genFIRIncrementLoopEnd(IncrementLoopNestInfo &incrementLoopNestInfo) { |
2547 | assert(!incrementLoopNestInfo.empty() && "empty loop nest"); |
2548 | mlir::Location loc = toLocation(); |
2549 | mlir::arith::IntegerOverflowFlags flags{}; |
2550 | if (!getLoweringOptions().getIntegerWrapAround()) |
2551 | flags = bitEnumSet(flags, mlir::arith::IntegerOverflowFlags::nsw); |
2552 | auto iofAttr = mlir::arith::IntegerOverflowFlagsAttr::get( |
2553 | builder->getContext(), flags); |
2554 | for (auto it = incrementLoopNestInfo.rbegin(), |
2555 | rend = incrementLoopNestInfo.rend(); |
2556 | it != rend; ++it) { |
2557 | IncrementLoopInfo &info = *it; |
2558 | if (info.isStructured()) { |
2559 | // End fir.do_concurent.loop. |
2560 | if (info.isConcurrent) { |
2561 | builder->setInsertionPointAfter(info.loopOp->getParentOp()); |
2562 | continue; |
2563 | } |
2564 | |
2565 | // End fir.do_loop. |
2566 | // Decrement tripVariable. |
2567 | auto doLoopOp = mlir::cast<fir::DoLoopOp>(info.loopOp); |
2568 | builder->setInsertionPointToEnd(doLoopOp.getBody()); |
2569 | llvm::SmallVector<mlir::Value, 2> results; |
2570 | results.push_back(builder->create<mlir::arith::AddIOp>( |
2571 | loc, doLoopOp.getInductionVar(), doLoopOp.getStep(), iofAttr)); |
2572 | // Step loopVariable to help optimizations such as vectorization. |
2573 | // Induction variable elimination will clean up as necessary. |
2574 | mlir::Value step = builder->createConvert( |
2575 | loc, info.getLoopVariableType(), doLoopOp.getStep()); |
2576 | mlir::Value loopVar = |
2577 | builder->create<fir::LoadOp>(loc, info.loopVariable); |
2578 | results.push_back( |
2579 | builder->create<mlir::arith::AddIOp>(loc, loopVar, step, iofAttr)); |
2580 | builder->create<fir::ResultOp>(loc, results); |
2581 | builder->setInsertionPointAfter(doLoopOp); |
2582 | // The loop control variable may be used after the loop. |
2583 | builder->create<fir::StoreOp>(loc, doLoopOp.getResult(1), |
2584 | info.loopVariable); |
2585 | continue; |
2586 | } |
2587 | |
2588 | // Unstructured loop - decrement tripVariable and step loopVariable. |
2589 | mlir::Value tripCount = |
2590 | builder->create<fir::LoadOp>(loc, info.tripVariable); |
2591 | mlir::Value one = |
2592 | builder->createIntegerConstant(loc, tripCount.getType(), 1); |
2593 | tripCount = builder->create<mlir::arith::SubIOp>(loc, tripCount, one); |
2594 | builder->create<fir::StoreOp>(loc, tripCount, info.tripVariable); |
2595 | mlir::Value value = builder->create<fir::LoadOp>(loc, info.loopVariable); |
2596 | mlir::Value step; |
2597 | if (info.stepVariable) |
2598 | step = builder->create<fir::LoadOp>(loc, info.stepVariable); |
2599 | else |
2600 | step = genControlValue(info.stepExpr, info); |
2601 | if (info.hasRealControl) |
2602 | value = builder->create<mlir::arith::AddFOp>(loc, value, step); |
2603 | else |
2604 | value = builder->create<mlir::arith::AddIOp>(loc, value, step, iofAttr); |
2605 | builder->create<fir::StoreOp>(loc, value, info.loopVariable); |
2606 | |
2607 | genBranch(info.headerBlock); |
2608 | if (&info != &incrementLoopNestInfo.front()) // not outermost |
2609 | startBlock(info.exitBlock); // latch block of enclosing dimension |
2610 | } |
2611 | } |
2612 | |
2613 | /// Generate structured or unstructured FIR for an IF construct. |
2614 | /// The initial statement may be either an IfStmt or an IfThenStmt. |
2615 | void genFIR(const Fortran::parser::IfConstruct &) { |
2616 | Fortran::lower::pft::Evaluation &eval = getEval(); |
2617 | |
2618 | // Structured fir.if nest. |
2619 | if (eval.lowerAsStructured()) { |
2620 | fir::IfOp topIfOp, currentIfOp; |
2621 | for (Fortran::lower::pft::Evaluation &e : eval.getNestedEvaluations()) { |
2622 | auto genIfOp = [&](mlir::Value cond) { |
2623 | Fortran::lower::pft::Evaluation &succ = *e.controlSuccessor; |
2624 | bool hasElse = succ.isA<Fortran::parser::ElseIfStmt>() || |
2625 | succ.isA<Fortran::parser::ElseStmt>(); |
2626 | auto ifOp = builder->create<fir::IfOp>(toLocation(), cond, |
2627 | /*withElseRegion=*/hasElse); |
2628 | builder->setInsertionPointToStart(&ifOp.getThenRegion().front()); |
2629 | return ifOp; |
2630 | }; |
2631 | setCurrentPosition(e.position); |
2632 | if (auto *s = e.getIf<Fortran::parser::IfThenStmt>()) { |
2633 | topIfOp = currentIfOp = genIfOp(genIfCondition(s, e.negateCondition)); |
2634 | } else if (auto *s = e.getIf<Fortran::parser::IfStmt>()) { |
2635 | topIfOp = currentIfOp = genIfOp(genIfCondition(s, e.negateCondition)); |
2636 | } else if (auto *s = e.getIf<Fortran::parser::ElseIfStmt>()) { |
2637 | builder->setInsertionPointToStart( |
2638 | ¤tIfOp.getElseRegion().front()); |
2639 | currentIfOp = genIfOp(genIfCondition(s)); |
2640 | } else if (e.isA<Fortran::parser::ElseStmt>()) { |
2641 | builder->setInsertionPointToStart( |
2642 | ¤tIfOp.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 ®ion, |
2946 | bool isMask = false) { |
2947 | if (region.empty()) |
2948 | builder->createBlock(®ion); |
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(®ionAssignOp.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(®ionAssignOp.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(®ionAssignOp.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(®ionAssignOp.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(®ionAssignOp.getUserDefinedAssignment(), |
4998 | mlir::Region::iterator{}, {rhsType, lhsType}, |
4999 | {loc, loc}); |
5000 | auto end = builder.create<fir::FirEndOp>(loc); |
5001 | builder.setInsertionPoint(end); |
5002 | hlfir::Entity lhsBlockArg{regionAssignOp.getUserAssignmentLhs()}; |
5003 | hlfir::Entity rhsBlockArg{regionAssignOp.getUserAssignmentRhs()}; |
5004 | Fortran::lower::convertUserDefinedAssignmentToHLFIR( |
5005 | loc, *this, *userDefinedAssignment, lhsBlockArg, rhsBlockArg, |
5006 | localSymbols); |
5007 | } |
5008 | builder.setInsertionPointAfter(regionAssignOp); |
5009 | } |
5010 | |
5011 | /// Shared for both assignments and pointer assignments. |
5012 | void genAssignment(const Fortran::evaluate::Assignment &assign) { |
5013 | mlir::Location loc = toLocation(); |
5014 | if (lowerToHighLevelFIR()) { |
5015 | Fortran::common::visit( |
5016 | Fortran::common::visitors{ |
5017 | [&](const Fortran::evaluate::Assignment::Intrinsic &) { |
5018 | genDataAssignment(assign, /*userDefinedAssignment=*/nullptr); |
5019 | }, |
5020 | [&](const Fortran::evaluate::ProcedureRef &procRef) { |
5021 | genDataAssignment(assign, /*userDefinedAssignment=*/&procRef); |
5022 | }, |
5023 | [&](const Fortran::evaluate::Assignment::BoundsSpec &lbExprs) { |
5024 | if (isInsideHlfirForallOrWhere()) |
5025 | genForallPointerAssignment(loc, assign); |
5026 | else |
5027 | genPointerAssignment(loc, assign, lbExprs); |
5028 | }, |
5029 | [&](const Fortran::evaluate::Assignment::BoundsRemapping |
5030 | &boundExprs) { |
5031 | if (isInsideHlfirForallOrWhere()) |
5032 | genForallPointerAssignment(loc, assign); |
5033 | else |
5034 | genPointerAssignment(loc, assign, boundExprs); |
5035 | }, |
5036 | }, |
5037 | assign.u); |
5038 | return; |
5039 | } |
5040 | if (explicitIterationSpace()) { |
5041 | Fortran::lower::createArrayLoads(*this, explicitIterSpace, localSymbols); |
5042 | explicitIterSpace.genLoopNest(); |
5043 | } |
5044 | Fortran::lower::StatementContext stmtCtx; |
5045 | Fortran::common::visit( |
5046 | Fortran::common::visitors{ |
5047 | // [1] Plain old assignment. |
5048 | [&](const Fortran::evaluate::Assignment::Intrinsic &) { |
5049 | const Fortran::semantics::Symbol *sym = |
5050 | Fortran::evaluate::GetLastSymbol(assign.lhs); |
5051 | |
5052 | if (!sym) |
5053 | TODO(loc, "assignment to pointer result of function reference"); |
5054 | |
5055 | std::optional<Fortran::evaluate::DynamicType> lhsType = |
5056 | assign.lhs.GetType(); |
5057 | assert(lhsType && "lhs cannot be typeless"); |
5058 | std::optional<Fortran::evaluate::DynamicType> rhsType = |
5059 | assign.rhs.GetType(); |
5060 | |
5061 | // Assignment to/from polymorphic entities are done with the |
5062 | // runtime. |
5063 | if (lhsType->IsPolymorphic() || |
5064 | lhsType->IsUnlimitedPolymorphic() || |
5065 | (rhsType && (rhsType->IsPolymorphic() || |
5066 | rhsType->IsUnlimitedPolymorphic()))) { |
5067 | mlir::Value lhs; |
5068 | if (Fortran::lower::isWholeAllocatable(assign.lhs)) |
5069 | lhs = genExprMutableBox(loc, assign.lhs).getAddr(); |
5070 | else |
5071 | lhs = fir::getBase(genExprBox(loc, assign.lhs, stmtCtx)); |
5072 | mlir::Value rhs = |
5073 | fir::getBase(genExprBox(loc, assign.rhs, stmtCtx)); |
5074 | if ((lhsType->IsPolymorphic() || |
5075 | lhsType->IsUnlimitedPolymorphic()) && |
5076 | Fortran::lower::isWholeAllocatable(assign.lhs)) |
5077 | fir::runtime::genAssignPolymorphic(*builder, loc, lhs, rhs); |
5078 | else |
5079 | fir::runtime::genAssign(*builder, loc, lhs, rhs); |
5080 | return; |
5081 | } |
5082 | |
5083 | // Note: No ad-hoc handling for pointers is required here. The |
5084 | // target will be assigned as per 2018 10.2.1.3 p2. genExprAddr |
5085 | // on a pointer returns the target address and not the address of |
5086 | // the pointer variable. |
5087 | |
5088 | if (assign.lhs.Rank() > 0 || explicitIterationSpace()) { |
5089 | if (isDerivedCategory(lhsType->category()) && |
5090 | Fortran::semantics::IsFinalizable( |
5091 | lhsType->GetDerivedTypeSpec())) |
5092 | TODO(loc, "derived-type finalization with array assignment"); |
5093 | // Array assignment |
5094 | // See Fortran 2018 10.2.1.3 p5, p6, and p7 |
5095 | genArrayAssignment(assign, stmtCtx); |
5096 | return; |
5097 | } |
5098 | |
5099 | // Scalar assignment |
5100 | const bool isNumericScalar = |
5101 | isNumericScalarCategory(lhsType->category()); |
5102 | const bool isVector = |
5103 | isDerivedCategory(lhsType->category()) && |
5104 | lhsType->GetDerivedTypeSpec().IsVectorType(); |
5105 | fir::ExtendedValue rhs = (isNumericScalar || isVector) |
5106 | ? genExprValue(assign.rhs, stmtCtx) |
5107 | : genExprAddr(assign.rhs, stmtCtx); |
5108 | const bool lhsIsWholeAllocatable = |
5109 | Fortran::lower::isWholeAllocatable(assign.lhs); |
5110 | std::optional<fir::factory::MutableBoxReallocation> lhsRealloc; |
5111 | std::optional<fir::MutableBoxValue> lhsMutableBox; |
5112 | |
5113 | // Set flag to know if the LHS needs finalization. Polymorphic, |
5114 | // unlimited polymorphic assignment will be done with genAssign. |
5115 | // Assign runtime function performs the finalization. |
5116 | bool needFinalization = !lhsType->IsPolymorphic() && |
5117 | !lhsType->IsUnlimitedPolymorphic() && |
5118 | (isDerivedCategory(lhsType->category()) && |
5119 | Fortran::semantics::IsFinalizable( |
5120 | lhsType->GetDerivedTypeSpec())); |
5121 | |
5122 | auto lhs = [&]() -> fir::ExtendedValue { |
5123 | if (lhsIsWholeAllocatable) { |
5124 | lhsMutableBox = genExprMutableBox(loc, assign.lhs); |
5125 | // Finalize if needed. |
5126 | if (needFinalization) { |
5127 | mlir::Value isAllocated = |
5128 | fir::factory::genIsAllocatedOrAssociatedTest( |
5129 | *builder, loc, *lhsMutableBox); |
5130 | builder->genIfThen(loc, isAllocated) |
5131 | .genThen([&]() { |
5132 | fir::runtime::genDerivedTypeDestroy( |
5133 | *builder, loc, fir::getBase(*lhsMutableBox)); |
5134 | }) |
5135 | .end(); |
5136 | needFinalization = false; |
5137 | } |
5138 | |
5139 | llvm::SmallVector<mlir::Value> lengthParams; |
5140 | if (const fir::CharBoxValue *charBox = rhs.getCharBox()) |
5141 | lengthParams.push_back(charBox->getLen()); |
5142 | else if (fir::isDerivedWithLenParameters(rhs)) |
5143 | TODO(loc, "assignment to derived type allocatable with " |
5144 | "LEN parameters"); |
5145 | lhsRealloc = fir::factory::genReallocIfNeeded( |
5146 | *builder, loc, *lhsMutableBox, |
5147 | /*shape=*/std::nullopt, lengthParams); |
5148 | return lhsRealloc->newValue; |
5149 | } |
5150 | return genExprAddr(assign.lhs, stmtCtx); |
5151 | }(); |
5152 | |
5153 | if (isNumericScalar || isVector) { |
5154 | // Fortran 2018 10.2.1.3 p8 and p9 |
5155 | // Conversions should have been inserted by semantic analysis, |
5156 | // but they can be incorrect between the rhs and lhs. Correct |
5157 | // that here. |
5158 | mlir::Value addr = fir::getBase(lhs); |
5159 | mlir::Value val = fir::getBase(rhs); |
5160 | // A function with multiple entry points returning different |
5161 | // types tags all result variables with one of the largest |
5162 | // types to allow them to share the same storage. Assignment |
5163 | // to a result variable of one of the other types requires |
5164 | // conversion to the actual type. |
5165 | mlir::Type toTy = genType(assign.lhs); |
5166 | |
5167 | // If Cray pointee, need to handle the address |
5168 | // Array is handled in genCoordinateOp. |
5169 | if (sym->test(Fortran::semantics::Symbol::Flag::CrayPointee) && |
5170 | sym->Rank() == 0) { |
5171 | // get the corresponding Cray pointer |
5172 | |
5173 | const Fortran::semantics::Symbol &ptrSym = |
5174 | Fortran::semantics::GetCrayPointer(*sym); |
5175 | fir::ExtendedValue ptr = |
5176 | getSymbolExtendedValue(ptrSym, nullptr); |
5177 | mlir::Value ptrVal = fir::getBase(ptr); |
5178 | mlir::Type ptrTy = genType(ptrSym); |
5179 | |
5180 | fir::ExtendedValue pte = |
5181 | getSymbolExtendedValue(*sym, nullptr); |
5182 | mlir::Value pteVal = fir::getBase(pte); |
5183 | mlir::Value cnvrt = Fortran::lower::addCrayPointerInst( |
5184 | loc, *builder, ptrVal, ptrTy, pteVal.getType()); |
5185 | addr = builder->create<fir::LoadOp>(loc, cnvrt); |
5186 | } |
5187 | mlir::Value cast = |
5188 | isVector ? val |
5189 | : builder->convertWithSemantics(loc, toTy, val); |
5190 | if (fir::dyn_cast_ptrEleTy(addr.getType()) != toTy) { |
5191 | assert(isFuncResultDesignator(assign.lhs) && "type mismatch"); |
5192 | addr = builder->createConvert( |
5193 | toLocation(), builder->getRefType(toTy), addr); |
5194 | } |
5195 | builder->create<fir::StoreOp>(loc, cast, addr); |
5196 | } else if (isCharacterCategory(lhsType->category())) { |
5197 | // Fortran 2018 10.2.1.3 p10 and p11 |
5198 | fir::factory::CharacterExprHelper{*builder, loc}.createAssign( |
5199 | lhs, rhs); |
5200 | } else if (isDerivedCategory(lhsType->category())) { |
5201 | // Handle parent component. |
5202 | if (Fortran::lower::isParentComponent(assign.lhs)) { |
5203 | if (!mlir::isa<fir::BaseBoxType>(fir::getBase(lhs).getType())) |
5204 | lhs = fir::getBase(builder->createBox(loc, lhs)); |
5205 | lhs = Fortran::lower::updateBoxForParentComponent(*this, lhs, |
5206 | assign.lhs); |
5207 | } |
5208 | |
5209 | // Fortran 2018 10.2.1.3 p13 and p14 |
5210 | // Recursively gen an assignment on each element pair. |
5211 | fir::factory::genRecordAssignment(*builder, loc, lhs, rhs, |
5212 | needFinalization); |
5213 | } else { |
5214 | llvm_unreachable("unknown category"); |
5215 | } |
5216 | if (lhsIsWholeAllocatable) { |
5217 | assert(lhsRealloc.has_value()); |
5218 | fir::factory::finalizeRealloc(*builder, loc, *lhsMutableBox, |
5219 | /*lbounds=*/std::nullopt, |
5220 | /*takeLboundsIfRealloc=*/false, |
5221 | *lhsRealloc); |
5222 | } |
5223 | }, |
5224 | |
5225 | // [2] User defined assignment. If the context is a scalar |
5226 | // expression then call the procedure. |
5227 | [&](const Fortran::evaluate::ProcedureRef &procRef) { |
5228 | Fortran::lower::StatementContext &ctx = |
5229 | explicitIterationSpace() ? explicitIterSpace.stmtContext() |
5230 | : stmtCtx; |
5231 | Fortran::lower::createSubroutineCall( |
5232 | *this, procRef, explicitIterSpace, implicitIterSpace, |
5233 | localSymbols, ctx, /*isUserDefAssignment=*/true); |
5234 | }, |
5235 | |
5236 | [&](const Fortran::evaluate::Assignment::BoundsSpec &lbExprs) { |
5237 | return genPointerAssignment(loc, assign, lbExprs); |
5238 | }, |
5239 | [&](const Fortran::evaluate::Assignment::BoundsRemapping |
5240 | &boundExprs) { |
5241 | return genPointerAssignment(loc, assign, boundExprs); |
5242 | }, |
5243 | }, |
5244 | assign.u); |
5245 | if (explicitIterationSpace()) |
5246 | Fortran::lower::createArrayMergeStores(*this, explicitIterSpace); |
5247 | } |
5248 | |
5249 | // Is the insertion point of the builder directly or indirectly set |
5250 | // inside any operation of type "Op"? |
5251 | template <typename... Op> |
5252 | bool isInsideOp() const { |
5253 | mlir::Block *block = builder->getInsertionBlock(); |
5254 | mlir::Operation *op = block ? block->getParentOp() : nullptr; |
5255 | while (op) { |
5256 | if (mlir::isa<Op...>(op)) |
5257 | return true; |
5258 | op = op->getParentOp(); |
5259 | } |
5260 | return false; |
5261 | } |
5262 | bool isInsideHlfirForallOrWhere() const { |
5263 | return isInsideOp<hlfir::ForallOp, hlfir::WhereOp>(); |
5264 | } |
5265 | bool isInsideHlfirWhere() const { return isInsideOp<hlfir::WhereOp>(); } |
5266 | |
5267 | void genFIR(const Fortran::parser::WhereConstruct &c) { |
5268 | mlir::Location loc = getCurrentLocation(); |
5269 | hlfir::WhereOp whereOp; |
5270 | |
5271 | if (!lowerToHighLevelFIR()) { |
5272 | implicitIterSpace.growStack(); |
5273 | } else { |
5274 | whereOp = builder->create<hlfir::WhereOp>(loc); |
5275 | builder->createBlock(&whereOp.getMaskRegion()); |
5276 | } |
5277 | |
5278 | // Lower the where mask. For HLFIR, this is done in the hlfir.where mask |
5279 | // region. |
5280 | genNestedStatement( |
5281 | std::get< |
5282 | Fortran::parser::Statement<Fortran::parser::WhereConstructStmt>>( |
5283 | c.t)); |
5284 | |
5285 | // Lower WHERE body. For HLFIR, this is done in the hlfir.where body |
5286 | // region. |
5287 | if (whereOp) |
5288 | builder->createBlock(&whereOp.getBody()); |
5289 | |
5290 | for (const auto &body : |
5291 | std::get<std::list<Fortran::parser::WhereBodyConstruct>>(c.t)) |
5292 | genFIR(body); |
5293 | for (const auto &e : |
5294 | std::get<std::list<Fortran::parser::WhereConstruct::MaskedElsewhere>>( |
5295 | c.t)) |
5296 | genFIR(e); |
5297 | if (const auto &e = |
5298 | std::get<std::optional<Fortran::parser::WhereConstruct::Elsewhere>>( |
5299 | c.t); |
5300 | e.has_value()) |
5301 | genFIR(*e); |
5302 | genNestedStatement( |
5303 | std::get<Fortran::parser::Statement<Fortran::parser::EndWhereStmt>>( |
5304 | c.t)); |
5305 | |
5306 | if (whereOp) { |
5307 | // For HLFIR, create fir.end terminator in the last hlfir.elsewhere, or |
5308 | // in the hlfir.where if it had no elsewhere. |
5309 | builder->create<fir::FirEndOp>(loc); |
5310 | builder->setInsertionPointAfter(whereOp); |
5311 | } |
5312 | } |
5313 | void genFIR(const Fortran::parser::WhereBodyConstruct &body) { |
5314 | Fortran::common::visit( |
5315 | Fortran::common::visitors{ |
5316 | [&](const Fortran::parser::Statement< |
5317 | Fortran::parser::AssignmentStmt> &stmt) { |
5318 | genNestedStatement(stmt); |
5319 | }, |
5320 | [&](const Fortran::parser::Statement<Fortran::parser::WhereStmt> |
5321 | &stmt) { genNestedStatement(stmt); }, |
5322 | [&](const Fortran::common::Indirection< |
5323 | Fortran::parser::WhereConstruct> &c) { genFIR(c.value()); }, |
5324 | }, |
5325 | body.u); |
5326 | } |
5327 | |
5328 | /// Lower a Where or Elsewhere mask into an hlfir mask region. |
5329 | void lowerWhereMaskToHlfir(mlir::Location loc, |
5330 | const Fortran::semantics::SomeExpr *maskExpr) { |
5331 | assert(maskExpr && "mask semantic analysis failed"); |
5332 | Fortran::lower::StatementContext maskContext; |
5333 | hlfir::Entity mask = Fortran::lower::convertExprToHLFIR( |
5334 | loc, *this, *maskExpr, localSymbols, maskContext); |
5335 | mask = hlfir::loadTrivialScalar(loc, *builder, mask); |
5336 | auto yieldOp = builder->create<hlfir::YieldOp>(loc, mask); |
5337 | Fortran::lower::genCleanUpInRegionIfAny(loc, *builder, yieldOp.getCleanup(), |
5338 | maskContext); |
5339 | } |
5340 | void genFIR(const Fortran::parser::WhereConstructStmt &stmt) { |
5341 | const Fortran::semantics::SomeExpr *maskExpr = Fortran::semantics::GetExpr( |
5342 | std::get<Fortran::parser::LogicalExpr>(stmt.t)); |
5343 | if (lowerToHighLevelFIR()) |
5344 | lowerWhereMaskToHlfir(getCurrentLocation(), maskExpr); |
5345 | else |
5346 | implicitIterSpace.append(maskExpr); |
5347 | } |
5348 | void genFIR(const Fortran::parser::WhereConstruct::MaskedElsewhere &ew) { |
5349 | mlir::Location loc = getCurrentLocation(); |
5350 | hlfir::ElseWhereOp elsewhereOp; |
5351 | if (lowerToHighLevelFIR()) { |
5352 | elsewhereOp = builder->create<hlfir::ElseWhereOp>(loc); |
5353 | // Lower mask in the mask region. |
5354 | builder->createBlock(&elsewhereOp.getMaskRegion()); |
5355 | } |
5356 | genNestedStatement( |
5357 | std::get< |
5358 | Fortran::parser::Statement<Fortran::parser::MaskedElsewhereStmt>>( |
5359 | ew.t)); |
5360 | |
5361 | // For HLFIR, lower the body in the hlfir.elsewhere body region. |
5362 | if (elsewhereOp) |
5363 | builder->createBlock(&elsewhereOp.getBody()); |
5364 | |
5365 | for (const auto &body : |
5366 | std::get<std::list<Fortran::parser::WhereBodyConstruct>>(ew.t)) |
5367 | genFIR(body); |
5368 | } |
5369 | void genFIR(const Fortran::parser::MaskedElsewhereStmt &stmt) { |
5370 | const auto *maskExpr = Fortran::semantics::GetExpr( |
5371 | std::get<Fortran::parser::LogicalExpr>(stmt.t)); |
5372 | if (lowerToHighLevelFIR()) |
5373 | lowerWhereMaskToHlfir(getCurrentLocation(), maskExpr); |
5374 | else |
5375 | implicitIterSpace.append(maskExpr); |
5376 | } |
5377 | void genFIR(const Fortran::parser::WhereConstruct::Elsewhere &ew) { |
5378 | if (lowerToHighLevelFIR()) { |
5379 | auto elsewhereOp = |
5380 | builder->create<hlfir::ElseWhereOp>(getCurrentLocation()); |
5381 | builder->createBlock(&elsewhereOp.getBody()); |
5382 | } |
5383 | genNestedStatement( |
5384 | std::get<Fortran::parser::Statement<Fortran::parser::ElsewhereStmt>>( |
5385 | ew.t)); |
5386 | for (const auto &body : |
5387 | std::get<std::list<Fortran::parser::WhereBodyConstruct>>(ew.t)) |
5388 | genFIR(body); |
5389 | } |
5390 | void genFIR(const Fortran::parser::ElsewhereStmt &stmt) { |
5391 | if (!lowerToHighLevelFIR()) |
5392 | implicitIterSpace.append(nullptr); |
5393 | } |
5394 | void genFIR(const Fortran::parser::EndWhereStmt &) { |
5395 | if (!lowerToHighLevelFIR()) |
5396 | implicitIterSpace.shrinkStack(); |
5397 | } |
5398 | |
5399 | void genFIR(const Fortran::parser::WhereStmt &stmt) { |
5400 | Fortran::lower::StatementContext stmtCtx; |
5401 | const auto &assign = std::get<Fortran::parser::AssignmentStmt>(stmt.t); |
5402 | const auto *mask = Fortran::semantics::GetExpr( |
5403 | std::get<Fortran::parser::LogicalExpr>(stmt.t)); |
5404 | if (lowerToHighLevelFIR()) { |
5405 | mlir::Location loc = getCurrentLocation(); |
5406 | auto whereOp = builder->create<hlfir::WhereOp>(loc); |
5407 | builder->createBlock(&whereOp.getMaskRegion()); |
5408 | lowerWhereMaskToHlfir(loc, mask); |
5409 | builder->createBlock(&whereOp.getBody()); |
5410 | genAssignment(*assign.typedAssignment->v); |
5411 | builder->create<fir::FirEndOp>(loc); |
5412 | builder->setInsertionPointAfter(whereOp); |
5413 | return; |
5414 | } |
5415 | implicitIterSpace.growStack(); |
5416 | implicitIterSpace.append(mask); |
5417 | genAssignment(*assign.typedAssignment->v); |
5418 | implicitIterSpace.shrinkStack(); |
5419 | } |
5420 | |
5421 | void genFIR(const Fortran::parser::PointerAssignmentStmt &stmt) { |
5422 | genAssignment(*stmt.typedAssignment->v); |
5423 | } |
5424 | |
5425 | void genFIR(const Fortran::parser::AssignmentStmt &stmt) { |
5426 | genAssignment(*stmt.typedAssignment->v); |
5427 | } |
5428 | |
5429 | void genFIR(const Fortran::parser::SyncAllStmt &stmt) { |
5430 | genSyncAllStatement(*this, stmt); |
5431 | } |
5432 | |
5433 | void genFIR(const Fortran::parser::SyncImagesStmt &stmt) { |
5434 | genSyncImagesStatement(*this, stmt); |
5435 | } |
5436 | |
5437 | void genFIR(const Fortran::parser::SyncMemoryStmt &stmt) { |
5438 | genSyncMemoryStatement(*this, stmt); |
5439 | } |
5440 | |
5441 | void genFIR(const Fortran::parser::SyncTeamStmt &stmt) { |
5442 | genSyncTeamStatement(*this, stmt); |
5443 | } |
5444 | |
5445 | void genFIR(const Fortran::parser::UnlockStmt &stmt) { |
5446 | genUnlockStatement(*this, stmt); |
5447 | } |
5448 | |
5449 | void genFIR(const Fortran::parser::AssignStmt &stmt) { |
5450 | const Fortran::semantics::Symbol &symbol = |
5451 | *std::get<Fortran::parser::Name>(stmt.t).symbol; |
5452 | mlir::Location loc = toLocation(); |
5453 | mlir::Value labelValue = builder->createIntegerConstant( |
5454 | loc, genType(symbol), std::get<Fortran::parser::Label>(stmt.t)); |
5455 | builder->create<fir::StoreOp>(loc, labelValue, getSymbolAddress(symbol)); |
5456 | } |
5457 | |
5458 | void genFIR(const Fortran::parser::FormatStmt &) { |
5459 | // do nothing. |
5460 | |
5461 | // FORMAT statements have no semantics. They may be lowered if used by a |
5462 | // data transfer statement. |
5463 | } |
5464 | |
5465 | void genFIR(const Fortran::parser::PauseStmt &stmt) { |
5466 | genPauseStatement(*this, stmt); |
5467 | } |
5468 | |
5469 | // call FAIL IMAGE in runtime |
5470 | void genFIR(const Fortran::parser::FailImageStmt &stmt) { |
5471 | genFailImageStatement(*this); |
5472 | } |
5473 | |
5474 | // call STOP, ERROR STOP in runtime |
5475 | void genFIR(const Fortran::parser::StopStmt &stmt) { |
5476 | genStopStatement(*this, stmt); |
5477 | } |
5478 | |
5479 | void genFIR(const Fortran::parser::ReturnStmt &stmt) { |
5480 | Fortran::lower::pft::FunctionLikeUnit *funit = |
5481 | getEval().getOwningProcedure(); |
5482 | assert(funit && "not inside main program, function or subroutine"); |
5483 | for (auto it = activeConstructStack.rbegin(), |
5484 | rend = activeConstructStack.rend(); |
5485 | it != rend; ++it) { |
5486 | it->stmtCtx.finalizeAndKeep(); |
5487 | } |
5488 | if (funit->isMainProgram()) { |
5489 | genExitRoutine(true); |
5490 | return; |
5491 | } |
5492 | mlir::Location loc = toLocation(); |
5493 | if (stmt.v) { |
5494 | // Alternate return statement - If this is a subroutine where some |
5495 | // alternate entries have alternate returns, but the active entry point |
5496 | // does not, ignore the alternate return value. Otherwise, assign it |
5497 | // to the compiler-generated result variable. |
5498 | const Fortran::semantics::Symbol &symbol = funit->getSubprogramSymbol(); |
5499 | if (Fortran::semantics::HasAlternateReturns(symbol)) { |
5500 | Fortran::lower::StatementContext stmtCtx; |
5501 | const Fortran::lower::SomeExpr *expr = |
5502 | Fortran::semantics::GetExpr(*stmt.v); |
5503 | assert(expr && "missing alternate return expression"); |
5504 | mlir::Value altReturnIndex = builder->createConvert( |
5505 | loc, builder->getIndexType(), createFIRExpr(loc, expr, stmtCtx)); |
5506 | builder->create<fir::StoreOp>(loc, altReturnIndex, |
5507 | getAltReturnResult(symbol)); |
5508 | } |
5509 | } |
5510 | // Branch to the last block of the SUBROUTINE, which has the actual return. |
5511 | if (!funit->finalBlock) { |
5512 | mlir::OpBuilder::InsertPoint insPt = builder->saveInsertionPoint(); |
5513 | Fortran::lower::setInsertionPointAfterOpenACCLoopIfInside(*builder); |
5514 | funit->finalBlock = builder->createBlock(&builder->getRegion()); |
5515 | builder->restoreInsertionPoint(insPt); |
5516 | } |
5517 | |
5518 | if (Fortran::lower::isInOpenACCLoop(*builder)) |
5519 | Fortran::lower::genEarlyReturnInOpenACCLoop(*builder, loc); |
5520 | else |
5521 | builder->create<mlir::cf::BranchOp>(loc, funit->finalBlock); |
5522 | } |
5523 | |
5524 | void genFIR(const Fortran::parser::CycleStmt &) { |
5525 | genConstructExitBranch(*getEval().controlSuccessor); |
5526 | } |
5527 | void genFIR(const Fortran::parser::ExitStmt &) { |
5528 | genConstructExitBranch(*getEval().controlSuccessor); |
5529 | } |
5530 | void genFIR(const Fortran::parser::GotoStmt &) { |
5531 | genConstructExitBranch(*getEval().controlSuccessor); |
5532 | } |
5533 | |
5534 | // Nop statements - No code, or code is generated at the construct level. |
5535 | // But note that the genFIR call immediately below that wraps one of these |
5536 | // calls does block management, possibly starting a new block, and possibly |
5537 | // generating a branch to end a block. So these calls may still be required |
5538 | // for that functionality. |
5539 | void genFIR(const Fortran::parser::AssociateStmt &) {} // nop |
5540 | void genFIR(const Fortran::parser::BlockStmt &) {} // nop |
5541 | void genFIR(const Fortran::parser::CaseStmt &) {} // nop |
5542 | void genFIR(const Fortran::parser::ContinueStmt &) {} // nop |
5543 | void genFIR(const Fortran::parser::ElseIfStmt &) {} // nop |
5544 | void genFIR(const Fortran::parser::ElseStmt &) {} // nop |
5545 | void genFIR(const Fortran::parser::EndAssociateStmt &) {} // nop |
5546 | void genFIR(const Fortran::parser::EndBlockStmt &) {} // nop |
5547 | void genFIR(const Fortran::parser::EndDoStmt &) {} // nop |
5548 | void genFIR(const Fortran::parser::EndFunctionStmt &) {} // nop |
5549 | void genFIR(const Fortran::parser::EndIfStmt &) {} // nop |
5550 | void genFIR(const Fortran::parser::EndMpSubprogramStmt &) {} // nop |
5551 | void genFIR(const Fortran::parser::EndProgramStmt &) {} // nop |
5552 | void genFIR(const Fortran::parser::EndSelectStmt &) {} // nop |
5553 | void genFIR(const Fortran::parser::EndSubroutineStmt &) {} // nop |
5554 | void genFIR(const Fortran::parser::EntryStmt &) {} // nop |
5555 | void genFIR(const Fortran::parser::IfStmt &) {} // nop |
5556 | void genFIR(const Fortran::parser::IfThenStmt &) {} // nop |
5557 | void genFIR(const Fortran::parser::NonLabelDoStmt &) {} // nop |
5558 | void genFIR(const Fortran::parser::OmpEndLoopDirective &) {} // nop |
5559 | void genFIR(const Fortran::parser::SelectTypeStmt &) {} // nop |
5560 | void genFIR(const Fortran::parser::TypeGuardStmt &) {} // nop |
5561 | |
5562 | /// Generate FIR for Evaluation \p eval. |
5563 | void genFIR(Fortran::lower::pft::Evaluation &eval, |
5564 | bool unstructuredContext = true) { |
5565 | // Start a new unstructured block when applicable. When transitioning |
5566 | // from unstructured to structured code, unstructuredContext is true, |
5567 | // which accounts for the possibility that the structured code could be |
5568 | // a target that starts a new block. |
5569 | if (unstructuredContext) |
5570 | maybeStartBlock(eval.isConstruct() && eval.lowerAsStructured() |
5571 | ? eval.getFirstNestedEvaluation().block |
5572 | : eval.block); |
5573 | |
5574 | // Generate evaluation specific code. Even nop calls should usually reach |
5575 | // here in case they start a new block or require generation of a generic |
5576 | // end-of-block branch. An alternative is to add special case code |
5577 | // elsewhere, such as in the genFIR code for a parent construct. |
5578 | setCurrentEval(eval); |
5579 | setCurrentPosition(eval.position); |
5580 | eval.visit([&](const auto &stmt) { genFIR(stmt); }); |
5581 | } |
5582 | |
5583 | /// Map mlir function block arguments to the corresponding Fortran dummy |
5584 | /// variables. When the result is passed as a hidden argument, the Fortran |
5585 | /// result is also mapped. The symbol map is used to hold this mapping. |
5586 | void mapDummiesAndResults(Fortran::lower::pft::FunctionLikeUnit &funit, |
5587 | const Fortran::lower::CalleeInterface &callee) { |
5588 | assert(builder && "require a builder object at this point"); |
5589 | using PassBy = Fortran::lower::CalleeInterface::PassEntityBy; |
5590 | auto mapPassedEntity = [&](const auto arg, bool isResult = false) { |
5591 | if (arg.passBy == PassBy::AddressAndLength) { |
5592 | if (callee.characterize().IsBindC()) |
5593 | return; |
5594 | // TODO: now that fir call has some attributes regarding character |
5595 | // return, PassBy::AddressAndLength should be retired. |
5596 | mlir::Location loc = toLocation(); |
5597 | fir::factory::CharacterExprHelper charHelp{*builder, loc}; |
5598 | mlir::Value casted = |
5599 | builder->createVolatileCast(loc, false, arg.firArgument); |
5600 | mlir::Value box = charHelp.createEmboxChar(casted, arg.firLength); |
5601 | mapBlockArgToDummyOrResult(arg.entity->get(), box, isResult); |
5602 | } else { |
5603 | if (arg.entity.has_value()) { |
5604 | mapBlockArgToDummyOrResult(arg.entity->get(), arg.firArgument, |
5605 | isResult); |
5606 | } else { |
5607 | assert(funit.parentHasTupleHostAssoc() && "expect tuple argument"); |
5608 | } |
5609 | } |
5610 | }; |
5611 | for (const Fortran::lower::CalleeInterface::PassedEntity &arg : |
5612 | callee.getPassedArguments()) |
5613 | mapPassedEntity(arg); |
5614 | |
5615 | // Always generate fir.dummy_scope even if there are no arguments. |
5616 | // It is currently used to create proper TBAA forest. |
5617 | if (lowerToHighLevelFIR()) { |
5618 | mlir::Value scopeOp = builder->create<fir::DummyScopeOp>(toLocation()); |
5619 | setDummyArgsScope(scopeOp); |
5620 | } |
5621 | if (std::optional<Fortran::lower::CalleeInterface::PassedEntity> |
5622 | passedResult = callee.getPassedResult()) { |
5623 | mapPassedEntity(*passedResult, /*isResult=*/true); |
5624 | // FIXME: need to make sure things are OK here. addSymbol may not be OK |
5625 | if (funit.primaryResult && |
5626 | passedResult->entity->get() != *funit.primaryResult) |
5627 | mapBlockArgToDummyOrResult( |
5628 | *funit.primaryResult, getSymbolAddress(passedResult->entity->get()), |
5629 | /*isResult=*/true); |
5630 | } |
5631 | } |
5632 | |
5633 | /// Instantiate variable \p var and add it to the symbol map. |
5634 | /// See ConvertVariable.cpp. |
5635 | void instantiateVar(const Fortran::lower::pft::Variable &var, |
5636 | Fortran::lower::AggregateStoreMap &storeMap) { |
5637 | Fortran::lower::instantiateVariable(*this, var, localSymbols, storeMap); |
5638 | if (var.hasSymbol()) |
5639 | genOpenMPSymbolProperties(*this, var); |
5640 | } |
5641 | |
5642 | /// Where applicable, save the exception state and halting, rounding, and |
5643 | /// underflow modes at function entry, and restore them at function exits. |
5644 | void manageFPEnvironment(Fortran::lower::pft::FunctionLikeUnit &funit) { |
5645 | mlir::Location loc = toLocation(); |
5646 | mlir::Location endLoc = |
5647 | toLocation(Fortran::lower::pft::stmtSourceLoc(funit.endStmt)); |
5648 | if (funit.hasIeeeAccess) { |
5649 | // Subject to F18 Clause 17.1p3, 17.3p3 states: If a flag is signaling |
5650 | // on entry to a procedure [...], the processor will set it to quiet |
5651 | // on entry and restore it to signaling on return. If a flag signals |
5652 | // during execution of a procedure, the processor shall not set it to |
5653 | // quiet on return. |
5654 | mlir::func::FuncOp testExcept = fir::factory::getFetestexcept(*builder); |
5655 | mlir::func::FuncOp clearExcept = fir::factory::getFeclearexcept(*builder); |
5656 | mlir::func::FuncOp raiseExcept = fir::factory::getFeraiseexcept(*builder); |
5657 | mlir::Value ones = builder->createIntegerConstant( |
5658 | loc, testExcept.getFunctionType().getInput(0), -1); |
5659 | mlir::Value exceptSet = |
5660 | builder->create<fir::CallOp>(loc, testExcept, ones).getResult(0); |
5661 | builder->create<fir::CallOp>(loc, clearExcept, exceptSet); |
5662 | bridge.fctCtx().attachCleanup([=]() { |
5663 | builder->create<fir::CallOp>(endLoc, raiseExcept, exceptSet); |
5664 | }); |
5665 | } |
5666 | if (funit.mayModifyHaltingMode) { |
5667 | // F18 Clause 17.6p1: In a procedure [...], the processor shall not |
5668 | // change the halting mode on entry, and on return shall ensure that |
5669 | // the halting mode is the same as it was on entry. |
5670 | mlir::func::FuncOp getExcept = fir::factory::getFegetexcept(*builder); |
5671 | mlir::func::FuncOp disableExcept = |
5672 | fir::factory::getFedisableexcept(*builder); |
5673 | mlir::func::FuncOp enableExcept = |
5674 | fir::factory::getFeenableexcept(*builder); |
5675 | mlir::Value exceptSet = |
5676 | builder->create<fir::CallOp>(loc, getExcept).getResult(0); |
5677 | mlir::Value ones = builder->createIntegerConstant( |
5678 | loc, disableExcept.getFunctionType().getInput(0), -1); |
5679 | bridge.fctCtx().attachCleanup([=]() { |
5680 | builder->create<fir::CallOp>(endLoc, disableExcept, ones); |
5681 | builder->create<fir::CallOp>(endLoc, enableExcept, exceptSet); |
5682 | }); |
5683 | } |
5684 | if (funit.mayModifyRoundingMode) { |
5685 | // F18 Clause 17.4p5: In a procedure [...], the processor shall not |
5686 | // change the rounding modes on entry, and on return shall ensure that |
5687 | // the rounding modes are the same as they were on entry. |
5688 | mlir::func::FuncOp getRounding = |
5689 | fir::factory::getLlvmGetRounding(*builder); |
5690 | mlir::func::FuncOp setRounding = |
5691 | fir::factory::getLlvmSetRounding(*builder); |
5692 | mlir::Value roundingMode = |
5693 | builder->create<fir::CallOp>(loc, getRounding).getResult(0); |
5694 | bridge.fctCtx().attachCleanup([=]() { |
5695 | builder->create<fir::CallOp>(endLoc, setRounding, roundingMode); |
5696 | }); |
5697 | } |
5698 | if ((funit.mayModifyUnderflowMode) && |
5699 | (bridge.getTargetCharacteristics().hasSubnormalFlushingControl( |
5700 | /*any=*/true))) { |
5701 | // F18 Clause 17.5p2: In a procedure [...], the processor shall not |
5702 | // change the underflow mode on entry, and on return shall ensure that |
5703 | // the underflow mode is the same as it was on entry. |
5704 | mlir::Value underflowMode = |
5705 | fir::runtime::genGetUnderflowMode(*builder, loc); |
5706 | bridge.fctCtx().attachCleanup([=]() { |
5707 | fir::runtime::genSetUnderflowMode(*builder, loc, {underflowMode}); |
5708 | }); |
5709 | } |
5710 | } |
5711 | |
5712 | /// Start translation of a function. |
5713 | void startNewFunction(Fortran::lower::pft::FunctionLikeUnit &funit) { |
5714 | assert(!builder && "expected nullptr"); |
5715 | bridge.fctCtx().pushScope(); |
5716 | bridge.openAccCtx().pushScope(); |
5717 | const Fortran::semantics::Scope &scope = funit.getScope(); |
5718 | LLVM_DEBUG(llvm::dbgs() << "\n[bridge - startNewFunction]"; |
5719 | if (auto *sym = scope.symbol()) llvm::dbgs() << " "<< *sym; |
5720 | llvm::dbgs() << "\n"); |
5721 | // Setting the builder is not necessary here, because callee |
5722 | // always looks up the FuncOp from the module. If there was a function that |
5723 | // was not declared yet, this call to callee will cause an assertion |
5724 | // failure. |
5725 | Fortran::lower::CalleeInterface callee(funit, *this); |
5726 | mlir::func::FuncOp func = callee.addEntryBlockAndMapArguments(); |
5727 | builder = |
5728 | new fir::FirOpBuilder(func, bridge.getKindMap(), &mlirSymbolTable); |
5729 | assert(builder && "FirOpBuilder did not instantiate"); |
5730 | builder->setFastMathFlags(bridge.getLoweringOptions().getMathOptions()); |
5731 | builder->setInsertionPointToStart(&func.front()); |
5732 | if (funit.parent.isA<Fortran::lower::pft::FunctionLikeUnit>()) { |
5733 | // Give internal linkage to internal functions. There are no name clash |
5734 | // risks, but giving global linkage to internal procedure will break the |
5735 | // static link register in shared libraries because of the system calls. |
5736 | // Also, it should be possible to eliminate the procedure code if all the |
5737 | // uses have been inlined. |
5738 | fir::factory::setInternalLinkage(func); |
5739 | } else { |
5740 | func.setVisibility(mlir::SymbolTable::Visibility::Public); |
5741 | } |
5742 | assert(blockId == 0 && "invalid blockId"); |
5743 | assert(activeConstructStack.empty() && "invalid construct stack state"); |
5744 | |
5745 | // Manage floating point exception, halting mode, and rounding mode |
5746 | // settings at function entry and exit. |
5747 | if (!funit.isMainProgram()) |
5748 | manageFPEnvironment(funit); |
5749 | |
5750 | mapDummiesAndResults(funit, callee); |
5751 | |
5752 | // Map host associated symbols from parent procedure if any. |
5753 | if (funit.parentHasHostAssoc()) |
5754 | funit.parentHostAssoc().internalProcedureBindings(*this, localSymbols); |
5755 | |
5756 | // Non-primary results of a function with multiple entry points. |
5757 | // These result values share storage with the primary result. |
5758 | llvm::SmallVector<Fortran::lower::pft::Variable> deferredFuncResultList; |
5759 | |
5760 | // Backup actual argument for entry character results with different |
5761 | // lengths. It needs to be added to the non-primary results symbol before |
5762 | // mapSymbolAttributes is called. |
5763 | Fortran::lower::SymbolBox resultArg; |
5764 | if (std::optional<Fortran::lower::CalleeInterface::PassedEntity> |
5765 | passedResult = callee.getPassedResult()) |
5766 | resultArg = lookupSymbol(passedResult->entity->get()); |
5767 | |
5768 | Fortran::lower::AggregateStoreMap storeMap; |
5769 | |
5770 | // Map all containing submodule and module equivalences and variables, in |
5771 | // case they are referenced. It might be better to limit this to variables |
5772 | // that are actually referenced, although that is more complicated when |
5773 | // there are equivalenced variables. |
5774 | auto &scopeVariableListMap = |
5775 | Fortran::lower::pft::getScopeVariableListMap(funit); |
5776 | for (auto *scp = &scope.parent(); !scp->IsGlobal(); scp = &scp->parent()) |
5777 | if (scp->kind() == Fortran::semantics::Scope::Kind::Module) |
5778 | for (const auto &var : Fortran::lower::pft::getScopeVariableList( |
5779 | *scp, scopeVariableListMap)) |
5780 | if (!var.isRuntimeTypeInfoData()) |
5781 | instantiateVar(var, storeMap); |
5782 | |
5783 | // Map function equivalences and variables. |
5784 | mlir::Value primaryFuncResultStorage; |
5785 | for (const Fortran::lower::pft::Variable &var : |
5786 | Fortran::lower::pft::getScopeVariableList(scope)) { |
5787 | // Always instantiate aggregate storage blocks. |
5788 | if (var.isAggregateStore()) { |
5789 | instantiateVar(var, storeMap); |
5790 | continue; |
5791 | } |
5792 | const Fortran::semantics::Symbol &sym = var.getSymbol(); |
5793 | if (funit.parentHasHostAssoc()) { |
5794 | // Never instantiate host associated variables, as they are already |
5795 | // instantiated from an argument tuple. Instead, just bind the symbol |
5796 | // to the host variable, which must be in the map. |
5797 | const Fortran::semantics::Symbol &ultimate = sym.GetUltimate(); |
5798 | if (funit.parentHostAssoc().isAssociated(ultimate)) { |
5799 | copySymbolBinding(ultimate, sym); |
5800 | continue; |
5801 | } |
5802 | } |
5803 | if (!sym.IsFuncResult() || !funit.primaryResult) { |
5804 | instantiateVar(var, storeMap); |
5805 | } else if (&sym == funit.primaryResult) { |
5806 | instantiateVar(var, storeMap); |
5807 | primaryFuncResultStorage = getSymbolAddress(sym); |
5808 | } else { |
5809 | deferredFuncResultList.push_back(var); |
5810 | } |
5811 | } |
5812 | |
5813 | // TODO: should use same mechanism as equivalence? |
5814 | // One blocking point is character entry returns that need special handling |
5815 | // since they are not locally allocated but come as argument. CHARACTER(*) |
5816 | // is not something that fits well with equivalence lowering. |
5817 | for (const Fortran::lower::pft::Variable &altResult : |
5818 | deferredFuncResultList) { |
5819 | Fortran::lower::StatementContext stmtCtx; |
5820 | if (std::optional<Fortran::lower::CalleeInterface::PassedEntity> |
5821 | passedResult = callee.getPassedResult()) { |
5822 | mapBlockArgToDummyOrResult(altResult.getSymbol(), resultArg.getAddr(), |
5823 | /*isResult=*/true); |
5824 | Fortran::lower::mapSymbolAttributes(*this, altResult, localSymbols, |
5825 | stmtCtx); |
5826 | } else { |
5827 | // catch cases where the allocation for the function result storage type |
5828 | // doesn't match the type of this symbol |
5829 | mlir::Value preAlloc = primaryFuncResultStorage; |
5830 | mlir::Type resTy = primaryFuncResultStorage.getType(); |
5831 | mlir::Type symTy = genType(altResult); |
5832 | mlir::Type wrappedSymTy = fir::ReferenceType::get(symTy); |
5833 | if (resTy != wrappedSymTy) { |
5834 | // check size of the pointed to type so we can't overflow by writing |
5835 | // double precision to a single precision allocation, etc |
5836 | LLVM_ATTRIBUTE_UNUSED auto getBitWidth = [this](mlir::Type ty) { |
5837 | // 15.6.2.6.3: differering result types should be integer, real, |
5838 | // complex or logical |
5839 | if (auto cmplx = mlir::dyn_cast_or_null<mlir::ComplexType>(ty)) |
5840 | return 2 * cmplx.getElementType().getIntOrFloatBitWidth(); |
5841 | if (auto logical = mlir::dyn_cast_or_null<fir::LogicalType>(ty)) { |
5842 | fir::KindTy kind = logical.getFKind(); |
5843 | return builder->getKindMap().getLogicalBitsize(kind); |
5844 | } |
5845 | return ty.getIntOrFloatBitWidth(); |
5846 | }; |
5847 | assert(getBitWidth(fir::unwrapRefType(resTy)) >= getBitWidth(symTy)); |
5848 | |
5849 | // convert the storage to the symbol type so that the hlfir.declare |
5850 | // gets the correct type for this symbol |
5851 | preAlloc = builder->create<fir::ConvertOp>(getCurrentLocation(), |
5852 | wrappedSymTy, preAlloc); |
5853 | } |
5854 | |
5855 | Fortran::lower::mapSymbolAttributes(*this, altResult, localSymbols, |
5856 | stmtCtx, preAlloc); |
5857 | } |
5858 | } |
5859 | |
5860 | // If this is a host procedure with host associations, then create the tuple |
5861 | // of pointers for passing to the internal procedures. |
5862 | if (!funit.getHostAssoc().empty()) |
5863 | funit.getHostAssoc().hostProcedureBindings(*this, localSymbols); |
5864 | |
5865 | // Unregister all dummy symbols, so that their cloning (e.g. for OpenMP |
5866 | // privatization) does not create the cloned hlfir.declare operations |
5867 | // with dummy_scope operands. |
5868 | resetRegisteredDummySymbols(); |
5869 | |
5870 | // Create most function blocks in advance. |
5871 | createEmptyBlocks(funit.evaluationList); |
5872 | |
5873 | // Reinstate entry block as the current insertion point. |
5874 | builder->setInsertionPointToEnd(&func.front()); |
5875 | |
5876 | if (callee.hasAlternateReturns()) { |
5877 | // Create a local temp to hold the alternate return index. |
5878 | // Give it an integer index type and the subroutine name (for dumps). |
5879 | // Attach it to the subroutine symbol in the localSymbols map. |
5880 | // Initialize it to zero, the "fallthrough" alternate return value. |
5881 | const Fortran::semantics::Symbol &symbol = funit.getSubprogramSymbol(); |
5882 | mlir::Location loc = toLocation(); |
5883 | mlir::Type idxTy = builder->getIndexType(); |
5884 | mlir::Value altResult = |
5885 | builder->createTemporary(loc, idxTy, toStringRef(symbol.name())); |
5886 | addSymbol(symbol, altResult); |
5887 | mlir::Value zero = builder->createIntegerConstant(loc, idxTy, 0); |
5888 | builder->create<fir::StoreOp>(loc, zero, altResult); |
5889 | } |
5890 | |
5891 | if (Fortran::lower::pft::Evaluation *alternateEntryEval = |
5892 | funit.getEntryEval()) |
5893 | genBranch(alternateEntryEval->lexicalSuccessor->block); |
5894 | } |
5895 | |
5896 | /// Create global blocks for the current function. This eliminates the |
5897 | /// distinction between forward and backward targets when generating |
5898 | /// branches. A block is "global" if it can be the target of a GOTO or |
5899 | /// other source code branch. A block that can only be targeted by a |
5900 | /// compiler generated branch is "local". For example, a DO loop preheader |
5901 | /// block containing loop initialization code is global. A loop header |
5902 | /// block, which is the target of the loop back edge, is local. Blocks |
5903 | /// belong to a region. Any block within a nested region must be replaced |
5904 | /// with a block belonging to that region. Branches may not cross region |
5905 | /// boundaries. |
5906 | void createEmptyBlocks( |
5907 | std::list<Fortran::lower::pft::Evaluation> &evaluationList) { |
5908 | mlir::Region *region = &builder->getRegion(); |
5909 | for (Fortran::lower::pft::Evaluation &eval : evaluationList) { |
5910 | if (eval.isNewBlock) |
5911 | eval.block = builder->createBlock(region); |
5912 | if (eval.isConstruct() || eval.isDirective()) { |
5913 | if (eval.lowerAsUnstructured()) { |
5914 | createEmptyBlocks(eval.getNestedEvaluations()); |
5915 | } else if (eval.hasNestedEvaluations()) { |
5916 | // A structured construct that is a target starts a new block. |
5917 | Fortran::lower::pft::Evaluation &constructStmt = |
5918 | eval.getFirstNestedEvaluation(); |
5919 | if (constructStmt.isNewBlock) |
5920 | constructStmt.block = builder->createBlock(region); |
5921 | } |
5922 | } |
5923 | } |
5924 | } |
5925 | |
5926 | /// Return the predicate: "current block does not have a terminator branch". |
5927 | bool blockIsUnterminated() { |
5928 | mlir::Block *currentBlock = builder->getBlock(); |
5929 | return currentBlock->empty() || |
5930 | !currentBlock->back().hasTrait<mlir::OpTrait::IsTerminator>(); |
5931 | } |
5932 | |
5933 | /// Unconditionally switch code insertion to a new block. |
5934 | void startBlock(mlir::Block *newBlock) { |
5935 | assert(newBlock && "missing block"); |
5936 | // Default termination for the current block is a fallthrough branch to |
5937 | // the new block. |
5938 | if (blockIsUnterminated()) |
5939 | genBranch(newBlock); |
5940 | // Some blocks may be re/started more than once, and might not be empty. |
5941 | // If the new block already has (only) a terminator, set the insertion |
5942 | // point to the start of the block. Otherwise set it to the end. |
5943 | builder->setInsertionPointToStart(newBlock); |
5944 | if (blockIsUnterminated()) |
5945 | builder->setInsertionPointToEnd(newBlock); |
5946 | } |
5947 | |
5948 | /// Conditionally switch code insertion to a new block. |
5949 | void maybeStartBlock(mlir::Block *newBlock) { |
5950 | if (newBlock) |
5951 | startBlock(newBlock); |
5952 | } |
5953 | |
5954 | void eraseDeadCodeAndBlocks(mlir::RewriterBase &rewriter, |
5955 | llvm::MutableArrayRef<mlir::Region> regions) { |
5956 | // WARNING: Do not add passes that can do folding or code motion here |
5957 | // because they might cross omp.target region boundaries, which can result |
5958 | // in incorrect code. Optimization passes like these must be added after |
5959 | // OMP early outlining has been done. |
5960 | (void)mlir::eraseUnreachableBlocks(rewriter, regions); |
5961 | (void)mlir::runRegionDCE(rewriter, regions); |
5962 | } |
5963 | |
5964 | /// Finish translation of a function. |
5965 | void endNewFunction(Fortran::lower::pft::FunctionLikeUnit &funit) { |
5966 | setCurrentPosition(Fortran::lower::pft::stmtSourceLoc(funit.endStmt)); |
5967 | if (funit.isMainProgram()) { |
5968 | genExitRoutine(false); |
5969 | } else { |
5970 | genFIRProcedureExit(funit, funit.getSubprogramSymbol()); |
5971 | } |
5972 | funit.finalBlock = nullptr; |
5973 | LLVM_DEBUG(llvm::dbgs() << "\n[bridge - endNewFunction"; |
5974 | if (auto *sym = funit.scope->symbol()) llvm::dbgs() |
5975 | << " "<< sym->name(); |
5976 | llvm::dbgs() << "] generated IR:\n\n" |
5977 | << *builder->getFunction() << '\n'); |
5978 | // Eliminate dead code as a prerequisite to calling other IR passes. |
5979 | // FIXME: This simplification should happen in a normal pass, not here. |
5980 | mlir::IRRewriter rewriter(*builder); |
5981 | (void)eraseDeadCodeAndBlocks(rewriter, {builder->getRegion()}); |
5982 | delete builder; |
5983 | builder = nullptr; |
5984 | hostAssocTuple = mlir::Value{}; |
5985 | localSymbols.clear(); |
5986 | blockId = 0; |
5987 | dummyArgsScope = mlir::Value{}; |
5988 | resetRegisteredDummySymbols(); |
5989 | } |
5990 | |
5991 | /// Helper to generate GlobalOps when the builder is not positioned in any |
5992 | /// region block. This is required because the FirOpBuilder assumes it is |
5993 | /// always positioned inside a region block when creating globals, the easiest |
5994 | /// way to comply is to create a dummy function and to throw it away |
5995 | /// afterwards. |
5996 | void createBuilderOutsideOfFuncOpAndDo( |
5997 | const std::function<void()> &createGlobals) { |
5998 | // FIXME: get rid of the bogus function context and instantiate the |
5999 | // globals directly into the module. |
6000 | mlir::MLIRContext *context = &getMLIRContext(); |
6001 | mlir::SymbolTable *symbolTable = getMLIRSymbolTable(); |
6002 | mlir::func::FuncOp func = fir::FirOpBuilder::createFunction( |
6003 | mlir::UnknownLoc::get(context), getModuleOp(), |
6004 | fir::NameUniquer::doGenerated("Sham"), |
6005 | mlir::FunctionType::get(context, std::nullopt, std::nullopt), |
6006 | symbolTable); |
6007 | func.addEntryBlock(); |
6008 | CHECK(!builder && "Expected builder to be uninitialized"); |
6009 | builder = new fir::FirOpBuilder(func, bridge.getKindMap(), symbolTable); |
6010 | assert(builder && "FirOpBuilder did not instantiate"); |
6011 | builder->setFastMathFlags(bridge.getLoweringOptions().getMathOptions()); |
6012 | createGlobals(); |
6013 | if (mlir::Region *region = func.getCallableRegion()) |
6014 | region->dropAllReferences(); |
6015 | func.erase(); |
6016 | delete builder; |
6017 | builder = nullptr; |
6018 | localSymbols.clear(); |
6019 | resetRegisteredDummySymbols(); |
6020 | } |
6021 | |
6022 | /// Instantiate the data from a BLOCK DATA unit. |
6023 | void lowerBlockData(Fortran::lower::pft::BlockDataUnit &bdunit) { |
6024 | createBuilderOutsideOfFuncOpAndDo(createGlobals: [&]() { |
6025 | Fortran::lower::AggregateStoreMap fakeMap; |
6026 | for (const auto &[_, sym] : bdunit.symTab) { |
6027 | if (sym->has<Fortran::semantics::ObjectEntityDetails>()) { |
6028 | Fortran::lower::pft::Variable var(*sym, true); |
6029 | instantiateVar(var, fakeMap); |
6030 | } |
6031 | } |
6032 | }); |
6033 | } |
6034 | |
6035 | /// Create fir::Global for all the common blocks that appear in the program. |
6036 | void |
6037 | lowerCommonBlocks(const Fortran::semantics::CommonBlockList &commonBlocks) { |
6038 | createBuilderOutsideOfFuncOpAndDo( |
6039 | createGlobals: [&]() { Fortran::lower::defineCommonBlocks(*this, commonBlocks); }); |
6040 | } |
6041 | |
6042 | /// Create intrinsic module array constant definitions. |
6043 | void createIntrinsicModuleDefinitions(Fortran::lower::pft::Program &pft) { |
6044 | // The intrinsic module scope, if present, is the first scope. |
6045 | const Fortran::semantics::Scope *intrinsicModuleScope = nullptr; |
6046 | for (Fortran::lower::pft::Program::Units &u : pft.getUnits()) { |
6047 | Fortran::common::visit( |
6048 | Fortran::common::visitors{ |
6049 | [&](Fortran::lower::pft::FunctionLikeUnit &f) { |
6050 | intrinsicModuleScope = &f.getScope().parent(); |
6051 | }, |
6052 | [&](Fortran::lower::pft::ModuleLikeUnit &m) { |
6053 | intrinsicModuleScope = &m.getScope().parent(); |
6054 | }, |
6055 | [&](Fortran::lower::pft::BlockDataUnit &b) {}, |
6056 | [&](Fortran::lower::pft::CompilerDirectiveUnit &d) {}, |
6057 | [&](Fortran::lower::pft::OpenACCDirectiveUnit &d) {}, |
6058 | }, |
6059 | u); |
6060 | if (intrinsicModuleScope) { |
6061 | while (!intrinsicModuleScope->IsGlobal()) |
6062 | intrinsicModuleScope = &intrinsicModuleScope->parent(); |
6063 | intrinsicModuleScope = &intrinsicModuleScope->children().front(); |
6064 | break; |
6065 | } |
6066 | } |
6067 | if (!intrinsicModuleScope || !intrinsicModuleScope->IsIntrinsicModules()) |
6068 | return; |
6069 | for (const auto &scope : intrinsicModuleScope->children()) { |
6070 | llvm::StringRef modName = toStringRef(scope.symbol()->name()); |
6071 | if (modName != "__fortran_ieee_exceptions") |
6072 | continue; |
6073 | for (auto &var : Fortran::lower::pft::getScopeVariableList(scope)) { |
6074 | const Fortran::semantics::Symbol &sym = var.getSymbol(); |
6075 | if (sym.test(Fortran::semantics::Symbol::Flag::CompilerCreated)) |
6076 | continue; |
6077 | const auto *object = |
6078 | sym.detailsIf<Fortran::semantics::ObjectEntityDetails>(); |
6079 | if (object && object->IsArray() && object->init()) |
6080 | Fortran::lower::createIntrinsicModuleGlobal(*this, var); |
6081 | } |
6082 | } |
6083 | } |
6084 | |
6085 | /// Lower a procedure (nest). |
6086 | void lowerFunc(Fortran::lower::pft::FunctionLikeUnit &funit) { |
6087 | setCurrentPosition(funit.getStartingSourceLoc()); |
6088 | setCurrentFunctionUnit(&funit); |
6089 | for (int entryIndex = 0, last = funit.entryPointList.size(); |
6090 | entryIndex < last; ++entryIndex) { |
6091 | funit.setActiveEntry(entryIndex); |
6092 | startNewFunction(funit); // the entry point for lowering this procedure |
6093 | for (Fortran::lower::pft::Evaluation &eval : funit.evaluationList) |
6094 | genFIR(eval); |
6095 | endNewFunction(funit); |
6096 | } |
6097 | funit.setActiveEntry(0); |
6098 | setCurrentFunctionUnit(nullptr); |
6099 | for (Fortran::lower::pft::ContainedUnit &unit : funit.containedUnitList) |
6100 | if (auto *f = std::get_if<Fortran::lower::pft::FunctionLikeUnit>(&unit)) |
6101 | lowerFunc(*f); // internal procedure |
6102 | } |
6103 | |
6104 | /// Lower module variable definitions to fir::globalOp and OpenMP/OpenACC |
6105 | /// declarative construct. |
6106 | void lowerModuleDeclScope(Fortran::lower::pft::ModuleLikeUnit &mod) { |
6107 | setCurrentPosition(mod.getStartingSourceLoc()); |
6108 | auto &scopeVariableListMap = |
6109 | Fortran::lower::pft::getScopeVariableListMap(mod); |
6110 | for (const auto &var : Fortran::lower::pft::getScopeVariableList( |
6111 | mod.getScope(), scopeVariableListMap)) { |
6112 | |
6113 | // Only define the variables owned by this module. |
6114 | const Fortran::semantics::Scope *owningScope = var.getOwningScope(); |
6115 | if (owningScope && mod.getScope() != *owningScope) |
6116 | continue; |
6117 | |
6118 | // Very special case: The value of numeric_storage_size depends on |
6119 | // compilation options and therefore its value is not yet known when |
6120 | // building the builtins runtime. Instead, the parameter is folding a |
6121 | // __numeric_storage_size() expression which is loaded into the user |
6122 | // program. For the iso_fortran_env object file, omit the symbol as it |
6123 | // is never used. |
6124 | if (var.hasSymbol()) { |
6125 | const Fortran::semantics::Symbol &sym = var.getSymbol(); |
6126 | const Fortran::semantics::Scope &owner = sym.owner(); |
6127 | if (sym.name() == "numeric_storage_size"&& owner.IsModule() && |
6128 | DEREF(owner.symbol()).name() == "iso_fortran_env") |
6129 | continue; |
6130 | } |
6131 | |
6132 | Fortran::lower::defineModuleVariable(*this, var); |
6133 | } |
6134 | for (auto &eval : mod.evaluationList) |
6135 | genFIR(eval); |
6136 | } |
6137 | |
6138 | /// Lower functions contained in a module. |
6139 | void lowerMod(Fortran::lower::pft::ModuleLikeUnit &mod) { |
6140 | for (Fortran::lower::pft::ContainedUnit &unit : mod.containedUnitList) |
6141 | if (auto *f = std::get_if<Fortran::lower::pft::FunctionLikeUnit>(&unit)) |
6142 | lowerFunc(*f); |
6143 | } |
6144 | |
6145 | void setCurrentPosition(const Fortran::parser::CharBlock &position) { |
6146 | if (position != Fortran::parser::CharBlock{}) |
6147 | currentPosition = position; |
6148 | } |
6149 | |
6150 | /// Set current position at the location of \p parseTreeNode. Note that the |
6151 | /// position is updated automatically when visiting statements, but not when |
6152 | /// entering higher level nodes like constructs or procedures. This helper is |
6153 | /// intended to cover the latter cases. |
6154 | template <typename A> |
6155 | void setCurrentPositionAt(const A &parseTreeNode) { |
6156 | setCurrentPosition(Fortran::parser::FindSourceLocation(parseTreeNode)); |
6157 | } |
6158 | |
6159 | //===--------------------------------------------------------------------===// |
6160 | // Utility methods |
6161 | //===--------------------------------------------------------------------===// |
6162 | |
6163 | /// Convert a parser CharBlock to a Location |
6164 | mlir::Location toLocation(const Fortran::parser::CharBlock &cb) { |
6165 | return genLocation(cb); |
6166 | } |
6167 | |
6168 | mlir::Location toLocation() { return toLocation(currentPosition); } |
6169 | void setCurrentEval(Fortran::lower::pft::Evaluation &eval) { |
6170 | evalPtr = &eval; |
6171 | } |
6172 | Fortran::lower::pft::Evaluation &getEval() { |
6173 | assert(evalPtr); |
6174 | return *evalPtr; |
6175 | } |
6176 | |
6177 | std::optional<Fortran::evaluate::Shape> |
6178 | getShape(const Fortran::lower::SomeExpr &expr) { |
6179 | return Fortran::evaluate::GetShape(foldingContext, expr); |
6180 | } |
6181 | |
6182 | //===--------------------------------------------------------------------===// |
6183 | // Analysis on a nested explicit iteration space. |
6184 | //===--------------------------------------------------------------------===// |
6185 | |
6186 | void analyzeExplicitSpace(const Fortran::parser::ConcurrentHeader &header) { |
6187 | explicitIterSpace.pushLevel(); |
6188 | for (const Fortran::parser::ConcurrentControl &ctrl : |
6189 | std::get<std::list<Fortran::parser::ConcurrentControl>>(header.t)) { |
6190 | const Fortran::semantics::Symbol *ctrlVar = |
6191 | std::get<Fortran::parser::Name>(ctrl.t).symbol; |
6192 | explicitIterSpace.addSymbol(ctrlVar); |
6193 | } |
6194 | if (const auto &mask = |
6195 | std::get<std::optional<Fortran::parser::ScalarLogicalExpr>>( |
6196 | header.t); |
6197 | mask.has_value()) |
6198 | analyzeExplicitSpace(*Fortran::semantics::GetExpr(*mask)); |
6199 | } |
6200 | template <bool LHS = false, typename A> |
6201 | void analyzeExplicitSpace(const Fortran::evaluate::Expr<A> &e) { |
6202 | explicitIterSpace.exprBase(&e, LHS); |
6203 | } |
6204 | void analyzeExplicitSpace(const Fortran::evaluate::Assignment *assign) { |
6205 | auto analyzeAssign = [&](const Fortran::lower::SomeExpr &lhs, |
6206 | const Fortran::lower::SomeExpr &rhs) { |
6207 | analyzeExplicitSpace</*LHS=*/true>(lhs); |
6208 | analyzeExplicitSpace(rhs); |
6209 | }; |
6210 | Fortran::common::visit( |
6211 | Fortran::common::visitors{ |
6212 | [&](const Fortran::evaluate::ProcedureRef &procRef) { |
6213 | // Ensure the procRef expressions are the one being visited. |
6214 | assert(procRef.arguments().size() == 2); |
6215 | const Fortran::lower::SomeExpr *lhs = |
6216 | procRef.arguments()[0].value().UnwrapExpr(); |
6217 | const Fortran::lower::SomeExpr *rhs = |
6218 | procRef.arguments()[1].value().UnwrapExpr(); |
6219 | assert(lhs && rhs && |
6220 | "user defined assignment arguments must be expressions"); |
6221 | analyzeAssign(*lhs, *rhs); |
6222 | }, |
6223 | [&](const auto &) { analyzeAssign(assign->lhs, assign->rhs); }}, |
6224 | assign->u); |
6225 | explicitIterSpace.endAssign(); |
6226 | } |
6227 | void analyzeExplicitSpace(const Fortran::parser::ForallAssignmentStmt &stmt) { |
6228 | Fortran::common::visit([&](const auto &s) { analyzeExplicitSpace(s); }, |
6229 | stmt.u); |
6230 | } |
6231 | void analyzeExplicitSpace(const Fortran::parser::AssignmentStmt &s) { |
6232 | analyzeExplicitSpace(s.typedAssignment->v.operator->()); |
6233 | } |
6234 | void analyzeExplicitSpace(const Fortran::parser::PointerAssignmentStmt &s) { |
6235 | analyzeExplicitSpace(s.typedAssignment->v.operator->()); |
6236 | } |
6237 | void analyzeExplicitSpace(const Fortran::parser::WhereConstruct &c) { |
6238 | analyzeExplicitSpace( |
6239 | std::get< |
6240 | Fortran::parser::Statement<Fortran::parser::WhereConstructStmt>>( |
6241 | c.t) |
6242 | .statement); |
6243 | for (const Fortran::parser::WhereBodyConstruct &body : |
6244 | std::get<std::list<Fortran::parser::WhereBodyConstruct>>(c.t)) |
6245 | analyzeExplicitSpace(body); |
6246 | for (const Fortran::parser::WhereConstruct::MaskedElsewhere &e : |
6247 | std::get<std::list<Fortran::parser::WhereConstruct::MaskedElsewhere>>( |
6248 | c.t)) |
6249 | analyzeExplicitSpace(e); |
6250 | if (const auto &e = |
6251 | std::get<std::optional<Fortran::parser::WhereConstruct::Elsewhere>>( |
6252 | c.t); |
6253 | e.has_value()) |
6254 | analyzeExplicitSpace(e.operator->()); |
6255 | } |
6256 | void analyzeExplicitSpace(const Fortran::parser::WhereConstructStmt &ws) { |
6257 | const Fortran::lower::SomeExpr *exp = Fortran::semantics::GetExpr( |
6258 | std::get<Fortran::parser::LogicalExpr>(ws.t)); |
6259 | addMaskVariable(exp); |
6260 | analyzeExplicitSpace(*exp); |
6261 | } |
6262 | void analyzeExplicitSpace( |
6263 | const Fortran::parser::WhereConstruct::MaskedElsewhere &ew) { |
6264 | analyzeExplicitSpace( |
6265 | std::get< |
6266 | Fortran::parser::Statement<Fortran::parser::MaskedElsewhereStmt>>( |
6267 | ew.t) |
6268 | .statement); |
6269 | for (const Fortran::parser::WhereBodyConstruct &e : |
6270 | std::get<std::list<Fortran::parser::WhereBodyConstruct>>(ew.t)) |
6271 | analyzeExplicitSpace(e); |
6272 | } |
6273 | void analyzeExplicitSpace(const Fortran::parser::WhereBodyConstruct &body) { |
6274 | Fortran::common::visit( |
6275 | Fortran::common::visitors{ |
6276 | [&](const Fortran::common::Indirection< |
6277 | Fortran::parser::WhereConstruct> &wc) { |
6278 | analyzeExplicitSpace(wc.value()); |
6279 | }, |
6280 | [&](const auto &s) { analyzeExplicitSpace(s.statement); }}, |
6281 | body.u); |
6282 | } |
6283 | void analyzeExplicitSpace(const Fortran::parser::MaskedElsewhereStmt &stmt) { |
6284 | const Fortran::lower::SomeExpr *exp = Fortran::semantics::GetExpr( |
6285 | std::get<Fortran::parser::LogicalExpr>(stmt.t)); |
6286 | addMaskVariable(exp); |
6287 | analyzeExplicitSpace(*exp); |
6288 | } |
6289 | void |
6290 | analyzeExplicitSpace(const Fortran::parser::WhereConstruct::Elsewhere *ew) { |
6291 | for (const Fortran::parser::WhereBodyConstruct &e : |
6292 | std::get<std::list<Fortran::parser::WhereBodyConstruct>>(ew->t)) |
6293 | analyzeExplicitSpace(e); |
6294 | } |
6295 | void analyzeExplicitSpace(const Fortran::parser::WhereStmt &stmt) { |
6296 | const Fortran::lower::SomeExpr *exp = Fortran::semantics::GetExpr( |
6297 | std::get<Fortran::parser::LogicalExpr>(stmt.t)); |
6298 | addMaskVariable(exp); |
6299 | analyzeExplicitSpace(*exp); |
6300 | const std::optional<Fortran::evaluate::Assignment> &assign = |
6301 | std::get<Fortran::parser::AssignmentStmt>(stmt.t).typedAssignment->v; |
6302 | assert(assign.has_value() && "WHERE has no statement"); |
6303 | analyzeExplicitSpace(assign.operator->()); |
6304 | } |
6305 | void analyzeExplicitSpace(const Fortran::parser::ForallStmt &forall) { |
6306 | analyzeExplicitSpace( |
6307 | std::get< |
6308 | Fortran::common::Indirection<Fortran::parser::ConcurrentHeader>>( |
6309 | forall.t) |
6310 | .value()); |
6311 | analyzeExplicitSpace(std::get<Fortran::parser::UnlabeledStatement< |
6312 | Fortran::parser::ForallAssignmentStmt>>(forall.t) |
6313 | .statement); |
6314 | analyzeExplicitSpacePop(); |
6315 | } |
6316 | void |
6317 | analyzeExplicitSpace(const Fortran::parser::ForallConstructStmt &forall) { |
6318 | analyzeExplicitSpace( |
6319 | std::get< |
6320 | Fortran::common::Indirection<Fortran::parser::ConcurrentHeader>>( |
6321 | forall.t) |
6322 | .value()); |
6323 | } |
6324 | void analyzeExplicitSpace(const Fortran::parser::ForallConstruct &forall) { |
6325 | analyzeExplicitSpace( |
6326 | std::get< |
6327 | Fortran::parser::Statement<Fortran::parser::ForallConstructStmt>>( |
6328 | forall.t) |
6329 | .statement); |
6330 | for (const Fortran::parser::ForallBodyConstruct &s : |
6331 | std::get<std::list<Fortran::parser::ForallBodyConstruct>>(forall.t)) { |
6332 | Fortran::common::visit( |
6333 | Fortran::common::visitors{ |
6334 | [&](const Fortran::common::Indirection< |
6335 | Fortran::parser::ForallConstruct> &b) { |
6336 | analyzeExplicitSpace(b.value()); |
6337 | }, |
6338 | [&](const Fortran::parser::WhereConstruct &w) { |
6339 | analyzeExplicitSpace(w); |
6340 | }, |
6341 | [&](const auto &b) { analyzeExplicitSpace(b.statement); }}, |
6342 | s.u); |
6343 | } |
6344 | analyzeExplicitSpacePop(); |
6345 | } |
6346 | |
6347 | void analyzeExplicitSpacePop() { explicitIterSpace.popLevel(); } |
6348 | |
6349 | void addMaskVariable(Fortran::lower::FrontEndExpr exp) { |
6350 | // Note: use i8 to store bool values. This avoids round-down behavior found |
6351 | // with sequences of i1. That is, an array of i1 will be truncated in size |
6352 | // and be too small. For example, a buffer of type fir.array<7xi1> will have |
6353 | // 0 size. |
6354 | mlir::Type i64Ty = builder->getIntegerType(64); |
6355 | mlir::TupleType ty = fir::factory::getRaggedArrayHeaderType(*builder); |
6356 | mlir::Type buffTy = ty.getType(1); |
6357 | mlir::Type shTy = ty.getType(2); |
6358 | mlir::Location loc = toLocation(); |
6359 | mlir::Value hdr = builder->createTemporary(loc, ty); |
6360 | // FIXME: Is there a way to create a `zeroinitializer` in LLVM-IR dialect? |
6361 | // For now, explicitly set lazy ragged header to all zeros. |
6362 | // auto nilTup = builder->createNullConstant(loc, ty); |
6363 | // builder->create<fir::StoreOp>(loc, nilTup, hdr); |
6364 | mlir::Type i32Ty = builder->getIntegerType(32); |
6365 | mlir::Value zero = builder->createIntegerConstant(loc, i32Ty, 0); |
6366 | mlir::Value zero64 = builder->createIntegerConstant(loc, i64Ty, 0); |
6367 | mlir::Value flags = builder->create<fir::CoordinateOp>( |
6368 | loc, builder->getRefType(i64Ty), hdr, zero); |
6369 | builder->create<fir::StoreOp>(loc, zero64, flags); |
6370 | mlir::Value one = builder->createIntegerConstant(loc, i32Ty, 1); |
6371 | mlir::Value nullPtr1 = builder->createNullConstant(loc, buffTy); |
6372 | mlir::Value var = builder->create<fir::CoordinateOp>( |
6373 | loc, builder->getRefType(buffTy), hdr, one); |
6374 | builder->create<fir::StoreOp>(loc, nullPtr1, var); |
6375 | mlir::Value two = builder->createIntegerConstant(loc, i32Ty, 2); |
6376 | mlir::Value nullPtr2 = builder->createNullConstant(loc, shTy); |
6377 | mlir::Value shape = builder->create<fir::CoordinateOp>( |
6378 | loc, builder->getRefType(shTy), hdr, two); |
6379 | builder->create<fir::StoreOp>(loc, nullPtr2, shape); |
6380 | implicitIterSpace.addMaskVariable(exp, var, shape, hdr); |
6381 | explicitIterSpace.outermostContext().attachCleanup( |
6382 | [builder = this->builder, hdr, loc]() { |
6383 | fir::runtime::genRaggedArrayDeallocate(loc, *builder, hdr); |
6384 | }); |
6385 | } |
6386 | |
6387 | void createRuntimeTypeInfoGlobals() {} |
6388 | |
6389 | bool lowerToHighLevelFIR() const { |
6390 | return bridge.getLoweringOptions().getLowerToHighLevelFIR(); |
6391 | } |
6392 | |
6393 | // Returns the mangling prefix for the given constant expression. |
6394 | std::string getConstantExprManglePrefix(mlir::Location loc, |
6395 | const Fortran::lower::SomeExpr &expr, |
6396 | mlir::Type eleTy) { |
6397 | return Fortran::common::visit( |
6398 | [&](const auto &x) -> std::string { |
6399 | using T = std::decay_t<decltype(x)>; |
6400 | if constexpr (Fortran::common::HasMember< |
6401 | T, Fortran::lower::CategoryExpression>) { |
6402 | if constexpr (T::Result::category == |
6403 | Fortran::common::TypeCategory::Derived) { |
6404 | if (const auto *constant = |
6405 | std::get_if<Fortran::evaluate::Constant< |
6406 | Fortran::evaluate::SomeDerived>>(&x.u)) |
6407 | return Fortran::lower::mangle::mangleArrayLiteral(eleTy, |
6408 | *constant); |
6409 | fir::emitFatalError(loc, |
6410 | "non a constant derived type expression"); |
6411 | } else { |
6412 | return Fortran::common::visit( |
6413 | [&](const auto &someKind) -> std::string { |
6414 | using T = std::decay_t<decltype(someKind)>; |
6415 | using TK = Fortran::evaluate::Type<T::Result::category, |
6416 | T::Result::kind>; |
6417 | if (const auto *constant = |
6418 | std::get_if<Fortran::evaluate::Constant<TK>>( |
6419 | &someKind.u)) { |
6420 | return Fortran::lower::mangle::mangleArrayLiteral( |
6421 | nullptr, *constant); |
6422 | } |
6423 | fir::emitFatalError( |
6424 | loc, "not a Fortran::evaluate::Constant<T> expression"); |
6425 | return {}; |
6426 | }, |
6427 | x.u); |
6428 | } |
6429 | } else { |
6430 | fir::emitFatalError(loc, "unexpected expression"); |
6431 | } |
6432 | }, |
6433 | expr.u); |
6434 | } |
6435 | |
6436 | /// Performing OpenMP lowering actions that were deferred to the end of |
6437 | /// lowering. |
6438 | void finalizeOpenMPLowering( |
6439 | const Fortran::semantics::Symbol *globalOmpRequiresSymbol) { |
6440 | if (!ompDeferredDeclareTarget.empty()) { |
6441 | bool deferredDeviceFuncFound = |
6442 | Fortran::lower::markOpenMPDeferredDeclareTargetFunctions( |
6443 | getModuleOp().getOperation(), ompDeferredDeclareTarget, *this); |
6444 | ompDeviceCodeFound = ompDeviceCodeFound || deferredDeviceFuncFound; |
6445 | } |
6446 | |
6447 | // Set the module attribute related to OpenMP requires directives |
6448 | if (ompDeviceCodeFound) |
6449 | Fortran::lower::genOpenMPRequires(getModuleOp().getOperation(), |
6450 | globalOmpRequiresSymbol); |
6451 | } |
6452 | |
6453 | /// Record fir.dummy_scope operation for this function. |
6454 | /// It will be used to set dummy_scope operand of the hlfir.declare |
6455 | /// operations. |
6456 | void setDummyArgsScope(mlir::Value val) { |
6457 | assert(!dummyArgsScope && val); |
6458 | dummyArgsScope = val; |
6459 | } |
6460 | |
6461 | /// Record the given symbol as a dummy argument of this function. |
6462 | void registerDummySymbol(Fortran::semantics::SymbolRef symRef) { |
6463 | auto *sym = &*symRef; |
6464 | registeredDummySymbols.insert(sym); |
6465 | } |
6466 | |
6467 | /// Reset all registered dummy symbols. |
6468 | void resetRegisteredDummySymbols() { registeredDummySymbols.clear(); } |
6469 | |
6470 | void setCurrentFunctionUnit(Fortran::lower::pft::FunctionLikeUnit *unit) { |
6471 | currentFunctionUnit = unit; |
6472 | } |
6473 | |
6474 | //===--------------------------------------------------------------------===// |
6475 | |
6476 | Fortran::lower::LoweringBridge &bridge; |
6477 | Fortran::evaluate::FoldingContext foldingContext; |
6478 | fir::FirOpBuilder *builder = nullptr; |
6479 | Fortran::lower::pft::Evaluation *evalPtr = nullptr; |
6480 | Fortran::lower::pft::FunctionLikeUnit *currentFunctionUnit = nullptr; |
6481 | Fortran::lower::SymMap localSymbols; |
6482 | Fortran::parser::CharBlock currentPosition; |
6483 | TypeInfoConverter typeInfoConverter; |
6484 | |
6485 | // Stack to manage object deallocation and finalization at construct exits. |
6486 | llvm::SmallVector<ConstructContext> activeConstructStack; |
6487 | |
6488 | /// BLOCK name mangling component map |
6489 | int blockId = 0; |
6490 | Fortran::lower::mangle::ScopeBlockIdMap scopeBlockIdMap; |
6491 | |
6492 | /// FORALL statement/construct context |
6493 | Fortran::lower::ExplicitIterSpace explicitIterSpace; |
6494 | |
6495 | /// WHERE statement/construct mask expression stack |
6496 | Fortran::lower::ImplicitIterSpace implicitIterSpace; |
6497 | |
6498 | /// Tuple of host associated variables |
6499 | mlir::Value hostAssocTuple; |
6500 | |
6501 | /// Value of fir.dummy_scope operation for this function. |
6502 | mlir::Value dummyArgsScope; |
6503 | |
6504 | /// A set of dummy argument symbols for this function. |
6505 | /// The set is only preserved during the instatiation |
6506 | /// of variables for this function. |
6507 | llvm::SmallPtrSet<const Fortran::semantics::Symbol *, 16> |
6508 | registeredDummySymbols; |
6509 | |
6510 | /// A map of unique names for constant expressions. |
6511 | /// The names are used for representing the constant expressions |
6512 | /// with global constant initialized objects. |
6513 | /// The names are usually prefixed by a mangling string based |
6514 | /// on the element type of the constant expression, but the element |
6515 | /// type is not used as a key into the map (so the assumption is that |
6516 | /// the equivalent constant expressions are prefixed using the same |
6517 | /// element type). |
6518 | llvm::DenseMap<const Fortran::lower::SomeExpr *, std::string> literalNamesMap; |
6519 | |
6520 | /// Storage for Constant expressions used as keys for literalNamesMap. |
6521 | llvm::SmallVector<std::unique_ptr<Fortran::lower::SomeExpr>> |
6522 | literalExprsStorage; |
6523 | |
6524 | /// A counter for uniquing names in `literalNamesMap`. |
6525 | std::uint64_t uniqueLitId = 0; |
6526 | |
6527 | /// Whether an OpenMP target region or declare target function/subroutine |
6528 | /// intended for device offloading has been detected |
6529 | bool ompDeviceCodeFound = false; |
6530 | |
6531 | /// Keeps track of symbols defined as declare target that could not be |
6532 | /// processed at the time of lowering the declare target construct, such |
6533 | /// as certain cases where interfaces are declared but not defined within |
6534 | /// a module. |
6535 | llvm::SmallVector<Fortran::lower::OMPDeferredDeclareTargetInfo> |
6536 | ompDeferredDeclareTarget; |
6537 | |
6538 | const Fortran::lower::ExprToValueMap *exprValueOverrides{nullptr}; |
6539 | |
6540 | /// Stack of derived type under construction to avoid infinite loops when |
6541 | /// dealing with recursive derived types. This is held in the bridge because |
6542 | /// the state needs to be maintained between data and function type lowering |
6543 | /// utilities to deal with procedure pointer components whose arguments have |
6544 | /// the type of the containing derived type. |
6545 | Fortran::lower::TypeConstructionStack typeConstructionStack; |
6546 | /// MLIR symbol table of the fir.global/func.func operations. Note that it is |
6547 | /// not guaranteed to contain all operations of the ModuleOp with Symbol |
6548 | /// attribute since mlirSymbolTable must pro-actively be maintained when |
6549 | /// new Symbol operations are created. |
6550 | mlir::SymbolTable mlirSymbolTable; |
6551 | }; |
6552 | |
6553 | } // namespace |
6554 | |
6555 | Fortran::evaluate::FoldingContext |
6556 | Fortran::lower::LoweringBridge::createFoldingContext() { |
6557 | return {getDefaultKinds(), getIntrinsicTable(), getTargetCharacteristics(), |
6558 | getLanguageFeatures(), tempNames}; |
6559 | } |
6560 | |
6561 | void Fortran::lower::LoweringBridge::lower( |
6562 | const Fortran::parser::Program &prg, |
6563 | const Fortran::semantics::SemanticsContext &semanticsContext) { |
6564 | std::unique_ptr<Fortran::lower::pft::Program> pft = |
6565 | Fortran::lower::createPFT(prg, semanticsContext); |
6566 | if (dumpBeforeFir) |
6567 | Fortran::lower::dumpPFT(llvm::errs(), *pft); |
6568 | FirConverter converter{*this}; |
6569 | converter.run(*pft); |
6570 | } |
6571 | |
6572 | void Fortran::lower::LoweringBridge::parseSourceFile(llvm::SourceMgr &srcMgr) { |
6573 | module = mlir::parseSourceFile<mlir::ModuleOp>(srcMgr, &context); |
6574 | } |
6575 | |
6576 | Fortran::lower::LoweringBridge::LoweringBridge( |
6577 | mlir::MLIRContext &context, |
6578 | Fortran::semantics::SemanticsContext &semanticsContext, |
6579 | const Fortran::common::IntrinsicTypeDefaultKinds &defaultKinds, |
6580 | const Fortran::evaluate::IntrinsicProcTable &intrinsics, |
6581 | const Fortran::evaluate::TargetCharacteristics &targetCharacteristics, |
6582 | const Fortran::parser::AllCookedSources &cooked, llvm::StringRef triple, |
6583 | fir::KindMapping &kindMap, |
6584 | const Fortran::lower::LoweringOptions &loweringOptions, |
6585 | const std::vector<Fortran::lower::EnvironmentDefault> &envDefaults, |
6586 | const Fortran::common::LanguageFeatureControl &languageFeatures, |
6587 | const llvm::TargetMachine &targetMachine, |
6588 | const Fortran::frontend::TargetOptions &targetOpts, |
6589 | const Fortran::frontend::CodeGenOptions &cgOpts) |
6590 | : semanticsContext{semanticsContext}, defaultKinds{defaultKinds}, |
6591 | intrinsics{intrinsics}, targetCharacteristics{targetCharacteristics}, |
6592 | cooked{&cooked}, context{context}, kindMap{kindMap}, |
6593 | loweringOptions{loweringOptions}, envDefaults{envDefaults}, |
6594 | languageFeatures{languageFeatures} { |
6595 | // Register the diagnostic handler. |
6596 | context.getDiagEngine().registerHandler([](mlir::Diagnostic &diag) { |
6597 | llvm::raw_ostream &os = llvm::errs(); |
6598 | switch (diag.getSeverity()) { |
6599 | case mlir::DiagnosticSeverity::Error: |
6600 | os << "error: "; |
6601 | break; |
6602 | case mlir::DiagnosticSeverity::Remark: |
6603 | os << "info: "; |
6604 | break; |
6605 | case mlir::DiagnosticSeverity::Warning: |
6606 | os << "warning: "; |
6607 | break; |
6608 | default: |
6609 | break; |
6610 | } |
6611 | if (!mlir::isa<mlir::UnknownLoc>(diag.getLocation())) |
6612 | os << diag.getLocation() << ": "; |
6613 | os << diag << '\n'; |
6614 | os.flush(); |
6615 | return mlir::success(); |
6616 | }); |
6617 | |
6618 | auto getPathLocation = [&semanticsContext, &context]() -> mlir::Location { |
6619 | std::optional<std::string> path; |
6620 | const auto &allSources{semanticsContext.allCookedSources().allSources()}; |
6621 | if (auto initial{allSources.GetFirstFileProvenance()}; |
6622 | initial && !initial->empty()) { |
6623 | if (const auto *sourceFile{allSources.GetSourceFile(initial->start())}) { |
6624 | path = sourceFile->path(); |
6625 | } |
6626 | } |
6627 | |
6628 | if (path.has_value()) { |
6629 | llvm::SmallString<256> curPath(*path); |
6630 | llvm::sys::fs::make_absolute(curPath); |
6631 | llvm::sys::path::remove_dots(curPath); |
6632 | return mlir::FileLineColLoc::get(&context, curPath.str(), /*line=*/0, |
6633 | /*col=*/0); |
6634 | } else { |
6635 | return mlir::UnknownLoc::get(&context); |
6636 | } |
6637 | }; |
6638 | |
6639 | // Create the module and attach the attributes. |
6640 | module = mlir::OwningOpRef<mlir::ModuleOp>( |
6641 | mlir::ModuleOp::create(getPathLocation())); |
6642 | assert(*module && "module was not created"); |
6643 | fir::setTargetTriple(*module, triple); |
6644 | fir::setKindMapping(*module, kindMap); |
6645 | fir::setTargetCPU(*module, targetMachine.getTargetCPU()); |
6646 | fir::setTuneCPU(*module, targetOpts.cpuToTuneFor); |
6647 | fir::setTargetFeatures(*module, targetMachine.getTargetFeatureString()); |
6648 | fir::support::setMLIRDataLayout(*module, targetMachine.createDataLayout()); |
6649 | fir::setIdent(*module, Fortran::common::getFlangFullVersion()); |
6650 | if (cgOpts.RecordCommandLine) |
6651 | fir::setCommandline(*module, *cgOpts.RecordCommandLine); |
6652 | } |
6653 | |
6654 | void Fortran::lower::genCleanUpInRegionIfAny( |
6655 | mlir::Location loc, fir::FirOpBuilder &builder, mlir::Region ®ion, |
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(®ion); |
6662 | else |
6663 | builder.setInsertionPointToEnd(®ion.front()); |
6664 | context.finalizeAndPop(); |
6665 | hlfir::YieldOp::ensureTerminator(region, builder, loc); |
6666 | builder.restoreInsertionPoint(insertPt); |
6667 | } |
6668 |
Definitions
- dumpBeforeFir
- forceLoopToExecuteOnce
- IncrementLoopInfo
- IncrementLoopInfo
- IncrementLoopInfo
- operator=
- isStructured
- getLoopVariableType
- hasLocalitySpecs
- ConstructContext
- ConstructContext
- gatherComponentNonDefaultLowerBounds
- gatherComponentInit
- TypeInfoConverter
- TypeInfo
- registerTypeInfo
- createTypeInfo
- createTypeInfoOpAndGlobal
- createTypeInfoOp
- FirConverter
- FirConverter
- ~FirConverter
- run
- declareFunction
- getSymbolHostScope
- collectHostAssociatedVariables
- getSymbolAddress
- symBoxToExtendedValue
- getSymbolExtendedValue
- impliedDoBinding
- copySymbolBinding
- bindIfNewSymbol
- bindSymbol
- overrideExprValues
- getExprOverrides
- lookupLabelSet
- lookupLabel
- genExprAddr
- genExprValue
- genExprBox
- getFoldingContext
- genType
- genType
- genType
- genType
- genType
- genType
- getTypeConstructionStack
- isPresentShallowLookup
- createHostAssociateVarClone
- createHostAssociateVarCloneDealloc
- copyVar
- copyHostAssociateVar
- genEval
- collectSymbolSet
- getCurrentLocation
- genUnknownLocation
- genLocation
- genLocation
- getCurrentScope
- getFirOpBuilder
- getModuleOp
- getMLIRContext
- mangleName
- mangleName
- mangleName
- mangleName
- getRecordTypeFieldName
- getKindMap
- getFctCtx
- hostAssocTupleValue
- bindHostAssocTuple
- dummyArgsScopeValue
- isRegisteredDummySymbol
- getCurrentFunctionUnit
- registerTypeInfo
- getUniqueLitName
- shallowLookupSymbol
- FirConverter
- FirConverter
- operator=
- createFIRExpr
- lookupSymbol
- lookupOneLevelUpSymbol
- getMLIRSymbolTable
- addSymbol
- copyVar
- copyVarHLFIR
- copyVarHLFIR
- copyVarFIR
- mapBlockArgToDummyOrResult
- genLoopVariableAddress
- isNumericScalarCategory
- isLogicalCategory
- isCharacterCategory
- isDerivedCategory
- insertBlock
- evalOfLabel
- genBranch
- genConditionalBranch
- genConditionalBranch
- genConditionalBranch
- genConditionalBranch
- getActiveAncestor
- hasExitCode
- genConstructExitBranch
- collectFinalEvaluations
- genMultiwayBranch
- pushActiveConstruct
- popActiveConstruct
- genExitRoutine
- genReturnSymbol
- getAltReturnResult
- genFIRProcedureExit
- genIfCondition
- getFunc
- genFIR
- genFIR
- genFIR
- genFIR
- getReduceOperationEnum
- getConcurrentControl
- handleLocalitySpecs
- genFIR
- genControlValue
- genLoopUnrollAttr
- genLoopUnrollAndJamAttr
- addLoopAnnotationAttr
- genFIRIncrementLoopBegin
- genFIRIncrementLoopEnd
- genFIR
- genCaseOrRankConstruct
- genFIR
- genNestedStatement
- forceControlVariableBinding
- genFIR
- genFIR
- genFIR
- prepareExplicitSpace
- cleanupExplicitSpace
- genFIR
- genFIR
- genFIR
- genForallNest
- attachDirectiveToLoop
- genFIR
- genFIR
- genFIR
- genFIR
- genFIR
- genFIR
- genFIR
- genFIR
- genAssociateSelector
- genFIR
- genFIR
- genFIR
- genFIR
- genFIR
- genFIR
- genFIR
- genFIR
- genFIR
- genFIR
- getAssociatingEntitySymbol
- genFIR
- genFIR
- genFIR
- genFIR
- genFIR
- genFIR
- genFIR
- genFIR
- genFIR
- genFIR
- genFIR
- genFIR
- genFIR
- genIoConditionBranches
- genFIR
- genFIR
- genFIR
- genFIR
- genFIR
- genFIR
- genFIR
- genFIR
- genInitializerExprValue
- implicitIterationSpace
- explicitIterationSpace
- genArrayAssignment
- isFuncResultDesignator
- genExprMutableBox
- createLboundArray
- genPointerAssignment
- genForallPointerAssignment
- lowerToIndexValue
- genForallPointerAssignmentRhs
- createBoundArray
- genPointerAssignment
- genImplicitConvert
- firstDummyIsPointerOrAllocatable
- genCUDADataTransfer
- genCUDAImplicitDataTransfer
- genDataAssignment
- genAssignment
- isInsideOp
- isInsideHlfirForallOrWhere
- isInsideHlfirWhere
- genFIR
- genFIR
- lowerWhereMaskToHlfir
- genFIR
- genFIR
- genFIR
- genFIR
- genFIR
- genFIR
- genFIR
- genFIR
- genFIR
- genFIR
- genFIR
- genFIR
- genFIR
- genFIR
- genFIR
- genFIR
- genFIR
- genFIR
- genFIR
- genFIR
- genFIR
- genFIR
- genFIR
- genFIR
- genFIR
- genFIR
- genFIR
- genFIR
- genFIR
- genFIR
- genFIR
- genFIR
- genFIR
- genFIR
- genFIR
- genFIR
- genFIR
- genFIR
- genFIR
- genFIR
- genFIR
- genFIR
- genFIR
- genFIR
- genFIR
- genFIR
- mapDummiesAndResults
- instantiateVar
- manageFPEnvironment
- startNewFunction
- createEmptyBlocks
- blockIsUnterminated
- startBlock
- maybeStartBlock
- eraseDeadCodeAndBlocks
- endNewFunction
- createBuilderOutsideOfFuncOpAndDo
- lowerBlockData
- lowerCommonBlocks
- createIntrinsicModuleDefinitions
- lowerFunc
- lowerModuleDeclScope
- lowerMod
- setCurrentPosition
- setCurrentPositionAt
- toLocation
- toLocation
- setCurrentEval
- getEval
- getShape
- analyzeExplicitSpace
- analyzeExplicitSpace
- analyzeExplicitSpace
- analyzeExplicitSpace
- analyzeExplicitSpace
- analyzeExplicitSpace
- analyzeExplicitSpace
- analyzeExplicitSpace
- analyzeExplicitSpace
- analyzeExplicitSpace
- analyzeExplicitSpace
- analyzeExplicitSpace
- analyzeExplicitSpace
- analyzeExplicitSpace
- analyzeExplicitSpace
- analyzeExplicitSpace
- analyzeExplicitSpacePop
- addMaskVariable
- createRuntimeTypeInfoGlobals
- lowerToHighLevelFIR
- getConstantExprManglePrefix
- finalizeOpenMPLowering
- setDummyArgsScope
- registerDummySymbol
- resetRegisteredDummySymbols
Learn to use CMake with our Intro Training
Find out more