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

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