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

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