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
51static 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.
59static 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?
78bool 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?
103static 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?
113static bool
114hasAllocatableDirectComponent(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.
128static fir::ExtendedValue
129genInitializerExprValue(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?
144static 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.
150static void
151createGlobalInitialization(fir::FirOpBuilder &builder, fir::GlobalOp global,
152 std::function<void(fir::FirOpBuilder &)> genInit);
153
154static 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
164static 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.
194static bool
195hasDerivedTypeWithLengthParameters(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
203fir::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.
229mlir::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.
322static 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.
330static 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
395static 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 ?
465static 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.
470static void
471createGlobalInitialization(fir::FirOpBuilder &builder, fir::GlobalOp global,
472 std::function<void(fir::FirOpBuilder &)> genInit) {
473 mlir::Region &region = 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
482static 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
497fir::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.
649static mlir::StringAttr
650getLinkageAttribute(Fortran::lower::AbstractConverter &converter,
651 const Fortran::lower::pft::Variable &var) {
652 fir::FirOpBuilder &builder = converter.getFirOpBuilder();
653 // Runtime type info for a same derived type is identical in each compilation
654 // unit. It desired to avoid having to link against module that only define a
655 // type. Therefore the runtime type info is generated everywhere it is needed
656 // with `linkonce_odr` LLVM linkage (unless the skipExternalRttiDefinition
657 // option is set, in which case one will need to link against objects of
658 // modules defining types). Builtin objects rtti is always generated because
659 // the builtin module is currently not compiled or part of the runtime.
660 if (var.isRuntimeTypeInfoData() &&
661 (!converter.getLoweringOptions().getSkipExternalRttiDefinition() ||
662 Fortran::semantics::IsFromBuiltinModule(var.getSymbol())))
663 return builder.createLinkOnceODRLinkage();
664 if (var.isModuleOrSubmoduleVariable())
665 return {}; // external linkage
666 // Otherwise, the variable is owned by a procedure and must not be visible in
667 // other compilation units.
668 return builder.createInternalLinkage();
669}
670
671/// Instantiate a global variable. If it hasn't already been processed, add
672/// the global to the ModuleOp as a new uniqued symbol and initialize it with
673/// the correct value. It will be referenced on demand using `fir.addr_of`.
674static void instantiateGlobal(Fortran::lower::AbstractConverter &converter,
675 const Fortran::lower::pft::Variable &var,
676 Fortran::lower::SymMap &symMap) {
677 const Fortran::semantics::Symbol &sym = var.getSymbol();
678 assert(!var.isAlias() && "must be handled in instantiateAlias");
679 fir::FirOpBuilder &builder = converter.getFirOpBuilder();
680 std::string globalName = converter.mangleName(sym);
681 mlir::Location loc = genLocation(converter, sym);
682 mlir::StringAttr linkage = getLinkageAttribute(converter, var);
683 fir::GlobalOp global;
684 if (var.isModuleOrSubmoduleVariable()) {
685 // A non-intrinsic module global is defined when lowering the module.
686 // Emit only a declaration if the global does not exist.
687 global = declareGlobal(converter, var, globalName, linkage);
688 } else {
689 cuf::DataAttributeAttr dataAttr =
690 Fortran::lower::translateSymbolCUFDataAttribute(builder.getContext(),
691 sym);
692 global = defineGlobal(converter, var, globalName, linkage, dataAttr);
693 }
694 auto addrOf = builder.create<fir::AddrOfOp>(loc, global.resultType(),
695 global.getSymbol());
696 // The type of the global cannot be trusted to be the same as the one
697 // of the variable as some existing programs map common blocks to
698 // BIND(C) module variables (e.g. mpi_argv_null in MPI and MPI_F08).
699 mlir::Type varAddrType = fir::ReferenceType::get(converter.genType(sym));
700 mlir::Value cast = builder.createConvert(loc, varAddrType, addrOf);
701 Fortran::lower::StatementContext stmtCtx;
702 mapSymbolAttributes(converter, var, symMap, stmtCtx, cast);
703}
704
705bool needCUDAAlloc(const Fortran::semantics::Symbol &sym) {
706 if (Fortran::semantics::IsDummy(sym))
707 return false;
708 if (const auto *details{
709 sym.GetUltimate()
710 .detailsIf<Fortran::semantics::ObjectEntityDetails>()}) {
711 if (details->cudaDataAttr() &&
712 (*details->cudaDataAttr() == Fortran::common::CUDADataAttr::Device ||
713 *details->cudaDataAttr() == Fortran::common::CUDADataAttr::Managed ||
714 *details->cudaDataAttr() == Fortran::common::CUDADataAttr::Unified ||
715 *details->cudaDataAttr() == Fortran::common::CUDADataAttr::Shared ||
716 *details->cudaDataAttr() == Fortran::common::CUDADataAttr::Pinned))
717 return true;
718 const Fortran::semantics::DeclTypeSpec *type{details->type()};
719 const Fortran::semantics::DerivedTypeSpec *derived{type ? type->AsDerived()
720 : nullptr};
721 if (derived)
722 if (FindCUDADeviceAllocatableUltimateComponent(*derived))
723 return true;
724 }
725 return false;
726}
727
728//===----------------------------------------------------------------===//
729// Local variables instantiation (not for alias)
730//===----------------------------------------------------------------===//
731
732/// Create a stack slot for a local variable. Precondition: the insertion
733/// point of the builder must be in the entry block, which is currently being
734/// constructed.
735static mlir::Value createNewLocal(Fortran::lower::AbstractConverter &converter,
736 mlir::Location loc,
737 const Fortran::lower::pft::Variable &var,
738 mlir::Value preAlloc,
739 llvm::ArrayRef<mlir::Value> shape = {},
740 llvm::ArrayRef<mlir::Value> lenParams = {}) {
741 if (preAlloc)
742 return preAlloc;
743 fir::FirOpBuilder &builder = converter.getFirOpBuilder();
744 std::string nm = converter.mangleName(var.getSymbol());
745 mlir::Type ty = converter.genType(var);
746 const Fortran::semantics::Symbol &ultimateSymbol =
747 var.getSymbol().GetUltimate();
748 llvm::StringRef symNm = toStringRef(ultimateSymbol.name());
749 bool isTarg = var.isTarget();
750
751 // Do not allocate storage for cray pointee. The address inside the cray
752 // pointer will be used instead when using the pointee. Allocating space
753 // would be a waste of space, and incorrect if the pointee is a non dummy
754 // assumed-size (possible with cray pointee).
755 if (ultimateSymbol.test(Fortran::semantics::Symbol::Flag::CrayPointee))
756 return builder.create<fir::ZeroOp>(loc, fir::ReferenceType::get(ty));
757
758 if (needCUDAAlloc(ultimateSymbol)) {
759 cuf::DataAttributeAttr dataAttr =
760 Fortran::lower::translateSymbolCUFDataAttribute(builder.getContext(),
761 ultimateSymbol);
762 llvm::SmallVector<mlir::Value> indices;
763 llvm::SmallVector<mlir::Value> elidedShape =
764 fir::factory::elideExtentsAlreadyInType(ty, shape);
765 llvm::SmallVector<mlir::Value> elidedLenParams =
766 fir::factory::elideLengthsAlreadyInType(ty, lenParams);
767 auto idxTy = builder.getIndexType();
768 for (mlir::Value sh : elidedShape)
769 indices.push_back(builder.createConvert(loc, idxTy, sh));
770 if (dataAttr.getValue() == cuf::DataAttribute::Shared)
771 return builder.create<cuf::SharedMemoryOp>(loc, ty, nm, symNm, lenParams,
772 indices);
773
774 if (!cuf::isCUDADeviceContext(builder.getRegion())) {
775 mlir::Value alloc = builder.create<cuf::AllocOp>(
776 loc, ty, nm, symNm, dataAttr, lenParams, indices);
777 if (const auto *details{
778 ultimateSymbol
779 .detailsIf<Fortran::semantics::ObjectEntityDetails>()}) {
780 const Fortran::semantics::DeclTypeSpec *type{details->type()};
781 const Fortran::semantics::DerivedTypeSpec *derived{
782 type ? type->AsDerived() : nullptr};
783 if (derived) {
784 Fortran::semantics::UltimateComponentIterator components{*derived};
785 auto recTy = mlir::dyn_cast<fir::RecordType>(ty);
786
787 llvm::SmallVector<mlir::Value> coordinates;
788 for (const auto &sym : components) {
789 if (Fortran::semantics::IsDeviceAllocatable(sym)) {
790 unsigned fieldIdx = recTy.getFieldIndex(sym.name().ToString());
791 mlir::Type fieldTy;
792 std::vector<mlir::Value> coordinates;
793
794 if (fieldIdx != std::numeric_limits<unsigned>::max()) {
795 // Field found in the base record type.
796 auto fieldName = recTy.getTypeList()[fieldIdx].first;
797 fieldTy = recTy.getTypeList()[fieldIdx].second;
798 mlir::Value fieldIndex = builder.create<fir::FieldIndexOp>(
799 loc, fir::FieldType::get(fieldTy.getContext()), fieldName,
800 recTy,
801 /*typeParams=*/mlir::ValueRange{});
802 coordinates.push_back(fieldIndex);
803 } else {
804 // Field not found in base record type, search in potential
805 // record type components.
806 for (auto component : recTy.getTypeList()) {
807 if (auto childRecTy =
808 mlir::dyn_cast<fir::RecordType>(component.second)) {
809 fieldIdx = childRecTy.getFieldIndex(sym.name().ToString());
810 if (fieldIdx != std::numeric_limits<unsigned>::max()) {
811 mlir::Value parentFieldIndex =
812 builder.create<fir::FieldIndexOp>(
813 loc, fir::FieldType::get(childRecTy.getContext()),
814 component.first, recTy,
815 /*typeParams=*/mlir::ValueRange{});
816 coordinates.push_back(parentFieldIndex);
817 auto fieldName = childRecTy.getTypeList()[fieldIdx].first;
818 fieldTy = childRecTy.getTypeList()[fieldIdx].second;
819 mlir::Value childFieldIndex =
820 builder.create<fir::FieldIndexOp>(
821 loc, fir::FieldType::get(fieldTy.getContext()),
822 fieldName, childRecTy,
823 /*typeParams=*/mlir::ValueRange{});
824 coordinates.push_back(childFieldIndex);
825 break;
826 }
827 }
828 }
829 }
830
831 if (coordinates.empty())
832 TODO(loc, "device resident component in complex derived-type "
833 "hierarchy");
834
835 mlir::Value comp = builder.create<fir::CoordinateOp>(
836 loc, builder.getRefType(fieldTy), alloc, coordinates);
837 cuf::DataAttributeAttr dataAttr =
838 Fortran::lower::translateSymbolCUFDataAttribute(
839 builder.getContext(), sym);
840 builder.create<cuf::SetAllocatorIndexOp>(loc, comp, dataAttr);
841 }
842 }
843 }
844 }
845 return alloc;
846 }
847 }
848
849 // Let the builder do all the heavy lifting.
850 if (!Fortran::semantics::IsProcedurePointer(ultimateSymbol))
851 return builder.allocateLocal(loc, ty, nm, symNm, shape, lenParams, isTarg);
852
853 // Local procedure pointer.
854 auto res{builder.allocateLocal(loc, ty, nm, symNm, shape, lenParams, isTarg)};
855 auto box{fir::factory::createNullBoxProc(builder, loc, ty)};
856 builder.create<fir::StoreOp>(loc, box, res);
857 return res;
858}
859
860/// Must \p var be default initialized at runtime when entering its scope.
861static bool
862mustBeDefaultInitializedAtRuntime(const Fortran::lower::pft::Variable &var) {
863 if (!var.hasSymbol())
864 return false;
865 const Fortran::semantics::Symbol &sym = var.getSymbol();
866 if (var.isGlobal())
867 // Global variables are statically initialized.
868 return false;
869 if (Fortran::semantics::IsDummy(sym) && !Fortran::semantics::IsIntentOut(sym))
870 return false;
871 // Polymorphic intent(out) dummy might need default initialization
872 // at runtime.
873 if (Fortran::semantics::IsPolymorphic(sym) &&
874 Fortran::semantics::IsDummy(sym) &&
875 Fortran::semantics::IsIntentOut(sym) &&
876 !Fortran::semantics::IsAllocatable(sym) &&
877 !Fortran::semantics::IsPointer(sym))
878 return true;
879 // Local variables (including function results), and intent(out) dummies must
880 // be default initialized at runtime if their type has default initialization.
881 return Fortran::lower::hasDefaultInitialization(sym);
882}
883
884/// Call default initialization runtime routine to initialize \p var.
885void Fortran::lower::defaultInitializeAtRuntime(
886 Fortran::lower::AbstractConverter &converter,
887 const Fortran::semantics::Symbol &sym, Fortran::lower::SymMap &symMap) {
888 fir::FirOpBuilder &builder = converter.getFirOpBuilder();
889 mlir::Location loc = converter.getCurrentLocation();
890 fir::ExtendedValue exv = converter.getSymbolExtendedValue(sym, &symMap);
891 if (Fortran::semantics::IsOptional(sym)) {
892 // 15.5.2.12 point 3, absent optional dummies are not initialized.
893 // Creating descriptor/passing null descriptor to the runtime would
894 // create runtime crashes.
895 auto isPresent = builder.create<fir::IsPresentOp>(loc, builder.getI1Type(),
896 fir::getBase(exv));
897 builder.genIfThen(loc, isPresent)
898 .genThen([&]() {
899 auto box = builder.createBox(loc, exv);
900 fir::runtime::genDerivedTypeInitialize(builder, loc, box);
901 })
902 .end();
903 } else {
904 /// For "simpler" types, relying on "_FortranAInitialize"
905 /// leads to poor runtime performance. Hence optimize
906 /// the same.
907 const Fortran::semantics::DeclTypeSpec *declTy = sym.GetType();
908 mlir::Type symTy = converter.genType(sym);
909 const auto *details =
910 sym.detailsIf<Fortran::semantics::ObjectEntityDetails>();
911 if (details && !Fortran::semantics::IsPolymorphic(sym) &&
912 declTy->category() ==
913 Fortran::semantics::DeclTypeSpec::Category::TypeDerived &&
914 !mlir::isa<fir::SequenceType>(symTy) &&
915 !sym.test(Fortran::semantics::Symbol::Flag::OmpPrivate) &&
916 !sym.test(Fortran::semantics::Symbol::Flag::OmpFirstPrivate)) {
917 std::string globalName = fir::NameUniquer::doGenerated(
918 (converter.mangleName(*declTy->AsDerived()) + fir::kNameSeparator +
919 fir::kDerivedTypeInitSuffix)
920 .str());
921 mlir::Location loc = genLocation(converter, sym);
922 mlir::StringAttr linkage = builder.createInternalLinkage();
923 fir::GlobalOp global = builder.getNamedGlobal(globalName);
924 if (!global && details->init()) {
925 global = builder.createGlobal(loc, symTy, globalName, linkage,
926 mlir::Attribute{},
927 /*isConst=*/true,
928 /*isTarget=*/false,
929 /*dataAttr=*/{});
930 createGlobalInitialization(
931 builder, global, [&](fir::FirOpBuilder &builder) {
932 Fortran::lower::StatementContext stmtCtx(
933 /*cleanupProhibited=*/true);
934 fir::ExtendedValue initVal = genInitializerExprValue(
935 converter, loc, details->init().value(), stmtCtx);
936 mlir::Value castTo =
937 builder.createConvert(loc, symTy, fir::getBase(initVal));
938 builder.create<fir::HasValueOp>(loc, castTo);
939 });
940 } else if (!global) {
941 global = builder.createGlobal(loc, symTy, globalName, linkage,
942 mlir::Attribute{},
943 /*isConst=*/true,
944 /*isTarget=*/false,
945 /*dataAttr=*/{});
946 createGlobalInitialization(
947 builder, global, [&](fir::FirOpBuilder &builder) {
948 Fortran::lower::StatementContext stmtCtx(
949 /*cleanupProhibited=*/true);
950 mlir::Value initVal = genDefaultInitializerValue(
951 converter, loc, sym, symTy, stmtCtx);
952 mlir::Value castTo = builder.createConvert(loc, symTy, initVal);
953 builder.create<fir::HasValueOp>(loc, castTo);
954 });
955 }
956 auto addrOf = builder.create<fir::AddrOfOp>(loc, global.resultType(),
957 global.getSymbol());
958 builder.create<fir::CopyOp>(loc, addrOf, fir::getBase(exv),
959 /*noOverlap=*/true);
960 } else {
961 mlir::Value box = builder.createBox(loc, exv);
962 fir::runtime::genDerivedTypeInitialize(builder, loc, box);
963 }
964 }
965}
966
967/// Call clone initialization runtime routine to initialize \p sym's value.
968void Fortran::lower::initializeCloneAtRuntime(
969 Fortran::lower::AbstractConverter &converter,
970 const Fortran::semantics::Symbol &sym, Fortran::lower::SymMap &symMap) {
971 fir::FirOpBuilder &builder = converter.getFirOpBuilder();
972 mlir::Location loc = converter.getCurrentLocation();
973 fir::ExtendedValue exv = converter.getSymbolExtendedValue(sym, &symMap);
974 mlir::Value newBox = builder.createBox(loc, exv);
975 lower::SymbolBox hsb = converter.lookupOneLevelUpSymbol(sym);
976 fir::ExtendedValue hexv = converter.symBoxToExtendedValue(hsb);
977 mlir::Value box = builder.createBox(loc, hexv);
978 fir::runtime::genDerivedTypeInitializeClone(builder, loc, newBox, box);
979}
980
981enum class VariableCleanUp { Finalize, Deallocate };
982/// Check whether a local variable needs to be finalized according to clause
983/// 7.5.6.3 point 3 or if it is an allocatable that must be deallocated. Note
984/// that deallocation will trigger finalization if the type has any.
985static std::optional<VariableCleanUp>
986needDeallocationOrFinalization(const Fortran::lower::pft::Variable &var) {
987 if (!var.hasSymbol())
988 return std::nullopt;
989 const Fortran::semantics::Symbol &sym = var.getSymbol();
990 const Fortran::semantics::Scope &owner = sym.owner();
991 if (owner.kind() == Fortran::semantics::Scope::Kind::MainProgram) {
992 // The standard does not require finalizing main program variables.
993 return std::nullopt;
994 }
995 if (!Fortran::semantics::IsPointer(sym) &&
996 !Fortran::semantics::IsDummy(sym) &&
997 !Fortran::semantics::IsFunctionResult(sym) &&
998 !Fortran::semantics::IsSaved(sym)) {
999 if (Fortran::semantics::IsAllocatable(sym))
1000 return VariableCleanUp::Deallocate;
1001 if (hasFinalization(sym))
1002 return VariableCleanUp::Finalize;
1003 // hasFinalization() check above handled all cases that require
1004 // finalization, but we also have to deallocate all allocatable
1005 // components of local variables (since they are also local variables
1006 // according to F18 5.4.3.2.2, p. 2, note 1).
1007 // Here, the variable itself is not allocatable. If it has an allocatable
1008 // component the Destroy runtime does the job. Use the Finalize clean-up,
1009 // though there will be no finalization in runtime.
1010 if (hasAllocatableDirectComponent(sym))
1011 return VariableCleanUp::Finalize;
1012 }
1013 return std::nullopt;
1014}
1015
1016/// Check whether a variable needs the be finalized according to clause 7.5.6.3
1017/// point 7.
1018/// Must be nonpointer, nonallocatable, INTENT (OUT) dummy argument.
1019static bool
1020needDummyIntentoutFinalization(const Fortran::semantics::Symbol &sym) {
1021 if (!Fortran::semantics::IsDummy(sym) ||
1022 !Fortran::semantics::IsIntentOut(sym) ||
1023 Fortran::semantics::IsAllocatable(sym) ||
1024 Fortran::semantics::IsPointer(sym))
1025 return false;
1026 // Polymorphic and unlimited polymorphic intent(out) dummy argument might need
1027 // finalization at runtime.
1028 if (Fortran::semantics::IsPolymorphic(sym) ||
1029 Fortran::semantics::IsUnlimitedPolymorphic(sym))
1030 return true;
1031 // Intent(out) dummies must be finalized at runtime if their type has a
1032 // finalization.
1033 // Allocatable components of INTENT(OUT) dummies must be deallocated (9.7.3.2
1034 // p6). Calling finalization runtime for this works even if the components
1035 // have no final procedures.
1036 return hasFinalization(sym) || hasAllocatableDirectComponent(sym);
1037}
1038
1039/// Check whether a variable needs the be finalized according to clause 7.5.6.3
1040/// point 7.
1041/// Must be nonpointer, nonallocatable, INTENT (OUT) dummy argument.
1042static bool
1043needDummyIntentoutFinalization(const Fortran::lower::pft::Variable &var) {
1044 if (!var.hasSymbol())
1045 return false;
1046 return needDummyIntentoutFinalization(var.getSymbol());
1047}
1048
1049/// Call default initialization runtime routine to initialize \p var.
1050static void finalizeAtRuntime(Fortran::lower::AbstractConverter &converter,
1051 const Fortran::lower::pft::Variable &var,
1052 Fortran::lower::SymMap &symMap) {
1053 fir::FirOpBuilder &builder = converter.getFirOpBuilder();
1054 mlir::Location loc = converter.getCurrentLocation();
1055 const Fortran::semantics::Symbol &sym = var.getSymbol();
1056 fir::ExtendedValue exv = converter.getSymbolExtendedValue(sym, &symMap);
1057 if (Fortran::semantics::IsOptional(sym)) {
1058 // Only finalize if present.
1059 auto isPresent = builder.create<fir::IsPresentOp>(loc, builder.getI1Type(),
1060 fir::getBase(exv));
1061 builder.genIfThen(loc, isPresent)
1062 .genThen([&]() {
1063 auto box = builder.createBox(loc, exv);
1064 fir::runtime::genDerivedTypeDestroy(builder, loc, box);
1065 })
1066 .end();
1067 } else {
1068 mlir::Value box = builder.createBox(loc, exv);
1069 fir::runtime::genDerivedTypeDestroy(builder, loc, box);
1070 }
1071}
1072
1073// Fortran 2018 - 9.7.3.2 point 6
1074// When a procedure is invoked, any allocated allocatable object that is an
1075// actual argument corresponding to an INTENT(OUT) allocatable dummy argument
1076// is deallocated; any allocated allocatable object that is a subobject of an
1077// actual argument corresponding to an INTENT(OUT) dummy argument is
1078// deallocated.
1079// Note that allocatable components of non-ALLOCATABLE INTENT(OUT) dummy
1080// arguments are dealt with needDummyIntentoutFinalization (finalization runtime
1081// is called to reach the intended component deallocation effect).
1082static void deallocateIntentOut(Fortran::lower::AbstractConverter &converter,
1083 const Fortran::lower::pft::Variable &var,
1084 Fortran::lower::SymMap &symMap) {
1085 if (!var.hasSymbol())
1086 return;
1087
1088 const Fortran::semantics::Symbol &sym = var.getSymbol();
1089 if (Fortran::semantics::IsDummy(sym) &&
1090 Fortran::semantics::IsIntentOut(sym) &&
1091 Fortran::semantics::IsAllocatable(sym)) {
1092 fir::ExtendedValue extVal = converter.getSymbolExtendedValue(sym, &symMap);
1093 if (auto mutBox = extVal.getBoxOf<fir::MutableBoxValue>()) {
1094 // The dummy argument is not passed in the ENTRY so it should not be
1095 // deallocated.
1096 if (mlir::Operation *op = mutBox->getAddr().getDefiningOp()) {
1097 if (auto declOp = mlir::dyn_cast<hlfir::DeclareOp>(op))
1098 op = declOp.getMemref().getDefiningOp();
1099 if (op && mlir::isa<fir::AllocaOp>(op))
1100 return;
1101 }
1102 mlir::Location loc = converter.getCurrentLocation();
1103 fir::FirOpBuilder &builder = converter.getFirOpBuilder();
1104
1105 if (Fortran::semantics::IsOptional(sym)) {
1106 auto isPresent = builder.create<fir::IsPresentOp>(
1107 loc, builder.getI1Type(), fir::getBase(extVal));
1108 builder.genIfThen(loc, isPresent)
1109 .genThen([&]() {
1110 Fortran::lower::genDeallocateIfAllocated(converter, *mutBox, loc);
1111 })
1112 .end();
1113 } else {
1114 Fortran::lower::genDeallocateIfAllocated(converter, *mutBox, loc);
1115 }
1116 }
1117 }
1118}
1119
1120/// Return true iff the given symbol represents a dummy array
1121/// that needs to be repacked when -frepack-arrays is set.
1122/// In general, the repacking is done for assumed-shape
1123/// dummy arguments, but there are limitations.
1124static bool needsRepack(Fortran::lower::AbstractConverter &converter,
1125 const Fortran::semantics::Symbol &sym) {
1126 const auto &attrs = sym.attrs();
1127 if (!converter.getLoweringOptions().getRepackArrays() ||
1128 !converter.isRegisteredDummySymbol(sym) ||
1129 !Fortran::semantics::IsAssumedShape(sym) ||
1130 Fortran::evaluate::IsSimplyContiguous(sym,
1131 converter.getFoldingContext()) ||
1132 // TARGET dummy may be accessed indirectly, so it is unsafe
1133 // to repack it. Some compilers provide options to override
1134 // this.
1135 // Repacking of VOLATILE and ASYNCHRONOUS is also unsafe.
1136 attrs.HasAny({Fortran::semantics::Attr::ASYNCHRONOUS,
1137 Fortran::semantics::Attr::TARGET,
1138 Fortran::semantics::Attr::VOLATILE}))
1139 return false;
1140
1141 return true;
1142}
1143
1144static mlir::ArrayAttr
1145getSafeRepackAttrs(Fortran::lower::AbstractConverter &converter) {
1146 llvm::SmallVector<mlir::Attribute> attrs;
1147 fir::FirOpBuilder &builder = converter.getFirOpBuilder();
1148 const auto &langFeatures = converter.getFoldingContext().languageFeatures();
1149 if (langFeatures.IsEnabled(Fortran::common::LanguageFeature::OpenACC))
1150 attrs.push_back(
1151 fir::OpenACCSafeTempArrayCopyAttr::get(builder.getContext()));
1152 if (langFeatures.IsEnabled(Fortran::common::LanguageFeature::OpenMP))
1153 attrs.push_back(
1154 fir::OpenMPSafeTempArrayCopyAttr::get(builder.getContext()));
1155
1156 return attrs.empty() ? mlir::ArrayAttr{} : builder.getArrayAttr(attrs);
1157}
1158
1159/// Instantiate a local variable. Precondition: Each variable will be visited
1160/// such that if its properties depend on other variables, the variables upon
1161/// which its properties depend will already have been visited.
1162static void instantiateLocal(Fortran::lower::AbstractConverter &converter,
1163 const Fortran::lower::pft::Variable &var,
1164 Fortran::lower::SymMap &symMap) {
1165 assert(!var.isAlias());
1166 Fortran::lower::StatementContext stmtCtx;
1167 // isUnusedEntryDummy must be computed before mapSymbolAttributes.
1168 const bool isUnusedEntryDummy =
1169 var.hasSymbol() && Fortran::semantics::IsDummy(var.getSymbol()) &&
1170 !symMap.lookupSymbol(var.getSymbol()).getAddr();
1171 mapSymbolAttributes(converter, var, symMap, stmtCtx);
1172 // Do not generate code to initialize/finalize/destroy dummy arguments that
1173 // are nor part of the current ENTRY. They do not have backing storage.
1174 if (isUnusedEntryDummy)
1175 return;
1176 deallocateIntentOut(converter, var, symMap);
1177 if (needDummyIntentoutFinalization(var))
1178 finalizeAtRuntime(converter, var, symMap);
1179 if (mustBeDefaultInitializedAtRuntime(var))
1180 Fortran::lower::defaultInitializeAtRuntime(converter, var.getSymbol(),
1181 symMap);
1182 auto *builder = &converter.getFirOpBuilder();
1183 if (needCUDAAlloc(var.getSymbol()) &&
1184 !cuf::isCUDADeviceContext(builder->getRegion())) {
1185 cuf::DataAttributeAttr dataAttr =
1186 Fortran::lower::translateSymbolCUFDataAttribute(builder->getContext(),
1187 var.getSymbol());
1188 mlir::Location loc = converter.getCurrentLocation();
1189 fir::ExtendedValue exv =
1190 converter.getSymbolExtendedValue(var.getSymbol(), &symMap);
1191 auto *sym = &var.getSymbol();
1192 const Fortran::semantics::Scope &owner = sym->owner();
1193 if (owner.kind() != Fortran::semantics::Scope::Kind::MainProgram &&
1194 dataAttr.getValue() != cuf::DataAttribute::Shared) {
1195 converter.getFctCtx().attachCleanup([builder, loc, exv, sym]() {
1196 cuf::DataAttributeAttr dataAttr =
1197 Fortran::lower::translateSymbolCUFDataAttribute(
1198 builder->getContext(), *sym);
1199 builder->create<cuf::FreeOp>(loc, fir::getBase(exv), dataAttr);
1200 });
1201 }
1202 }
1203 if (std::optional<VariableCleanUp> cleanup =
1204 needDeallocationOrFinalization(var)) {
1205 auto *builder = &converter.getFirOpBuilder();
1206 mlir::Location loc = converter.getCurrentLocation();
1207 fir::ExtendedValue exv =
1208 converter.getSymbolExtendedValue(var.getSymbol(), &symMap);
1209 switch (*cleanup) {
1210 case VariableCleanUp::Finalize:
1211 converter.getFctCtx().attachCleanup([builder, loc, exv]() {
1212 mlir::Value box = builder->createBox(loc, exv);
1213 fir::runtime::genDerivedTypeDestroy(*builder, loc, box);
1214 });
1215 break;
1216 case VariableCleanUp::Deallocate:
1217 auto *converterPtr = &converter;
1218 auto *sym = &var.getSymbol();
1219 converter.getFctCtx().attachCleanup([converterPtr, loc, exv, sym]() {
1220 const fir::MutableBoxValue *mutableBox =
1221 exv.getBoxOf<fir::MutableBoxValue>();
1222 assert(mutableBox &&
1223 "trying to deallocate entity not lowered as allocatable");
1224 Fortran::lower::genDeallocateIfAllocated(*converterPtr, *mutableBox,
1225 loc, sym);
1226 });
1227 }
1228 } else if (var.hasSymbol() && needsRepack(converter, var.getSymbol())) {
1229 auto *converterPtr = &converter;
1230 mlir::Location loc = converter.getCurrentLocation();
1231 auto *sym = &var.getSymbol();
1232 std::optional<fir::FortranVariableOpInterface> varDef =
1233 symMap.lookupVariableDefinition(*sym);
1234 assert(varDef && "cannot find defining operation for an array that needs "
1235 "to be repacked");
1236 converter.getFctCtx().attachCleanup([converterPtr, loc, varDef, sym]() {
1237 Fortran::lower::genUnpackArray(*converterPtr, loc, *varDef, *sym);
1238 });
1239 }
1240}
1241
1242//===----------------------------------------------------------------===//
1243// Aliased (EQUIVALENCE) variables instantiation
1244//===----------------------------------------------------------------===//
1245
1246/// Insert \p aggregateStore instance into an AggregateStoreMap.
1247static void insertAggregateStore(Fortran::lower::AggregateStoreMap &storeMap,
1248 const Fortran::lower::pft::Variable &var,
1249 mlir::Value aggregateStore) {
1250 std::size_t off = var.getAggregateStore().getOffset();
1251 Fortran::lower::AggregateStoreKey key = {var.getOwningScope(), off};
1252 storeMap[key] = aggregateStore;
1253}
1254
1255/// Retrieve the aggregate store instance of \p alias from an
1256/// AggregateStoreMap.
1257static mlir::Value
1258getAggregateStore(Fortran::lower::AggregateStoreMap &storeMap,
1259 const Fortran::lower::pft::Variable &alias) {
1260 Fortran::lower::AggregateStoreKey key = {alias.getOwningScope(),
1261 alias.getAliasOffset()};
1262 auto iter = storeMap.find(key);
1263 assert(iter != storeMap.end());
1264 return iter->second;
1265}
1266
1267/// Build the name for the storage of a global equivalence.
1268static std::string mangleGlobalAggregateStore(
1269 Fortran::lower::AbstractConverter &converter,
1270 const Fortran::lower::pft::Variable::AggregateStore &st) {
1271 return converter.mangleName(st.getNamingSymbol());
1272}
1273
1274/// Build the type for the storage of an equivalence.
1275static mlir::Type
1276getAggregateType(Fortran::lower::AbstractConverter &converter,
1277 const Fortran::lower::pft::Variable::AggregateStore &st) {
1278 if (const Fortran::semantics::Symbol *initSym = st.getInitialValueSymbol())
1279 return converter.genType(*initSym);
1280 mlir::IntegerType byteTy = converter.getFirOpBuilder().getIntegerType(8);
1281 return fir::SequenceType::get(std::get<1>(st.interval), byteTy);
1282}
1283
1284/// Define a GlobalOp for the storage of a global equivalence described
1285/// by \p aggregate. The global is named \p aggName and is created with
1286/// the provided \p linkage.
1287/// If any of the equivalence members are initialized, an initializer is
1288/// created for the equivalence.
1289/// This is to be used when lowering the scope that owns the equivalence
1290/// (as opposed to simply using it through host or use association).
1291/// This is not to be used for equivalence of common block members (they
1292/// already have the common block GlobalOp for them, see defineCommonBlock).
1293static fir::GlobalOp defineGlobalAggregateStore(
1294 Fortran::lower::AbstractConverter &converter,
1295 const Fortran::lower::pft::Variable::AggregateStore &aggregate,
1296 llvm::StringRef aggName, mlir::StringAttr linkage) {
1297 assert(aggregate.isGlobal() && "not a global interval");
1298 fir::FirOpBuilder &builder = converter.getFirOpBuilder();
1299 fir::GlobalOp global = builder.getNamedGlobal(aggName);
1300 if (global && globalIsInitialized(global))
1301 return global;
1302 mlir::Location loc = converter.getCurrentLocation();
1303 mlir::Type aggTy = getAggregateType(converter, aggregate);
1304 if (!global)
1305 global = builder.createGlobal(loc, aggTy, aggName, linkage);
1306
1307 if (const Fortran::semantics::Symbol *initSym =
1308 aggregate.getInitialValueSymbol())
1309 if (const auto *objectDetails =
1310 initSym->detailsIf<Fortran::semantics::ObjectEntityDetails>())
1311 if (objectDetails->init()) {
1312 createGlobalInitialization(
1313 builder, global, [&](fir::FirOpBuilder &builder) {
1314 Fortran::lower::StatementContext stmtCtx;
1315 mlir::Value initVal = fir::getBase(genInitializerExprValue(
1316 converter, loc, objectDetails->init().value(), stmtCtx));
1317 builder.create<fir::HasValueOp>(loc, initVal);
1318 });
1319 return global;
1320 }
1321 // Equivalence has no Fortran initial value. Create an undefined FIR initial
1322 // value to ensure this is consider an object definition in the IR regardless
1323 // of the linkage.
1324 createGlobalInitialization(builder, global, [&](fir::FirOpBuilder &builder) {
1325 Fortran::lower::StatementContext stmtCtx;
1326 mlir::Value initVal = builder.create<fir::ZeroOp>(loc, aggTy);
1327 builder.create<fir::HasValueOp>(loc, initVal);
1328 });
1329 return global;
1330}
1331
1332/// Declare a GlobalOp for the storage of a global equivalence described
1333/// by \p aggregate. The global is named \p aggName and is created with
1334/// the provided \p linkage.
1335/// No initializer is built for the created GlobalOp.
1336/// This is to be used when lowering the scope that uses members of an
1337/// equivalence it through host or use association.
1338/// This is not to be used for equivalence of common block members (they
1339/// already have the common block GlobalOp for them, see defineCommonBlock).
1340static fir::GlobalOp declareGlobalAggregateStore(
1341 Fortran::lower::AbstractConverter &converter, mlir::Location loc,
1342 const Fortran::lower::pft::Variable::AggregateStore &aggregate,
1343 llvm::StringRef aggName, mlir::StringAttr linkage) {
1344 assert(aggregate.isGlobal() && "not a global interval");
1345 fir::FirOpBuilder &builder = converter.getFirOpBuilder();
1346 if (fir::GlobalOp global = builder.getNamedGlobal(aggName))
1347 return global;
1348 mlir::Type aggTy = getAggregateType(converter, aggregate);
1349 return builder.createGlobal(loc, aggTy, aggName, linkage);
1350}
1351
1352/// This is an aggregate store for a set of EQUIVALENCED variables. Create the
1353/// storage on the stack or global memory and add it to the map.
1354static void
1355instantiateAggregateStore(Fortran::lower::AbstractConverter &converter,
1356 const Fortran::lower::pft::Variable &var,
1357 Fortran::lower::AggregateStoreMap &storeMap) {
1358 assert(var.isAggregateStore() && "not an interval");
1359 fir::FirOpBuilder &builder = converter.getFirOpBuilder();
1360 mlir::IntegerType i8Ty = builder.getIntegerType(8);
1361 mlir::Location loc = converter.getCurrentLocation();
1362 std::string aggName =
1363 mangleGlobalAggregateStore(converter, var.getAggregateStore());
1364 if (var.isGlobal()) {
1365 fir::GlobalOp global;
1366 auto &aggregate = var.getAggregateStore();
1367 mlir::StringAttr linkage = getLinkageAttribute(converter, var);
1368 if (var.isModuleOrSubmoduleVariable()) {
1369 // A module global was or will be defined when lowering the module. Emit
1370 // only a declaration if the global does not exist at that point.
1371 global = declareGlobalAggregateStore(converter, loc, aggregate, aggName,
1372 linkage);
1373 } else {
1374 global =
1375 defineGlobalAggregateStore(converter, aggregate, aggName, linkage);
1376 }
1377 auto addr = builder.create<fir::AddrOfOp>(loc, global.resultType(),
1378 global.getSymbol());
1379 auto size = std::get<1>(var.getInterval());
1380 fir::SequenceType::Shape shape(1, size);
1381 auto seqTy = fir::SequenceType::get(shape, i8Ty);
1382 mlir::Type refTy = builder.getRefType(seqTy);
1383 mlir::Value aggregateStore = builder.createConvert(loc, refTy, addr);
1384 insertAggregateStore(storeMap, var, aggregateStore);
1385 return;
1386 }
1387 // This is a local aggregate, allocate an anonymous block of memory.
1388 auto size = std::get<1>(var.getInterval());
1389 fir::SequenceType::Shape shape(1, size);
1390 auto seqTy = fir::SequenceType::get(shape, i8Ty);
1391 mlir::Value local = builder.allocateLocal(loc, seqTy, aggName, "", {}, {},
1392 /*target=*/false);
1393 insertAggregateStore(storeMap, var, local);
1394}
1395
1396/// Cast an alias address (variable part of an equivalence) to fir.ptr so that
1397/// the optimizer is conservative and avoids doing copy elision in assignment
1398/// involving equivalenced variables.
1399/// TODO: Represent the equivalence aliasing constraint in another way to avoid
1400/// pessimizing array assignments involving equivalenced variables.
1401static mlir::Value castAliasToPointer(fir::FirOpBuilder &builder,
1402 mlir::Location loc, mlir::Type aliasType,
1403 mlir::Value aliasAddr) {
1404 return builder.createConvert(loc, fir::PointerType::get(aliasType),
1405 aliasAddr);
1406}
1407
1408/// Instantiate a member of an equivalence. Compute its address in its
1409/// aggregate storage and lower its attributes.
1410static void instantiateAlias(Fortran::lower::AbstractConverter &converter,
1411 const Fortran::lower::pft::Variable &var,
1412 Fortran::lower::SymMap &symMap,
1413 Fortran::lower::AggregateStoreMap &storeMap) {
1414 fir::FirOpBuilder &builder = converter.getFirOpBuilder();
1415 assert(var.isAlias());
1416 const Fortran::semantics::Symbol &sym = var.getSymbol();
1417 const mlir::Location loc = genLocation(converter, sym);
1418 mlir::IndexType idxTy = builder.getIndexType();
1419 mlir::IntegerType i8Ty = builder.getIntegerType(8);
1420 mlir::Type i8Ptr = builder.getRefType(i8Ty);
1421 mlir::Type symType = converter.genType(sym);
1422 std::size_t off = sym.GetUltimate().offset() - var.getAliasOffset();
1423 mlir::Value storeAddr = getAggregateStore(storeMap, var);
1424 mlir::Value offset = builder.createIntegerConstant(loc, idxTy, off);
1425 mlir::Value bytePtr = builder.create<fir::CoordinateOp>(
1426 loc, i8Ptr, storeAddr, mlir::ValueRange{offset});
1427 mlir::Value typedPtr = castAliasToPointer(builder, loc, symType, bytePtr);
1428 Fortran::lower::StatementContext stmtCtx;
1429 mapSymbolAttributes(converter, var, symMap, stmtCtx, typedPtr);
1430 // Default initialization is possible for equivalence members: see
1431 // F2018 19.5.3.4. Note that if several equivalenced entities have
1432 // default initialization, they must have the same type, and the standard
1433 // allows the storage to be default initialized several times (this has
1434 // no consequences other than wasting some execution time). For now,
1435 // do not try optimizing this to single default initializations of
1436 // the equivalenced storages. Keep lowering simple.
1437 if (mustBeDefaultInitializedAtRuntime(var))
1438 Fortran::lower::defaultInitializeAtRuntime(converter, var.getSymbol(),
1439 symMap);
1440}
1441
1442//===--------------------------------------------------------------===//
1443// COMMON blocks instantiation
1444//===--------------------------------------------------------------===//
1445
1446/// Does any member of the common block has an initializer ?
1447static bool
1448commonBlockHasInit(const Fortran::semantics::MutableSymbolVector &cmnBlkMems) {
1449 for (const Fortran::semantics::MutableSymbolRef &mem : cmnBlkMems) {
1450 if (const auto *memDet =
1451 mem->detailsIf<Fortran::semantics::ObjectEntityDetails>())
1452 if (memDet->init())
1453 return true;
1454 }
1455 return false;
1456}
1457
1458/// Build a tuple type for a common block based on the common block
1459/// members and the common block size.
1460/// This type is only needed to build common block initializers where
1461/// the initial value is the collection of the member initial values.
1462static mlir::TupleType getTypeOfCommonWithInit(
1463 Fortran::lower::AbstractConverter &converter,
1464 const Fortran::semantics::MutableSymbolVector &cmnBlkMems,
1465 std::size_t commonSize) {
1466 fir::FirOpBuilder &builder = converter.getFirOpBuilder();
1467 llvm::SmallVector<mlir::Type> members;
1468 std::size_t counter = 0;
1469 for (const Fortran::semantics::MutableSymbolRef &mem : cmnBlkMems) {
1470 if (const auto *memDet =
1471 mem->detailsIf<Fortran::semantics::ObjectEntityDetails>()) {
1472 if (mem->offset() > counter) {
1473 fir::SequenceType::Shape len = {
1474 static_cast<fir::SequenceType::Extent>(mem->offset() - counter)};
1475 mlir::IntegerType byteTy = builder.getIntegerType(8);
1476 auto memTy = fir::SequenceType::get(len, byteTy);
1477 members.push_back(memTy);
1478 counter = mem->offset();
1479 }
1480 if (memDet->init()) {
1481 mlir::Type memTy = converter.genType(*mem);
1482 members.push_back(memTy);
1483 counter = mem->offset() + mem->size();
1484 }
1485 }
1486 }
1487 if (counter < commonSize) {
1488 fir::SequenceType::Shape len = {
1489 static_cast<fir::SequenceType::Extent>(commonSize - counter)};
1490 mlir::IntegerType byteTy = builder.getIntegerType(8);
1491 auto memTy = fir::SequenceType::get(len, byteTy);
1492 members.push_back(memTy);
1493 }
1494 return mlir::TupleType::get(builder.getContext(), members);
1495}
1496
1497/// Common block members may have aliases. They are not in the common block
1498/// member list from the symbol. We need to know about these aliases if they
1499/// have initializer to generate the common initializer.
1500/// This function takes care of adding aliases with initializer to the member
1501/// list.
1502static Fortran::semantics::MutableSymbolVector
1503getCommonMembersWithInitAliases(const Fortran::semantics::Symbol &common) {
1504 const auto &commonDetails =
1505 common.get<Fortran::semantics::CommonBlockDetails>();
1506 auto members = commonDetails.objects();
1507
1508 // The number and size of equivalence and common is expected to be small, so
1509 // no effort is given to optimize this loop of complexity equivalenced
1510 // common members * common members
1511 for (const Fortran::semantics::EquivalenceSet &set :
1512 common.owner().equivalenceSets())
1513 for (const Fortran::semantics::EquivalenceObject &obj : set) {
1514 if (!obj.symbol.test(Fortran::semantics::Symbol::Flag::CompilerCreated)) {
1515 if (const auto &details =
1516 obj.symbol
1517 .detailsIf<Fortran::semantics::ObjectEntityDetails>()) {
1518 const Fortran::semantics::Symbol *com =
1519 FindCommonBlockContaining(obj.symbol);
1520 if (!details->init() || com != &common)
1521 continue;
1522 // This is an alias with an init that belongs to the list
1523 if (!llvm::is_contained(members, obj.symbol))
1524 members.emplace_back(obj.symbol);
1525 }
1526 }
1527 }
1528 return members;
1529}
1530
1531/// Return the fir::GlobalOp that was created of COMMON block \p common.
1532/// It is an error if the fir::GlobalOp was not created before this is
1533/// called (it cannot be created on the flight because it is not known here
1534/// what mlir type the GlobalOp should have to satisfy all the
1535/// appearances in the program).
1536static fir::GlobalOp
1537getCommonBlockGlobal(Fortran::lower::AbstractConverter &converter,
1538 const Fortran::semantics::Symbol &common) {
1539 fir::FirOpBuilder &builder = converter.getFirOpBuilder();
1540 std::string commonName = converter.mangleName(common);
1541 fir::GlobalOp global = builder.getNamedGlobal(commonName);
1542 // Common blocks are lowered before any subprograms to deal with common
1543 // whose size may not be the same in every subprograms.
1544 if (!global)
1545 fir::emitFatalError(converter.genLocation(common.name()),
1546 "COMMON block was not lowered before its usage");
1547 return global;
1548}
1549
1550/// Create the fir::GlobalOp for COMMON block \p common. If \p common has an
1551/// initial value, it is not created yet. Instead, the common block list
1552/// members is returned to later create the initial value in
1553/// finalizeCommonBlockDefinition.
1554static std::optional<std::tuple<
1555 fir::GlobalOp, Fortran::semantics::MutableSymbolVector, mlir::Location>>
1556declareCommonBlock(Fortran::lower::AbstractConverter &converter,
1557 const Fortran::semantics::Symbol &common,
1558 std::size_t commonSize) {
1559 fir::FirOpBuilder &builder = converter.getFirOpBuilder();
1560 std::string commonName = converter.mangleName(common);
1561 fir::GlobalOp global = builder.getNamedGlobal(commonName);
1562 if (global)
1563 return std::nullopt;
1564 Fortran::semantics::MutableSymbolVector cmnBlkMems =
1565 getCommonMembersWithInitAliases(common);
1566 mlir::Location loc = converter.genLocation(common.name());
1567 mlir::StringAttr linkage = builder.createCommonLinkage();
1568 const auto *details =
1569 common.detailsIf<Fortran::semantics::CommonBlockDetails>();
1570 assert(details && "Expect CommonBlockDetails on the common symbol");
1571 if (!commonBlockHasInit(cmnBlkMems)) {
1572 // A COMMON block sans initializers is initialized to zero.
1573 // mlir::Vector types must have a strictly positive size, so at least
1574 // temporarily, force a zero size COMMON block to have one byte.
1575 const auto sz =
1576 static_cast<fir::SequenceType::Extent>(commonSize > 0 ? commonSize : 1);
1577 fir::SequenceType::Shape shape = {sz};
1578 mlir::IntegerType i8Ty = builder.getIntegerType(8);
1579 auto commonTy = fir::SequenceType::get(shape, i8Ty);
1580 auto vecTy = mlir::VectorType::get(sz, i8Ty);
1581 mlir::Attribute zero = builder.getIntegerAttr(i8Ty, 0);
1582 auto init = mlir::DenseElementsAttr::get(vecTy, llvm::ArrayRef(zero));
1583 global = builder.createGlobal(loc, commonTy, commonName, linkage, init);
1584 global.setAlignment(details->alignment());
1585 // No need to add any initial value later.
1586 return std::nullopt;
1587 }
1588 // COMMON block with initializer (note that initialized blank common are
1589 // accepted as an extension by semantics). Sort members by offset before
1590 // generating the type and initializer.
1591 std::sort(cmnBlkMems.begin(), cmnBlkMems.end(),
1592 [](auto &s1, auto &s2) { return s1->offset() < s2->offset(); });
1593 mlir::TupleType commonTy =
1594 getTypeOfCommonWithInit(converter, cmnBlkMems, commonSize);
1595 // Create the global object, the initial value will be added later.
1596 global = builder.createGlobal(loc, commonTy, commonName);
1597 global.setAlignment(details->alignment());
1598 return std::make_tuple(global, std::move(cmnBlkMems), loc);
1599}
1600
1601/// Add initial value to a COMMON block fir::GlobalOp \p global given the list
1602/// \p cmnBlkMems of the common block member symbols that contains symbols with
1603/// an initial value.
1604static void finalizeCommonBlockDefinition(
1605 mlir::Location loc, Fortran::lower::AbstractConverter &converter,
1606 fir::GlobalOp global,
1607 const Fortran::semantics::MutableSymbolVector &cmnBlkMems) {
1608 fir::FirOpBuilder &builder = converter.getFirOpBuilder();
1609 mlir::TupleType commonTy = mlir::cast<mlir::TupleType>(global.getType());
1610 auto initFunc = [&](fir::FirOpBuilder &builder) {
1611 mlir::IndexType idxTy = builder.getIndexType();
1612 mlir::Value cb = builder.create<fir::ZeroOp>(loc, commonTy);
1613 unsigned tupIdx = 0;
1614 std::size_t offset = 0;
1615 LLVM_DEBUG(llvm::dbgs() << "block {\n");
1616 for (const Fortran::semantics::MutableSymbolRef &mem : cmnBlkMems) {
1617 if (const auto *memDet =
1618 mem->detailsIf<Fortran::semantics::ObjectEntityDetails>()) {
1619 if (mem->offset() > offset) {
1620 ++tupIdx;
1621 offset = mem->offset();
1622 }
1623 if (memDet->init()) {
1624 LLVM_DEBUG(llvm::dbgs()
1625 << "offset: " << mem->offset() << " is " << *mem << '\n');
1626 Fortran::lower::StatementContext stmtCtx;
1627 auto initExpr = memDet->init().value();
1628 fir::ExtendedValue initVal =
1629 Fortran::semantics::IsPointer(*mem)
1630 ? Fortran::lower::genInitialDataTarget(
1631 converter, loc, converter.genType(*mem), initExpr)
1632 : genInitializerExprValue(converter, loc, initExpr, stmtCtx);
1633 mlir::IntegerAttr offVal = builder.getIntegerAttr(idxTy, tupIdx);
1634 mlir::Value castVal = builder.createConvert(
1635 loc, commonTy.getType(tupIdx), fir::getBase(initVal));
1636 cb = builder.create<fir::InsertValueOp>(loc, commonTy, cb, castVal,
1637 builder.getArrayAttr(offVal));
1638 ++tupIdx;
1639 offset = mem->offset() + mem->size();
1640 }
1641 }
1642 }
1643 LLVM_DEBUG(llvm::dbgs() << "}\n");
1644 builder.create<fir::HasValueOp>(loc, cb);
1645 };
1646 createGlobalInitialization(builder, global, initFunc);
1647}
1648
1649void Fortran::lower::defineCommonBlocks(
1650 Fortran::lower::AbstractConverter &converter,
1651 const Fortran::semantics::CommonBlockList &commonBlocks) {
1652 // Common blocks may depend on another common block address (if they contain
1653 // pointers with initial targets). To cover this case, create all common block
1654 // fir::Global before creating the initial values (if any).
1655 std::vector<std::tuple<fir::GlobalOp, Fortran::semantics::MutableSymbolVector,
1656 mlir::Location>>
1657 delayedInitializations;
1658 for (const auto &[common, size] : commonBlocks)
1659 if (auto delayedInit = declareCommonBlock(converter, common, size))
1660 delayedInitializations.emplace_back(std::move(*delayedInit));
1661 for (auto &[global, cmnBlkMems, loc] : delayedInitializations)
1662 finalizeCommonBlockDefinition(loc, converter, global, cmnBlkMems);
1663}
1664
1665mlir::Value Fortran::lower::genCommonBlockMember(
1666 Fortran::lower::AbstractConverter &converter, mlir::Location loc,
1667 const Fortran::semantics::Symbol &sym, mlir::Value commonValue) {
1668 fir::FirOpBuilder &builder = converter.getFirOpBuilder();
1669
1670 std::size_t byteOffset = sym.GetUltimate().offset();
1671 mlir::IntegerType i8Ty = builder.getIntegerType(8);
1672 mlir::Type i8Ptr = builder.getRefType(i8Ty);
1673 mlir::Type seqTy = builder.getRefType(builder.getVarLenSeqTy(i8Ty));
1674 mlir::Value base = builder.createConvert(loc, seqTy, commonValue);
1675
1676 mlir::Value offs =
1677 builder.createIntegerConstant(loc, builder.getIndexType(), byteOffset);
1678 mlir::Value varAddr = builder.create<fir::CoordinateOp>(
1679 loc, i8Ptr, base, mlir::ValueRange{offs});
1680 mlir::Type symType = converter.genType(sym);
1681
1682 return Fortran::semantics::FindEquivalenceSet(sym) != nullptr
1683 ? castAliasToPointer(builder, loc, symType, varAddr)
1684 : builder.createConvert(loc, builder.getRefType(symType), varAddr);
1685}
1686
1687/// The COMMON block is a global structure. `var` will be at some offset
1688/// within the COMMON block. Adds the address of `var` (COMMON + offset) to
1689/// the symbol map.
1690static void instantiateCommon(Fortran::lower::AbstractConverter &converter,
1691 const Fortran::semantics::Symbol &common,
1692 const Fortran::lower::pft::Variable &var,
1693 Fortran::lower::SymMap &symMap) {
1694 fir::FirOpBuilder &builder = converter.getFirOpBuilder();
1695 const Fortran::semantics::Symbol &varSym = var.getSymbol();
1696 mlir::Location loc = converter.genLocation(varSym.name());
1697
1698 mlir::Value commonAddr;
1699 if (Fortran::lower::SymbolBox symBox = symMap.lookupSymbol(common))
1700 commonAddr = symBox.getAddr();
1701 if (!commonAddr) {
1702 // introduce a local AddrOf and add it to the map
1703 fir::GlobalOp global = getCommonBlockGlobal(converter, common);
1704 commonAddr = builder.create<fir::AddrOfOp>(loc, global.resultType(),
1705 global.getSymbol());
1706
1707 symMap.addSymbol(common, commonAddr);
1708 }
1709
1710 mlir::Value local = genCommonBlockMember(converter, loc, varSym, commonAddr);
1711 Fortran::lower::StatementContext stmtCtx;
1712 mapSymbolAttributes(converter, var, symMap, stmtCtx, local);
1713}
1714
1715//===--------------------------------------------------------------===//
1716// Lower Variables specification expressions and attributes
1717//===--------------------------------------------------------------===//
1718
1719/// Helper to decide if a dummy argument must be tracked in an BoxValue.
1720static bool lowerToBoxValue(const Fortran::semantics::Symbol &sym,
1721 mlir::Value dummyArg,
1722 Fortran::lower::AbstractConverter &converter) {
1723 // Only dummy arguments coming as fir.box can be tracked in an BoxValue.
1724 if (!dummyArg || !mlir::isa<fir::BaseBoxType>(dummyArg.getType()))
1725 return false;
1726 // Non contiguous arrays must be tracked in an BoxValue.
1727 if (sym.Rank() > 0 && !Fortran::evaluate::IsSimplyContiguous(
1728 sym, converter.getFoldingContext()))
1729 return true;
1730 // Assumed rank and optional fir.box cannot yet be read while lowering the
1731 // specifications.
1732 if (Fortran::evaluate::IsAssumedRank(sym) ||
1733 Fortran::semantics::IsOptional(sym))
1734 return true;
1735 // Polymorphic entity should be tracked through a fir.box that has the
1736 // dynamic type info.
1737 if (const Fortran::semantics::DeclTypeSpec *type = sym.GetType())
1738 if (type->IsPolymorphic())
1739 return true;
1740 return false;
1741}
1742
1743/// Lower explicit lower bounds into \p result. Does nothing if this is not an
1744/// array, or if the lower bounds are deferred, or all implicit or one.
1745static void lowerExplicitLowerBounds(
1746 Fortran::lower::AbstractConverter &converter, mlir::Location loc,
1747 const Fortran::lower::BoxAnalyzer &box,
1748 llvm::SmallVectorImpl<mlir::Value> &result, Fortran::lower::SymMap &symMap,
1749 Fortran::lower::StatementContext &stmtCtx) {
1750 if (!box.isArray() || box.lboundIsAllOnes())
1751 return;
1752 fir::FirOpBuilder &builder = converter.getFirOpBuilder();
1753 mlir::IndexType idxTy = builder.getIndexType();
1754 if (box.isStaticArray()) {
1755 for (int64_t lb : box.staticLBound())
1756 result.emplace_back(builder.createIntegerConstant(loc, idxTy, lb));
1757 return;
1758 }
1759 for (const Fortran::semantics::ShapeSpec *spec : box.dynamicBound()) {
1760 if (auto low = spec->lbound().GetExplicit()) {
1761 auto expr = Fortran::lower::SomeExpr{*low};
1762 mlir::Value lb = builder.createConvert(
1763 loc, idxTy, genScalarValue(converter, loc, expr, symMap, stmtCtx));
1764 result.emplace_back(lb);
1765 }
1766 }
1767 assert(result.empty() || result.size() == box.dynamicBound().size());
1768}
1769
1770/// Return -1 for the last dimension extent/upper bound of assumed-size arrays.
1771/// This value is required to fulfill the requirements for assumed-rank
1772/// associated with assumed-size (see for instance UBOUND in 16.9.196, and
1773/// CFI_desc_t requirements in 18.5.3 point 5.).
1774static mlir::Value getAssumedSizeExtent(mlir::Location loc,
1775 fir::FirOpBuilder &builder) {
1776 return builder.createMinusOneInteger(loc, builder.getIndexType());
1777}
1778
1779/// Lower explicit extents into \p result if this is an explicit-shape or
1780/// assumed-size array. Does nothing if this is not an explicit-shape or
1781/// assumed-size array.
1782static void
1783lowerExplicitExtents(Fortran::lower::AbstractConverter &converter,
1784 mlir::Location loc, const Fortran::lower::BoxAnalyzer &box,
1785 llvm::SmallVectorImpl<mlir::Value> &lowerBounds,
1786 llvm::SmallVectorImpl<mlir::Value> &result,
1787 Fortran::lower::SymMap &symMap,
1788 Fortran::lower::StatementContext &stmtCtx) {
1789 if (!box.isArray())
1790 return;
1791 fir::FirOpBuilder &builder = converter.getFirOpBuilder();
1792 mlir::IndexType idxTy = builder.getIndexType();
1793 if (box.isStaticArray()) {
1794 for (int64_t extent : box.staticShape())
1795 result.emplace_back(builder.createIntegerConstant(loc, idxTy, extent));
1796 return;
1797 }
1798 for (const auto &spec : llvm::enumerate(box.dynamicBound())) {
1799 if (auto up = spec.value()->ubound().GetExplicit()) {
1800 auto expr = Fortran::lower::SomeExpr{*up};
1801 mlir::Value ub = builder.createConvert(
1802 loc, idxTy, genScalarValue(converter, loc, expr, symMap, stmtCtx));
1803 if (lowerBounds.empty())
1804 result.emplace_back(fir::factory::genMaxWithZero(builder, loc, ub));
1805 else
1806 result.emplace_back(fir::factory::computeExtent(
1807 builder, loc, lowerBounds[spec.index()], ub));
1808 } else if (spec.value()->ubound().isStar()) {
1809 result.emplace_back(getAssumedSizeExtent(loc, builder));
1810 }
1811 }
1812 assert(result.empty() || result.size() == box.dynamicBound().size());
1813}
1814
1815/// Lower explicit character length if any. Return empty mlir::Value if no
1816/// explicit length.
1817static mlir::Value
1818lowerExplicitCharLen(Fortran::lower::AbstractConverter &converter,
1819 mlir::Location loc, const Fortran::lower::BoxAnalyzer &box,
1820 Fortran::lower::SymMap &symMap,
1821 Fortran::lower::StatementContext &stmtCtx) {
1822 if (!box.isChar())
1823 return mlir::Value{};
1824 fir::FirOpBuilder &builder = converter.getFirOpBuilder();
1825 mlir::Type lenTy = builder.getCharacterLengthType();
1826 if (std::optional<int64_t> len = box.getCharLenConst())
1827 return builder.createIntegerConstant(loc, lenTy, *len);
1828 if (std::optional<Fortran::lower::SomeExpr> lenExpr = box.getCharLenExpr())
1829 // If the length expression is negative, the length is zero. See F2018
1830 // 7.4.4.2 point 5.
1831 return fir::factory::genMaxWithZero(
1832 builder, loc,
1833 genScalarValue(converter, loc, *lenExpr, symMap, stmtCtx));
1834 return mlir::Value{};
1835}
1836
1837/// Assumed size arrays last extent is -1 in the front end.
1838static mlir::Value genExtentValue(fir::FirOpBuilder &builder,
1839 mlir::Location loc, mlir::Type idxTy,
1840 long frontEndExtent) {
1841 if (frontEndExtent >= 0)
1842 return builder.createIntegerConstant(loc, idxTy, frontEndExtent);
1843 return getAssumedSizeExtent(loc, builder);
1844}
1845
1846/// If a symbol is an array, it may have been declared with unknown extent
1847/// parameters (e.g., `*`), but if it has an initial value then the actual size
1848/// may be available from the initial array value's type.
1849inline static llvm::SmallVector<std::int64_t>
1850recoverShapeVector(llvm::ArrayRef<std::int64_t> shapeVec, mlir::Value initVal) {
1851 llvm::SmallVector<std::int64_t> result;
1852 if (initVal) {
1853 if (auto seqTy = fir::unwrapUntilSeqType(initVal.getType())) {
1854 for (auto [fst, snd] : llvm::zip(shapeVec, seqTy.getShape()))
1855 result.push_back(fst == fir::SequenceType::getUnknownExtent() ? snd
1856 : fst);
1857 return result;
1858 }
1859 }
1860 result.assign(in_start: shapeVec.begin(), in_end: shapeVec.end());
1861 return result;
1862}
1863
1864fir::FortranVariableFlagsAttr Fortran::lower::translateSymbolAttributes(
1865 mlir::MLIRContext *mlirContext, const Fortran::semantics::Symbol &sym,
1866 fir::FortranVariableFlagsEnum extraFlags) {
1867 fir::FortranVariableFlagsEnum flags = extraFlags;
1868 if (sym.test(Fortran::semantics::Symbol::Flag::CrayPointee)) {
1869 // CrayPointee are represented as pointers.
1870 flags = flags | fir::FortranVariableFlagsEnum::pointer;
1871 return fir::FortranVariableFlagsAttr::get(mlirContext, flags);
1872 }
1873 const auto &attrs = sym.attrs();
1874 if (attrs.test(Fortran::semantics::Attr::ALLOCATABLE))
1875 flags = flags | fir::FortranVariableFlagsEnum::allocatable;
1876 if (attrs.test(Fortran::semantics::Attr::ASYNCHRONOUS))
1877 flags = flags | fir::FortranVariableFlagsEnum::asynchronous;
1878 if (attrs.test(Fortran::semantics::Attr::BIND_C))
1879 flags = flags | fir::FortranVariableFlagsEnum::bind_c;
1880 if (attrs.test(Fortran::semantics::Attr::CONTIGUOUS))
1881 flags = flags | fir::FortranVariableFlagsEnum::contiguous;
1882 if (attrs.test(Fortran::semantics::Attr::INTENT_IN))
1883 flags = flags | fir::FortranVariableFlagsEnum::intent_in;
1884 if (attrs.test(Fortran::semantics::Attr::INTENT_INOUT))
1885 flags = flags | fir::FortranVariableFlagsEnum::intent_inout;
1886 if (attrs.test(Fortran::semantics::Attr::INTENT_OUT))
1887 flags = flags | fir::FortranVariableFlagsEnum::intent_out;
1888 if (attrs.test(Fortran::semantics::Attr::OPTIONAL))
1889 flags = flags | fir::FortranVariableFlagsEnum::optional;
1890 if (attrs.test(Fortran::semantics::Attr::PARAMETER))
1891 flags = flags | fir::FortranVariableFlagsEnum::parameter;
1892 if (attrs.test(Fortran::semantics::Attr::POINTER))
1893 flags = flags | fir::FortranVariableFlagsEnum::pointer;
1894 if (attrs.test(Fortran::semantics::Attr::TARGET))
1895 flags = flags | fir::FortranVariableFlagsEnum::target;
1896 if (attrs.test(Fortran::semantics::Attr::VALUE))
1897 flags = flags | fir::FortranVariableFlagsEnum::value;
1898 if (attrs.test(Fortran::semantics::Attr::VOLATILE))
1899 flags = flags | fir::FortranVariableFlagsEnum::fortran_volatile;
1900 if (flags == fir::FortranVariableFlagsEnum::None)
1901 return {};
1902 return fir::FortranVariableFlagsAttr::get(mlirContext, flags);
1903}
1904
1905cuf::DataAttributeAttr Fortran::lower::translateSymbolCUFDataAttribute(
1906 mlir::MLIRContext *mlirContext, const Fortran::semantics::Symbol &sym) {
1907 std::optional<Fortran::common::CUDADataAttr> cudaAttr =
1908 Fortran::semantics::GetCUDADataAttr(&sym.GetUltimate());
1909 return cuf::getDataAttribute(mlirContext, cudaAttr);
1910}
1911
1912static bool
1913isCapturedInInternalProcedure(Fortran::lower::AbstractConverter &converter,
1914 const Fortran::semantics::Symbol &sym) {
1915 const Fortran::lower::pft::FunctionLikeUnit *funit =
1916 converter.getCurrentFunctionUnit();
1917 if (!funit || funit->getHostAssoc().empty())
1918 return false;
1919 if (funit->getHostAssoc().isAssociated(sym))
1920 return true;
1921 // Consider that any capture of a variable that is in an equivalence with the
1922 // symbol imply that the storage of the symbol may also be accessed inside
1923 // symbol implies that the storage of the symbol may also be accessed inside
1924
1925 // the internal procedure and flag it as captured.
1926 if (const auto *equivSet = Fortran::semantics::FindEquivalenceSet(sym))
1927 for (const Fortran::semantics::EquivalenceObject &eqObj : *equivSet)
1928 if (funit->getHostAssoc().isAssociated(eqObj.symbol))
1929 return true;
1930 return false;
1931}
1932
1933/// Map a symbol to its FIR address and evaluated specification expressions.
1934/// Not for symbols lowered to fir.box.
1935/// Will optionally create fir.declare.
1936static void genDeclareSymbol(Fortran::lower::AbstractConverter &converter,
1937 Fortran::lower::SymMap &symMap,
1938 const Fortran::semantics::Symbol &sym,
1939 mlir::Value base, mlir::Value len = {},
1940 llvm::ArrayRef<mlir::Value> shape = {},
1941 llvm::ArrayRef<mlir::Value> lbounds = {},
1942 bool force = false) {
1943 // In HLFIR, procedure dummy symbols are not added with an hlfir.declare
1944 // because they are "values", and hlfir.declare is intended for variables. It
1945 // would add too much complexity to hlfir.declare to support this case, and
1946 // this would bring very little (the only point being debug info, that are not
1947 // yet emitted) since alias analysis is meaningless for those.
1948 // Commonblock names are not variables, but in some lowerings (like OpenMP) it
1949 // is useful to maintain the address of the commonblock in an MLIR value and
1950 // query it. hlfir.declare need not be created for these.
1951 if (converter.getLoweringOptions().getLowerToHighLevelFIR() &&
1952 (!Fortran::semantics::IsProcedure(sym) ||
1953 Fortran::semantics::IsPointer(sym)) &&
1954 !sym.detailsIf<Fortran::semantics::CommonBlockDetails>()) {
1955 fir::FirOpBuilder &builder = converter.getFirOpBuilder();
1956 const mlir::Location loc = genLocation(converter, sym);
1957 mlir::Value shapeOrShift;
1958 if (!shape.empty() && !lbounds.empty())
1959 shapeOrShift = builder.genShape(loc, lbounds, shape);
1960 else if (!shape.empty())
1961 shapeOrShift = builder.genShape(loc, shape);
1962 else if (!lbounds.empty())
1963 shapeOrShift = builder.genShift(loc, lbounds);
1964 llvm::SmallVector<mlir::Value> lenParams;
1965 if (len)
1966 lenParams.emplace_back(len);
1967 auto name = converter.mangleName(sym);
1968 fir::FortranVariableFlagsEnum extraFlags = {};
1969 if (isCapturedInInternalProcedure(converter, sym))
1970 extraFlags = extraFlags | fir::FortranVariableFlagsEnum::internal_assoc;
1971 fir::FortranVariableFlagsAttr attributes =
1972 Fortran::lower::translateSymbolAttributes(builder.getContext(), sym,
1973 extraFlags);
1974 cuf::DataAttributeAttr dataAttr =
1975 Fortran::lower::translateSymbolCUFDataAttribute(builder.getContext(),
1976 sym);
1977
1978 if (sym.test(Fortran::semantics::Symbol::Flag::CrayPointee)) {
1979 mlir::Type ptrBoxType =
1980 Fortran::lower::getCrayPointeeBoxType(base.getType());
1981 mlir::Value boxAlloc = builder.createTemporary(
1982 loc, ptrBoxType,
1983 /*name=*/{}, /*shape=*/{}, /*lenParams=*/{}, /*attrs=*/{},
1984 Fortran::semantics::GetCUDADataAttr(&sym.GetUltimate()));
1985
1986 // Declare a local pointer variable.
1987 auto newBase = builder.create<hlfir::DeclareOp>(
1988 loc, boxAlloc, name, /*shape=*/nullptr, lenParams,
1989 /*dummy_scope=*/nullptr, attributes);
1990 mlir::Value nullAddr = builder.createNullConstant(
1991 loc, llvm::cast<fir::BaseBoxType>(ptrBoxType).getEleTy());
1992
1993 // If the element type is known-length character, then
1994 // EmboxOp does not need the length parameters.
1995 if (auto charType = mlir::dyn_cast<fir::CharacterType>(
1996 hlfir::getFortranElementType(base.getType())))
1997 if (!charType.hasDynamicLen())
1998 lenParams.clear();
1999
2000 // Inherit the shape (and maybe length parameters) from the pointee
2001 // declaration.
2002 mlir::Value initVal =
2003 builder.create<fir::EmboxOp>(loc, ptrBoxType, nullAddr, shapeOrShift,
2004 /*slice=*/nullptr, lenParams);
2005 builder.create<fir::StoreOp>(loc, initVal, newBase.getBase());
2006
2007 // Any reference to the pointee is going to be using the pointer
2008 // box from now on. The base_addr of the descriptor must be updated
2009 // to hold the value of the Cray pointer at the point of the pointee
2010 // access.
2011 // Note that the same Cray pointer may be associated with
2012 // multiple pointees and each of them has its own descriptor.
2013 symMap.addVariableDefinition(sym, newBase, force);
2014 return;
2015 }
2016 mlir::Value dummyScope;
2017 if (converter.isRegisteredDummySymbol(sym))
2018 dummyScope = converter.dummyArgsScopeValue();
2019 auto newBase = builder.create<hlfir::DeclareOp>(
2020 loc, base, name, shapeOrShift, lenParams, dummyScope, attributes,
2021 dataAttr);
2022 symMap.addVariableDefinition(sym, newBase, force);
2023 return;
2024 }
2025
2026 if (len) {
2027 if (!shape.empty()) {
2028 if (!lbounds.empty())
2029 symMap.addCharSymbolWithBounds(sym, base, len, shape, lbounds, force);
2030 else
2031 symMap.addCharSymbolWithShape(sym, base, len, shape, force);
2032 } else {
2033 symMap.addCharSymbol(sym, base, len, force);
2034 }
2035 } else {
2036 if (!shape.empty()) {
2037 if (!lbounds.empty())
2038 symMap.addSymbolWithBounds(sym, base, shape, lbounds, force);
2039 else
2040 symMap.addSymbolWithShape(sym, base, shape, force);
2041 } else {
2042 symMap.addSymbol(sym, base, force);
2043 }
2044 }
2045}
2046
2047/// Map a symbol to its FIR address and evaluated specification expressions
2048/// provided as a fir::ExtendedValue. Will optionally create fir.declare.
2049void Fortran::lower::genDeclareSymbol(
2050 Fortran::lower::AbstractConverter &converter,
2051 Fortran::lower::SymMap &symMap, const Fortran::semantics::Symbol &sym,
2052 const fir::ExtendedValue &exv, fir::FortranVariableFlagsEnum extraFlags,
2053 bool force) {
2054 if (converter.getLoweringOptions().getLowerToHighLevelFIR() &&
2055 (!Fortran::semantics::IsProcedure(sym) ||
2056 Fortran::semantics::IsPointer(sym.GetUltimate())) &&
2057 !sym.detailsIf<Fortran::semantics::CommonBlockDetails>()) {
2058 fir::FirOpBuilder &builder = converter.getFirOpBuilder();
2059 const mlir::Location loc = genLocation(converter, sym);
2060 if (isCapturedInInternalProcedure(converter, sym))
2061 extraFlags = extraFlags | fir::FortranVariableFlagsEnum::internal_assoc;
2062 // FIXME: Using the ultimate symbol for translating symbol attributes will
2063 // lead to situations where the VOLATILE/ASYNCHRONOUS attributes are not
2064 // propagated to the hlfir.declare (these attributes can be added when
2065 // using module variables).
2066 fir::FortranVariableFlagsAttr attributes =
2067 Fortran::lower::translateSymbolAttributes(
2068 builder.getContext(), sym.GetUltimate(), extraFlags);
2069 cuf::DataAttributeAttr dataAttr =
2070 Fortran::lower::translateSymbolCUFDataAttribute(builder.getContext(),
2071 sym.GetUltimate());
2072 auto name = converter.mangleName(sym);
2073 mlir::Value dummyScope;
2074 fir::ExtendedValue base = exv;
2075 if (converter.isRegisteredDummySymbol(sym)) {
2076 base = genPackArray(converter, sym, exv);
2077 dummyScope = converter.dummyArgsScopeValue();
2078 }
2079 hlfir::EntityWithAttributes declare = hlfir::genDeclare(
2080 loc, builder, base, name, attributes, dummyScope, dataAttr);
2081 symMap.addVariableDefinition(sym, declare.getIfVariableInterface(), force);
2082 return;
2083 }
2084 symMap.addSymbol(sym, exv, force);
2085}
2086
2087/// Map an allocatable or pointer symbol to its FIR address and evaluated
2088/// specification expressions. Will optionally create fir.declare.
2089static void
2090genAllocatableOrPointerDeclare(Fortran::lower::AbstractConverter &converter,
2091 Fortran::lower::SymMap &symMap,
2092 const Fortran::semantics::Symbol &sym,
2093 fir::MutableBoxValue box, bool force = false) {
2094 if (!converter.getLoweringOptions().getLowerToHighLevelFIR()) {
2095 symMap.addAllocatableOrPointer(sym, box, force);
2096 return;
2097 }
2098 assert(!box.isDescribedByVariables() &&
2099 "HLFIR alloctables/pointers must be fir.ref<fir.box>");
2100 mlir::Value base = box.getAddr();
2101 mlir::Value explictLength;
2102 if (box.hasNonDeferredLenParams()) {
2103 if (!box.isCharacter())
2104 TODO(genLocation(converter, sym),
2105 "Pointer or Allocatable parametrized derived type");
2106 explictLength = box.nonDeferredLenParams()[0];
2107 }
2108 genDeclareSymbol(converter, symMap, sym, base, explictLength,
2109 /*shape=*/{},
2110 /*lbounds=*/{}, force);
2111}
2112
2113/// Map a procedure pointer
2114static void genProcPointer(Fortran::lower::AbstractConverter &converter,
2115 Fortran::lower::SymMap &symMap,
2116 const Fortran::semantics::Symbol &sym,
2117 mlir::Value addr, bool force = false) {
2118 genDeclareSymbol(converter, symMap, sym, addr, mlir::Value{},
2119 /*shape=*/{},
2120 /*lbounds=*/{}, force);
2121}
2122
2123/// Map a symbol represented with a runtime descriptor to its FIR fir.box and
2124/// evaluated specification expressions. Will optionally create fir.declare.
2125static void genBoxDeclare(Fortran::lower::AbstractConverter &converter,
2126 Fortran::lower::SymMap &symMap,
2127 const Fortran::semantics::Symbol &sym,
2128 mlir::Value box, llvm::ArrayRef<mlir::Value> lbounds,
2129 llvm::ArrayRef<mlir::Value> explicitParams,
2130 llvm::ArrayRef<mlir::Value> explicitExtents,
2131 bool replace = false) {
2132 if (converter.getLoweringOptions().getLowerToHighLevelFIR()) {
2133 fir::BoxValue boxValue{box, lbounds, explicitParams, explicitExtents};
2134 Fortran::lower::genDeclareSymbol(
2135 converter, symMap, sym, std::move(boxValue),
2136 fir::FortranVariableFlagsEnum::None, replace);
2137 return;
2138 }
2139 symMap.addBoxSymbol(sym, box, lbounds, explicitParams, explicitExtents,
2140 replace);
2141}
2142
2143/// Lower specification expressions and attributes of variable \p var and
2144/// add it to the symbol map. For a global or an alias, the address must be
2145/// pre-computed and provided in \p preAlloc. A dummy argument for the current
2146/// entry point has already been mapped to an mlir block argument in
2147/// mapDummiesAndResults. Its mapping may be updated here.
2148void Fortran::lower::mapSymbolAttributes(
2149 AbstractConverter &converter, const Fortran::lower::pft::Variable &var,
2150 Fortran::lower::SymMap &symMap, Fortran::lower::StatementContext &stmtCtx,
2151 mlir::Value preAlloc) {
2152 fir::FirOpBuilder &builder = converter.getFirOpBuilder();
2153 const Fortran::semantics::Symbol &sym = var.getSymbol();
2154 const mlir::Location loc = genLocation(converter, sym);
2155 mlir::IndexType idxTy = builder.getIndexType();
2156 const bool isDeclaredDummy = Fortran::semantics::IsDummy(sym);
2157 // An active dummy from the current entry point.
2158 const bool isDummy = isDeclaredDummy && symMap.lookupSymbol(sym).getAddr();
2159 // An unused dummy from another entry point.
2160 const bool isUnusedEntryDummy = isDeclaredDummy && !isDummy;
2161 const bool isResult = Fortran::semantics::IsFunctionResult(sym);
2162 const bool replace = isDummy || isResult;
2163 fir::factory::CharacterExprHelper charHelp{builder, loc};
2164
2165 if (Fortran::semantics::IsProcedure(sym)) {
2166 if (isUnusedEntryDummy) {
2167 // Additional discussion below.
2168 mlir::Type dummyProcType =
2169 Fortran::lower::getDummyProcedureType(sym, converter);
2170 mlir::Value undefOp = builder.create<fir::UndefOp>(loc, dummyProcType);
2171
2172 Fortran::lower::genDeclareSymbol(converter, symMap, sym, undefOp);
2173 }
2174
2175 // Procedure pointer.
2176 if (Fortran::semantics::IsPointer(sym)) {
2177 // global
2178 mlir::Value boxAlloc = preAlloc;
2179 // dummy or passed result
2180 if (!boxAlloc)
2181 if (Fortran::lower::SymbolBox symbox = symMap.lookupSymbol(sym))
2182 boxAlloc = symbox.getAddr();
2183 // local
2184 if (!boxAlloc)
2185 boxAlloc = createNewLocal(converter, loc, var, preAlloc);
2186 genProcPointer(converter, symMap, sym, boxAlloc, replace);
2187 }
2188 return;
2189 }
2190
2191 const bool isAssumedRank = Fortran::evaluate::IsAssumedRank(sym);
2192 if (isAssumedRank && !allowAssumedRank)
2193 TODO(loc, "assumed-rank variable in procedure implemented in Fortran");
2194
2195 Fortran::lower::BoxAnalyzer ba;
2196 ba.analyze(sym);
2197
2198 // First deal with pointers and allocatables, because their handling here
2199 // is the same regardless of their rank.
2200 if (Fortran::semantics::IsAllocatableOrPointer(sym)) {
2201 // Get address of fir.box describing the entity.
2202 // global
2203 mlir::Value boxAlloc = preAlloc;
2204 // dummy or passed result
2205 if (!boxAlloc)
2206 if (Fortran::lower::SymbolBox symbox = symMap.lookupSymbol(sym))
2207 boxAlloc = symbox.getAddr();
2208 assert((boxAlloc || !isAssumedRank) && "assumed-ranks cannot be local");
2209 // local
2210 if (!boxAlloc)
2211 boxAlloc = createNewLocal(converter, loc, var, preAlloc);
2212 // Lower non deferred parameters.
2213 llvm::SmallVector<mlir::Value> nonDeferredLenParams;
2214 if (ba.isChar()) {
2215 if (mlir::Value len =
2216 lowerExplicitCharLen(converter, loc, ba, symMap, stmtCtx))
2217 nonDeferredLenParams.push_back(len);
2218 else if (Fortran::semantics::IsAssumedLengthCharacter(sym))
2219 nonDeferredLenParams.push_back(
2220 Fortran::lower::getAssumedCharAllocatableOrPointerLen(
2221 builder, loc, sym, boxAlloc));
2222 } else if (const Fortran::semantics::DeclTypeSpec *declTy = sym.GetType()) {
2223 if (const Fortran::semantics::DerivedTypeSpec *derived =
2224 declTy->AsDerived())
2225 if (Fortran::semantics::CountLenParameters(*derived) != 0)
2226 TODO(loc,
2227 "derived type allocatable or pointer with length parameters");
2228 }
2229 fir::MutableBoxValue box = Fortran::lower::createMutableBox(
2230 converter, loc, var, boxAlloc, nonDeferredLenParams,
2231 /*alwaysUseBox=*/
2232 converter.getLoweringOptions().getLowerToHighLevelFIR(),
2233 Fortran::lower::getAllocatorIdx(var.getSymbol()));
2234 genAllocatableOrPointerDeclare(converter, symMap, var.getSymbol(), box,
2235 replace);
2236 return;
2237 }
2238
2239 if (isDummy) {
2240 mlir::Value dummyArg = symMap.lookupSymbol(sym).getAddr();
2241 if (lowerToBoxValue(sym, dummyArg, converter)) {
2242 llvm::SmallVector<mlir::Value> lbounds;
2243 llvm::SmallVector<mlir::Value> explicitExtents;
2244 llvm::SmallVector<mlir::Value> explicitParams;
2245 // Lower lower bounds, explicit type parameters and explicit
2246 // extents if any.
2247 if (ba.isChar()) {
2248 if (mlir::Value len =
2249 lowerExplicitCharLen(converter, loc, ba, symMap, stmtCtx))
2250 explicitParams.push_back(len);
2251 if (!isAssumedRank && sym.Rank() == 0) {
2252 // Do not keep scalar characters as fir.box (even when optional).
2253 // Lowering and FIR is not meant to deal with scalar characters as
2254 // fir.box outside of calls.
2255 auto boxTy = mlir::dyn_cast<fir::BaseBoxType>(dummyArg.getType());
2256 mlir::Type refTy = builder.getRefType(boxTy.getEleTy());
2257 mlir::Type lenType = builder.getCharacterLengthType();
2258 mlir::Value addr, len;
2259 if (Fortran::semantics::IsOptional(sym)) {
2260 auto isPresent = builder.create<fir::IsPresentOp>(
2261 loc, builder.getI1Type(), dummyArg);
2262 auto addrAndLen =
2263 builder
2264 .genIfOp(loc, {refTy, lenType}, isPresent,
2265 /*withElseRegion=*/true)
2266 .genThen([&]() {
2267 mlir::Value readAddr =
2268 builder.create<fir::BoxAddrOp>(loc, refTy, dummyArg);
2269 mlir::Value readLength =
2270 charHelp.readLengthFromBox(dummyArg);
2271 builder.create<fir::ResultOp>(
2272 loc, mlir::ValueRange{readAddr, readLength});
2273 })
2274 .genElse([&] {
2275 mlir::Value readAddr = builder.genAbsentOp(loc, refTy);
2276 mlir::Value readLength =
2277 fir::factory::createZeroValue(builder, loc, lenType);
2278 builder.create<fir::ResultOp>(
2279 loc, mlir::ValueRange{readAddr, readLength});
2280 })
2281 .getResults();
2282 addr = addrAndLen[0];
2283 len = addrAndLen[1];
2284 } else {
2285 addr = builder.create<fir::BoxAddrOp>(loc, refTy, dummyArg);
2286 len = charHelp.readLengthFromBox(dummyArg);
2287 }
2288 if (!explicitParams.empty())
2289 len = explicitParams[0];
2290 ::genDeclareSymbol(converter, symMap, sym, addr, len, /*extents=*/{},
2291 /*lbounds=*/{}, replace);
2292 return;
2293 }
2294 }
2295 // TODO: derived type length parameters.
2296 if (!isAssumedRank) {
2297 lowerExplicitLowerBounds(converter, loc, ba, lbounds, symMap, stmtCtx);
2298 lowerExplicitExtents(converter, loc, ba, lbounds, explicitExtents,
2299 symMap, stmtCtx);
2300 }
2301 genBoxDeclare(converter, symMap, sym, dummyArg, lbounds, explicitParams,
2302 explicitExtents, replace);
2303 return;
2304 }
2305 }
2306
2307 // A dummy from another entry point that is not declared in the current
2308 // entry point requires a skeleton definition. Most such "unused" dummies
2309 // will not survive into final generated code, but some will. It is illegal
2310 // to reference one at run time if it does. Such a dummy is mapped to a
2311 // value in one of three ways:
2312 //
2313 // - Generate a fir::UndefOp value. This is lightweight, easy to clean up,
2314 // and often valid, but it may fail for a dummy with dynamic bounds,
2315 // or a dummy used to define another dummy. Information to distinguish
2316 // valid cases is not generally available here, with the exception of
2317 // dummy procedures. See the first function exit above.
2318 //
2319 // - Allocate an uninitialized stack slot. This is an intermediate-weight
2320 // solution that is harder to clean up. It is often valid, but may fail
2321 // for an object with dynamic bounds. This option is "automatically"
2322 // used by default for cases that do not use one of the other options.
2323 //
2324 // - Allocate a heap box/descriptor, initialized to zero. This always
2325 // works, but is more heavyweight and harder to clean up. It is used
2326 // for dynamic objects via calls to genUnusedEntryPointBox.
2327
2328 auto genUnusedEntryPointBox = [&]() {
2329 if (isUnusedEntryDummy) {
2330 assert(!Fortran::semantics::IsAllocatableOrPointer(sym) &&
2331 "handled above");
2332 // The box is read right away because lowering code does not expect
2333 // a non pointer/allocatable symbol to be mapped to a MutableBox.
2334 mlir::Type ty = converter.genType(var);
2335 bool isPolymorphic = false;
2336 if (auto boxTy = mlir::dyn_cast<fir::BaseBoxType>(ty)) {
2337 isPolymorphic = mlir::isa<fir::ClassType>(ty);
2338 ty = boxTy.getEleTy();
2339 }
2340 Fortran::lower::genDeclareSymbol(
2341 converter, symMap, sym,
2342 fir::factory::genMutableBoxRead(
2343 builder, loc,
2344 fir::factory::createTempMutableBox(builder, loc, ty, {}, {},
2345 isPolymorphic)),
2346 fir::FortranVariableFlagsEnum::None,
2347 converter.isRegisteredDummySymbol(sym));
2348 return true;
2349 }
2350 return false;
2351 };
2352
2353 if (isAssumedRank) {
2354 assert(isUnusedEntryDummy && "assumed rank must be pointers/allocatables "
2355 "or descriptor dummy arguments");
2356 genUnusedEntryPointBox();
2357 return;
2358 }
2359
2360 // Helper to generate scalars for the symbol properties.
2361 auto genValue = [&](const Fortran::lower::SomeExpr &expr) {
2362 return genScalarValue(converter, loc, expr, symMap, stmtCtx);
2363 };
2364
2365 // For symbols reaching this point, all properties are constant and can be
2366 // read/computed already into ssa values.
2367
2368 // The origin must be \vec{1}.
2369 auto populateShape = [&](auto &shapes, const auto &bounds, mlir::Value box) {
2370 for (auto iter : llvm::enumerate(bounds)) {
2371 auto *spec = iter.value();
2372 assert(spec->lbound().GetExplicit() &&
2373 "lbound must be explicit with constant value 1");
2374 if (auto high = spec->ubound().GetExplicit()) {
2375 Fortran::lower::SomeExpr highEx{*high};
2376 mlir::Value ub = genValue(highEx);
2377 ub = builder.createConvert(loc, idxTy, ub);
2378 shapes.emplace_back(fir::factory::genMaxWithZero(builder, loc, ub));
2379 } else if (spec->ubound().isColon()) {
2380 assert(box && "assumed bounds require a descriptor");
2381 mlir::Value dim =
2382 builder.createIntegerConstant(loc, idxTy, iter.index());
2383 auto dimInfo =
2384 builder.create<fir::BoxDimsOp>(loc, idxTy, idxTy, idxTy, box, dim);
2385 shapes.emplace_back(dimInfo.getResult(1));
2386 } else if (spec->ubound().isStar()) {
2387 shapes.emplace_back(getAssumedSizeExtent(loc, builder));
2388 } else {
2389 llvm::report_fatal_error("unknown bound category");
2390 }
2391 }
2392 };
2393
2394 // The origin is not \vec{1}.
2395 auto populateLBoundsExtents = [&](auto &lbounds, auto &extents,
2396 const auto &bounds, mlir::Value box) {
2397 for (auto iter : llvm::enumerate(bounds)) {
2398 auto *spec = iter.value();
2399 fir::BoxDimsOp dimInfo;
2400 mlir::Value ub, lb;
2401 if (spec->lbound().isColon() || spec->ubound().isColon()) {
2402 // This is an assumed shape because allocatables and pointers extents
2403 // are not constant in the scope and are not read here.
2404 assert(box && "deferred bounds require a descriptor");
2405 mlir::Value dim =
2406 builder.createIntegerConstant(loc, idxTy, iter.index());
2407 dimInfo =
2408 builder.create<fir::BoxDimsOp>(loc, idxTy, idxTy, idxTy, box, dim);
2409 extents.emplace_back(dimInfo.getResult(1));
2410 if (auto low = spec->lbound().GetExplicit()) {
2411 auto expr = Fortran::lower::SomeExpr{*low};
2412 mlir::Value lb = builder.createConvert(loc, idxTy, genValue(expr));
2413 lbounds.emplace_back(lb);
2414 } else {
2415 // Implicit lower bound is 1 (Fortran 2018 section 8.5.8.3 point 3.)
2416 lbounds.emplace_back(builder.createIntegerConstant(loc, idxTy, 1));
2417 }
2418 } else {
2419 if (auto low = spec->lbound().GetExplicit()) {
2420 auto expr = Fortran::lower::SomeExpr{*low};
2421 lb = builder.createConvert(loc, idxTy, genValue(expr));
2422 } else {
2423 TODO(loc, "support for assumed rank entities");
2424 }
2425 lbounds.emplace_back(lb);
2426
2427 if (auto high = spec->ubound().GetExplicit()) {
2428 auto expr = Fortran::lower::SomeExpr{*high};
2429 ub = builder.createConvert(loc, idxTy, genValue(expr));
2430 extents.emplace_back(
2431 fir::factory::computeExtent(builder, loc, lb, ub));
2432 } else {
2433 // An assumed size array. The extent is not computed.
2434 assert(spec->ubound().isStar() && "expected assumed size");
2435 extents.emplace_back(getAssumedSizeExtent(loc, builder));
2436 }
2437 }
2438 }
2439 };
2440
2441 //===--------------------------------------------------------------===//
2442 // Non Pointer non allocatable scalar, explicit shape, and assumed
2443 // size arrays.
2444 // Lower the specification expressions.
2445 //===--------------------------------------------------------------===//
2446
2447 mlir::Value len;
2448 llvm::SmallVector<mlir::Value> extents;
2449 llvm::SmallVector<mlir::Value> lbounds;
2450 auto arg = symMap.lookupSymbol(sym).getAddr();
2451 mlir::Value addr = preAlloc;
2452
2453 if (arg)
2454 if (auto boxTy = mlir::dyn_cast<fir::BaseBoxType>(arg.getType())) {
2455 // Contiguous assumed shape that can be tracked without a fir.box.
2456 mlir::Type refTy = builder.getRefType(boxTy.getEleTy());
2457 addr = builder.create<fir::BoxAddrOp>(loc, refTy, arg);
2458 }
2459
2460 // Compute/Extract character length.
2461 if (ba.isChar()) {
2462 if (arg) {
2463 assert(!preAlloc && "dummy cannot be pre-allocated");
2464 if (mlir::isa<fir::BoxCharType>(arg.getType())) {
2465 std::tie(addr, len) = charHelp.createUnboxChar(arg);
2466 } else if (mlir::isa<fir::CharacterType>(arg.getType())) {
2467 // fir.char<1> passed by value (BIND(C) with VALUE attribute).
2468 addr = builder.create<fir::AllocaOp>(loc, arg.getType());
2469 builder.create<fir::StoreOp>(loc, arg, addr);
2470 } else if (!addr) {
2471 addr = arg;
2472 }
2473 // Ensure proper type is given to array/scalar that was transmitted as a
2474 // fir.boxchar arg or is a statement function actual argument with
2475 // a different length than the dummy.
2476 mlir::Type castTy = builder.getRefType(converter.genType(var));
2477 addr = builder.createConvert(loc, castTy, addr);
2478 }
2479 if (std::optional<int64_t> cstLen = ba.getCharLenConst()) {
2480 // Static length
2481 len = builder.createIntegerConstant(loc, idxTy, *cstLen);
2482 } else {
2483 // Dynamic length
2484 if (genUnusedEntryPointBox())
2485 return;
2486 if (std::optional<Fortran::lower::SomeExpr> charLenExpr =
2487 ba.getCharLenExpr()) {
2488 // Explicit length
2489 mlir::Value rawLen = genValue(*charLenExpr);
2490 // If the length expression is negative, the length is zero. See
2491 // F2018 7.4.4.2 point 5.
2492 len = fir::factory::genMaxWithZero(builder, loc, rawLen);
2493 } else if (!len) {
2494 // Assumed length fir.box (possible for contiguous assumed shapes).
2495 // Read length from box.
2496 assert(arg && mlir::isa<fir::BoxType>(arg.getType()) &&
2497 "must be character dummy fir.box");
2498 len = charHelp.readLengthFromBox(arg);
2499 }
2500 }
2501 }
2502
2503 // Compute array extents and lower bounds.
2504 if (ba.isArray()) {
2505 if (ba.isStaticArray()) {
2506 if (ba.lboundIsAllOnes()) {
2507 for (std::int64_t extent :
2508 recoverShapeVector(ba.staticShape(), preAlloc))
2509 extents.push_back(genExtentValue(builder, loc, idxTy, extent));
2510 } else {
2511 for (auto [lb, extent] :
2512 llvm::zip(ba.staticLBound(),
2513 recoverShapeVector(ba.staticShape(), preAlloc))) {
2514 lbounds.emplace_back(builder.createIntegerConstant(loc, idxTy, lb));
2515 extents.emplace_back(genExtentValue(builder, loc, idxTy, extent));
2516 }
2517 }
2518 } else {
2519 // Non compile time constant shape.
2520 if (genUnusedEntryPointBox())
2521 return;
2522 if (ba.lboundIsAllOnes())
2523 populateShape(extents, ba.dynamicBound(), arg);
2524 else
2525 populateLBoundsExtents(lbounds, extents, ba.dynamicBound(), arg);
2526 }
2527 }
2528
2529 // Allocate or extract raw address for the entity
2530 if (!addr) {
2531 if (arg) {
2532 mlir::Type argType = arg.getType();
2533 const bool isCptrByVal = Fortran::semantics::IsBuiltinCPtr(sym) &&
2534 Fortran::lower::isCPtrArgByValueType(argType);
2535 if (isCptrByVal || !fir::conformsWithPassByRef(argType)) {
2536 // Dummy argument passed in register. Place the value in memory at that
2537 // point since lowering expect symbols to be mapped to memory addresses.
2538 mlir::Type symType = converter.genType(sym);
2539 addr = builder.create<fir::AllocaOp>(loc, symType);
2540 if (isCptrByVal) {
2541 // Place the void* address into the CPTR address component.
2542 mlir::Value addrComponent =
2543 fir::factory::genCPtrOrCFunptrAddr(builder, loc, addr, symType);
2544 builder.createStoreWithConvert(loc, arg, addrComponent);
2545 } else {
2546 builder.createStoreWithConvert(loc, arg, addr);
2547 }
2548 } else {
2549 // Dummy address, or address of result whose storage is passed by the
2550 // caller.
2551 assert(fir::isa_ref_type(argType) && "must be a memory address");
2552 addr = arg;
2553 }
2554 } else {
2555 // Local variables
2556 llvm::SmallVector<mlir::Value> typeParams;
2557 if (len)
2558 typeParams.emplace_back(len);
2559 addr = createNewLocal(converter, loc, var, preAlloc, extents, typeParams);
2560 }
2561 }
2562
2563 ::genDeclareSymbol(converter, symMap, sym, addr, len, extents, lbounds,
2564 replace);
2565 return;
2566}
2567
2568void Fortran::lower::defineModuleVariable(
2569 AbstractConverter &converter, const Fortran::lower::pft::Variable &var) {
2570 // Use empty linkage for module variables, which makes them available
2571 // for use in another unit.
2572 mlir::StringAttr linkage = getLinkageAttribute(converter, var);
2573 if (!var.isGlobal())
2574 fir::emitFatalError(converter.getCurrentLocation(),
2575 "attempting to lower module variable as local");
2576 // Define aggregate storages for equivalenced objects.
2577 if (var.isAggregateStore()) {
2578 const Fortran::lower::pft::Variable::AggregateStore &aggregate =
2579 var.getAggregateStore();
2580 std::string aggName = mangleGlobalAggregateStore(converter, aggregate);
2581 defineGlobalAggregateStore(converter, aggregate, aggName, linkage);
2582 return;
2583 }
2584 const Fortran::semantics::Symbol &sym = var.getSymbol();
2585 if (const Fortran::semantics::Symbol *common =
2586 Fortran::semantics::FindCommonBlockContaining(var.getSymbol())) {
2587 // Nothing to do, common block are generated before everything. Ensure
2588 // this was done by calling getCommonBlockGlobal.
2589 getCommonBlockGlobal(converter, *common);
2590 } else if (var.isAlias()) {
2591 // Do nothing. Mapping will be done on user side.
2592 } else {
2593 std::string globalName = converter.mangleName(sym);
2594 cuf::DataAttributeAttr dataAttr =
2595 Fortran::lower::translateSymbolCUFDataAttribute(
2596 converter.getFirOpBuilder().getContext(), sym);
2597 defineGlobal(converter, var, globalName, linkage, dataAttr);
2598 }
2599}
2600
2601void Fortran::lower::instantiateVariable(AbstractConverter &converter,
2602 const pft::Variable &var,
2603 Fortran::lower::SymMap &symMap,
2604 AggregateStoreMap &storeMap) {
2605 if (var.hasSymbol()) {
2606 // Do not try to instantiate symbols twice, except for dummies and results,
2607 // that may have been mapped to the MLIR entry block arguments, and for
2608 // which the explicit specifications, if any, has not yet been lowered.
2609 const auto &sym = var.getSymbol();
2610 if (!IsDummy(sym) && !IsFunctionResult(sym) && symMap.lookupSymbol(sym))
2611 return;
2612 }
2613 LLVM_DEBUG(llvm::dbgs() << "instantiateVariable: "; var.dump());
2614 if (var.isAggregateStore())
2615 instantiateAggregateStore(converter, var, storeMap);
2616 else if (const Fortran::semantics::Symbol *common =
2617 Fortran::semantics::FindCommonBlockContaining(
2618 var.getSymbol().GetUltimate()))
2619 instantiateCommon(converter, *common, var, symMap);
2620 else if (var.isAlias())
2621 instantiateAlias(converter, var, symMap, storeMap);
2622 else if (var.isGlobal())
2623 instantiateGlobal(converter, var, symMap);
2624 else
2625 instantiateLocal(converter, var, symMap);
2626}
2627
2628static void
2629mapCallInterfaceSymbol(const Fortran::semantics::Symbol &interfaceSymbol,
2630 Fortran::lower::AbstractConverter &converter,
2631 const Fortran::lower::CallerInterface &caller,
2632 Fortran::lower::SymMap &symMap) {
2633 Fortran::lower::AggregateStoreMap storeMap;
2634 for (Fortran::lower::pft::Variable var :
2635 Fortran::lower::pft::getDependentVariableList(interfaceSymbol)) {
2636 if (var.isAggregateStore()) {
2637 instantiateVariable(converter, var, symMap, storeMap);
2638 continue;
2639 }
2640 const Fortran::semantics::Symbol &sym = var.getSymbol();
2641 if (&sym == &interfaceSymbol)
2642 continue;
2643 const auto *hostDetails =
2644 sym.detailsIf<Fortran::semantics::HostAssocDetails>();
2645 if (hostDetails && !var.isModuleOrSubmoduleVariable()) {
2646 // The callee is an internal procedure `A` whose result properties
2647 // depend on host variables. The caller may be the host, or another
2648 // internal procedure `B` contained in the same host. In the first
2649 // case, the host symbol is obviously mapped, in the second case, it
2650 // must also be mapped because
2651 // HostAssociations::internalProcedureBindings that was called when
2652 // lowering `B` will have mapped all host symbols of captured variables
2653 // to the tuple argument containing the composite of all host associated
2654 // variables, whether or not the host symbol is actually referred to in
2655 // `B`. Hence it is possible to simply lookup the variable associated to
2656 // the host symbol without having to go back to the tuple argument.
2657 symMap.copySymbolBinding(hostDetails->symbol(), sym);
2658 // The SymbolBox associated to the host symbols is complete, skip
2659 // instantiateVariable that would try to allocate a new storage.
2660 continue;
2661 }
2662 if (Fortran::semantics::IsDummy(sym) &&
2663 sym.owner() == interfaceSymbol.owner()) {
2664 // Get the argument for the dummy argument symbols of the current call.
2665 symMap.addSymbol(sym, caller.getArgumentValue(sym));
2666 // All the properties of the dummy variable may not come from the actual
2667 // argument, let instantiateVariable handle this.
2668 }
2669 // If this is neither a host associated or dummy symbol, it must be a
2670 // module or common block variable to satisfy specification expression
2671 // requirements in 10.1.11, instantiateVariable will get its address and
2672 // properties.
2673 instantiateVariable(converter, var, symMap, storeMap);
2674 }
2675}
2676
2677void Fortran::lower::mapCallInterfaceSymbolsForResult(
2678 AbstractConverter &converter, const Fortran::lower::CallerInterface &caller,
2679 SymMap &symMap) {
2680 const Fortran::semantics::Symbol &result = caller.getResultSymbol();
2681 mapCallInterfaceSymbol(result, converter, caller, symMap);
2682}
2683
2684void Fortran::lower::mapCallInterfaceSymbolsForDummyArgument(
2685 AbstractConverter &converter, const Fortran::lower::CallerInterface &caller,
2686 SymMap &symMap, const Fortran::semantics::Symbol &dummySymbol) {
2687 mapCallInterfaceSymbol(dummySymbol, converter, caller, symMap);
2688}
2689
2690void Fortran::lower::mapSymbolAttributes(
2691 AbstractConverter &converter, const Fortran::semantics::SymbolRef &symbol,
2692 Fortran::lower::SymMap &symMap, Fortran::lower::StatementContext &stmtCtx,
2693 mlir::Value preAlloc) {
2694 mapSymbolAttributes(converter, pft::Variable{symbol}, symMap, stmtCtx,
2695 preAlloc);
2696}
2697
2698void Fortran::lower::createIntrinsicModuleGlobal(
2699 Fortran::lower::AbstractConverter &converter, const pft::Variable &var) {
2700 defineGlobal(converter, var, converter.mangleName(var.getSymbol()),
2701 converter.getFirOpBuilder().createLinkOnceODRLinkage());
2702}
2703
2704void Fortran::lower::createRuntimeTypeInfoGlobal(
2705 Fortran::lower::AbstractConverter &converter,
2706 const Fortran::semantics::Symbol &typeInfoSym) {
2707 std::string globalName = converter.mangleName(typeInfoSym);
2708 auto var = Fortran::lower::pft::Variable(typeInfoSym, /*global=*/true);
2709 mlir::StringAttr linkage = getLinkageAttribute(converter, var);
2710 defineGlobal(converter, var, globalName, linkage);
2711}
2712
2713mlir::Type Fortran::lower::getCrayPointeeBoxType(mlir::Type fortranType) {
2714 mlir::Type baseType = hlfir::getFortranElementOrSequenceType(fortranType);
2715 if (auto seqType = mlir::dyn_cast<fir::SequenceType>(baseType)) {
2716 // The pointer box's sequence type must be with unknown shape.
2717 llvm::SmallVector<int64_t> shape(seqType.getDimension(),
2718 fir::SequenceType::getUnknownExtent());
2719 baseType = fir::SequenceType::get(shape, seqType.getEleTy());
2720 }
2721 return fir::BoxType::get(fir::PointerType::get(baseType));
2722}
2723
2724fir::ExtendedValue
2725Fortran::lower::genPackArray(Fortran::lower::AbstractConverter &converter,
2726 const Fortran::semantics::Symbol &sym,
2727 fir::ExtendedValue exv) {
2728 if (!needsRepack(converter, sym))
2729 return exv;
2730
2731 auto &opts = converter.getLoweringOptions();
2732 llvm::SmallVector<mlir::Value> lenParams;
2733 exv.match(
2734 [&](const fir::CharArrayBoxValue &box) {
2735 lenParams.emplace_back(box.getLen());
2736 },
2737 [&](const fir::BoxValue &box) {
2738 lenParams.append(box.getExplicitParameters().begin(),
2739 box.getExplicitParameters().end());
2740 },
2741 [](const auto &) {
2742 llvm_unreachable("unexpected lowering for assumed-shape dummy");
2743 });
2744 fir::FirOpBuilder &builder = converter.getFirOpBuilder();
2745 const mlir::Location loc = genLocation(converter, sym);
2746 bool stackAlloc = opts.getStackRepackArrays();
2747 // 1D arrays must always use 'whole' mode.
2748 bool isInnermostMode = !opts.getRepackArraysWhole() && sym.Rank() > 1;
2749 // Avoid copy-in for 'intent(out)' variable, unless this is a dummy
2750 // argument with INTENT(OUT) that needs finalization on entry
2751 // to the subprogram. The finalization routine may read the initial
2752 // value of the array.
2753 bool noCopy = Fortran::semantics::IsIntentOut(sym) &&
2754 !needDummyIntentoutFinalization(sym);
2755 auto boxType = mlir::cast<fir::BaseBoxType>(fir::getBase(exv).getType());
2756 mlir::Type elementType = boxType.unwrapInnerType();
2757 llvm::SmallVector<mlir::Value> elidedLenParams =
2758 fir::factory::elideLengthsAlreadyInType(elementType, lenParams);
2759 auto packOp = builder.create<fir::PackArrayOp>(
2760 loc, fir::getBase(exv), stackAlloc, isInnermostMode, noCopy,
2761 /*max_size=*/mlir::IntegerAttr{},
2762 /*max_element_size=*/mlir::IntegerAttr{},
2763 /*min_stride=*/mlir::IntegerAttr{}, fir::PackArrayHeuristics::None,
2764 elidedLenParams, getSafeRepackAttrs(converter));
2765
2766 mlir::Value newBase = packOp.getResult();
2767 return exv.match(
2768 [&](const fir::CharArrayBoxValue &box) -> fir::ExtendedValue {
2769 return box.clone(newBase);
2770 },
2771 [&](const fir::BoxValue &box) -> fir::ExtendedValue {
2772 return box.clone(newBase);
2773 },
2774 [](const auto &) -> fir::ExtendedValue {
2775 llvm_unreachable("unexpected lowering for assumed-shape dummy");
2776 });
2777}
2778
2779void Fortran::lower::genUnpackArray(
2780 Fortran::lower::AbstractConverter &converter, mlir::Location loc,
2781 fir::FortranVariableOpInterface def,
2782 const Fortran::semantics::Symbol &sym) {
2783 // Subtle: rely on the fact that the memref of the defining
2784 // hlfir.declare is a result of fir.pack_array.
2785 // Alternatively, we can track the pack operation for a symbol
2786 // via SymMap.
2787 auto declareOp = mlir::dyn_cast<hlfir::DeclareOp>(def.getOperation());
2788 assert(declareOp &&
2789 "cannot find hlfir.declare for an array that needs to be repacked");
2790 auto packOp = declareOp.getMemref().getDefiningOp<fir::PackArrayOp>();
2791 assert(packOp && "cannot find fir.pack_array");
2792 mlir::Value temp = packOp.getResult();
2793 mlir::Value original = packOp.getArray();
2794 bool stackAlloc = packOp.getStack();
2795 // Avoid copy-out for 'intent(in)' variables.
2796 bool noCopy = Fortran::semantics::IsIntentIn(sym);
2797 fir::FirOpBuilder &builder = converter.getFirOpBuilder();
2798 builder.create<fir::UnpackArrayOp>(loc, temp, original, stackAlloc, noCopy,
2799 getSafeRepackAttrs(converter));
2800}
2801

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