1 | //===-- ConvertVariable.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/ConvertVariable.h" |
14 | #include "flang/Lower/AbstractConverter.h" |
15 | #include "flang/Lower/Allocatable.h" |
16 | #include "flang/Lower/BoxAnalyzer.h" |
17 | #include "flang/Lower/CallInterface.h" |
18 | #include "flang/Lower/ConvertConstant.h" |
19 | #include "flang/Lower/ConvertExpr.h" |
20 | #include "flang/Lower/ConvertExprToHLFIR.h" |
21 | #include "flang/Lower/ConvertProcedureDesignator.h" |
22 | #include "flang/Lower/Cuda.h" |
23 | #include "flang/Lower/Mangler.h" |
24 | #include "flang/Lower/PFTBuilder.h" |
25 | #include "flang/Lower/StatementContext.h" |
26 | #include "flang/Lower/Support/Utils.h" |
27 | #include "flang/Lower/SymbolMap.h" |
28 | #include "flang/Optimizer/Builder/CUFCommon.h" |
29 | #include "flang/Optimizer/Builder/Character.h" |
30 | #include "flang/Optimizer/Builder/FIRBuilder.h" |
31 | #include "flang/Optimizer/Builder/HLFIRTools.h" |
32 | #include "flang/Optimizer/Builder/IntrinsicCall.h" |
33 | #include "flang/Optimizer/Builder/Runtime/Derived.h" |
34 | #include "flang/Optimizer/Builder/Todo.h" |
35 | #include "flang/Optimizer/Dialect/CUF/CUFOps.h" |
36 | #include "flang/Optimizer/Dialect/FIRAttr.h" |
37 | #include "flang/Optimizer/Dialect/FIRDialect.h" |
38 | #include "flang/Optimizer/Dialect/FIROps.h" |
39 | #include "flang/Optimizer/Dialect/Support/FIRContext.h" |
40 | #include "flang/Optimizer/HLFIR/HLFIROps.h" |
41 | #include "flang/Optimizer/Support/FatalError.h" |
42 | #include "flang/Optimizer/Support/InternalNames.h" |
43 | #include "flang/Optimizer/Support/Utils.h" |
44 | #include "flang/Runtime/allocator-registry-consts.h" |
45 | #include "flang/Semantics/runtime-type-info.h" |
46 | #include "flang/Semantics/tools.h" |
47 | #include "llvm/Support/CommandLine.h" |
48 | #include "llvm/Support/Debug.h" |
49 | #include <optional> |
50 | |
51 | static llvm::cl::opt<bool> |
52 | allowAssumedRank("allow-assumed-rank" , |
53 | llvm::cl::desc("Enable assumed rank lowering" ), |
54 | llvm::cl::init(Val: true)); |
55 | |
56 | #define DEBUG_TYPE "flang-lower-variable" |
57 | |
58 | /// Helper to lower a scalar expression using a specific symbol mapping. |
59 | static mlir::Value genScalarValue(Fortran::lower::AbstractConverter &converter, |
60 | mlir::Location loc, |
61 | const Fortran::lower::SomeExpr &expr, |
62 | Fortran::lower::SymMap &symMap, |
63 | Fortran::lower::StatementContext &context) { |
64 | // This does not use the AbstractConverter member function to override the |
65 | // symbol mapping to be used expression lowering. |
66 | if (converter.getLoweringOptions().getLowerToHighLevelFIR()) { |
67 | hlfir::EntityWithAttributes loweredExpr = |
68 | Fortran::lower::convertExprToHLFIR(loc, converter, expr, symMap, |
69 | context); |
70 | return hlfir::loadTrivialScalar(loc, converter.getFirOpBuilder(), |
71 | loweredExpr); |
72 | } |
73 | return fir::getBase(Fortran::lower::createSomeExtendedExpression( |
74 | loc, converter, expr, symMap, context)); |
75 | } |
76 | |
77 | /// Does this variable have a default initialization? |
78 | bool Fortran::lower::hasDefaultInitialization( |
79 | const Fortran::semantics::Symbol &sym) { |
80 | if (sym.has<Fortran::semantics::ObjectEntityDetails>() && sym.size()) |
81 | if (!Fortran::semantics::IsAllocatableOrPointer(sym)) |
82 | if (const Fortran::semantics::DeclTypeSpec *declTypeSpec = sym.GetType()) |
83 | if (const Fortran::semantics::DerivedTypeSpec *derivedTypeSpec = |
84 | declTypeSpec->AsDerived()) { |
85 | // Pointer assignments in the runtime may hit undefined behaviors if |
86 | // the RHS contains garbage. Pointer objects are always established by |
87 | // lowering to NULL() (in Fortran::lower::createMutableBox). However, |
88 | // pointer components need special care here so that local and global |
89 | // derived type containing pointers are always initialized. |
90 | // Intent(out), however, do not need to be initialized since the |
91 | // related descriptor storage comes from a local or global that has |
92 | // been initialized (it may not be NULL() anymore, but the rank, type, |
93 | // and non deferred length parameters are still correct in a |
94 | // conformant program, and that is what matters). |
95 | const bool ignorePointer = Fortran::semantics::IsIntentOut(sym); |
96 | return derivedTypeSpec->HasDefaultInitialization( |
97 | /*ignoreAllocatable=*/false, ignorePointer); |
98 | } |
99 | return false; |
100 | } |
101 | |
102 | // Does this variable have a finalization? |
103 | static bool hasFinalization(const Fortran::semantics::Symbol &sym) { |
104 | if (sym.has<Fortran::semantics::ObjectEntityDetails>()) |
105 | if (const Fortran::semantics::DeclTypeSpec *declTypeSpec = sym.GetType()) |
106 | if (const Fortran::semantics::DerivedTypeSpec *derivedTypeSpec = |
107 | declTypeSpec->AsDerived()) |
108 | return Fortran::semantics::IsFinalizable(*derivedTypeSpec); |
109 | return false; |
110 | } |
111 | |
112 | // Does this variable have an allocatable direct component? |
113 | static bool |
114 | hasAllocatableDirectComponent(const Fortran::semantics::Symbol &sym) { |
115 | if (sym.has<Fortran::semantics::ObjectEntityDetails>()) |
116 | if (const Fortran::semantics::DeclTypeSpec *declTypeSpec = sym.GetType()) |
117 | if (const Fortran::semantics::DerivedTypeSpec *derivedTypeSpec = |
118 | declTypeSpec->AsDerived()) |
119 | return Fortran::semantics::HasAllocatableDirectComponent( |
120 | *derivedTypeSpec); |
121 | return false; |
122 | } |
123 | //===----------------------------------------------------------------===// |
124 | // Global variables instantiation (not for alias and common) |
125 | //===----------------------------------------------------------------===// |
126 | |
127 | /// Helper to generate expression value inside global initializer. |
128 | static fir::ExtendedValue |
129 | genInitializerExprValue(Fortran::lower::AbstractConverter &converter, |
130 | mlir::Location loc, |
131 | const Fortran::lower::SomeExpr &expr, |
132 | Fortran::lower::StatementContext &stmtCtx) { |
133 | // Data initializer are constant value and should not depend on other symbols |
134 | // given the front-end fold parameter references. In any case, the "current" |
135 | // map of the converter should not be used since it holds mapping to |
136 | // mlir::Value from another mlir region. If these value are used by accident |
137 | // in the initializer, this will lead to segfaults in mlir code. |
138 | Fortran::lower::SymMap emptyMap; |
139 | return Fortran::lower::createSomeInitializerExpression(loc, converter, expr, |
140 | emptyMap, stmtCtx); |
141 | } |
142 | |
143 | /// Can this symbol constant be placed in read-only memory? |
144 | static bool isConstant(const Fortran::semantics::Symbol &sym) { |
145 | return sym.attrs().test(Fortran::semantics::Attr::PARAMETER) || |
146 | sym.test(Fortran::semantics::Symbol::Flag::ReadOnly); |
147 | } |
148 | |
149 | /// Call \p genInit to generate code inside \p global initializer region. |
150 | static void |
151 | createGlobalInitialization(fir::FirOpBuilder &builder, fir::GlobalOp global, |
152 | std::function<void(fir::FirOpBuilder &)> genInit); |
153 | |
154 | static mlir::Location genLocation(Fortran::lower::AbstractConverter &converter, |
155 | const Fortran::semantics::Symbol &sym) { |
156 | // Compiler generated name cannot be used as source location, their name |
157 | // is not pointing to the source files. |
158 | if (!sym.test(Fortran::semantics::Symbol::Flag::CompilerCreated)) |
159 | return converter.genLocation(sym.name()); |
160 | return converter.getCurrentLocation(); |
161 | } |
162 | |
163 | /// Create the global op declaration without any initializer |
164 | static fir::GlobalOp declareGlobal(Fortran::lower::AbstractConverter &converter, |
165 | const Fortran::lower::pft::Variable &var, |
166 | llvm::StringRef globalName, |
167 | mlir::StringAttr linkage) { |
168 | fir::FirOpBuilder &builder = converter.getFirOpBuilder(); |
169 | if (fir::GlobalOp global = builder.getNamedGlobal(globalName)) |
170 | return global; |
171 | const Fortran::semantics::Symbol &sym = var.getSymbol(); |
172 | cuf::DataAttributeAttr dataAttr = |
173 | Fortran::lower::translateSymbolCUFDataAttribute( |
174 | converter.getFirOpBuilder().getContext(), sym); |
175 | // Always define linkonce data since it may be optimized out from the module |
176 | // that actually owns the variable if it does not refers to it. |
177 | if (linkage == builder.createLinkOnceODRLinkage() || |
178 | linkage == builder.createLinkOnceLinkage()) |
179 | return defineGlobal(converter, var, globalName, linkage, dataAttr); |
180 | mlir::Location loc = genLocation(converter, sym); |
181 | // Resolve potential host and module association before checking that this |
182 | // symbol is an object of a function pointer. |
183 | const Fortran::semantics::Symbol &ultimate = sym.GetUltimate(); |
184 | if (!ultimate.has<Fortran::semantics::ObjectEntityDetails>() && |
185 | !Fortran::semantics::IsProcedurePointer(ultimate)) |
186 | mlir::emitError(loc, "processing global declaration: symbol '" ) |
187 | << toStringRef(sym.name()) << "' has unexpected details\n" ; |
188 | return builder.createGlobal(loc, converter.genType(var), globalName, linkage, |
189 | mlir::Attribute{}, isConstant(ultimate), |
190 | var.isTarget(), dataAttr); |
191 | } |
192 | |
193 | /// Temporary helper to catch todos in initial data target lowering. |
194 | static bool |
195 | hasDerivedTypeWithLengthParameters(const Fortran::semantics::Symbol &sym) { |
196 | if (const Fortran::semantics::DeclTypeSpec *declTy = sym.GetType()) |
197 | if (const Fortran::semantics::DerivedTypeSpec *derived = |
198 | declTy->AsDerived()) |
199 | return Fortran::semantics::CountLenParameters(*derived) > 0; |
200 | return false; |
201 | } |
202 | |
203 | fir::ExtendedValue Fortran::lower::genExtAddrInInitializer( |
204 | Fortran::lower::AbstractConverter &converter, mlir::Location loc, |
205 | const Fortran::lower::SomeExpr &addr) { |
206 | Fortran::lower::SymMap globalOpSymMap; |
207 | Fortran::lower::AggregateStoreMap storeMap; |
208 | Fortran::lower::StatementContext stmtCtx; |
209 | if (const Fortran::semantics::Symbol *sym = |
210 | Fortran::evaluate::GetFirstSymbol(addr)) { |
211 | // Length parameters processing will need care in global initializer |
212 | // context. |
213 | if (hasDerivedTypeWithLengthParameters(*sym)) |
214 | TODO(loc, "initial-data-target with derived type length parameters" ); |
215 | |
216 | auto var = Fortran::lower::pft::Variable(*sym, /*global=*/true); |
217 | Fortran::lower::instantiateVariable(converter, var, globalOpSymMap, |
218 | storeMap); |
219 | } |
220 | |
221 | if (converter.getLoweringOptions().getLowerToHighLevelFIR()) |
222 | return Fortran::lower::convertExprToAddress(loc, converter, addr, |
223 | globalOpSymMap, stmtCtx); |
224 | return Fortran::lower::createInitializerAddress(loc, converter, addr, |
225 | globalOpSymMap, stmtCtx); |
226 | } |
227 | |
228 | /// create initial-data-target fir.box in a global initializer region. |
229 | mlir::Value Fortran::lower::genInitialDataTarget( |
230 | Fortran::lower::AbstractConverter &converter, mlir::Location loc, |
231 | mlir::Type boxType, const Fortran::lower::SomeExpr &initialTarget, |
232 | bool couldBeInEquivalence) { |
233 | Fortran::lower::SymMap globalOpSymMap; |
234 | Fortran::lower::AggregateStoreMap storeMap; |
235 | Fortran::lower::StatementContext stmtCtx; |
236 | fir::FirOpBuilder &builder = converter.getFirOpBuilder(); |
237 | if (Fortran::evaluate::UnwrapExpr<Fortran::evaluate::NullPointer>( |
238 | initialTarget)) |
239 | return fir::factory::createUnallocatedBox( |
240 | builder, loc, boxType, |
241 | /*nonDeferredParams=*/std::nullopt); |
242 | // Pointer initial data target, and NULL(mold). |
243 | for (const auto &sym : Fortran::evaluate::CollectSymbols(initialTarget)) { |
244 | // Derived type component symbols should not be instantiated as objects |
245 | // on their own. |
246 | if (sym->owner().IsDerivedType()) |
247 | continue; |
248 | // Length parameters processing will need care in global initializer |
249 | // context. |
250 | if (hasDerivedTypeWithLengthParameters(sym)) |
251 | TODO(loc, "initial-data-target with derived type length parameters" ); |
252 | auto var = Fortran::lower::pft::Variable(sym, /*global=*/true); |
253 | if (couldBeInEquivalence) { |
254 | auto dependentVariableList = |
255 | Fortran::lower::pft::getDependentVariableList(sym); |
256 | for (Fortran::lower::pft::Variable var : dependentVariableList) { |
257 | if (!var.isAggregateStore()) |
258 | break; |
259 | instantiateVariable(converter, var, globalOpSymMap, storeMap); |
260 | } |
261 | var = dependentVariableList.back(); |
262 | assert(var.getSymbol().name() == sym->name() && |
263 | "missing symbol in dependence list" ); |
264 | } |
265 | Fortran::lower::instantiateVariable(converter, var, globalOpSymMap, |
266 | storeMap); |
267 | } |
268 | |
269 | // Handle NULL(mold) as a special case. Return an unallocated box of MOLD |
270 | // type. The return box is correctly created as a fir.box<fir.ptr<T>> where |
271 | // T is extracted from the MOLD argument. |
272 | if (const Fortran::evaluate::ProcedureRef *procRef = |
273 | Fortran::evaluate::UnwrapProcedureRef(initialTarget)) { |
274 | const Fortran::evaluate::SpecificIntrinsic *intrinsic = |
275 | procRef->proc().GetSpecificIntrinsic(); |
276 | if (intrinsic && intrinsic->name == "null" ) { |
277 | assert(procRef->arguments().size() == 1 && |
278 | "Expecting mold argument for NULL intrinsic" ); |
279 | const auto *argExpr = procRef->arguments()[0].value().UnwrapExpr(); |
280 | assert(argExpr); |
281 | const Fortran::semantics::Symbol *sym = |
282 | Fortran::evaluate::GetFirstSymbol(*argExpr); |
283 | assert(sym && "MOLD must be a pointer or allocatable symbol" ); |
284 | mlir::Type boxType = converter.genType(*sym); |
285 | mlir::Value box = |
286 | fir::factory::createUnallocatedBox(builder, loc, boxType, {}); |
287 | return box; |
288 | } |
289 | } |
290 | |
291 | mlir::Value targetBox; |
292 | mlir::Value targetShift; |
293 | if (converter.getLoweringOptions().getLowerToHighLevelFIR()) { |
294 | auto target = Fortran::lower::convertExprToBox( |
295 | loc, converter, initialTarget, globalOpSymMap, stmtCtx); |
296 | targetBox = fir::getBase(target); |
297 | targetShift = builder.createShape(loc, target); |
298 | } else { |
299 | if (initialTarget.Rank() > 0) { |
300 | auto target = Fortran::lower::createSomeArrayBox(converter, initialTarget, |
301 | globalOpSymMap, stmtCtx); |
302 | targetBox = fir::getBase(target); |
303 | targetShift = builder.createShape(loc, target); |
304 | } else { |
305 | fir::ExtendedValue addr = Fortran::lower::createInitializerAddress( |
306 | loc, converter, initialTarget, globalOpSymMap, stmtCtx); |
307 | targetBox = builder.createBox(loc, addr); |
308 | // Nothing to do for targetShift, the target is a scalar. |
309 | } |
310 | } |
311 | // The targetBox is a fir.box<T>, not a fir.box<fir.ptr<T>> as it should for |
312 | // pointers (this matters to get the POINTER attribute correctly inside the |
313 | // initial value of the descriptor). |
314 | // Create a fir.rebox to set the attribute correctly, and use targetShift |
315 | // to preserve the target lower bounds if any. |
316 | return builder.create<fir::ReboxOp>(loc, boxType, targetBox, targetShift, |
317 | /*slice=*/mlir::Value{}); |
318 | } |
319 | |
320 | /// Generate default initial value for a derived type object \p sym with mlir |
321 | /// type \p symTy. |
322 | static mlir::Value genDefaultInitializerValue( |
323 | Fortran::lower::AbstractConverter &converter, mlir::Location loc, |
324 | const Fortran::semantics::Symbol &sym, mlir::Type symTy, |
325 | Fortran::lower::StatementContext &stmtCtx); |
326 | |
327 | /// Generate the initial value of a derived component \p component and insert |
328 | /// it into the derived type initial value \p insertInto of type \p recTy. |
329 | /// Return the new derived type initial value after the insertion. |
330 | static mlir::Value genComponentDefaultInit( |
331 | Fortran::lower::AbstractConverter &converter, mlir::Location loc, |
332 | const Fortran::semantics::Symbol &component, fir::RecordType recTy, |
333 | mlir::Value insertInto, Fortran::lower::StatementContext &stmtCtx) { |
334 | fir::FirOpBuilder &builder = converter.getFirOpBuilder(); |
335 | std::string name = converter.getRecordTypeFieldName(component); |
336 | mlir::Type componentTy = recTy.getType(name); |
337 | assert(componentTy && "component not found in type" ); |
338 | mlir::Value componentValue; |
339 | if (const auto *object{ |
340 | component.detailsIf<Fortran::semantics::ObjectEntityDetails>()}) { |
341 | if (const auto &init = object->init()) { |
342 | // Component has explicit initialization. |
343 | if (Fortran::semantics::IsPointer(component)) |
344 | // Initial data target. |
345 | componentValue = |
346 | genInitialDataTarget(converter, loc, componentTy, *init); |
347 | else |
348 | // Initial value. |
349 | componentValue = fir::getBase( |
350 | genInitializerExprValue(converter, loc, *init, stmtCtx)); |
351 | } else if (Fortran::semantics::IsAllocatableOrPointer(component)) { |
352 | // Pointer or allocatable without initialization. |
353 | // Create deallocated/disassociated value. |
354 | // From a standard point of view, pointer without initialization do not |
355 | // need to be disassociated, but for sanity and simplicity, do it in |
356 | // global constructor since this has no runtime cost. |
357 | componentValue = fir::factory::createUnallocatedBox( |
358 | builder, loc, componentTy, std::nullopt); |
359 | } else if (Fortran::lower::hasDefaultInitialization(component)) { |
360 | // Component type has default initialization. |
361 | componentValue = genDefaultInitializerValue(converter, loc, component, |
362 | componentTy, stmtCtx); |
363 | } else { |
364 | // Component has no initial value. Set its bits to zero by extension |
365 | // to match what is expected because other compilers are doing it. |
366 | componentValue = builder.create<fir::ZeroOp>(loc, componentTy); |
367 | } |
368 | } else if (const auto *proc{ |
369 | component |
370 | .detailsIf<Fortran::semantics::ProcEntityDetails>()}) { |
371 | if (proc->init().has_value()) { |
372 | auto sym{*proc->init()}; |
373 | if (sym) // Has a procedure target. |
374 | componentValue = |
375 | Fortran::lower::convertProcedureDesignatorInitialTarget(converter, |
376 | loc, *sym); |
377 | else // Has NULL() target. |
378 | componentValue = |
379 | fir::factory::createNullBoxProc(builder, loc, componentTy); |
380 | } else |
381 | componentValue = builder.create<fir::ZeroOp>(loc, componentTy); |
382 | } |
383 | assert(componentValue && "must have been computed" ); |
384 | componentValue = builder.createConvert(loc, componentTy, componentValue); |
385 | auto fieldTy = fir::FieldType::get(recTy.getContext()); |
386 | // FIXME: type parameters must come from the derived-type-spec |
387 | auto field = builder.create<fir::FieldIndexOp>( |
388 | loc, fieldTy, name, recTy, |
389 | /*typeParams=*/mlir::ValueRange{} /*TODO*/); |
390 | return builder.create<fir::InsertValueOp>( |
391 | loc, recTy, insertInto, componentValue, |
392 | builder.getArrayAttr(field.getAttributes())); |
393 | } |
394 | |
395 | static mlir::Value genDefaultInitializerValue( |
396 | Fortran::lower::AbstractConverter &converter, mlir::Location loc, |
397 | const Fortran::semantics::Symbol &sym, mlir::Type symTy, |
398 | Fortran::lower::StatementContext &stmtCtx) { |
399 | fir::FirOpBuilder &builder = converter.getFirOpBuilder(); |
400 | mlir::Type scalarType = symTy; |
401 | fir::SequenceType sequenceType; |
402 | if (auto ty = mlir::dyn_cast<fir::SequenceType>(symTy)) { |
403 | sequenceType = ty; |
404 | scalarType = ty.getEleTy(); |
405 | } |
406 | // Build a scalar default value of the symbol type, looping through the |
407 | // components to build each component initial value. |
408 | auto recTy = mlir::cast<fir::RecordType>(scalarType); |
409 | mlir::Value initialValue = builder.create<fir::UndefOp>(loc, scalarType); |
410 | const Fortran::semantics::DeclTypeSpec *declTy = sym.GetType(); |
411 | assert(declTy && "var with default initialization must have a type" ); |
412 | |
413 | if (converter.getLoweringOptions().getLowerToHighLevelFIR()) { |
414 | // In HLFIR, the parent type is the first component, while in FIR there is |
415 | // not parent component in the fir.type and the component of the parent are |
416 | // "inlined" at the beginning of the fir.type. |
417 | const Fortran::semantics::Symbol &typeSymbol = |
418 | declTy->derivedTypeSpec().typeSymbol(); |
419 | const Fortran::semantics::Scope *derivedScope = |
420 | declTy->derivedTypeSpec().GetScope(); |
421 | assert(derivedScope && "failed to retrieve derived type scope" ); |
422 | for (const auto &componentName : |
423 | typeSymbol.get<Fortran::semantics::DerivedTypeDetails>() |
424 | .componentNames()) { |
425 | auto scopeIter = derivedScope->find(componentName); |
426 | assert(scopeIter != derivedScope->cend() && |
427 | "failed to find derived type component symbol" ); |
428 | const Fortran::semantics::Symbol &component = scopeIter->second.get(); |
429 | initialValue = genComponentDefaultInit(converter, loc, component, recTy, |
430 | initialValue, stmtCtx); |
431 | } |
432 | } else { |
433 | Fortran::semantics::OrderedComponentIterator components( |
434 | declTy->derivedTypeSpec()); |
435 | for (const auto &component : components) { |
436 | // Skip parent components, the sub-components of parent types are part of |
437 | // components and will be looped through right after. |
438 | if (component.test(Fortran::semantics::Symbol::Flag::ParentComp)) |
439 | continue; |
440 | initialValue = genComponentDefaultInit(converter, loc, component, recTy, |
441 | initialValue, stmtCtx); |
442 | } |
443 | } |
444 | |
445 | if (sequenceType) { |
446 | // For arrays, duplicate the scalar value to all elements with an |
447 | // fir.insert_range covering the whole array. |
448 | auto arrayInitialValue = builder.create<fir::UndefOp>(loc, sequenceType); |
449 | llvm::SmallVector<int64_t> rangeBounds; |
450 | for (int64_t extent : sequenceType.getShape()) { |
451 | if (extent == fir::SequenceType::getUnknownExtent()) |
452 | TODO(loc, |
453 | "default initial value of array component with length parameters" ); |
454 | rangeBounds.push_back(0); |
455 | rangeBounds.push_back(extent - 1); |
456 | } |
457 | return builder.create<fir::InsertOnRangeOp>( |
458 | loc, sequenceType, arrayInitialValue, initialValue, |
459 | builder.getIndexVectorAttr(rangeBounds)); |
460 | } |
461 | return initialValue; |
462 | } |
463 | |
464 | /// Does this global already have an initializer ? |
465 | static bool globalIsInitialized(fir::GlobalOp global) { |
466 | return !global.getRegion().empty() || global.getInitVal(); |
467 | } |
468 | |
469 | /// Call \p genInit to generate code inside \p global initializer region. |
470 | static void |
471 | createGlobalInitialization(fir::FirOpBuilder &builder, fir::GlobalOp global, |
472 | std::function<void(fir::FirOpBuilder &)> genInit) { |
473 | mlir::Region ®ion = global.getRegion(); |
474 | region.push_back(new mlir::Block); |
475 | mlir::Block &block = region.back(); |
476 | auto insertPt = builder.saveInsertionPoint(); |
477 | builder.setInsertionPointToStart(&block); |
478 | genInit(builder); |
479 | builder.restoreInsertionPoint(insertPt); |
480 | } |
481 | |
482 | static unsigned getAllocatorIdxFromDataAttr(cuf::DataAttributeAttr dataAttr) { |
483 | if (dataAttr) { |
484 | if (dataAttr.getValue() == cuf::DataAttribute::Pinned) |
485 | return kPinnedAllocatorPos; |
486 | if (dataAttr.getValue() == cuf::DataAttribute::Device) |
487 | return kDeviceAllocatorPos; |
488 | if (dataAttr.getValue() == cuf::DataAttribute::Managed) |
489 | return kManagedAllocatorPos; |
490 | if (dataAttr.getValue() == cuf::DataAttribute::Unified) |
491 | return kUnifiedAllocatorPos; |
492 | } |
493 | return kDefaultAllocator; |
494 | } |
495 | |
496 | /// Create the global op and its init if it has one |
497 | fir::GlobalOp Fortran::lower::defineGlobal( |
498 | Fortran::lower::AbstractConverter &converter, |
499 | const Fortran::lower::pft::Variable &var, llvm::StringRef globalName, |
500 | mlir::StringAttr linkage, cuf::DataAttributeAttr dataAttr) { |
501 | fir::FirOpBuilder &builder = converter.getFirOpBuilder(); |
502 | const Fortran::semantics::Symbol &sym = var.getSymbol(); |
503 | mlir::Location loc = genLocation(converter, sym); |
504 | bool isConst = isConstant(sym); |
505 | fir::GlobalOp global = builder.getNamedGlobal(globalName); |
506 | mlir::Type symTy = converter.genType(var); |
507 | |
508 | if (global && globalIsInitialized(global)) |
509 | return global; |
510 | |
511 | if (!converter.getLoweringOptions().getLowerToHighLevelFIR() && |
512 | Fortran::semantics::IsProcedurePointer(sym)) |
513 | TODO(loc, "procedure pointer globals" ); |
514 | |
515 | // If this is an array, check to see if we can use a dense attribute |
516 | // with a tensor mlir type. This optimization currently only supports |
517 | // Fortran arrays of integer, real, complex, or logical. The tensor |
518 | // type does not support nested structures. |
519 | if (mlir::isa<fir::SequenceType>(symTy) && |
520 | !Fortran::semantics::IsAllocatableOrPointer(sym)) { |
521 | mlir::Type eleTy = mlir::cast<fir::SequenceType>(symTy).getElementType(); |
522 | if (mlir::isa<mlir::IntegerType, mlir::FloatType, mlir::ComplexType, |
523 | fir::LogicalType>(eleTy)) { |
524 | const auto *details = |
525 | sym.detailsIf<Fortran::semantics::ObjectEntityDetails>(); |
526 | if (details->init()) { |
527 | global = Fortran::lower::tryCreatingDenseGlobal( |
528 | builder, loc, symTy, globalName, linkage, isConst, |
529 | details->init().value(), dataAttr); |
530 | if (global) { |
531 | global.setVisibility(mlir::SymbolTable::Visibility::Public); |
532 | return global; |
533 | } |
534 | } |
535 | } |
536 | } |
537 | if (!global) |
538 | global = |
539 | builder.createGlobal(loc, symTy, globalName, linkage, mlir::Attribute{}, |
540 | isConst, var.isTarget(), dataAttr); |
541 | if (Fortran::semantics::IsAllocatableOrPointer(sym) && |
542 | !Fortran::semantics::IsProcedure(sym)) { |
543 | const auto *details = |
544 | sym.detailsIf<Fortran::semantics::ObjectEntityDetails>(); |
545 | if (details && details->init()) { |
546 | auto expr = *details->init(); |
547 | createGlobalInitialization(builder, global, [&](fir::FirOpBuilder &b) { |
548 | mlir::Value box = |
549 | Fortran::lower::genInitialDataTarget(converter, loc, symTy, expr); |
550 | b.create<fir::HasValueOp>(loc, box); |
551 | }); |
552 | } else { |
553 | // Create unallocated/disassociated descriptor if no explicit init |
554 | createGlobalInitialization(builder, global, [&](fir::FirOpBuilder &b) { |
555 | mlir::Value box = fir::factory::createUnallocatedBox( |
556 | b, loc, symTy, |
557 | /*nonDeferredParams=*/std::nullopt, |
558 | /*typeSourceBox=*/{}, getAllocatorIdxFromDataAttr(dataAttr)); |
559 | b.create<fir::HasValueOp>(loc, box); |
560 | }); |
561 | } |
562 | } else if (const auto *details = |
563 | sym.detailsIf<Fortran::semantics::ObjectEntityDetails>()) { |
564 | if (details->init()) { |
565 | createGlobalInitialization( |
566 | builder, global, [&](fir::FirOpBuilder &builder) { |
567 | Fortran::lower::StatementContext stmtCtx( |
568 | /*cleanupProhibited=*/true); |
569 | fir::ExtendedValue initVal = genInitializerExprValue( |
570 | converter, loc, details->init().value(), stmtCtx); |
571 | mlir::Value castTo = |
572 | builder.createConvert(loc, symTy, fir::getBase(initVal)); |
573 | builder.create<fir::HasValueOp>(loc, castTo); |
574 | }); |
575 | } else if (Fortran::lower::hasDefaultInitialization(sym)) { |
576 | createGlobalInitialization( |
577 | builder, global, [&](fir::FirOpBuilder &builder) { |
578 | Fortran::lower::StatementContext stmtCtx( |
579 | /*cleanupProhibited=*/true); |
580 | mlir::Value initVal = |
581 | genDefaultInitializerValue(converter, loc, sym, symTy, stmtCtx); |
582 | mlir::Value castTo = builder.createConvert(loc, symTy, initVal); |
583 | builder.create<fir::HasValueOp>(loc, castTo); |
584 | }); |
585 | } |
586 | } else if (Fortran::semantics::IsProcedurePointer(sym)) { |
587 | const auto *details{sym.detailsIf<Fortran::semantics::ProcEntityDetails>()}; |
588 | if (details && details->init()) { |
589 | auto sym{*details->init()}; |
590 | if (sym) // Has a procedure target. |
591 | createGlobalInitialization( |
592 | builder, global, [&](fir::FirOpBuilder &b) { |
593 | Fortran::lower::StatementContext stmtCtx( |
594 | /*cleanupProhibited=*/true); |
595 | auto box{Fortran::lower::convertProcedureDesignatorInitialTarget( |
596 | converter, loc, *sym)}; |
597 | auto castTo{builder.createConvert(loc, symTy, box)}; |
598 | b.create<fir::HasValueOp>(loc, castTo); |
599 | }); |
600 | else { // Has NULL() target. |
601 | createGlobalInitialization(builder, global, [&](fir::FirOpBuilder &b) { |
602 | auto box{fir::factory::createNullBoxProc(b, loc, symTy)}; |
603 | b.create<fir::HasValueOp>(loc, box); |
604 | }); |
605 | } |
606 | } else { |
607 | // No initialization. |
608 | createGlobalInitialization(builder, global, [&](fir::FirOpBuilder &b) { |
609 | auto box{fir::factory::createNullBoxProc(b, loc, symTy)}; |
610 | b.create<fir::HasValueOp>(loc, box); |
611 | }); |
612 | } |
613 | } else if (sym.has<Fortran::semantics::CommonBlockDetails>()) { |
614 | mlir::emitError(loc, "COMMON symbol processed elsewhere" ); |
615 | } else { |
616 | TODO(loc, "global" ); // Something else |
617 | } |
618 | // Creates zero initializer for globals without initializers, this is a common |
619 | // and expected behavior (although not required by the standard) |
620 | if (!globalIsInitialized(global)) { |
621 | // Fortran does not provide means to specify that a BIND(C) module |
622 | // uninitialized variables will be defined in C. |
623 | // Add the common linkage to those to allow some level of support |
624 | // for this use case. Note that this use case will not work if the Fortran |
625 | // module code is placed in a shared library since, at least for the ELF |
626 | // format, common symbols are assigned a section in shared libraries. |
627 | // The best is still to declare C defined variables in a Fortran module file |
628 | // with no other definitions, and to never link the resulting module object |
629 | // file. |
630 | if (sym.attrs().test(Fortran::semantics::Attr::BIND_C)) |
631 | global.setLinkName(builder.createCommonLinkage()); |
632 | createGlobalInitialization( |
633 | builder, global, [&](fir::FirOpBuilder &builder) { |
634 | mlir::Value initValue; |
635 | if (converter.getLoweringOptions().getInitGlobalZero()) |
636 | initValue = builder.create<fir::ZeroOp>(loc, symTy); |
637 | else |
638 | initValue = builder.create<fir::UndefOp>(loc, symTy); |
639 | builder.create<fir::HasValueOp>(loc, initValue); |
640 | }); |
641 | } |
642 | // Set public visibility to prevent global definition to be optimized out |
643 | // even if they have no initializer and are unused in this compilation unit. |
644 | global.setVisibility(mlir::SymbolTable::Visibility::Public); |
645 | return global; |
646 | } |
647 | |
648 | /// Return linkage attribute for \p var. |
649 | static mlir::StringAttr |
650 | getLinkageAttribute(fir::FirOpBuilder &builder, |
651 | const Fortran::lower::pft::Variable &var) { |
652 | // Runtime type info for a same derived type is identical in each compilation |
653 | // unit. It desired to avoid having to link against module that only define a |
654 | // type. Therefore the runtime type info is generated everywhere it is needed |
655 | // with `linkonce_odr` LLVM linkage. |
656 | if (var.isRuntimeTypeInfoData()) |
657 | return builder.createLinkOnceODRLinkage(); |
658 | if (var.isModuleOrSubmoduleVariable()) |
659 | return {}; // external linkage |
660 | // Otherwise, the variable is owned by a procedure and must not be visible in |
661 | // other compilation units. |
662 | return builder.createInternalLinkage(); |
663 | } |
664 | |
665 | /// Instantiate a global variable. If it hasn't already been processed, add |
666 | /// the global to the ModuleOp as a new uniqued symbol and initialize it with |
667 | /// the correct value. It will be referenced on demand using `fir.addr_of`. |
668 | static void instantiateGlobal(Fortran::lower::AbstractConverter &converter, |
669 | const Fortran::lower::pft::Variable &var, |
670 | Fortran::lower::SymMap &symMap) { |
671 | const Fortran::semantics::Symbol &sym = var.getSymbol(); |
672 | assert(!var.isAlias() && "must be handled in instantiateAlias" ); |
673 | fir::FirOpBuilder &builder = converter.getFirOpBuilder(); |
674 | std::string globalName = converter.mangleName(sym); |
675 | mlir::Location loc = genLocation(converter, sym); |
676 | mlir::StringAttr linkage = getLinkageAttribute(builder, var); |
677 | fir::GlobalOp global; |
678 | if (var.isModuleOrSubmoduleVariable()) { |
679 | // A non-intrinsic module global is defined when lowering the module. |
680 | // Emit only a declaration if the global does not exist. |
681 | global = declareGlobal(converter, var, globalName, linkage); |
682 | } else { |
683 | cuf::DataAttributeAttr dataAttr = |
684 | Fortran::lower::translateSymbolCUFDataAttribute(builder.getContext(), |
685 | sym); |
686 | global = defineGlobal(converter, var, globalName, linkage, dataAttr); |
687 | } |
688 | auto addrOf = builder.create<fir::AddrOfOp>(loc, global.resultType(), |
689 | global.getSymbol()); |
690 | Fortran::lower::StatementContext stmtCtx; |
691 | mapSymbolAttributes(converter, var, symMap, stmtCtx, addrOf); |
692 | } |
693 | |
694 | //===----------------------------------------------------------------===// |
695 | // Local variables instantiation (not for alias) |
696 | //===----------------------------------------------------------------===// |
697 | |
698 | /// Create a stack slot for a local variable. Precondition: the insertion |
699 | /// point of the builder must be in the entry block, which is currently being |
700 | /// constructed. |
701 | static mlir::Value createNewLocal(Fortran::lower::AbstractConverter &converter, |
702 | mlir::Location loc, |
703 | const Fortran::lower::pft::Variable &var, |
704 | mlir::Value preAlloc, |
705 | llvm::ArrayRef<mlir::Value> shape = {}, |
706 | llvm::ArrayRef<mlir::Value> lenParams = {}) { |
707 | if (preAlloc) |
708 | return preAlloc; |
709 | fir::FirOpBuilder &builder = converter.getFirOpBuilder(); |
710 | std::string nm = converter.mangleName(var.getSymbol()); |
711 | mlir::Type ty = converter.genType(var); |
712 | const Fortran::semantics::Symbol &ultimateSymbol = |
713 | var.getSymbol().GetUltimate(); |
714 | llvm::StringRef symNm = toStringRef(ultimateSymbol.name()); |
715 | bool isTarg = var.isTarget(); |
716 | |
717 | // Do not allocate storage for cray pointee. The address inside the cray |
718 | // pointer will be used instead when using the pointee. Allocating space |
719 | // would be a waste of space, and incorrect if the pointee is a non dummy |
720 | // assumed-size (possible with cray pointee). |
721 | if (ultimateSymbol.test(Fortran::semantics::Symbol::Flag::CrayPointee)) |
722 | return builder.create<fir::ZeroOp>(loc, fir::ReferenceType::get(ty)); |
723 | |
724 | if (Fortran::semantics::NeedCUDAAlloc(ultimateSymbol)) { |
725 | cuf::DataAttributeAttr dataAttr = |
726 | Fortran::lower::translateSymbolCUFDataAttribute(builder.getContext(), |
727 | ultimateSymbol); |
728 | llvm::SmallVector<mlir::Value> indices; |
729 | llvm::SmallVector<mlir::Value> elidedShape = |
730 | fir::factory::elideExtentsAlreadyInType(ty, shape); |
731 | llvm::SmallVector<mlir::Value> elidedLenParams = |
732 | fir::factory::elideLengthsAlreadyInType(ty, lenParams); |
733 | auto idxTy = builder.getIndexType(); |
734 | for (mlir::Value sh : elidedShape) |
735 | indices.push_back(builder.createConvert(loc, idxTy, sh)); |
736 | if (dataAttr.getValue() == cuf::DataAttribute::Shared) |
737 | return builder.create<cuf::SharedMemoryOp>(loc, ty, nm, symNm, lenParams, |
738 | indices); |
739 | |
740 | if (!cuf::isCUDADeviceContext(builder.getRegion())) |
741 | return builder.create<cuf::AllocOp>(loc, ty, nm, symNm, dataAttr, |
742 | lenParams, indices); |
743 | } |
744 | |
745 | // Let the builder do all the heavy lifting. |
746 | if (!Fortran::semantics::IsProcedurePointer(ultimateSymbol)) |
747 | return builder.allocateLocal(loc, ty, nm, symNm, shape, lenParams, isTarg); |
748 | |
749 | // Local procedure pointer. |
750 | auto res{builder.allocateLocal(loc, ty, nm, symNm, shape, lenParams, isTarg)}; |
751 | auto box{fir::factory::createNullBoxProc(builder, loc, ty)}; |
752 | builder.create<fir::StoreOp>(loc, box, res); |
753 | return res; |
754 | } |
755 | |
756 | /// Must \p var be default initialized at runtime when entering its scope. |
757 | static bool |
758 | mustBeDefaultInitializedAtRuntime(const Fortran::lower::pft::Variable &var) { |
759 | if (!var.hasSymbol()) |
760 | return false; |
761 | const Fortran::semantics::Symbol &sym = var.getSymbol(); |
762 | if (var.isGlobal()) |
763 | // Global variables are statically initialized. |
764 | return false; |
765 | if (Fortran::semantics::IsDummy(sym) && !Fortran::semantics::IsIntentOut(sym)) |
766 | return false; |
767 | // Polymorphic intent(out) dummy might need default initialization |
768 | // at runtime. |
769 | if (Fortran::semantics::IsPolymorphic(sym) && |
770 | Fortran::semantics::IsDummy(sym) && |
771 | Fortran::semantics::IsIntentOut(sym) && |
772 | !Fortran::semantics::IsAllocatable(sym) && |
773 | !Fortran::semantics::IsPointer(sym)) |
774 | return true; |
775 | // Local variables (including function results), and intent(out) dummies must |
776 | // be default initialized at runtime if their type has default initialization. |
777 | return Fortran::lower::hasDefaultInitialization(sym); |
778 | } |
779 | |
780 | /// Call default initialization runtime routine to initialize \p var. |
781 | void Fortran::lower::defaultInitializeAtRuntime( |
782 | Fortran::lower::AbstractConverter &converter, |
783 | const Fortran::semantics::Symbol &sym, Fortran::lower::SymMap &symMap) { |
784 | fir::FirOpBuilder &builder = converter.getFirOpBuilder(); |
785 | mlir::Location loc = converter.getCurrentLocation(); |
786 | fir::ExtendedValue exv = converter.getSymbolExtendedValue(sym, &symMap); |
787 | if (Fortran::semantics::IsOptional(sym)) { |
788 | // 15.5.2.12 point 3, absent optional dummies are not initialized. |
789 | // Creating descriptor/passing null descriptor to the runtime would |
790 | // create runtime crashes. |
791 | auto isPresent = builder.create<fir::IsPresentOp>(loc, builder.getI1Type(), |
792 | fir::getBase(exv)); |
793 | builder.genIfThen(loc, isPresent) |
794 | .genThen([&]() { |
795 | auto box = builder.createBox(loc, exv); |
796 | fir::runtime::genDerivedTypeInitialize(builder, loc, box); |
797 | }) |
798 | .end(); |
799 | } else { |
800 | /// For "simpler" types, relying on "_FortranAInitialize" |
801 | /// leads to poor runtime performance. Hence optimize |
802 | /// the same. |
803 | const Fortran::semantics::DeclTypeSpec *declTy = sym.GetType(); |
804 | mlir::Type symTy = converter.genType(sym); |
805 | const auto *details = |
806 | sym.detailsIf<Fortran::semantics::ObjectEntityDetails>(); |
807 | if (details && !Fortran::semantics::IsPolymorphic(sym) && |
808 | declTy->category() == |
809 | Fortran::semantics::DeclTypeSpec::Category::TypeDerived && |
810 | !mlir::isa<fir::SequenceType>(symTy) && |
811 | !sym.test(Fortran::semantics::Symbol::Flag::OmpPrivate) && |
812 | !sym.test(Fortran::semantics::Symbol::Flag::OmpFirstPrivate)) { |
813 | std::string globalName = fir::NameUniquer::doGenerated( |
814 | (converter.mangleName(*declTy->AsDerived()) + fir::kNameSeparator + |
815 | fir::kDerivedTypeInitSuffix) |
816 | .str()); |
817 | mlir::Location loc = genLocation(converter, sym); |
818 | mlir::StringAttr linkage = builder.createInternalLinkage(); |
819 | fir::GlobalOp global = builder.getNamedGlobal(globalName); |
820 | if (!global && details->init()) { |
821 | global = builder.createGlobal(loc, symTy, globalName, linkage, |
822 | mlir::Attribute{}, |
823 | /*isConst=*/true, |
824 | /*isTarget=*/false, |
825 | /*dataAttr=*/{}); |
826 | createGlobalInitialization( |
827 | builder, global, [&](fir::FirOpBuilder &builder) { |
828 | Fortran::lower::StatementContext stmtCtx( |
829 | /*cleanupProhibited=*/true); |
830 | fir::ExtendedValue initVal = genInitializerExprValue( |
831 | converter, loc, details->init().value(), stmtCtx); |
832 | mlir::Value castTo = |
833 | builder.createConvert(loc, symTy, fir::getBase(initVal)); |
834 | builder.create<fir::HasValueOp>(loc, castTo); |
835 | }); |
836 | } else if (!global) { |
837 | global = builder.createGlobal(loc, symTy, globalName, linkage, |
838 | mlir::Attribute{}, |
839 | /*isConst=*/true, |
840 | /*isTarget=*/false, |
841 | /*dataAttr=*/{}); |
842 | createGlobalInitialization( |
843 | builder, global, [&](fir::FirOpBuilder &builder) { |
844 | Fortran::lower::StatementContext stmtCtx( |
845 | /*cleanupProhibited=*/true); |
846 | mlir::Value initVal = genDefaultInitializerValue( |
847 | converter, loc, sym, symTy, stmtCtx); |
848 | mlir::Value castTo = builder.createConvert(loc, symTy, initVal); |
849 | builder.create<fir::HasValueOp>(loc, castTo); |
850 | }); |
851 | } |
852 | auto addrOf = builder.create<fir::AddrOfOp>(loc, global.resultType(), |
853 | global.getSymbol()); |
854 | builder.create<fir::CopyOp>(loc, addrOf, fir::getBase(exv), |
855 | /*noOverlap=*/true); |
856 | } else { |
857 | mlir::Value box = builder.createBox(loc, exv); |
858 | fir::runtime::genDerivedTypeInitialize(builder, loc, box); |
859 | } |
860 | } |
861 | } |
862 | |
863 | /// Call clone initialization runtime routine to initialize \p sym's value. |
864 | void Fortran::lower::initializeCloneAtRuntime( |
865 | Fortran::lower::AbstractConverter &converter, |
866 | const Fortran::semantics::Symbol &sym, Fortran::lower::SymMap &symMap) { |
867 | fir::FirOpBuilder &builder = converter.getFirOpBuilder(); |
868 | mlir::Location loc = converter.getCurrentLocation(); |
869 | fir::ExtendedValue exv = converter.getSymbolExtendedValue(sym, &symMap); |
870 | mlir::Value newBox = builder.createBox(loc, exv); |
871 | lower::SymbolBox hsb = converter.lookupOneLevelUpSymbol(sym); |
872 | fir::ExtendedValue hexv = converter.symBoxToExtendedValue(hsb); |
873 | mlir::Value box = builder.createBox(loc, hexv); |
874 | fir::runtime::genDerivedTypeInitializeClone(builder, loc, newBox, box); |
875 | } |
876 | |
877 | enum class VariableCleanUp { Finalize, Deallocate }; |
878 | /// Check whether a local variable needs to be finalized according to clause |
879 | /// 7.5.6.3 point 3 or if it is an allocatable that must be deallocated. Note |
880 | /// that deallocation will trigger finalization if the type has any. |
881 | static std::optional<VariableCleanUp> |
882 | needDeallocationOrFinalization(const Fortran::lower::pft::Variable &var) { |
883 | if (!var.hasSymbol()) |
884 | return std::nullopt; |
885 | const Fortran::semantics::Symbol &sym = var.getSymbol(); |
886 | const Fortran::semantics::Scope &owner = sym.owner(); |
887 | if (owner.kind() == Fortran::semantics::Scope::Kind::MainProgram) { |
888 | // The standard does not require finalizing main program variables. |
889 | return std::nullopt; |
890 | } |
891 | if (!Fortran::semantics::IsPointer(sym) && |
892 | !Fortran::semantics::IsDummy(sym) && |
893 | !Fortran::semantics::IsFunctionResult(sym) && |
894 | !Fortran::semantics::IsSaved(sym)) { |
895 | if (Fortran::semantics::IsAllocatable(sym)) |
896 | return VariableCleanUp::Deallocate; |
897 | if (hasFinalization(sym)) |
898 | return VariableCleanUp::Finalize; |
899 | // hasFinalization() check above handled all cases that require |
900 | // finalization, but we also have to deallocate all allocatable |
901 | // components of local variables (since they are also local variables |
902 | // according to F18 5.4.3.2.2, p. 2, note 1). |
903 | // Here, the variable itself is not allocatable. If it has an allocatable |
904 | // component the Destroy runtime does the job. Use the Finalize clean-up, |
905 | // though there will be no finalization in runtime. |
906 | if (hasAllocatableDirectComponent(sym)) |
907 | return VariableCleanUp::Finalize; |
908 | } |
909 | return std::nullopt; |
910 | } |
911 | |
912 | /// Check whether a variable needs the be finalized according to clause 7.5.6.3 |
913 | /// point 7. |
914 | /// Must be nonpointer, nonallocatable, INTENT (OUT) dummy argument. |
915 | static bool |
916 | needDummyIntentoutFinalization(const Fortran::semantics::Symbol &sym) { |
917 | if (!Fortran::semantics::IsDummy(sym) || |
918 | !Fortran::semantics::IsIntentOut(sym) || |
919 | Fortran::semantics::IsAllocatable(sym) || |
920 | Fortran::semantics::IsPointer(sym)) |
921 | return false; |
922 | // Polymorphic and unlimited polymorphic intent(out) dummy argument might need |
923 | // finalization at runtime. |
924 | if (Fortran::semantics::IsPolymorphic(sym) || |
925 | Fortran::semantics::IsUnlimitedPolymorphic(sym)) |
926 | return true; |
927 | // Intent(out) dummies must be finalized at runtime if their type has a |
928 | // finalization. |
929 | // Allocatable components of INTENT(OUT) dummies must be deallocated (9.7.3.2 |
930 | // p6). Calling finalization runtime for this works even if the components |
931 | // have no final procedures. |
932 | return hasFinalization(sym) || hasAllocatableDirectComponent(sym); |
933 | } |
934 | |
935 | /// Check whether a variable needs the be finalized according to clause 7.5.6.3 |
936 | /// point 7. |
937 | /// Must be nonpointer, nonallocatable, INTENT (OUT) dummy argument. |
938 | static bool |
939 | needDummyIntentoutFinalization(const Fortran::lower::pft::Variable &var) { |
940 | if (!var.hasSymbol()) |
941 | return false; |
942 | return needDummyIntentoutFinalization(var.getSymbol()); |
943 | } |
944 | |
945 | /// Call default initialization runtime routine to initialize \p var. |
946 | static void finalizeAtRuntime(Fortran::lower::AbstractConverter &converter, |
947 | const Fortran::lower::pft::Variable &var, |
948 | Fortran::lower::SymMap &symMap) { |
949 | fir::FirOpBuilder &builder = converter.getFirOpBuilder(); |
950 | mlir::Location loc = converter.getCurrentLocation(); |
951 | const Fortran::semantics::Symbol &sym = var.getSymbol(); |
952 | fir::ExtendedValue exv = converter.getSymbolExtendedValue(sym, &symMap); |
953 | if (Fortran::semantics::IsOptional(sym)) { |
954 | // Only finalize if present. |
955 | auto isPresent = builder.create<fir::IsPresentOp>(loc, builder.getI1Type(), |
956 | fir::getBase(exv)); |
957 | builder.genIfThen(loc, isPresent) |
958 | .genThen([&]() { |
959 | auto box = builder.createBox(loc, exv); |
960 | fir::runtime::genDerivedTypeDestroy(builder, loc, box); |
961 | }) |
962 | .end(); |
963 | } else { |
964 | mlir::Value box = builder.createBox(loc, exv); |
965 | fir::runtime::genDerivedTypeDestroy(builder, loc, box); |
966 | } |
967 | } |
968 | |
969 | // Fortran 2018 - 9.7.3.2 point 6 |
970 | // When a procedure is invoked, any allocated allocatable object that is an |
971 | // actual argument corresponding to an INTENT(OUT) allocatable dummy argument |
972 | // is deallocated; any allocated allocatable object that is a subobject of an |
973 | // actual argument corresponding to an INTENT(OUT) dummy argument is |
974 | // deallocated. |
975 | // Note that allocatable components of non-ALLOCATABLE INTENT(OUT) dummy |
976 | // arguments are dealt with needDummyIntentoutFinalization (finalization runtime |
977 | // is called to reach the intended component deallocation effect). |
978 | static void deallocateIntentOut(Fortran::lower::AbstractConverter &converter, |
979 | const Fortran::lower::pft::Variable &var, |
980 | Fortran::lower::SymMap &symMap) { |
981 | if (!var.hasSymbol()) |
982 | return; |
983 | |
984 | const Fortran::semantics::Symbol &sym = var.getSymbol(); |
985 | if (Fortran::semantics::IsDummy(sym) && |
986 | Fortran::semantics::IsIntentOut(sym) && |
987 | Fortran::semantics::IsAllocatable(sym)) { |
988 | fir::ExtendedValue extVal = converter.getSymbolExtendedValue(sym, &symMap); |
989 | if (auto mutBox = extVal.getBoxOf<fir::MutableBoxValue>()) { |
990 | // The dummy argument is not passed in the ENTRY so it should not be |
991 | // deallocated. |
992 | if (mlir::Operation *op = mutBox->getAddr().getDefiningOp()) { |
993 | if (auto declOp = mlir::dyn_cast<hlfir::DeclareOp>(op)) |
994 | op = declOp.getMemref().getDefiningOp(); |
995 | if (op && mlir::isa<fir::AllocaOp>(op)) |
996 | return; |
997 | } |
998 | mlir::Location loc = converter.getCurrentLocation(); |
999 | fir::FirOpBuilder &builder = converter.getFirOpBuilder(); |
1000 | |
1001 | if (Fortran::semantics::IsOptional(sym)) { |
1002 | auto isPresent = builder.create<fir::IsPresentOp>( |
1003 | loc, builder.getI1Type(), fir::getBase(extVal)); |
1004 | builder.genIfThen(loc, isPresent) |
1005 | .genThen([&]() { |
1006 | Fortran::lower::genDeallocateIfAllocated(converter, *mutBox, loc); |
1007 | }) |
1008 | .end(); |
1009 | } else { |
1010 | Fortran::lower::genDeallocateIfAllocated(converter, *mutBox, loc); |
1011 | } |
1012 | } |
1013 | } |
1014 | } |
1015 | |
1016 | /// Return true iff the given symbol represents a dummy array |
1017 | /// that needs to be repacked when -frepack-arrays is set. |
1018 | /// In general, the repacking is done for assumed-shape |
1019 | /// dummy arguments, but there are limitations. |
1020 | static bool needsRepack(Fortran::lower::AbstractConverter &converter, |
1021 | const Fortran::semantics::Symbol &sym) { |
1022 | const auto &attrs = sym.attrs(); |
1023 | if (!converter.getLoweringOptions().getRepackArrays() || |
1024 | !converter.isRegisteredDummySymbol(sym) || |
1025 | !Fortran::semantics::IsAssumedShape(sym) || |
1026 | Fortran::evaluate::IsSimplyContiguous(sym, |
1027 | converter.getFoldingContext()) || |
1028 | // TARGET dummy may be accessed indirectly, so it is unsafe |
1029 | // to repack it. Some compilers provide options to override |
1030 | // this. |
1031 | // Repacking of VOLATILE and ASYNCHRONOUS is also unsafe. |
1032 | attrs.HasAny({Fortran::semantics::Attr::ASYNCHRONOUS, |
1033 | Fortran::semantics::Attr::TARGET, |
1034 | Fortran::semantics::Attr::VOLATILE})) |
1035 | return false; |
1036 | |
1037 | return true; |
1038 | } |
1039 | |
1040 | static mlir::ArrayAttr |
1041 | getSafeRepackAttrs(Fortran::lower::AbstractConverter &converter) { |
1042 | llvm::SmallVector<mlir::Attribute> attrs; |
1043 | fir::FirOpBuilder &builder = converter.getFirOpBuilder(); |
1044 | const auto &langFeatures = converter.getFoldingContext().languageFeatures(); |
1045 | if (langFeatures.IsEnabled(Fortran::common::LanguageFeature::OpenACC)) |
1046 | attrs.push_back( |
1047 | fir::OpenACCSafeTempArrayCopyAttr::get(builder.getContext())); |
1048 | if (langFeatures.IsEnabled(Fortran::common::LanguageFeature::OpenMP)) |
1049 | attrs.push_back( |
1050 | fir::OpenMPSafeTempArrayCopyAttr::get(builder.getContext())); |
1051 | |
1052 | return attrs.empty() ? mlir::ArrayAttr{} : builder.getArrayAttr(attrs); |
1053 | } |
1054 | |
1055 | /// Instantiate a local variable. Precondition: Each variable will be visited |
1056 | /// such that if its properties depend on other variables, the variables upon |
1057 | /// which its properties depend will already have been visited. |
1058 | static void instantiateLocal(Fortran::lower::AbstractConverter &converter, |
1059 | const Fortran::lower::pft::Variable &var, |
1060 | Fortran::lower::SymMap &symMap) { |
1061 | assert(!var.isAlias()); |
1062 | Fortran::lower::StatementContext stmtCtx; |
1063 | // isUnusedEntryDummy must be computed before mapSymbolAttributes. |
1064 | const bool isUnusedEntryDummy = |
1065 | var.hasSymbol() && Fortran::semantics::IsDummy(var.getSymbol()) && |
1066 | !symMap.lookupSymbol(var.getSymbol()).getAddr(); |
1067 | mapSymbolAttributes(converter, var, symMap, stmtCtx); |
1068 | // Do not generate code to initialize/finalize/destroy dummy arguments that |
1069 | // are nor part of the current ENTRY. They do not have backing storage. |
1070 | if (isUnusedEntryDummy) |
1071 | return; |
1072 | deallocateIntentOut(converter, var, symMap); |
1073 | if (needDummyIntentoutFinalization(var)) |
1074 | finalizeAtRuntime(converter, var, symMap); |
1075 | if (mustBeDefaultInitializedAtRuntime(var)) |
1076 | Fortran::lower::defaultInitializeAtRuntime(converter, var.getSymbol(), |
1077 | symMap); |
1078 | auto *builder = &converter.getFirOpBuilder(); |
1079 | if (Fortran::semantics::NeedCUDAAlloc(var.getSymbol()) && |
1080 | !cuf::isCUDADeviceContext(builder->getRegion())) { |
1081 | cuf::DataAttributeAttr dataAttr = |
1082 | Fortran::lower::translateSymbolCUFDataAttribute(builder->getContext(), |
1083 | var.getSymbol()); |
1084 | mlir::Location loc = converter.getCurrentLocation(); |
1085 | fir::ExtendedValue exv = |
1086 | converter.getSymbolExtendedValue(var.getSymbol(), &symMap); |
1087 | auto *sym = &var.getSymbol(); |
1088 | const Fortran::semantics::Scope &owner = sym->owner(); |
1089 | if (owner.kind() != Fortran::semantics::Scope::Kind::MainProgram && |
1090 | dataAttr.getValue() != cuf::DataAttribute::Shared) { |
1091 | converter.getFctCtx().attachCleanup([builder, loc, exv, sym]() { |
1092 | cuf::DataAttributeAttr dataAttr = |
1093 | Fortran::lower::translateSymbolCUFDataAttribute( |
1094 | builder->getContext(), *sym); |
1095 | builder->create<cuf::FreeOp>(loc, fir::getBase(exv), dataAttr); |
1096 | }); |
1097 | } |
1098 | } |
1099 | if (std::optional<VariableCleanUp> cleanup = |
1100 | needDeallocationOrFinalization(var)) { |
1101 | auto *builder = &converter.getFirOpBuilder(); |
1102 | mlir::Location loc = converter.getCurrentLocation(); |
1103 | fir::ExtendedValue exv = |
1104 | converter.getSymbolExtendedValue(var.getSymbol(), &symMap); |
1105 | switch (*cleanup) { |
1106 | case VariableCleanUp::Finalize: |
1107 | converter.getFctCtx().attachCleanup([builder, loc, exv]() { |
1108 | mlir::Value box = builder->createBox(loc, exv); |
1109 | fir::runtime::genDerivedTypeDestroy(*builder, loc, box); |
1110 | }); |
1111 | break; |
1112 | case VariableCleanUp::Deallocate: |
1113 | auto *converterPtr = &converter; |
1114 | auto *sym = &var.getSymbol(); |
1115 | converter.getFctCtx().attachCleanup([converterPtr, loc, exv, sym]() { |
1116 | const fir::MutableBoxValue *mutableBox = |
1117 | exv.getBoxOf<fir::MutableBoxValue>(); |
1118 | assert(mutableBox && |
1119 | "trying to deallocate entity not lowered as allocatable" ); |
1120 | Fortran::lower::genDeallocateIfAllocated(*converterPtr, *mutableBox, |
1121 | loc, sym); |
1122 | }); |
1123 | } |
1124 | } else if (var.hasSymbol() && needsRepack(converter, var.getSymbol())) { |
1125 | auto *converterPtr = &converter; |
1126 | mlir::Location loc = converter.getCurrentLocation(); |
1127 | auto *sym = &var.getSymbol(); |
1128 | std::optional<fir::FortranVariableOpInterface> varDef = |
1129 | symMap.lookupVariableDefinition(*sym); |
1130 | assert(varDef && "cannot find defining operation for an array that needs " |
1131 | "to be repacked" ); |
1132 | converter.getFctCtx().attachCleanup([converterPtr, loc, varDef, sym]() { |
1133 | Fortran::lower::genUnpackArray(*converterPtr, loc, *varDef, *sym); |
1134 | }); |
1135 | } |
1136 | } |
1137 | |
1138 | //===----------------------------------------------------------------===// |
1139 | // Aliased (EQUIVALENCE) variables instantiation |
1140 | //===----------------------------------------------------------------===// |
1141 | |
1142 | /// Insert \p aggregateStore instance into an AggregateStoreMap. |
1143 | static void insertAggregateStore(Fortran::lower::AggregateStoreMap &storeMap, |
1144 | const Fortran::lower::pft::Variable &var, |
1145 | mlir::Value aggregateStore) { |
1146 | std::size_t off = var.getAggregateStore().getOffset(); |
1147 | Fortran::lower::AggregateStoreKey key = {var.getOwningScope(), off}; |
1148 | storeMap[key] = aggregateStore; |
1149 | } |
1150 | |
1151 | /// Retrieve the aggregate store instance of \p alias from an |
1152 | /// AggregateStoreMap. |
1153 | static mlir::Value |
1154 | getAggregateStore(Fortran::lower::AggregateStoreMap &storeMap, |
1155 | const Fortran::lower::pft::Variable &alias) { |
1156 | Fortran::lower::AggregateStoreKey key = {alias.getOwningScope(), |
1157 | alias.getAliasOffset()}; |
1158 | auto iter = storeMap.find(key); |
1159 | assert(iter != storeMap.end()); |
1160 | return iter->second; |
1161 | } |
1162 | |
1163 | /// Build the name for the storage of a global equivalence. |
1164 | static std::string mangleGlobalAggregateStore( |
1165 | Fortran::lower::AbstractConverter &converter, |
1166 | const Fortran::lower::pft::Variable::AggregateStore &st) { |
1167 | return converter.mangleName(st.getNamingSymbol()); |
1168 | } |
1169 | |
1170 | /// Build the type for the storage of an equivalence. |
1171 | static mlir::Type |
1172 | getAggregateType(Fortran::lower::AbstractConverter &converter, |
1173 | const Fortran::lower::pft::Variable::AggregateStore &st) { |
1174 | if (const Fortran::semantics::Symbol *initSym = st.getInitialValueSymbol()) |
1175 | return converter.genType(*initSym); |
1176 | mlir::IntegerType byteTy = converter.getFirOpBuilder().getIntegerType(8); |
1177 | return fir::SequenceType::get(std::get<1>(st.interval), byteTy); |
1178 | } |
1179 | |
1180 | /// Define a GlobalOp for the storage of a global equivalence described |
1181 | /// by \p aggregate. The global is named \p aggName and is created with |
1182 | /// the provided \p linkage. |
1183 | /// If any of the equivalence members are initialized, an initializer is |
1184 | /// created for the equivalence. |
1185 | /// This is to be used when lowering the scope that owns the equivalence |
1186 | /// (as opposed to simply using it through host or use association). |
1187 | /// This is not to be used for equivalence of common block members (they |
1188 | /// already have the common block GlobalOp for them, see defineCommonBlock). |
1189 | static fir::GlobalOp defineGlobalAggregateStore( |
1190 | Fortran::lower::AbstractConverter &converter, |
1191 | const Fortran::lower::pft::Variable::AggregateStore &aggregate, |
1192 | llvm::StringRef aggName, mlir::StringAttr linkage) { |
1193 | assert(aggregate.isGlobal() && "not a global interval" ); |
1194 | fir::FirOpBuilder &builder = converter.getFirOpBuilder(); |
1195 | fir::GlobalOp global = builder.getNamedGlobal(aggName); |
1196 | if (global && globalIsInitialized(global)) |
1197 | return global; |
1198 | mlir::Location loc = converter.getCurrentLocation(); |
1199 | mlir::Type aggTy = getAggregateType(converter, aggregate); |
1200 | if (!global) |
1201 | global = builder.createGlobal(loc, aggTy, aggName, linkage); |
1202 | |
1203 | if (const Fortran::semantics::Symbol *initSym = |
1204 | aggregate.getInitialValueSymbol()) |
1205 | if (const auto *objectDetails = |
1206 | initSym->detailsIf<Fortran::semantics::ObjectEntityDetails>()) |
1207 | if (objectDetails->init()) { |
1208 | createGlobalInitialization( |
1209 | builder, global, [&](fir::FirOpBuilder &builder) { |
1210 | Fortran::lower::StatementContext stmtCtx; |
1211 | mlir::Value initVal = fir::getBase(genInitializerExprValue( |
1212 | converter, loc, objectDetails->init().value(), stmtCtx)); |
1213 | builder.create<fir::HasValueOp>(loc, initVal); |
1214 | }); |
1215 | return global; |
1216 | } |
1217 | // Equivalence has no Fortran initial value. Create an undefined FIR initial |
1218 | // value to ensure this is consider an object definition in the IR regardless |
1219 | // of the linkage. |
1220 | createGlobalInitialization(builder, global, [&](fir::FirOpBuilder &builder) { |
1221 | Fortran::lower::StatementContext stmtCtx; |
1222 | mlir::Value initVal = builder.create<fir::ZeroOp>(loc, aggTy); |
1223 | builder.create<fir::HasValueOp>(loc, initVal); |
1224 | }); |
1225 | return global; |
1226 | } |
1227 | |
1228 | /// Declare a GlobalOp for the storage of a global equivalence described |
1229 | /// by \p aggregate. The global is named \p aggName and is created with |
1230 | /// the provided \p linkage. |
1231 | /// No initializer is built for the created GlobalOp. |
1232 | /// This is to be used when lowering the scope that uses members of an |
1233 | /// equivalence it through host or use association. |
1234 | /// This is not to be used for equivalence of common block members (they |
1235 | /// already have the common block GlobalOp for them, see defineCommonBlock). |
1236 | static fir::GlobalOp declareGlobalAggregateStore( |
1237 | Fortran::lower::AbstractConverter &converter, mlir::Location loc, |
1238 | const Fortran::lower::pft::Variable::AggregateStore &aggregate, |
1239 | llvm::StringRef aggName, mlir::StringAttr linkage) { |
1240 | assert(aggregate.isGlobal() && "not a global interval" ); |
1241 | fir::FirOpBuilder &builder = converter.getFirOpBuilder(); |
1242 | if (fir::GlobalOp global = builder.getNamedGlobal(aggName)) |
1243 | return global; |
1244 | mlir::Type aggTy = getAggregateType(converter, aggregate); |
1245 | return builder.createGlobal(loc, aggTy, aggName, linkage); |
1246 | } |
1247 | |
1248 | /// This is an aggregate store for a set of EQUIVALENCED variables. Create the |
1249 | /// storage on the stack or global memory and add it to the map. |
1250 | static void |
1251 | instantiateAggregateStore(Fortran::lower::AbstractConverter &converter, |
1252 | const Fortran::lower::pft::Variable &var, |
1253 | Fortran::lower::AggregateStoreMap &storeMap) { |
1254 | assert(var.isAggregateStore() && "not an interval" ); |
1255 | fir::FirOpBuilder &builder = converter.getFirOpBuilder(); |
1256 | mlir::IntegerType i8Ty = builder.getIntegerType(8); |
1257 | mlir::Location loc = converter.getCurrentLocation(); |
1258 | std::string aggName = |
1259 | mangleGlobalAggregateStore(converter, var.getAggregateStore()); |
1260 | if (var.isGlobal()) { |
1261 | fir::GlobalOp global; |
1262 | auto &aggregate = var.getAggregateStore(); |
1263 | mlir::StringAttr linkage = getLinkageAttribute(builder, var); |
1264 | if (var.isModuleOrSubmoduleVariable()) { |
1265 | // A module global was or will be defined when lowering the module. Emit |
1266 | // only a declaration if the global does not exist at that point. |
1267 | global = declareGlobalAggregateStore(converter, loc, aggregate, aggName, |
1268 | linkage); |
1269 | } else { |
1270 | global = |
1271 | defineGlobalAggregateStore(converter, aggregate, aggName, linkage); |
1272 | } |
1273 | auto addr = builder.create<fir::AddrOfOp>(loc, global.resultType(), |
1274 | global.getSymbol()); |
1275 | auto size = std::get<1>(var.getInterval()); |
1276 | fir::SequenceType::Shape shape(1, size); |
1277 | auto seqTy = fir::SequenceType::get(shape, i8Ty); |
1278 | mlir::Type refTy = builder.getRefType(seqTy); |
1279 | mlir::Value aggregateStore = builder.createConvert(loc, refTy, addr); |
1280 | insertAggregateStore(storeMap, var, aggregateStore); |
1281 | return; |
1282 | } |
1283 | // This is a local aggregate, allocate an anonymous block of memory. |
1284 | auto size = std::get<1>(var.getInterval()); |
1285 | fir::SequenceType::Shape shape(1, size); |
1286 | auto seqTy = fir::SequenceType::get(shape, i8Ty); |
1287 | mlir::Value local = |
1288 | builder.allocateLocal(loc, seqTy, aggName, "" , std::nullopt, std::nullopt, |
1289 | /*target=*/false); |
1290 | insertAggregateStore(storeMap, var, local); |
1291 | } |
1292 | |
1293 | /// Cast an alias address (variable part of an equivalence) to fir.ptr so that |
1294 | /// the optimizer is conservative and avoids doing copy elision in assignment |
1295 | /// involving equivalenced variables. |
1296 | /// TODO: Represent the equivalence aliasing constraint in another way to avoid |
1297 | /// pessimizing array assignments involving equivalenced variables. |
1298 | static mlir::Value castAliasToPointer(fir::FirOpBuilder &builder, |
1299 | mlir::Location loc, mlir::Type aliasType, |
1300 | mlir::Value aliasAddr) { |
1301 | return builder.createConvert(loc, fir::PointerType::get(aliasType), |
1302 | aliasAddr); |
1303 | } |
1304 | |
1305 | /// Instantiate a member of an equivalence. Compute its address in its |
1306 | /// aggregate storage and lower its attributes. |
1307 | static void instantiateAlias(Fortran::lower::AbstractConverter &converter, |
1308 | const Fortran::lower::pft::Variable &var, |
1309 | Fortran::lower::SymMap &symMap, |
1310 | Fortran::lower::AggregateStoreMap &storeMap) { |
1311 | fir::FirOpBuilder &builder = converter.getFirOpBuilder(); |
1312 | assert(var.isAlias()); |
1313 | const Fortran::semantics::Symbol &sym = var.getSymbol(); |
1314 | const mlir::Location loc = genLocation(converter, sym); |
1315 | mlir::IndexType idxTy = builder.getIndexType(); |
1316 | mlir::IntegerType i8Ty = builder.getIntegerType(8); |
1317 | mlir::Type i8Ptr = builder.getRefType(i8Ty); |
1318 | mlir::Type symType = converter.genType(sym); |
1319 | std::size_t off = sym.GetUltimate().offset() - var.getAliasOffset(); |
1320 | mlir::Value storeAddr = getAggregateStore(storeMap, var); |
1321 | mlir::Value offset = builder.createIntegerConstant(loc, idxTy, off); |
1322 | mlir::Value bytePtr = builder.create<fir::CoordinateOp>( |
1323 | loc, i8Ptr, storeAddr, mlir::ValueRange{offset}); |
1324 | mlir::Value typedPtr = castAliasToPointer(builder, loc, symType, bytePtr); |
1325 | Fortran::lower::StatementContext stmtCtx; |
1326 | mapSymbolAttributes(converter, var, symMap, stmtCtx, typedPtr); |
1327 | // Default initialization is possible for equivalence members: see |
1328 | // F2018 19.5.3.4. Note that if several equivalenced entities have |
1329 | // default initialization, they must have the same type, and the standard |
1330 | // allows the storage to be default initialized several times (this has |
1331 | // no consequences other than wasting some execution time). For now, |
1332 | // do not try optimizing this to single default initializations of |
1333 | // the equivalenced storages. Keep lowering simple. |
1334 | if (mustBeDefaultInitializedAtRuntime(var)) |
1335 | Fortran::lower::defaultInitializeAtRuntime(converter, var.getSymbol(), |
1336 | symMap); |
1337 | } |
1338 | |
1339 | //===--------------------------------------------------------------===// |
1340 | // COMMON blocks instantiation |
1341 | //===--------------------------------------------------------------===// |
1342 | |
1343 | /// Does any member of the common block has an initializer ? |
1344 | static bool |
1345 | commonBlockHasInit(const Fortran::semantics::MutableSymbolVector &cmnBlkMems) { |
1346 | for (const Fortran::semantics::MutableSymbolRef &mem : cmnBlkMems) { |
1347 | if (const auto *memDet = |
1348 | mem->detailsIf<Fortran::semantics::ObjectEntityDetails>()) |
1349 | if (memDet->init()) |
1350 | return true; |
1351 | } |
1352 | return false; |
1353 | } |
1354 | |
1355 | /// Build a tuple type for a common block based on the common block |
1356 | /// members and the common block size. |
1357 | /// This type is only needed to build common block initializers where |
1358 | /// the initial value is the collection of the member initial values. |
1359 | static mlir::TupleType getTypeOfCommonWithInit( |
1360 | Fortran::lower::AbstractConverter &converter, |
1361 | const Fortran::semantics::MutableSymbolVector &cmnBlkMems, |
1362 | std::size_t commonSize) { |
1363 | fir::FirOpBuilder &builder = converter.getFirOpBuilder(); |
1364 | llvm::SmallVector<mlir::Type> members; |
1365 | std::size_t counter = 0; |
1366 | for (const Fortran::semantics::MutableSymbolRef &mem : cmnBlkMems) { |
1367 | if (const auto *memDet = |
1368 | mem->detailsIf<Fortran::semantics::ObjectEntityDetails>()) { |
1369 | if (mem->offset() > counter) { |
1370 | fir::SequenceType::Shape len = { |
1371 | static_cast<fir::SequenceType::Extent>(mem->offset() - counter)}; |
1372 | mlir::IntegerType byteTy = builder.getIntegerType(8); |
1373 | auto memTy = fir::SequenceType::get(len, byteTy); |
1374 | members.push_back(memTy); |
1375 | counter = mem->offset(); |
1376 | } |
1377 | if (memDet->init()) { |
1378 | mlir::Type memTy = converter.genType(*mem); |
1379 | members.push_back(memTy); |
1380 | counter = mem->offset() + mem->size(); |
1381 | } |
1382 | } |
1383 | } |
1384 | if (counter < commonSize) { |
1385 | fir::SequenceType::Shape len = { |
1386 | static_cast<fir::SequenceType::Extent>(commonSize - counter)}; |
1387 | mlir::IntegerType byteTy = builder.getIntegerType(8); |
1388 | auto memTy = fir::SequenceType::get(len, byteTy); |
1389 | members.push_back(memTy); |
1390 | } |
1391 | return mlir::TupleType::get(builder.getContext(), members); |
1392 | } |
1393 | |
1394 | /// Common block members may have aliases. They are not in the common block |
1395 | /// member list from the symbol. We need to know about these aliases if they |
1396 | /// have initializer to generate the common initializer. |
1397 | /// This function takes care of adding aliases with initializer to the member |
1398 | /// list. |
1399 | static Fortran::semantics::MutableSymbolVector |
1400 | getCommonMembersWithInitAliases(const Fortran::semantics::Symbol &common) { |
1401 | const auto &commonDetails = |
1402 | common.get<Fortran::semantics::CommonBlockDetails>(); |
1403 | auto members = commonDetails.objects(); |
1404 | |
1405 | // The number and size of equivalence and common is expected to be small, so |
1406 | // no effort is given to optimize this loop of complexity equivalenced |
1407 | // common members * common members |
1408 | for (const Fortran::semantics::EquivalenceSet &set : |
1409 | common.owner().equivalenceSets()) |
1410 | for (const Fortran::semantics::EquivalenceObject &obj : set) { |
1411 | if (!obj.symbol.test(Fortran::semantics::Symbol::Flag::CompilerCreated)) { |
1412 | if (const auto &details = |
1413 | obj.symbol |
1414 | .detailsIf<Fortran::semantics::ObjectEntityDetails>()) { |
1415 | const Fortran::semantics::Symbol *com = |
1416 | FindCommonBlockContaining(obj.symbol); |
1417 | if (!details->init() || com != &common) |
1418 | continue; |
1419 | // This is an alias with an init that belongs to the list |
1420 | if (!llvm::is_contained(members, obj.symbol)) |
1421 | members.emplace_back(obj.symbol); |
1422 | } |
1423 | } |
1424 | } |
1425 | return members; |
1426 | } |
1427 | |
1428 | /// Return the fir::GlobalOp that was created of COMMON block \p common. |
1429 | /// It is an error if the fir::GlobalOp was not created before this is |
1430 | /// called (it cannot be created on the flight because it is not known here |
1431 | /// what mlir type the GlobalOp should have to satisfy all the |
1432 | /// appearances in the program). |
1433 | static fir::GlobalOp |
1434 | getCommonBlockGlobal(Fortran::lower::AbstractConverter &converter, |
1435 | const Fortran::semantics::Symbol &common) { |
1436 | fir::FirOpBuilder &builder = converter.getFirOpBuilder(); |
1437 | std::string commonName = converter.mangleName(common); |
1438 | fir::GlobalOp global = builder.getNamedGlobal(commonName); |
1439 | // Common blocks are lowered before any subprograms to deal with common |
1440 | // whose size may not be the same in every subprograms. |
1441 | if (!global) |
1442 | fir::emitFatalError(converter.genLocation(common.name()), |
1443 | "COMMON block was not lowered before its usage" ); |
1444 | return global; |
1445 | } |
1446 | |
1447 | /// Create the fir::GlobalOp for COMMON block \p common. If \p common has an |
1448 | /// initial value, it is not created yet. Instead, the common block list |
1449 | /// members is returned to later create the initial value in |
1450 | /// finalizeCommonBlockDefinition. |
1451 | static std::optional<std::tuple< |
1452 | fir::GlobalOp, Fortran::semantics::MutableSymbolVector, mlir::Location>> |
1453 | declareCommonBlock(Fortran::lower::AbstractConverter &converter, |
1454 | const Fortran::semantics::Symbol &common, |
1455 | std::size_t commonSize) { |
1456 | fir::FirOpBuilder &builder = converter.getFirOpBuilder(); |
1457 | std::string commonName = converter.mangleName(common); |
1458 | fir::GlobalOp global = builder.getNamedGlobal(commonName); |
1459 | if (global) |
1460 | return std::nullopt; |
1461 | Fortran::semantics::MutableSymbolVector cmnBlkMems = |
1462 | getCommonMembersWithInitAliases(common); |
1463 | mlir::Location loc = converter.genLocation(common.name()); |
1464 | mlir::StringAttr linkage = builder.createCommonLinkage(); |
1465 | const auto *details = |
1466 | common.detailsIf<Fortran::semantics::CommonBlockDetails>(); |
1467 | assert(details && "Expect CommonBlockDetails on the common symbol" ); |
1468 | if (!commonBlockHasInit(cmnBlkMems)) { |
1469 | // A COMMON block sans initializers is initialized to zero. |
1470 | // mlir::Vector types must have a strictly positive size, so at least |
1471 | // temporarily, force a zero size COMMON block to have one byte. |
1472 | const auto sz = |
1473 | static_cast<fir::SequenceType::Extent>(commonSize > 0 ? commonSize : 1); |
1474 | fir::SequenceType::Shape shape = {sz}; |
1475 | mlir::IntegerType i8Ty = builder.getIntegerType(8); |
1476 | auto commonTy = fir::SequenceType::get(shape, i8Ty); |
1477 | auto vecTy = mlir::VectorType::get(sz, i8Ty); |
1478 | mlir::Attribute zero = builder.getIntegerAttr(i8Ty, 0); |
1479 | auto init = mlir::DenseElementsAttr::get(vecTy, llvm::ArrayRef(zero)); |
1480 | global = builder.createGlobal(loc, commonTy, commonName, linkage, init); |
1481 | global.setAlignment(details->alignment()); |
1482 | // No need to add any initial value later. |
1483 | return std::nullopt; |
1484 | } |
1485 | // COMMON block with initializer (note that initialized blank common are |
1486 | // accepted as an extension by semantics). Sort members by offset before |
1487 | // generating the type and initializer. |
1488 | std::sort(cmnBlkMems.begin(), cmnBlkMems.end(), |
1489 | [](auto &s1, auto &s2) { return s1->offset() < s2->offset(); }); |
1490 | mlir::TupleType commonTy = |
1491 | getTypeOfCommonWithInit(converter, cmnBlkMems, commonSize); |
1492 | // Create the global object, the initial value will be added later. |
1493 | global = builder.createGlobal(loc, commonTy, commonName); |
1494 | global.setAlignment(details->alignment()); |
1495 | return std::make_tuple(global, std::move(cmnBlkMems), loc); |
1496 | } |
1497 | |
1498 | /// Add initial value to a COMMON block fir::GlobalOp \p global given the list |
1499 | /// \p cmnBlkMems of the common block member symbols that contains symbols with |
1500 | /// an initial value. |
1501 | static void finalizeCommonBlockDefinition( |
1502 | mlir::Location loc, Fortran::lower::AbstractConverter &converter, |
1503 | fir::GlobalOp global, |
1504 | const Fortran::semantics::MutableSymbolVector &cmnBlkMems) { |
1505 | fir::FirOpBuilder &builder = converter.getFirOpBuilder(); |
1506 | mlir::TupleType commonTy = mlir::cast<mlir::TupleType>(global.getType()); |
1507 | auto initFunc = [&](fir::FirOpBuilder &builder) { |
1508 | mlir::IndexType idxTy = builder.getIndexType(); |
1509 | mlir::Value cb = builder.create<fir::ZeroOp>(loc, commonTy); |
1510 | unsigned tupIdx = 0; |
1511 | std::size_t offset = 0; |
1512 | LLVM_DEBUG(llvm::dbgs() << "block {\n" ); |
1513 | for (const Fortran::semantics::MutableSymbolRef &mem : cmnBlkMems) { |
1514 | if (const auto *memDet = |
1515 | mem->detailsIf<Fortran::semantics::ObjectEntityDetails>()) { |
1516 | if (mem->offset() > offset) { |
1517 | ++tupIdx; |
1518 | offset = mem->offset(); |
1519 | } |
1520 | if (memDet->init()) { |
1521 | LLVM_DEBUG(llvm::dbgs() |
1522 | << "offset: " << mem->offset() << " is " << *mem << '\n'); |
1523 | Fortran::lower::StatementContext stmtCtx; |
1524 | auto initExpr = memDet->init().value(); |
1525 | fir::ExtendedValue initVal = |
1526 | Fortran::semantics::IsPointer(*mem) |
1527 | ? Fortran::lower::genInitialDataTarget( |
1528 | converter, loc, converter.genType(*mem), initExpr) |
1529 | : genInitializerExprValue(converter, loc, initExpr, stmtCtx); |
1530 | mlir::IntegerAttr offVal = builder.getIntegerAttr(idxTy, tupIdx); |
1531 | mlir::Value castVal = builder.createConvert( |
1532 | loc, commonTy.getType(tupIdx), fir::getBase(initVal)); |
1533 | cb = builder.create<fir::InsertValueOp>(loc, commonTy, cb, castVal, |
1534 | builder.getArrayAttr(offVal)); |
1535 | ++tupIdx; |
1536 | offset = mem->offset() + mem->size(); |
1537 | } |
1538 | } |
1539 | } |
1540 | LLVM_DEBUG(llvm::dbgs() << "}\n" ); |
1541 | builder.create<fir::HasValueOp>(loc, cb); |
1542 | }; |
1543 | createGlobalInitialization(builder, global, initFunc); |
1544 | } |
1545 | |
1546 | void Fortran::lower::defineCommonBlocks( |
1547 | Fortran::lower::AbstractConverter &converter, |
1548 | const Fortran::semantics::CommonBlockList &commonBlocks) { |
1549 | // Common blocks may depend on another common block address (if they contain |
1550 | // pointers with initial targets). To cover this case, create all common block |
1551 | // fir::Global before creating the initial values (if any). |
1552 | std::vector<std::tuple<fir::GlobalOp, Fortran::semantics::MutableSymbolVector, |
1553 | mlir::Location>> |
1554 | delayedInitializations; |
1555 | for (const auto &[common, size] : commonBlocks) |
1556 | if (auto delayedInit = declareCommonBlock(converter, common, size)) |
1557 | delayedInitializations.emplace_back(std::move(*delayedInit)); |
1558 | for (auto &[global, cmnBlkMems, loc] : delayedInitializations) |
1559 | finalizeCommonBlockDefinition(loc, converter, global, cmnBlkMems); |
1560 | } |
1561 | |
1562 | mlir::Value Fortran::lower::genCommonBlockMember( |
1563 | Fortran::lower::AbstractConverter &converter, mlir::Location loc, |
1564 | const Fortran::semantics::Symbol &sym, mlir::Value commonValue) { |
1565 | fir::FirOpBuilder &builder = converter.getFirOpBuilder(); |
1566 | |
1567 | std::size_t byteOffset = sym.GetUltimate().offset(); |
1568 | mlir::IntegerType i8Ty = builder.getIntegerType(8); |
1569 | mlir::Type i8Ptr = builder.getRefType(i8Ty); |
1570 | mlir::Type seqTy = builder.getRefType(builder.getVarLenSeqTy(i8Ty)); |
1571 | mlir::Value base = builder.createConvert(loc, seqTy, commonValue); |
1572 | |
1573 | mlir::Value offs = |
1574 | builder.createIntegerConstant(loc, builder.getIndexType(), byteOffset); |
1575 | mlir::Value varAddr = builder.create<fir::CoordinateOp>( |
1576 | loc, i8Ptr, base, mlir::ValueRange{offs}); |
1577 | mlir::Type symType = converter.genType(sym); |
1578 | |
1579 | return Fortran::semantics::FindEquivalenceSet(sym) != nullptr |
1580 | ? castAliasToPointer(builder, loc, symType, varAddr) |
1581 | : builder.createConvert(loc, builder.getRefType(symType), varAddr); |
1582 | } |
1583 | |
1584 | /// The COMMON block is a global structure. `var` will be at some offset |
1585 | /// within the COMMON block. Adds the address of `var` (COMMON + offset) to |
1586 | /// the symbol map. |
1587 | static void instantiateCommon(Fortran::lower::AbstractConverter &converter, |
1588 | const Fortran::semantics::Symbol &common, |
1589 | const Fortran::lower::pft::Variable &var, |
1590 | Fortran::lower::SymMap &symMap) { |
1591 | fir::FirOpBuilder &builder = converter.getFirOpBuilder(); |
1592 | const Fortran::semantics::Symbol &varSym = var.getSymbol(); |
1593 | mlir::Location loc = converter.genLocation(varSym.name()); |
1594 | |
1595 | mlir::Value commonAddr; |
1596 | if (Fortran::lower::SymbolBox symBox = symMap.lookupSymbol(common)) |
1597 | commonAddr = symBox.getAddr(); |
1598 | if (!commonAddr) { |
1599 | // introduce a local AddrOf and add it to the map |
1600 | fir::GlobalOp global = getCommonBlockGlobal(converter, common); |
1601 | commonAddr = builder.create<fir::AddrOfOp>(loc, global.resultType(), |
1602 | global.getSymbol()); |
1603 | |
1604 | symMap.addSymbol(common, commonAddr); |
1605 | } |
1606 | |
1607 | mlir::Value local = genCommonBlockMember(converter, loc, varSym, commonAddr); |
1608 | Fortran::lower::StatementContext stmtCtx; |
1609 | mapSymbolAttributes(converter, var, symMap, stmtCtx, local); |
1610 | } |
1611 | |
1612 | //===--------------------------------------------------------------===// |
1613 | // Lower Variables specification expressions and attributes |
1614 | //===--------------------------------------------------------------===// |
1615 | |
1616 | /// Helper to decide if a dummy argument must be tracked in an BoxValue. |
1617 | static bool lowerToBoxValue(const Fortran::semantics::Symbol &sym, |
1618 | mlir::Value dummyArg, |
1619 | Fortran::lower::AbstractConverter &converter) { |
1620 | // Only dummy arguments coming as fir.box can be tracked in an BoxValue. |
1621 | if (!dummyArg || !mlir::isa<fir::BaseBoxType>(dummyArg.getType())) |
1622 | return false; |
1623 | // Non contiguous arrays must be tracked in an BoxValue. |
1624 | if (sym.Rank() > 0 && !Fortran::evaluate::IsSimplyContiguous( |
1625 | sym, converter.getFoldingContext())) |
1626 | return true; |
1627 | // Assumed rank and optional fir.box cannot yet be read while lowering the |
1628 | // specifications. |
1629 | if (Fortran::evaluate::IsAssumedRank(sym) || |
1630 | Fortran::semantics::IsOptional(sym)) |
1631 | return true; |
1632 | // Polymorphic entity should be tracked through a fir.box that has the |
1633 | // dynamic type info. |
1634 | if (const Fortran::semantics::DeclTypeSpec *type = sym.GetType()) |
1635 | if (type->IsPolymorphic()) |
1636 | return true; |
1637 | return false; |
1638 | } |
1639 | |
1640 | /// Lower explicit lower bounds into \p result. Does nothing if this is not an |
1641 | /// array, or if the lower bounds are deferred, or all implicit or one. |
1642 | static void lowerExplicitLowerBounds( |
1643 | Fortran::lower::AbstractConverter &converter, mlir::Location loc, |
1644 | const Fortran::lower::BoxAnalyzer &box, |
1645 | llvm::SmallVectorImpl<mlir::Value> &result, Fortran::lower::SymMap &symMap, |
1646 | Fortran::lower::StatementContext &stmtCtx) { |
1647 | if (!box.isArray() || box.lboundIsAllOnes()) |
1648 | return; |
1649 | fir::FirOpBuilder &builder = converter.getFirOpBuilder(); |
1650 | mlir::IndexType idxTy = builder.getIndexType(); |
1651 | if (box.isStaticArray()) { |
1652 | for (int64_t lb : box.staticLBound()) |
1653 | result.emplace_back(builder.createIntegerConstant(loc, idxTy, lb)); |
1654 | return; |
1655 | } |
1656 | for (const Fortran::semantics::ShapeSpec *spec : box.dynamicBound()) { |
1657 | if (auto low = spec->lbound().GetExplicit()) { |
1658 | auto expr = Fortran::lower::SomeExpr{*low}; |
1659 | mlir::Value lb = builder.createConvert( |
1660 | loc, idxTy, genScalarValue(converter, loc, expr, symMap, stmtCtx)); |
1661 | result.emplace_back(lb); |
1662 | } |
1663 | } |
1664 | assert(result.empty() || result.size() == box.dynamicBound().size()); |
1665 | } |
1666 | |
1667 | /// Return -1 for the last dimension extent/upper bound of assumed-size arrays. |
1668 | /// This value is required to fulfill the requirements for assumed-rank |
1669 | /// associated with assumed-size (see for instance UBOUND in 16.9.196, and |
1670 | /// CFI_desc_t requirements in 18.5.3 point 5.). |
1671 | static mlir::Value getAssumedSizeExtent(mlir::Location loc, |
1672 | fir::FirOpBuilder &builder) { |
1673 | return builder.createMinusOneInteger(loc, builder.getIndexType()); |
1674 | } |
1675 | |
1676 | /// Lower explicit extents into \p result if this is an explicit-shape or |
1677 | /// assumed-size array. Does nothing if this is not an explicit-shape or |
1678 | /// assumed-size array. |
1679 | static void |
1680 | lowerExplicitExtents(Fortran::lower::AbstractConverter &converter, |
1681 | mlir::Location loc, const Fortran::lower::BoxAnalyzer &box, |
1682 | llvm::SmallVectorImpl<mlir::Value> &lowerBounds, |
1683 | llvm::SmallVectorImpl<mlir::Value> &result, |
1684 | Fortran::lower::SymMap &symMap, |
1685 | Fortran::lower::StatementContext &stmtCtx) { |
1686 | if (!box.isArray()) |
1687 | return; |
1688 | fir::FirOpBuilder &builder = converter.getFirOpBuilder(); |
1689 | mlir::IndexType idxTy = builder.getIndexType(); |
1690 | if (box.isStaticArray()) { |
1691 | for (int64_t extent : box.staticShape()) |
1692 | result.emplace_back(builder.createIntegerConstant(loc, idxTy, extent)); |
1693 | return; |
1694 | } |
1695 | for (const auto &spec : llvm::enumerate(box.dynamicBound())) { |
1696 | if (auto up = spec.value()->ubound().GetExplicit()) { |
1697 | auto expr = Fortran::lower::SomeExpr{*up}; |
1698 | mlir::Value ub = builder.createConvert( |
1699 | loc, idxTy, genScalarValue(converter, loc, expr, symMap, stmtCtx)); |
1700 | if (lowerBounds.empty()) |
1701 | result.emplace_back(fir::factory::genMaxWithZero(builder, loc, ub)); |
1702 | else |
1703 | result.emplace_back(fir::factory::computeExtent( |
1704 | builder, loc, lowerBounds[spec.index()], ub)); |
1705 | } else if (spec.value()->ubound().isStar()) { |
1706 | result.emplace_back(getAssumedSizeExtent(loc, builder)); |
1707 | } |
1708 | } |
1709 | assert(result.empty() || result.size() == box.dynamicBound().size()); |
1710 | } |
1711 | |
1712 | /// Lower explicit character length if any. Return empty mlir::Value if no |
1713 | /// explicit length. |
1714 | static mlir::Value |
1715 | lowerExplicitCharLen(Fortran::lower::AbstractConverter &converter, |
1716 | mlir::Location loc, const Fortran::lower::BoxAnalyzer &box, |
1717 | Fortran::lower::SymMap &symMap, |
1718 | Fortran::lower::StatementContext &stmtCtx) { |
1719 | if (!box.isChar()) |
1720 | return mlir::Value{}; |
1721 | fir::FirOpBuilder &builder = converter.getFirOpBuilder(); |
1722 | mlir::Type lenTy = builder.getCharacterLengthType(); |
1723 | if (std::optional<int64_t> len = box.getCharLenConst()) |
1724 | return builder.createIntegerConstant(loc, lenTy, *len); |
1725 | if (std::optional<Fortran::lower::SomeExpr> lenExpr = box.getCharLenExpr()) |
1726 | // If the length expression is negative, the length is zero. See F2018 |
1727 | // 7.4.4.2 point 5. |
1728 | return fir::factory::genMaxWithZero( |
1729 | builder, loc, |
1730 | genScalarValue(converter, loc, *lenExpr, symMap, stmtCtx)); |
1731 | return mlir::Value{}; |
1732 | } |
1733 | |
1734 | /// Assumed size arrays last extent is -1 in the front end. |
1735 | static mlir::Value genExtentValue(fir::FirOpBuilder &builder, |
1736 | mlir::Location loc, mlir::Type idxTy, |
1737 | long frontEndExtent) { |
1738 | if (frontEndExtent >= 0) |
1739 | return builder.createIntegerConstant(loc, idxTy, frontEndExtent); |
1740 | return getAssumedSizeExtent(loc, builder); |
1741 | } |
1742 | |
1743 | /// If a symbol is an array, it may have been declared with unknown extent |
1744 | /// parameters (e.g., `*`), but if it has an initial value then the actual size |
1745 | /// may be available from the initial array value's type. |
1746 | inline static llvm::SmallVector<std::int64_t> |
1747 | recoverShapeVector(llvm::ArrayRef<std::int64_t> shapeVec, mlir::Value initVal) { |
1748 | llvm::SmallVector<std::int64_t> result; |
1749 | if (initVal) { |
1750 | if (auto seqTy = fir::unwrapUntilSeqType(initVal.getType())) { |
1751 | for (auto [fst, snd] : llvm::zip(shapeVec, seqTy.getShape())) |
1752 | result.push_back(fst == fir::SequenceType::getUnknownExtent() ? snd |
1753 | : fst); |
1754 | return result; |
1755 | } |
1756 | } |
1757 | result.assign(shapeVec.begin(), shapeVec.end()); |
1758 | return result; |
1759 | } |
1760 | |
1761 | fir::FortranVariableFlagsAttr Fortran::lower::translateSymbolAttributes( |
1762 | mlir::MLIRContext *mlirContext, const Fortran::semantics::Symbol &sym, |
1763 | fir::FortranVariableFlagsEnum extraFlags) { |
1764 | fir::FortranVariableFlagsEnum flags = extraFlags; |
1765 | if (sym.test(Fortran::semantics::Symbol::Flag::CrayPointee)) { |
1766 | // CrayPointee are represented as pointers. |
1767 | flags = flags | fir::FortranVariableFlagsEnum::pointer; |
1768 | return fir::FortranVariableFlagsAttr::get(mlirContext, flags); |
1769 | } |
1770 | const auto &attrs = sym.attrs(); |
1771 | if (attrs.test(Fortran::semantics::Attr::ALLOCATABLE)) |
1772 | flags = flags | fir::FortranVariableFlagsEnum::allocatable; |
1773 | if (attrs.test(Fortran::semantics::Attr::ASYNCHRONOUS)) |
1774 | flags = flags | fir::FortranVariableFlagsEnum::asynchronous; |
1775 | if (attrs.test(Fortran::semantics::Attr::BIND_C)) |
1776 | flags = flags | fir::FortranVariableFlagsEnum::bind_c; |
1777 | if (attrs.test(Fortran::semantics::Attr::CONTIGUOUS)) |
1778 | flags = flags | fir::FortranVariableFlagsEnum::contiguous; |
1779 | if (attrs.test(Fortran::semantics::Attr::INTENT_IN)) |
1780 | flags = flags | fir::FortranVariableFlagsEnum::intent_in; |
1781 | if (attrs.test(Fortran::semantics::Attr::INTENT_INOUT)) |
1782 | flags = flags | fir::FortranVariableFlagsEnum::intent_inout; |
1783 | if (attrs.test(Fortran::semantics::Attr::INTENT_OUT)) |
1784 | flags = flags | fir::FortranVariableFlagsEnum::intent_out; |
1785 | if (attrs.test(Fortran::semantics::Attr::OPTIONAL)) |
1786 | flags = flags | fir::FortranVariableFlagsEnum::optional; |
1787 | if (attrs.test(Fortran::semantics::Attr::PARAMETER)) |
1788 | flags = flags | fir::FortranVariableFlagsEnum::parameter; |
1789 | if (attrs.test(Fortran::semantics::Attr::POINTER)) |
1790 | flags = flags | fir::FortranVariableFlagsEnum::pointer; |
1791 | if (attrs.test(Fortran::semantics::Attr::TARGET)) |
1792 | flags = flags | fir::FortranVariableFlagsEnum::target; |
1793 | if (attrs.test(Fortran::semantics::Attr::VALUE)) |
1794 | flags = flags | fir::FortranVariableFlagsEnum::value; |
1795 | if (attrs.test(Fortran::semantics::Attr::VOLATILE)) |
1796 | flags = flags | fir::FortranVariableFlagsEnum::fortran_volatile; |
1797 | if (flags == fir::FortranVariableFlagsEnum::None) |
1798 | return {}; |
1799 | return fir::FortranVariableFlagsAttr::get(mlirContext, flags); |
1800 | } |
1801 | |
1802 | cuf::DataAttributeAttr Fortran::lower::translateSymbolCUFDataAttribute( |
1803 | mlir::MLIRContext *mlirContext, const Fortran::semantics::Symbol &sym) { |
1804 | std::optional<Fortran::common::CUDADataAttr> cudaAttr = |
1805 | Fortran::semantics::GetCUDADataAttr(&sym.GetUltimate()); |
1806 | return cuf::getDataAttribute(mlirContext, cudaAttr); |
1807 | } |
1808 | |
1809 | static bool |
1810 | isCapturedInInternalProcedure(Fortran::lower::AbstractConverter &converter, |
1811 | const Fortran::semantics::Symbol &sym) { |
1812 | const Fortran::lower::pft::FunctionLikeUnit *funit = |
1813 | converter.getCurrentFunctionUnit(); |
1814 | if (!funit || funit->getHostAssoc().empty()) |
1815 | return false; |
1816 | if (funit->getHostAssoc().isAssociated(sym)) |
1817 | return true; |
1818 | // Consider that any capture of a variable that is in an equivalence with the |
1819 | // symbol imply that the storage of the symbol may also be accessed inside |
1820 | // symbol implies that the storage of the symbol may also be accessed inside |
1821 | |
1822 | // the internal procedure and flag it as captured. |
1823 | if (const auto *equivSet = Fortran::semantics::FindEquivalenceSet(sym)) |
1824 | for (const Fortran::semantics::EquivalenceObject &eqObj : *equivSet) |
1825 | if (funit->getHostAssoc().isAssociated(eqObj.symbol)) |
1826 | return true; |
1827 | return false; |
1828 | } |
1829 | |
1830 | /// Map a symbol to its FIR address and evaluated specification expressions. |
1831 | /// Not for symbols lowered to fir.box. |
1832 | /// Will optionally create fir.declare. |
1833 | static void genDeclareSymbol(Fortran::lower::AbstractConverter &converter, |
1834 | Fortran::lower::SymMap &symMap, |
1835 | const Fortran::semantics::Symbol &sym, |
1836 | mlir::Value base, mlir::Value len = {}, |
1837 | llvm::ArrayRef<mlir::Value> shape = std::nullopt, |
1838 | llvm::ArrayRef<mlir::Value> lbounds = std::nullopt, |
1839 | bool force = false) { |
1840 | // In HLFIR, procedure dummy symbols are not added with an hlfir.declare |
1841 | // because they are "values", and hlfir.declare is intended for variables. It |
1842 | // would add too much complexity to hlfir.declare to support this case, and |
1843 | // this would bring very little (the only point being debug info, that are not |
1844 | // yet emitted) since alias analysis is meaningless for those. |
1845 | // Commonblock names are not variables, but in some lowerings (like OpenMP) it |
1846 | // is useful to maintain the address of the commonblock in an MLIR value and |
1847 | // query it. hlfir.declare need not be created for these. |
1848 | if (converter.getLoweringOptions().getLowerToHighLevelFIR() && |
1849 | (!Fortran::semantics::IsProcedure(sym) || |
1850 | Fortran::semantics::IsPointer(sym)) && |
1851 | !sym.detailsIf<Fortran::semantics::CommonBlockDetails>()) { |
1852 | fir::FirOpBuilder &builder = converter.getFirOpBuilder(); |
1853 | const mlir::Location loc = genLocation(converter, sym); |
1854 | mlir::Value shapeOrShift; |
1855 | if (!shape.empty() && !lbounds.empty()) |
1856 | shapeOrShift = builder.genShape(loc, lbounds, shape); |
1857 | else if (!shape.empty()) |
1858 | shapeOrShift = builder.genShape(loc, shape); |
1859 | else if (!lbounds.empty()) |
1860 | shapeOrShift = builder.genShift(loc, lbounds); |
1861 | llvm::SmallVector<mlir::Value> lenParams; |
1862 | if (len) |
1863 | lenParams.emplace_back(len); |
1864 | auto name = converter.mangleName(sym); |
1865 | fir::FortranVariableFlagsEnum extraFlags = {}; |
1866 | if (isCapturedInInternalProcedure(converter, sym)) |
1867 | extraFlags = extraFlags | fir::FortranVariableFlagsEnum::internal_assoc; |
1868 | fir::FortranVariableFlagsAttr attributes = |
1869 | Fortran::lower::translateSymbolAttributes(builder.getContext(), sym, |
1870 | extraFlags); |
1871 | cuf::DataAttributeAttr dataAttr = |
1872 | Fortran::lower::translateSymbolCUFDataAttribute(builder.getContext(), |
1873 | sym); |
1874 | |
1875 | if (sym.test(Fortran::semantics::Symbol::Flag::CrayPointee)) { |
1876 | mlir::Type ptrBoxType = |
1877 | Fortran::lower::getCrayPointeeBoxType(base.getType()); |
1878 | mlir::Value boxAlloc = builder.createTemporary( |
1879 | loc, ptrBoxType, |
1880 | /*name=*/{}, /*shape=*/{}, /*lenParams=*/{}, /*attrs=*/{}, |
1881 | Fortran::semantics::GetCUDADataAttr(&sym.GetUltimate())); |
1882 | |
1883 | // Declare a local pointer variable. |
1884 | auto newBase = builder.create<hlfir::DeclareOp>( |
1885 | loc, boxAlloc, name, /*shape=*/nullptr, lenParams, |
1886 | /*dummy_scope=*/nullptr, attributes); |
1887 | mlir::Value nullAddr = builder.createNullConstant( |
1888 | loc, llvm::cast<fir::BaseBoxType>(ptrBoxType).getEleTy()); |
1889 | |
1890 | // If the element type is known-length character, then |
1891 | // EmboxOp does not need the length parameters. |
1892 | if (auto charType = mlir::dyn_cast<fir::CharacterType>( |
1893 | hlfir::getFortranElementType(base.getType()))) |
1894 | if (!charType.hasDynamicLen()) |
1895 | lenParams.clear(); |
1896 | |
1897 | // Inherit the shape (and maybe length parameters) from the pointee |
1898 | // declaration. |
1899 | mlir::Value initVal = |
1900 | builder.create<fir::EmboxOp>(loc, ptrBoxType, nullAddr, shapeOrShift, |
1901 | /*slice=*/nullptr, lenParams); |
1902 | builder.create<fir::StoreOp>(loc, initVal, newBase.getBase()); |
1903 | |
1904 | // Any reference to the pointee is going to be using the pointer |
1905 | // box from now on. The base_addr of the descriptor must be updated |
1906 | // to hold the value of the Cray pointer at the point of the pointee |
1907 | // access. |
1908 | // Note that the same Cray pointer may be associated with |
1909 | // multiple pointees and each of them has its own descriptor. |
1910 | symMap.addVariableDefinition(sym, newBase, force); |
1911 | return; |
1912 | } |
1913 | mlir::Value dummyScope; |
1914 | if (converter.isRegisteredDummySymbol(sym)) |
1915 | dummyScope = converter.dummyArgsScopeValue(); |
1916 | auto newBase = builder.create<hlfir::DeclareOp>( |
1917 | loc, base, name, shapeOrShift, lenParams, dummyScope, attributes, |
1918 | dataAttr); |
1919 | symMap.addVariableDefinition(sym, newBase, force); |
1920 | return; |
1921 | } |
1922 | |
1923 | if (len) { |
1924 | if (!shape.empty()) { |
1925 | if (!lbounds.empty()) |
1926 | symMap.addCharSymbolWithBounds(sym, base, len, shape, lbounds, force); |
1927 | else |
1928 | symMap.addCharSymbolWithShape(sym, base, len, shape, force); |
1929 | } else { |
1930 | symMap.addCharSymbol(sym, base, len, force); |
1931 | } |
1932 | } else { |
1933 | if (!shape.empty()) { |
1934 | if (!lbounds.empty()) |
1935 | symMap.addSymbolWithBounds(sym, base, shape, lbounds, force); |
1936 | else |
1937 | symMap.addSymbolWithShape(sym, base, shape, force); |
1938 | } else { |
1939 | symMap.addSymbol(sym, base, force); |
1940 | } |
1941 | } |
1942 | } |
1943 | |
1944 | /// Map a symbol to its FIR address and evaluated specification expressions |
1945 | /// provided as a fir::ExtendedValue. Will optionally create fir.declare. |
1946 | void Fortran::lower::genDeclareSymbol( |
1947 | Fortran::lower::AbstractConverter &converter, |
1948 | Fortran::lower::SymMap &symMap, const Fortran::semantics::Symbol &sym, |
1949 | const fir::ExtendedValue &exv, fir::FortranVariableFlagsEnum extraFlags, |
1950 | bool force) { |
1951 | if (converter.getLoweringOptions().getLowerToHighLevelFIR() && |
1952 | (!Fortran::semantics::IsProcedure(sym) || |
1953 | Fortran::semantics::IsPointer(sym.GetUltimate())) && |
1954 | !sym.detailsIf<Fortran::semantics::CommonBlockDetails>()) { |
1955 | fir::FirOpBuilder &builder = converter.getFirOpBuilder(); |
1956 | const mlir::Location loc = genLocation(converter, sym); |
1957 | if (isCapturedInInternalProcedure(converter, sym)) |
1958 | extraFlags = extraFlags | fir::FortranVariableFlagsEnum::internal_assoc; |
1959 | // FIXME: Using the ultimate symbol for translating symbol attributes will |
1960 | // lead to situations where the VOLATILE/ASYNCHRONOUS attributes are not |
1961 | // propagated to the hlfir.declare (these attributes can be added when |
1962 | // using module variables). |
1963 | fir::FortranVariableFlagsAttr attributes = |
1964 | Fortran::lower::translateSymbolAttributes( |
1965 | builder.getContext(), sym.GetUltimate(), extraFlags); |
1966 | cuf::DataAttributeAttr dataAttr = |
1967 | Fortran::lower::translateSymbolCUFDataAttribute(builder.getContext(), |
1968 | sym.GetUltimate()); |
1969 | auto name = converter.mangleName(sym); |
1970 | mlir::Value dummyScope; |
1971 | fir::ExtendedValue base = exv; |
1972 | if (converter.isRegisteredDummySymbol(sym)) { |
1973 | base = genPackArray(converter, sym, exv); |
1974 | dummyScope = converter.dummyArgsScopeValue(); |
1975 | } |
1976 | hlfir::EntityWithAttributes declare = hlfir::genDeclare( |
1977 | loc, builder, base, name, attributes, dummyScope, dataAttr); |
1978 | symMap.addVariableDefinition(sym, declare.getIfVariableInterface(), force); |
1979 | return; |
1980 | } |
1981 | symMap.addSymbol(sym, exv, force); |
1982 | } |
1983 | |
1984 | /// Map an allocatable or pointer symbol to its FIR address and evaluated |
1985 | /// specification expressions. Will optionally create fir.declare. |
1986 | static void |
1987 | genAllocatableOrPointerDeclare(Fortran::lower::AbstractConverter &converter, |
1988 | Fortran::lower::SymMap &symMap, |
1989 | const Fortran::semantics::Symbol &sym, |
1990 | fir::MutableBoxValue box, bool force = false) { |
1991 | if (!converter.getLoweringOptions().getLowerToHighLevelFIR()) { |
1992 | symMap.addAllocatableOrPointer(sym, box, force); |
1993 | return; |
1994 | } |
1995 | assert(!box.isDescribedByVariables() && |
1996 | "HLFIR alloctables/pointers must be fir.ref<fir.box>" ); |
1997 | mlir::Value base = box.getAddr(); |
1998 | mlir::Value explictLength; |
1999 | if (box.hasNonDeferredLenParams()) { |
2000 | if (!box.isCharacter()) |
2001 | TODO(genLocation(converter, sym), |
2002 | "Pointer or Allocatable parametrized derived type" ); |
2003 | explictLength = box.nonDeferredLenParams()[0]; |
2004 | } |
2005 | genDeclareSymbol(converter, symMap, sym, base, explictLength, |
2006 | /*shape=*/std::nullopt, |
2007 | /*lbounds=*/std::nullopt, force); |
2008 | } |
2009 | |
2010 | /// Map a procedure pointer |
2011 | static void genProcPointer(Fortran::lower::AbstractConverter &converter, |
2012 | Fortran::lower::SymMap &symMap, |
2013 | const Fortran::semantics::Symbol &sym, |
2014 | mlir::Value addr, bool force = false) { |
2015 | genDeclareSymbol(converter, symMap, sym, addr, mlir::Value{}, |
2016 | /*shape=*/std::nullopt, |
2017 | /*lbounds=*/std::nullopt, force); |
2018 | } |
2019 | |
2020 | /// Map a symbol represented with a runtime descriptor to its FIR fir.box and |
2021 | /// evaluated specification expressions. Will optionally create fir.declare. |
2022 | static void genBoxDeclare(Fortran::lower::AbstractConverter &converter, |
2023 | Fortran::lower::SymMap &symMap, |
2024 | const Fortran::semantics::Symbol &sym, |
2025 | mlir::Value box, llvm::ArrayRef<mlir::Value> lbounds, |
2026 | llvm::ArrayRef<mlir::Value> explicitParams, |
2027 | llvm::ArrayRef<mlir::Value> explicitExtents, |
2028 | bool replace = false) { |
2029 | if (converter.getLoweringOptions().getLowerToHighLevelFIR()) { |
2030 | fir::BoxValue boxValue{box, lbounds, explicitParams, explicitExtents}; |
2031 | Fortran::lower::genDeclareSymbol( |
2032 | converter, symMap, sym, std::move(boxValue), |
2033 | fir::FortranVariableFlagsEnum::None, replace); |
2034 | return; |
2035 | } |
2036 | symMap.addBoxSymbol(sym, box, lbounds, explicitParams, explicitExtents, |
2037 | replace); |
2038 | } |
2039 | |
2040 | /// Lower specification expressions and attributes of variable \p var and |
2041 | /// add it to the symbol map. For a global or an alias, the address must be |
2042 | /// pre-computed and provided in \p preAlloc. A dummy argument for the current |
2043 | /// entry point has already been mapped to an mlir block argument in |
2044 | /// mapDummiesAndResults. Its mapping may be updated here. |
2045 | void Fortran::lower::mapSymbolAttributes( |
2046 | AbstractConverter &converter, const Fortran::lower::pft::Variable &var, |
2047 | Fortran::lower::SymMap &symMap, Fortran::lower::StatementContext &stmtCtx, |
2048 | mlir::Value preAlloc) { |
2049 | fir::FirOpBuilder &builder = converter.getFirOpBuilder(); |
2050 | const Fortran::semantics::Symbol &sym = var.getSymbol(); |
2051 | const mlir::Location loc = genLocation(converter, sym); |
2052 | mlir::IndexType idxTy = builder.getIndexType(); |
2053 | const bool isDeclaredDummy = Fortran::semantics::IsDummy(sym); |
2054 | // An active dummy from the current entry point. |
2055 | const bool isDummy = isDeclaredDummy && symMap.lookupSymbol(sym).getAddr(); |
2056 | // An unused dummy from another entry point. |
2057 | const bool isUnusedEntryDummy = isDeclaredDummy && !isDummy; |
2058 | const bool isResult = Fortran::semantics::IsFunctionResult(sym); |
2059 | const bool replace = isDummy || isResult; |
2060 | fir::factory::CharacterExprHelper charHelp{builder, loc}; |
2061 | |
2062 | if (Fortran::semantics::IsProcedure(sym)) { |
2063 | if (isUnusedEntryDummy) { |
2064 | // Additional discussion below. |
2065 | mlir::Type dummyProcType = |
2066 | Fortran::lower::getDummyProcedureType(sym, converter); |
2067 | mlir::Value undefOp = builder.create<fir::UndefOp>(loc, dummyProcType); |
2068 | |
2069 | Fortran::lower::genDeclareSymbol(converter, symMap, sym, undefOp); |
2070 | } |
2071 | |
2072 | // Procedure pointer. |
2073 | if (Fortran::semantics::IsPointer(sym)) { |
2074 | // global |
2075 | mlir::Value boxAlloc = preAlloc; |
2076 | // dummy or passed result |
2077 | if (!boxAlloc) |
2078 | if (Fortran::lower::SymbolBox symbox = symMap.lookupSymbol(sym)) |
2079 | boxAlloc = symbox.getAddr(); |
2080 | // local |
2081 | if (!boxAlloc) |
2082 | boxAlloc = createNewLocal(converter, loc, var, preAlloc); |
2083 | genProcPointer(converter, symMap, sym, boxAlloc, replace); |
2084 | } |
2085 | return; |
2086 | } |
2087 | |
2088 | const bool isAssumedRank = Fortran::evaluate::IsAssumedRank(sym); |
2089 | if (isAssumedRank && !allowAssumedRank) |
2090 | TODO(loc, "assumed-rank variable in procedure implemented in Fortran" ); |
2091 | |
2092 | Fortran::lower::BoxAnalyzer ba; |
2093 | ba.analyze(sym); |
2094 | |
2095 | // First deal with pointers and allocatables, because their handling here |
2096 | // is the same regardless of their rank. |
2097 | if (Fortran::semantics::IsAllocatableOrPointer(sym)) { |
2098 | // Get address of fir.box describing the entity. |
2099 | // global |
2100 | mlir::Value boxAlloc = preAlloc; |
2101 | // dummy or passed result |
2102 | if (!boxAlloc) |
2103 | if (Fortran::lower::SymbolBox symbox = symMap.lookupSymbol(sym)) |
2104 | boxAlloc = symbox.getAddr(); |
2105 | assert((boxAlloc || !isAssumedRank) && "assumed-ranks cannot be local" ); |
2106 | // local |
2107 | if (!boxAlloc) |
2108 | boxAlloc = createNewLocal(converter, loc, var, preAlloc); |
2109 | // Lower non deferred parameters. |
2110 | llvm::SmallVector<mlir::Value> nonDeferredLenParams; |
2111 | if (ba.isChar()) { |
2112 | if (mlir::Value len = |
2113 | lowerExplicitCharLen(converter, loc, ba, symMap, stmtCtx)) |
2114 | nonDeferredLenParams.push_back(len); |
2115 | else if (Fortran::semantics::IsAssumedLengthCharacter(sym)) |
2116 | nonDeferredLenParams.push_back( |
2117 | Fortran::lower::getAssumedCharAllocatableOrPointerLen( |
2118 | builder, loc, sym, boxAlloc)); |
2119 | } else if (const Fortran::semantics::DeclTypeSpec *declTy = sym.GetType()) { |
2120 | if (const Fortran::semantics::DerivedTypeSpec *derived = |
2121 | declTy->AsDerived()) |
2122 | if (Fortran::semantics::CountLenParameters(*derived) != 0) |
2123 | TODO(loc, |
2124 | "derived type allocatable or pointer with length parameters" ); |
2125 | } |
2126 | fir::MutableBoxValue box = Fortran::lower::createMutableBox( |
2127 | converter, loc, var, boxAlloc, nonDeferredLenParams, |
2128 | /*alwaysUseBox=*/ |
2129 | converter.getLoweringOptions().getLowerToHighLevelFIR(), |
2130 | Fortran::lower::getAllocatorIdx(var.getSymbol())); |
2131 | genAllocatableOrPointerDeclare(converter, symMap, var.getSymbol(), box, |
2132 | replace); |
2133 | return; |
2134 | } |
2135 | |
2136 | if (isDummy) { |
2137 | mlir::Value dummyArg = symMap.lookupSymbol(sym).getAddr(); |
2138 | if (lowerToBoxValue(sym, dummyArg, converter)) { |
2139 | llvm::SmallVector<mlir::Value> lbounds; |
2140 | llvm::SmallVector<mlir::Value> explicitExtents; |
2141 | llvm::SmallVector<mlir::Value> explicitParams; |
2142 | // Lower lower bounds, explicit type parameters and explicit |
2143 | // extents if any. |
2144 | if (ba.isChar()) { |
2145 | if (mlir::Value len = |
2146 | lowerExplicitCharLen(converter, loc, ba, symMap, stmtCtx)) |
2147 | explicitParams.push_back(len); |
2148 | if (!isAssumedRank && sym.Rank() == 0) { |
2149 | // Do not keep scalar characters as fir.box (even when optional). |
2150 | // Lowering and FIR is not meant to deal with scalar characters as |
2151 | // fir.box outside of calls. |
2152 | auto boxTy = mlir::dyn_cast<fir::BaseBoxType>(dummyArg.getType()); |
2153 | mlir::Type refTy = builder.getRefType(boxTy.getEleTy()); |
2154 | mlir::Type lenType = builder.getCharacterLengthType(); |
2155 | mlir::Value addr, len; |
2156 | if (Fortran::semantics::IsOptional(sym)) { |
2157 | auto isPresent = builder.create<fir::IsPresentOp>( |
2158 | loc, builder.getI1Type(), dummyArg); |
2159 | auto addrAndLen = |
2160 | builder |
2161 | .genIfOp(loc, {refTy, lenType}, isPresent, |
2162 | /*withElseRegion=*/true) |
2163 | .genThen([&]() { |
2164 | mlir::Value readAddr = |
2165 | builder.create<fir::BoxAddrOp>(loc, refTy, dummyArg); |
2166 | mlir::Value readLength = |
2167 | charHelp.readLengthFromBox(dummyArg); |
2168 | builder.create<fir::ResultOp>( |
2169 | loc, mlir::ValueRange{readAddr, readLength}); |
2170 | }) |
2171 | .genElse([&] { |
2172 | mlir::Value readAddr = builder.genAbsentOp(loc, refTy); |
2173 | mlir::Value readLength = |
2174 | fir::factory::createZeroValue(builder, loc, lenType); |
2175 | builder.create<fir::ResultOp>( |
2176 | loc, mlir::ValueRange{readAddr, readLength}); |
2177 | }) |
2178 | .getResults(); |
2179 | addr = addrAndLen[0]; |
2180 | len = addrAndLen[1]; |
2181 | } else { |
2182 | addr = builder.create<fir::BoxAddrOp>(loc, refTy, dummyArg); |
2183 | len = charHelp.readLengthFromBox(dummyArg); |
2184 | } |
2185 | if (!explicitParams.empty()) |
2186 | len = explicitParams[0]; |
2187 | ::genDeclareSymbol(converter, symMap, sym, addr, len, /*extents=*/{}, |
2188 | /*lbounds=*/{}, replace); |
2189 | return; |
2190 | } |
2191 | } |
2192 | // TODO: derived type length parameters. |
2193 | if (!isAssumedRank) { |
2194 | lowerExplicitLowerBounds(converter, loc, ba, lbounds, symMap, stmtCtx); |
2195 | lowerExplicitExtents(converter, loc, ba, lbounds, explicitExtents, |
2196 | symMap, stmtCtx); |
2197 | } |
2198 | genBoxDeclare(converter, symMap, sym, dummyArg, lbounds, explicitParams, |
2199 | explicitExtents, replace); |
2200 | return; |
2201 | } |
2202 | } |
2203 | |
2204 | // A dummy from another entry point that is not declared in the current |
2205 | // entry point requires a skeleton definition. Most such "unused" dummies |
2206 | // will not survive into final generated code, but some will. It is illegal |
2207 | // to reference one at run time if it does. Such a dummy is mapped to a |
2208 | // value in one of three ways: |
2209 | // |
2210 | // - Generate a fir::UndefOp value. This is lightweight, easy to clean up, |
2211 | // and often valid, but it may fail for a dummy with dynamic bounds, |
2212 | // or a dummy used to define another dummy. Information to distinguish |
2213 | // valid cases is not generally available here, with the exception of |
2214 | // dummy procedures. See the first function exit above. |
2215 | // |
2216 | // - Allocate an uninitialized stack slot. This is an intermediate-weight |
2217 | // solution that is harder to clean up. It is often valid, but may fail |
2218 | // for an object with dynamic bounds. This option is "automatically" |
2219 | // used by default for cases that do not use one of the other options. |
2220 | // |
2221 | // - Allocate a heap box/descriptor, initialized to zero. This always |
2222 | // works, but is more heavyweight and harder to clean up. It is used |
2223 | // for dynamic objects via calls to genUnusedEntryPointBox. |
2224 | |
2225 | auto genUnusedEntryPointBox = [&]() { |
2226 | if (isUnusedEntryDummy) { |
2227 | assert(!Fortran::semantics::IsAllocatableOrPointer(sym) && |
2228 | "handled above" ); |
2229 | // The box is read right away because lowering code does not expect |
2230 | // a non pointer/allocatable symbol to be mapped to a MutableBox. |
2231 | mlir::Type ty = converter.genType(var); |
2232 | bool isPolymorphic = false; |
2233 | if (auto boxTy = mlir::dyn_cast<fir::BaseBoxType>(ty)) { |
2234 | isPolymorphic = mlir::isa<fir::ClassType>(ty); |
2235 | ty = boxTy.getEleTy(); |
2236 | } |
2237 | Fortran::lower::genDeclareSymbol( |
2238 | converter, symMap, sym, |
2239 | fir::factory::genMutableBoxRead( |
2240 | builder, loc, |
2241 | fir::factory::createTempMutableBox(builder, loc, ty, {}, {}, |
2242 | isPolymorphic)), |
2243 | fir::FortranVariableFlagsEnum::None, |
2244 | converter.isRegisteredDummySymbol(sym)); |
2245 | return true; |
2246 | } |
2247 | return false; |
2248 | }; |
2249 | |
2250 | if (isAssumedRank) { |
2251 | assert(isUnusedEntryDummy && "assumed rank must be pointers/allocatables " |
2252 | "or descriptor dummy arguments" ); |
2253 | genUnusedEntryPointBox(); |
2254 | return; |
2255 | } |
2256 | |
2257 | // Helper to generate scalars for the symbol properties. |
2258 | auto genValue = [&](const Fortran::lower::SomeExpr &expr) { |
2259 | return genScalarValue(converter, loc, expr, symMap, stmtCtx); |
2260 | }; |
2261 | |
2262 | // For symbols reaching this point, all properties are constant and can be |
2263 | // read/computed already into ssa values. |
2264 | |
2265 | // The origin must be \vec{1}. |
2266 | auto populateShape = [&](auto &shapes, const auto &bounds, mlir::Value box) { |
2267 | for (auto iter : llvm::enumerate(bounds)) { |
2268 | auto *spec = iter.value(); |
2269 | assert(spec->lbound().GetExplicit() && |
2270 | "lbound must be explicit with constant value 1" ); |
2271 | if (auto high = spec->ubound().GetExplicit()) { |
2272 | Fortran::lower::SomeExpr highEx{*high}; |
2273 | mlir::Value ub = genValue(highEx); |
2274 | ub = builder.createConvert(loc, idxTy, ub); |
2275 | shapes.emplace_back(fir::factory::genMaxWithZero(builder, loc, ub)); |
2276 | } else if (spec->ubound().isColon()) { |
2277 | assert(box && "assumed bounds require a descriptor" ); |
2278 | mlir::Value dim = |
2279 | builder.createIntegerConstant(loc, idxTy, iter.index()); |
2280 | auto dimInfo = |
2281 | builder.create<fir::BoxDimsOp>(loc, idxTy, idxTy, idxTy, box, dim); |
2282 | shapes.emplace_back(dimInfo.getResult(1)); |
2283 | } else if (spec->ubound().isStar()) { |
2284 | shapes.emplace_back(getAssumedSizeExtent(loc, builder)); |
2285 | } else { |
2286 | llvm::report_fatal_error("unknown bound category" ); |
2287 | } |
2288 | } |
2289 | }; |
2290 | |
2291 | // The origin is not \vec{1}. |
2292 | auto populateLBoundsExtents = [&](auto &lbounds, auto &extents, |
2293 | const auto &bounds, mlir::Value box) { |
2294 | for (auto iter : llvm::enumerate(bounds)) { |
2295 | auto *spec = iter.value(); |
2296 | fir::BoxDimsOp dimInfo; |
2297 | mlir::Value ub, lb; |
2298 | if (spec->lbound().isColon() || spec->ubound().isColon()) { |
2299 | // This is an assumed shape because allocatables and pointers extents |
2300 | // are not constant in the scope and are not read here. |
2301 | assert(box && "deferred bounds require a descriptor" ); |
2302 | mlir::Value dim = |
2303 | builder.createIntegerConstant(loc, idxTy, iter.index()); |
2304 | dimInfo = |
2305 | builder.create<fir::BoxDimsOp>(loc, idxTy, idxTy, idxTy, box, dim); |
2306 | extents.emplace_back(dimInfo.getResult(1)); |
2307 | if (auto low = spec->lbound().GetExplicit()) { |
2308 | auto expr = Fortran::lower::SomeExpr{*low}; |
2309 | mlir::Value lb = builder.createConvert(loc, idxTy, genValue(expr)); |
2310 | lbounds.emplace_back(lb); |
2311 | } else { |
2312 | // Implicit lower bound is 1 (Fortran 2018 section 8.5.8.3 point 3.) |
2313 | lbounds.emplace_back(builder.createIntegerConstant(loc, idxTy, 1)); |
2314 | } |
2315 | } else { |
2316 | if (auto low = spec->lbound().GetExplicit()) { |
2317 | auto expr = Fortran::lower::SomeExpr{*low}; |
2318 | lb = builder.createConvert(loc, idxTy, genValue(expr)); |
2319 | } else { |
2320 | TODO(loc, "support for assumed rank entities" ); |
2321 | } |
2322 | lbounds.emplace_back(lb); |
2323 | |
2324 | if (auto high = spec->ubound().GetExplicit()) { |
2325 | auto expr = Fortran::lower::SomeExpr{*high}; |
2326 | ub = builder.createConvert(loc, idxTy, genValue(expr)); |
2327 | extents.emplace_back( |
2328 | fir::factory::computeExtent(builder, loc, lb, ub)); |
2329 | } else { |
2330 | // An assumed size array. The extent is not computed. |
2331 | assert(spec->ubound().isStar() && "expected assumed size" ); |
2332 | extents.emplace_back(getAssumedSizeExtent(loc, builder)); |
2333 | } |
2334 | } |
2335 | } |
2336 | }; |
2337 | |
2338 | //===--------------------------------------------------------------===// |
2339 | // Non Pointer non allocatable scalar, explicit shape, and assumed |
2340 | // size arrays. |
2341 | // Lower the specification expressions. |
2342 | //===--------------------------------------------------------------===// |
2343 | |
2344 | mlir::Value len; |
2345 | llvm::SmallVector<mlir::Value> extents; |
2346 | llvm::SmallVector<mlir::Value> lbounds; |
2347 | auto arg = symMap.lookupSymbol(sym).getAddr(); |
2348 | mlir::Value addr = preAlloc; |
2349 | |
2350 | if (arg) |
2351 | if (auto boxTy = mlir::dyn_cast<fir::BaseBoxType>(arg.getType())) { |
2352 | // Contiguous assumed shape that can be tracked without a fir.box. |
2353 | mlir::Type refTy = builder.getRefType(boxTy.getEleTy()); |
2354 | addr = builder.create<fir::BoxAddrOp>(loc, refTy, arg); |
2355 | } |
2356 | |
2357 | // Compute/Extract character length. |
2358 | if (ba.isChar()) { |
2359 | if (arg) { |
2360 | assert(!preAlloc && "dummy cannot be pre-allocated" ); |
2361 | if (mlir::isa<fir::BoxCharType>(arg.getType())) { |
2362 | std::tie(addr, len) = charHelp.createUnboxChar(arg); |
2363 | } else if (mlir::isa<fir::CharacterType>(arg.getType())) { |
2364 | // fir.char<1> passed by value (BIND(C) with VALUE attribute). |
2365 | addr = builder.create<fir::AllocaOp>(loc, arg.getType()); |
2366 | builder.create<fir::StoreOp>(loc, arg, addr); |
2367 | } else if (!addr) { |
2368 | addr = arg; |
2369 | } |
2370 | // Ensure proper type is given to array/scalar that was transmitted as a |
2371 | // fir.boxchar arg or is a statement function actual argument with |
2372 | // a different length than the dummy. |
2373 | mlir::Type castTy = builder.getRefType(converter.genType(var)); |
2374 | addr = builder.createConvert(loc, castTy, addr); |
2375 | } |
2376 | if (std::optional<int64_t> cstLen = ba.getCharLenConst()) { |
2377 | // Static length |
2378 | len = builder.createIntegerConstant(loc, idxTy, *cstLen); |
2379 | } else { |
2380 | // Dynamic length |
2381 | if (genUnusedEntryPointBox()) |
2382 | return; |
2383 | if (std::optional<Fortran::lower::SomeExpr> charLenExpr = |
2384 | ba.getCharLenExpr()) { |
2385 | // Explicit length |
2386 | mlir::Value rawLen = genValue(*charLenExpr); |
2387 | // If the length expression is negative, the length is zero. See |
2388 | // F2018 7.4.4.2 point 5. |
2389 | len = fir::factory::genMaxWithZero(builder, loc, rawLen); |
2390 | } else if (!len) { |
2391 | // Assumed length fir.box (possible for contiguous assumed shapes). |
2392 | // Read length from box. |
2393 | assert(arg && mlir::isa<fir::BoxType>(arg.getType()) && |
2394 | "must be character dummy fir.box" ); |
2395 | len = charHelp.readLengthFromBox(arg); |
2396 | } |
2397 | } |
2398 | } |
2399 | |
2400 | // Compute array extents and lower bounds. |
2401 | if (ba.isArray()) { |
2402 | if (ba.isStaticArray()) { |
2403 | if (ba.lboundIsAllOnes()) { |
2404 | for (std::int64_t extent : |
2405 | recoverShapeVector(ba.staticShape(), preAlloc)) |
2406 | extents.push_back(genExtentValue(builder, loc, idxTy, extent)); |
2407 | } else { |
2408 | for (auto [lb, extent] : |
2409 | llvm::zip(ba.staticLBound(), |
2410 | recoverShapeVector(ba.staticShape(), preAlloc))) { |
2411 | lbounds.emplace_back(builder.createIntegerConstant(loc, idxTy, lb)); |
2412 | extents.emplace_back(genExtentValue(builder, loc, idxTy, extent)); |
2413 | } |
2414 | } |
2415 | } else { |
2416 | // Non compile time constant shape. |
2417 | if (genUnusedEntryPointBox()) |
2418 | return; |
2419 | if (ba.lboundIsAllOnes()) |
2420 | populateShape(extents, ba.dynamicBound(), arg); |
2421 | else |
2422 | populateLBoundsExtents(lbounds, extents, ba.dynamicBound(), arg); |
2423 | } |
2424 | } |
2425 | |
2426 | // Allocate or extract raw address for the entity |
2427 | if (!addr) { |
2428 | if (arg) { |
2429 | mlir::Type argType = arg.getType(); |
2430 | const bool isCptrByVal = Fortran::semantics::IsBuiltinCPtr(sym) && |
2431 | Fortran::lower::isCPtrArgByValueType(argType); |
2432 | if (isCptrByVal || !fir::conformsWithPassByRef(argType)) { |
2433 | // Dummy argument passed in register. Place the value in memory at that |
2434 | // point since lowering expect symbols to be mapped to memory addresses. |
2435 | mlir::Type symType = converter.genType(sym); |
2436 | addr = builder.create<fir::AllocaOp>(loc, symType); |
2437 | if (isCptrByVal) { |
2438 | // Place the void* address into the CPTR address component. |
2439 | mlir::Value addrComponent = |
2440 | fir::factory::genCPtrOrCFunptrAddr(builder, loc, addr, symType); |
2441 | builder.createStoreWithConvert(loc, arg, addrComponent); |
2442 | } else { |
2443 | builder.createStoreWithConvert(loc, arg, addr); |
2444 | } |
2445 | } else { |
2446 | // Dummy address, or address of result whose storage is passed by the |
2447 | // caller. |
2448 | assert(fir::isa_ref_type(argType) && "must be a memory address" ); |
2449 | addr = arg; |
2450 | } |
2451 | } else { |
2452 | // Local variables |
2453 | llvm::SmallVector<mlir::Value> typeParams; |
2454 | if (len) |
2455 | typeParams.emplace_back(len); |
2456 | addr = createNewLocal(converter, loc, var, preAlloc, extents, typeParams); |
2457 | } |
2458 | } |
2459 | |
2460 | ::genDeclareSymbol(converter, symMap, sym, addr, len, extents, lbounds, |
2461 | replace); |
2462 | return; |
2463 | } |
2464 | |
2465 | void Fortran::lower::defineModuleVariable( |
2466 | AbstractConverter &converter, const Fortran::lower::pft::Variable &var) { |
2467 | // Use empty linkage for module variables, which makes them available |
2468 | // for use in another unit. |
2469 | mlir::StringAttr linkage = |
2470 | getLinkageAttribute(converter.getFirOpBuilder(), var); |
2471 | if (!var.isGlobal()) |
2472 | fir::emitFatalError(converter.getCurrentLocation(), |
2473 | "attempting to lower module variable as local" ); |
2474 | // Define aggregate storages for equivalenced objects. |
2475 | if (var.isAggregateStore()) { |
2476 | const Fortran::lower::pft::Variable::AggregateStore &aggregate = |
2477 | var.getAggregateStore(); |
2478 | std::string aggName = mangleGlobalAggregateStore(converter, aggregate); |
2479 | defineGlobalAggregateStore(converter, aggregate, aggName, linkage); |
2480 | return; |
2481 | } |
2482 | const Fortran::semantics::Symbol &sym = var.getSymbol(); |
2483 | if (const Fortran::semantics::Symbol *common = |
2484 | Fortran::semantics::FindCommonBlockContaining(var.getSymbol())) { |
2485 | // Nothing to do, common block are generated before everything. Ensure |
2486 | // this was done by calling getCommonBlockGlobal. |
2487 | getCommonBlockGlobal(converter, *common); |
2488 | } else if (var.isAlias()) { |
2489 | // Do nothing. Mapping will be done on user side. |
2490 | } else { |
2491 | std::string globalName = converter.mangleName(sym); |
2492 | cuf::DataAttributeAttr dataAttr = |
2493 | Fortran::lower::translateSymbolCUFDataAttribute( |
2494 | converter.getFirOpBuilder().getContext(), sym); |
2495 | defineGlobal(converter, var, globalName, linkage, dataAttr); |
2496 | } |
2497 | } |
2498 | |
2499 | void Fortran::lower::instantiateVariable(AbstractConverter &converter, |
2500 | const pft::Variable &var, |
2501 | Fortran::lower::SymMap &symMap, |
2502 | AggregateStoreMap &storeMap) { |
2503 | if (var.hasSymbol()) { |
2504 | // Do not try to instantiate symbols twice, except for dummies and results, |
2505 | // that may have been mapped to the MLIR entry block arguments, and for |
2506 | // which the explicit specifications, if any, has not yet been lowered. |
2507 | const auto &sym = var.getSymbol(); |
2508 | if (!IsDummy(sym) && !IsFunctionResult(sym) && symMap.lookupSymbol(sym)) |
2509 | return; |
2510 | } |
2511 | LLVM_DEBUG(llvm::dbgs() << "instantiateVariable: " ; var.dump()); |
2512 | if (var.isAggregateStore()) |
2513 | instantiateAggregateStore(converter, var, storeMap); |
2514 | else if (const Fortran::semantics::Symbol *common = |
2515 | Fortran::semantics::FindCommonBlockContaining( |
2516 | var.getSymbol().GetUltimate())) |
2517 | instantiateCommon(converter, *common, var, symMap); |
2518 | else if (var.isAlias()) |
2519 | instantiateAlias(converter, var, symMap, storeMap); |
2520 | else if (var.isGlobal()) |
2521 | instantiateGlobal(converter, var, symMap); |
2522 | else |
2523 | instantiateLocal(converter, var, symMap); |
2524 | } |
2525 | |
2526 | static void |
2527 | mapCallInterfaceSymbol(const Fortran::semantics::Symbol &interfaceSymbol, |
2528 | Fortran::lower::AbstractConverter &converter, |
2529 | const Fortran::lower::CallerInterface &caller, |
2530 | Fortran::lower::SymMap &symMap) { |
2531 | Fortran::lower::AggregateStoreMap storeMap; |
2532 | for (Fortran::lower::pft::Variable var : |
2533 | Fortran::lower::pft::getDependentVariableList(interfaceSymbol)) { |
2534 | if (var.isAggregateStore()) { |
2535 | instantiateVariable(converter, var, symMap, storeMap); |
2536 | continue; |
2537 | } |
2538 | const Fortran::semantics::Symbol &sym = var.getSymbol(); |
2539 | if (&sym == &interfaceSymbol) |
2540 | continue; |
2541 | const auto *hostDetails = |
2542 | sym.detailsIf<Fortran::semantics::HostAssocDetails>(); |
2543 | if (hostDetails && !var.isModuleOrSubmoduleVariable()) { |
2544 | // The callee is an internal procedure `A` whose result properties |
2545 | // depend on host variables. The caller may be the host, or another |
2546 | // internal procedure `B` contained in the same host. In the first |
2547 | // case, the host symbol is obviously mapped, in the second case, it |
2548 | // must also be mapped because |
2549 | // HostAssociations::internalProcedureBindings that was called when |
2550 | // lowering `B` will have mapped all host symbols of captured variables |
2551 | // to the tuple argument containing the composite of all host associated |
2552 | // variables, whether or not the host symbol is actually referred to in |
2553 | // `B`. Hence it is possible to simply lookup the variable associated to |
2554 | // the host symbol without having to go back to the tuple argument. |
2555 | symMap.copySymbolBinding(hostDetails->symbol(), sym); |
2556 | // The SymbolBox associated to the host symbols is complete, skip |
2557 | // instantiateVariable that would try to allocate a new storage. |
2558 | continue; |
2559 | } |
2560 | if (Fortran::semantics::IsDummy(sym) && |
2561 | sym.owner() == interfaceSymbol.owner()) { |
2562 | // Get the argument for the dummy argument symbols of the current call. |
2563 | symMap.addSymbol(sym, caller.getArgumentValue(sym)); |
2564 | // All the properties of the dummy variable may not come from the actual |
2565 | // argument, let instantiateVariable handle this. |
2566 | } |
2567 | // If this is neither a host associated or dummy symbol, it must be a |
2568 | // module or common block variable to satisfy specification expression |
2569 | // requirements in 10.1.11, instantiateVariable will get its address and |
2570 | // properties. |
2571 | instantiateVariable(converter, var, symMap, storeMap); |
2572 | } |
2573 | } |
2574 | |
2575 | void Fortran::lower::mapCallInterfaceSymbolsForResult( |
2576 | AbstractConverter &converter, const Fortran::lower::CallerInterface &caller, |
2577 | SymMap &symMap) { |
2578 | const Fortran::semantics::Symbol &result = caller.getResultSymbol(); |
2579 | mapCallInterfaceSymbol(result, converter, caller, symMap); |
2580 | } |
2581 | |
2582 | void Fortran::lower::mapCallInterfaceSymbolsForDummyArgument( |
2583 | AbstractConverter &converter, const Fortran::lower::CallerInterface &caller, |
2584 | SymMap &symMap, const Fortran::semantics::Symbol &dummySymbol) { |
2585 | mapCallInterfaceSymbol(dummySymbol, converter, caller, symMap); |
2586 | } |
2587 | |
2588 | void Fortran::lower::mapSymbolAttributes( |
2589 | AbstractConverter &converter, const Fortran::semantics::SymbolRef &symbol, |
2590 | Fortran::lower::SymMap &symMap, Fortran::lower::StatementContext &stmtCtx, |
2591 | mlir::Value preAlloc) { |
2592 | mapSymbolAttributes(converter, pft::Variable{symbol}, symMap, stmtCtx, |
2593 | preAlloc); |
2594 | } |
2595 | |
2596 | void Fortran::lower::createIntrinsicModuleGlobal( |
2597 | Fortran::lower::AbstractConverter &converter, const pft::Variable &var) { |
2598 | defineGlobal(converter, var, converter.mangleName(var.getSymbol()), |
2599 | converter.getFirOpBuilder().createLinkOnceODRLinkage()); |
2600 | } |
2601 | |
2602 | void Fortran::lower::createRuntimeTypeInfoGlobal( |
2603 | Fortran::lower::AbstractConverter &converter, |
2604 | const Fortran::semantics::Symbol &typeInfoSym) { |
2605 | fir::FirOpBuilder &builder = converter.getFirOpBuilder(); |
2606 | std::string globalName = converter.mangleName(typeInfoSym); |
2607 | auto var = Fortran::lower::pft::Variable(typeInfoSym, /*global=*/true); |
2608 | mlir::StringAttr linkage = getLinkageAttribute(builder, var); |
2609 | defineGlobal(converter, var, globalName, linkage); |
2610 | } |
2611 | |
2612 | mlir::Type Fortran::lower::getCrayPointeeBoxType(mlir::Type fortranType) { |
2613 | mlir::Type baseType = hlfir::getFortranElementOrSequenceType(fortranType); |
2614 | if (auto seqType = mlir::dyn_cast<fir::SequenceType>(baseType)) { |
2615 | // The pointer box's sequence type must be with unknown shape. |
2616 | llvm::SmallVector<int64_t> shape(seqType.getDimension(), |
2617 | fir::SequenceType::getUnknownExtent()); |
2618 | baseType = fir::SequenceType::get(shape, seqType.getEleTy()); |
2619 | } |
2620 | return fir::BoxType::get(fir::PointerType::get(baseType)); |
2621 | } |
2622 | |
2623 | fir::ExtendedValue |
2624 | Fortran::lower::genPackArray(Fortran::lower::AbstractConverter &converter, |
2625 | const Fortran::semantics::Symbol &sym, |
2626 | fir::ExtendedValue exv) { |
2627 | if (!needsRepack(converter, sym)) |
2628 | return exv; |
2629 | |
2630 | auto &opts = converter.getLoweringOptions(); |
2631 | llvm::SmallVector<mlir::Value> lenParams; |
2632 | exv.match( |
2633 | [&](const fir::CharArrayBoxValue &box) { |
2634 | lenParams.emplace_back(box.getLen()); |
2635 | }, |
2636 | [&](const fir::BoxValue &box) { |
2637 | lenParams.append(box.getExplicitParameters().begin(), |
2638 | box.getExplicitParameters().end()); |
2639 | }, |
2640 | [](const auto &) { |
2641 | llvm_unreachable("unexpected lowering for assumed-shape dummy" ); |
2642 | }); |
2643 | fir::FirOpBuilder &builder = converter.getFirOpBuilder(); |
2644 | const mlir::Location loc = genLocation(converter, sym); |
2645 | bool stackAlloc = opts.getStackRepackArrays(); |
2646 | // 1D arrays must always use 'whole' mode. |
2647 | bool isInnermostMode = !opts.getRepackArraysWhole() && sym.Rank() > 1; |
2648 | // Avoid copy-in for 'intent(out)' variable, unless this is a dummy |
2649 | // argument with INTENT(OUT) that needs finalization on entry |
2650 | // to the subprogram. The finalization routine may read the initial |
2651 | // value of the array. |
2652 | bool noCopy = Fortran::semantics::IsIntentOut(sym) && |
2653 | !needDummyIntentoutFinalization(sym); |
2654 | auto boxType = mlir::cast<fir::BaseBoxType>(fir::getBase(exv).getType()); |
2655 | mlir::Type elementType = boxType.unwrapInnerType(); |
2656 | llvm::SmallVector<mlir::Value> elidedLenParams = |
2657 | fir::factory::elideLengthsAlreadyInType(elementType, lenParams); |
2658 | auto packOp = builder.create<fir::PackArrayOp>( |
2659 | loc, fir::getBase(exv), stackAlloc, isInnermostMode, noCopy, |
2660 | /*max_size=*/mlir::IntegerAttr{}, |
2661 | /*max_element_size=*/mlir::IntegerAttr{}, |
2662 | /*min_stride=*/mlir::IntegerAttr{}, fir::PackArrayHeuristics::None, |
2663 | elidedLenParams, getSafeRepackAttrs(converter)); |
2664 | |
2665 | mlir::Value newBase = packOp.getResult(); |
2666 | return exv.match( |
2667 | [&](const fir::CharArrayBoxValue &box) -> fir::ExtendedValue { |
2668 | return box.clone(newBase); |
2669 | }, |
2670 | [&](const fir::BoxValue &box) -> fir::ExtendedValue { |
2671 | return box.clone(newBase); |
2672 | }, |
2673 | [](const auto &) -> fir::ExtendedValue { |
2674 | llvm_unreachable("unexpected lowering for assumed-shape dummy" ); |
2675 | }); |
2676 | } |
2677 | |
2678 | void Fortran::lower::genUnpackArray( |
2679 | Fortran::lower::AbstractConverter &converter, mlir::Location loc, |
2680 | fir::FortranVariableOpInterface def, |
2681 | const Fortran::semantics::Symbol &sym) { |
2682 | // Subtle: rely on the fact that the memref of the defining |
2683 | // hlfir.declare is a result of fir.pack_array. |
2684 | // Alternatively, we can track the pack operation for a symbol |
2685 | // via SymMap. |
2686 | auto declareOp = mlir::dyn_cast<hlfir::DeclareOp>(def.getOperation()); |
2687 | assert(declareOp && |
2688 | "cannot find hlfir.declare for an array that needs to be repacked" ); |
2689 | auto packOp = declareOp.getMemref().getDefiningOp<fir::PackArrayOp>(); |
2690 | assert(packOp && "cannot find fir.pack_array" ); |
2691 | mlir::Value temp = packOp.getResult(); |
2692 | mlir::Value original = packOp.getArray(); |
2693 | bool stackAlloc = packOp.getStack(); |
2694 | // Avoid copy-out for 'intent(in)' variables. |
2695 | bool noCopy = Fortran::semantics::IsIntentIn(sym); |
2696 | fir::FirOpBuilder &builder = converter.getFirOpBuilder(); |
2697 | builder.create<fir::UnpackArrayOp>(loc, temp, original, stackAlloc, noCopy, |
2698 | getSafeRepackAttrs(converter)); |
2699 | } |
2700 | |