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