//===-- ConvertVariable.cpp -- bridge to lower to MLIR --------------------===// // // Part of the LLVM Project, under the Apache License v2.0 with LLVM Exceptions. // See https://llvm.org/LICENSE.txt for license information. // SPDX-License-Identifier: Apache-2.0 WITH LLVM-exception // //===----------------------------------------------------------------------===// // // Coding style: https://mlir.llvm.org/getting_started/DeveloperGuide/ // //===----------------------------------------------------------------------===// #include "flang/Lower/ConvertVariable.h" #include "flang/Lower/AbstractConverter.h" #include "flang/Lower/Allocatable.h" #include "flang/Lower/BoxAnalyzer.h" #include "flang/Lower/CallInterface.h" #include "flang/Lower/ConvertConstant.h" #include "flang/Lower/ConvertExpr.h" #include "flang/Lower/ConvertExprToHLFIR.h" #include "flang/Lower/ConvertProcedureDesignator.h" #include "flang/Lower/Mangler.h" #include "flang/Lower/PFTBuilder.h" #include "flang/Lower/StatementContext.h" #include "flang/Lower/Support/Utils.h" #include "flang/Lower/SymbolMap.h" #include "flang/Optimizer/Builder/Character.h" #include "flang/Optimizer/Builder/FIRBuilder.h" #include "flang/Optimizer/Builder/HLFIRTools.h" #include "flang/Optimizer/Builder/IntrinsicCall.h" #include "flang/Optimizer/Builder/Runtime/Derived.h" #include "flang/Optimizer/Builder/Todo.h" #include "flang/Optimizer/Dialect/FIRAttr.h" #include "flang/Optimizer/Dialect/FIRDialect.h" #include "flang/Optimizer/Dialect/FIROps.h" #include "flang/Optimizer/Dialect/Support/FIRContext.h" #include "flang/Optimizer/HLFIR/HLFIROps.h" #include "flang/Optimizer/Support/FatalError.h" #include "flang/Optimizer/Support/InternalNames.h" #include "flang/Optimizer/Support/Utils.h" #include "flang/Semantics/runtime-type-info.h" #include "flang/Semantics/tools.h" #include "llvm/Support/Debug.h" #include #define DEBUG_TYPE "flang-lower-variable" /// Helper to lower a scalar expression using a specific symbol mapping. static mlir::Value genScalarValue(Fortran::lower::AbstractConverter &converter, mlir::Location loc, const Fortran::lower::SomeExpr &expr, Fortran::lower::SymMap &symMap, Fortran::lower::StatementContext &context) { // This does not use the AbstractConverter member function to override the // symbol mapping to be used expression lowering. if (converter.getLoweringOptions().getLowerToHighLevelFIR()) { hlfir::EntityWithAttributes loweredExpr = Fortran::lower::convertExprToHLFIR(loc, converter, expr, symMap, context); return hlfir::loadTrivialScalar(loc, converter.getFirOpBuilder(), loweredExpr); } return fir::getBase(Fortran::lower::createSomeExtendedExpression( loc, converter, expr, symMap, context)); } /// Does this variable have a default initialization? static bool hasDefaultInitialization(const Fortran::semantics::Symbol &sym) { if (sym.has() && sym.size()) if (!Fortran::semantics::IsAllocatableOrPointer(sym)) if (const Fortran::semantics::DeclTypeSpec *declTypeSpec = sym.GetType()) if (const Fortran::semantics::DerivedTypeSpec *derivedTypeSpec = declTypeSpec->AsDerived()) { // Pointer assignments in the runtime may hit undefined behaviors if // the RHS contains garbage. Pointer objects are always established by // lowering to NULL() (in Fortran::lower::createMutableBox). However, // pointer components need special care here so that local and global // derived type containing pointers are always initialized. // Intent(out), however, do not need to be initialized since the // related descriptor storage comes from a local or global that has // been initialized (it may not be NULL() anymore, but the rank, type, // and non deferred length parameters are still correct in a // conformant program, and that is what matters). const bool ignorePointer = Fortran::semantics::IsIntentOut(sym); return derivedTypeSpec->HasDefaultInitialization( /*ignoreAllocatable=*/false, ignorePointer); } return false; } // Does this variable have a finalization? static bool hasFinalization(const Fortran::semantics::Symbol &sym) { if (sym.has()) if (const Fortran::semantics::DeclTypeSpec *declTypeSpec = sym.GetType()) if (const Fortran::semantics::DerivedTypeSpec *derivedTypeSpec = declTypeSpec->AsDerived()) return Fortran::semantics::IsFinalizable(*derivedTypeSpec); return false; } // Does this variable have an allocatable direct component? static bool hasAllocatableDirectComponent(const Fortran::semantics::Symbol &sym) { if (sym.has()) if (const Fortran::semantics::DeclTypeSpec *declTypeSpec = sym.GetType()) if (const Fortran::semantics::DerivedTypeSpec *derivedTypeSpec = declTypeSpec->AsDerived()) return Fortran::semantics::HasAllocatableDirectComponent( *derivedTypeSpec); return false; } //===----------------------------------------------------------------===// // Global variables instantiation (not for alias and common) //===----------------------------------------------------------------===// /// Helper to generate expression value inside global initializer. static fir::ExtendedValue genInitializerExprValue(Fortran::lower::AbstractConverter &converter, mlir::Location loc, const Fortran::lower::SomeExpr &expr, Fortran::lower::StatementContext &stmtCtx) { // Data initializer are constant value and should not depend on other symbols // given the front-end fold parameter references. In any case, the "current" // map of the converter should not be used since it holds mapping to // mlir::Value from another mlir region. If these value are used by accident // in the initializer, this will lead to segfaults in mlir code. Fortran::lower::SymMap emptyMap; return Fortran::lower::createSomeInitializerExpression(loc, converter, expr, emptyMap, stmtCtx); } /// Can this symbol constant be placed in read-only memory? static bool isConstant(const Fortran::semantics::Symbol &sym) { return sym.attrs().test(Fortran::semantics::Attr::PARAMETER) || sym.test(Fortran::semantics::Symbol::Flag::ReadOnly); } static fir::GlobalOp defineGlobal(Fortran::lower::AbstractConverter &converter, const Fortran::lower::pft::Variable &var, llvm::StringRef globalName, mlir::StringAttr linkage, fir::CUDADataAttributeAttr cudaAttr = {}); static mlir::Location genLocation(Fortran::lower::AbstractConverter &converter, const Fortran::semantics::Symbol &sym) { // Compiler generated name cannot be used as source location, their name // is not pointing to the source files. if (!sym.test(Fortran::semantics::Symbol::Flag::CompilerCreated)) return converter.genLocation(sym.name()); return converter.getCurrentLocation(); } /// Create the global op declaration without any initializer static fir::GlobalOp declareGlobal(Fortran::lower::AbstractConverter &converter, const Fortran::lower::pft::Variable &var, llvm::StringRef globalName, mlir::StringAttr linkage) { fir::FirOpBuilder &builder = converter.getFirOpBuilder(); if (fir::GlobalOp global = builder.getNamedGlobal(globalName)) return global; // Always define linkonce data since it may be optimized out from the module // that actually owns the variable if it does not refers to it. if (linkage == builder.createLinkOnceODRLinkage() || linkage == builder.createLinkOnceLinkage()) return defineGlobal(converter, var, globalName, linkage); const Fortran::semantics::Symbol &sym = var.getSymbol(); mlir::Location loc = genLocation(converter, sym); // Resolve potential host and module association before checking that this // symbol is an object of a function pointer. const Fortran::semantics::Symbol &ultimate = sym.GetUltimate(); if (!ultimate.has() && !Fortran::semantics::IsProcedurePointer(ultimate)) mlir::emitError(loc, "processing global declaration: symbol '") << toStringRef(sym.name()) << "' has unexpected details\n"; fir::CUDADataAttributeAttr cudaAttr = Fortran::lower::translateSymbolCUDADataAttribute( converter.getFirOpBuilder().getContext(), sym); return builder.createGlobal(loc, converter.genType(var), globalName, linkage, mlir::Attribute{}, isConstant(ultimate), var.isTarget(), cudaAttr); } /// Temporary helper to catch todos in initial data target lowering. static bool hasDerivedTypeWithLengthParameters(const Fortran::semantics::Symbol &sym) { if (const Fortran::semantics::DeclTypeSpec *declTy = sym.GetType()) if (const Fortran::semantics::DerivedTypeSpec *derived = declTy->AsDerived()) return Fortran::semantics::CountLenParameters(*derived) > 0; return false; } fir::ExtendedValue Fortran::lower::genExtAddrInInitializer( Fortran::lower::AbstractConverter &converter, mlir::Location loc, const Fortran::lower::SomeExpr &addr) { Fortran::lower::SymMap globalOpSymMap; Fortran::lower::AggregateStoreMap storeMap; Fortran::lower::StatementContext stmtCtx; if (const Fortran::semantics::Symbol *sym = Fortran::evaluate::GetFirstSymbol(addr)) { // Length parameters processing will need care in global initializer // context. if (hasDerivedTypeWithLengthParameters(*sym)) TODO(loc, "initial-data-target with derived type length parameters"); auto var = Fortran::lower::pft::Variable(*sym, /*global=*/true); Fortran::lower::instantiateVariable(converter, var, globalOpSymMap, storeMap); } if (converter.getLoweringOptions().getLowerToHighLevelFIR()) return Fortran::lower::convertExprToAddress(loc, converter, addr, globalOpSymMap, stmtCtx); return Fortran::lower::createInitializerAddress(loc, converter, addr, globalOpSymMap, stmtCtx); } /// create initial-data-target fir.box in a global initializer region. mlir::Value Fortran::lower::genInitialDataTarget( Fortran::lower::AbstractConverter &converter, mlir::Location loc, mlir::Type boxType, const Fortran::lower::SomeExpr &initialTarget, bool couldBeInEquivalence) { Fortran::lower::SymMap globalOpSymMap; Fortran::lower::AggregateStoreMap storeMap; Fortran::lower::StatementContext stmtCtx; fir::FirOpBuilder &builder = converter.getFirOpBuilder(); if (Fortran::evaluate::UnwrapExpr( initialTarget)) return fir::factory::createUnallocatedBox( builder, loc, boxType, /*nonDeferredParams=*/std::nullopt); // Pointer initial data target, and NULL(mold). for (const auto &sym : Fortran::evaluate::CollectSymbols(initialTarget)) { // Derived type component symbols should not be instantiated as objects // on their own. if (sym->owner().IsDerivedType()) continue; // Length parameters processing will need care in global initializer // context. if (hasDerivedTypeWithLengthParameters(sym)) TODO(loc, "initial-data-target with derived type length parameters"); auto var = Fortran::lower::pft::Variable(sym, /*global=*/true); if (couldBeInEquivalence) { auto dependentVariableList = Fortran::lower::pft::getDependentVariableList(sym); for (Fortran::lower::pft::Variable var : dependentVariableList) { if (!var.isAggregateStore()) break; instantiateVariable(converter, var, globalOpSymMap, storeMap); } var = dependentVariableList.back(); assert(var.getSymbol().name() == sym->name() && "missing symbol in dependence list"); } Fortran::lower::instantiateVariable(converter, var, globalOpSymMap, storeMap); } // Handle NULL(mold) as a special case. Return an unallocated box of MOLD // type. The return box is correctly created as a fir.box> where // T is extracted from the MOLD argument. if (const Fortran::evaluate::ProcedureRef *procRef = Fortran::evaluate::UnwrapProcedureRef(initialTarget)) { const Fortran::evaluate::SpecificIntrinsic *intrinsic = procRef->proc().GetSpecificIntrinsic(); if (intrinsic && intrinsic->name == "null") { assert(procRef->arguments().size() == 1 && "Expecting mold argument for NULL intrinsic"); const auto *argExpr = procRef->arguments()[0].value().UnwrapExpr(); assert(argExpr); const Fortran::semantics::Symbol *sym = Fortran::evaluate::GetFirstSymbol(*argExpr); assert(sym && "MOLD must be a pointer or allocatable symbol"); mlir::Type boxType = converter.genType(*sym); mlir::Value box = fir::factory::createUnallocatedBox(builder, loc, boxType, {}); return box; } } mlir::Value targetBox; mlir::Value targetShift; if (converter.getLoweringOptions().getLowerToHighLevelFIR()) { auto target = Fortran::lower::convertExprToBox( loc, converter, initialTarget, globalOpSymMap, stmtCtx); targetBox = fir::getBase(target); targetShift = builder.createShape(loc, target); } else { if (initialTarget.Rank() > 0) { auto target = Fortran::lower::createSomeArrayBox(converter, initialTarget, globalOpSymMap, stmtCtx); targetBox = fir::getBase(target); targetShift = builder.createShape(loc, target); } else { fir::ExtendedValue addr = Fortran::lower::createInitializerAddress( loc, converter, initialTarget, globalOpSymMap, stmtCtx); targetBox = builder.createBox(loc, addr); // Nothing to do for targetShift, the target is a scalar. } } // The targetBox is a fir.box, not a fir.box> as it should for // pointers (this matters to get the POINTER attribute correctly inside the // initial value of the descriptor). // Create a fir.rebox to set the attribute correctly, and use targetShift // to preserve the target lower bounds if any. return builder.create(loc, boxType, targetBox, targetShift, /*slice=*/mlir::Value{}); } /// Generate default initial value for a derived type object \p sym with mlir /// type \p symTy. static mlir::Value genDefaultInitializerValue( Fortran::lower::AbstractConverter &converter, mlir::Location loc, const Fortran::semantics::Symbol &sym, mlir::Type symTy, Fortran::lower::StatementContext &stmtCtx); /// Generate the initial value of a derived component \p component and insert /// it into the derived type initial value \p insertInto of type \p recTy. /// Return the new derived type initial value after the insertion. static mlir::Value genComponentDefaultInit( Fortran::lower::AbstractConverter &converter, mlir::Location loc, const Fortran::semantics::Symbol &component, fir::RecordType recTy, mlir::Value insertInto, Fortran::lower::StatementContext &stmtCtx) { fir::FirOpBuilder &builder = converter.getFirOpBuilder(); std::string name = converter.getRecordTypeFieldName(component); mlir::Type componentTy = recTy.getType(name); assert(componentTy && "component not found in type"); mlir::Value componentValue; if (const auto *object{ component.detailsIf()}) { if (const auto &init = object->init()) { // Component has explicit initialization. if (Fortran::semantics::IsPointer(component)) // Initial data target. componentValue = genInitialDataTarget(converter, loc, componentTy, *init); else // Initial value. componentValue = fir::getBase( genInitializerExprValue(converter, loc, *init, stmtCtx)); } else if (Fortran::semantics::IsAllocatableOrPointer(component)) { // Pointer or allocatable without initialization. // Create deallocated/disassociated value. // From a standard point of view, pointer without initialization do not // need to be disassociated, but for sanity and simplicity, do it in // global constructor since this has no runtime cost. componentValue = fir::factory::createUnallocatedBox( builder, loc, componentTy, std::nullopt); } else if (hasDefaultInitialization(component)) { // Component type has default initialization. componentValue = genDefaultInitializerValue(converter, loc, component, componentTy, stmtCtx); } else { // Component has no initial value. Set its bits to zero by extension // to match what is expected because other compilers are doing it. componentValue = builder.create(loc, componentTy); } } else if (const auto *proc{ component .detailsIf()}) { if (proc->init().has_value()) { auto sym{*proc->init()}; if (sym) // Has a procedure target. componentValue = Fortran::lower::convertProcedureDesignatorInitialTarget(converter, loc, *sym); else // Has NULL() target. componentValue = fir::factory::createNullBoxProc(builder, loc, componentTy); } else componentValue = builder.create(loc, componentTy); } assert(componentValue && "must have been computed"); componentValue = builder.createConvert(loc, componentTy, componentValue); auto fieldTy = fir::FieldType::get(recTy.getContext()); // FIXME: type parameters must come from the derived-type-spec auto field = builder.create( loc, fieldTy, name, recTy, /*typeParams=*/mlir::ValueRange{} /*TODO*/); return builder.create( loc, recTy, insertInto, componentValue, builder.getArrayAttr(field.getAttributes())); } static mlir::Value genDefaultInitializerValue( Fortran::lower::AbstractConverter &converter, mlir::Location loc, const Fortran::semantics::Symbol &sym, mlir::Type symTy, Fortran::lower::StatementContext &stmtCtx) { fir::FirOpBuilder &builder = converter.getFirOpBuilder(); mlir::Type scalarType = symTy; fir::SequenceType sequenceType; if (auto ty = symTy.dyn_cast()) { sequenceType = ty; scalarType = ty.getEleTy(); } // Build a scalar default value of the symbol type, looping through the // components to build each component initial value. auto recTy = scalarType.cast(); mlir::Value initialValue = builder.create(loc, scalarType); const Fortran::semantics::DeclTypeSpec *declTy = sym.GetType(); assert(declTy && "var with default initialization must have a type"); if (converter.getLoweringOptions().getLowerToHighLevelFIR()) { // In HLFIR, the parent type is the first component, while in FIR there is // not parent component in the fir.type and the component of the parent are // "inlined" at the beginning of the fir.type. const Fortran::semantics::Symbol &typeSymbol = declTy->derivedTypeSpec().typeSymbol(); const Fortran::semantics::Scope *derivedScope = declTy->derivedTypeSpec().GetScope(); assert(derivedScope && "failed to retrieve derived type scope"); for (const auto &componentName : typeSymbol.get() .componentNames()) { auto scopeIter = derivedScope->find(componentName); assert(scopeIter != derivedScope->cend() && "failed to find derived type component symbol"); const Fortran::semantics::Symbol &component = scopeIter->second.get(); initialValue = genComponentDefaultInit(converter, loc, component, recTy, initialValue, stmtCtx); } } else { Fortran::semantics::OrderedComponentIterator components( declTy->derivedTypeSpec()); for (const auto &component : components) { // Skip parent components, the sub-components of parent types are part of // components and will be looped through right after. if (component.test(Fortran::semantics::Symbol::Flag::ParentComp)) continue; initialValue = genComponentDefaultInit(converter, loc, component, recTy, initialValue, stmtCtx); } } if (sequenceType) { // For arrays, duplicate the scalar value to all elements with an // fir.insert_range covering the whole array. auto arrayInitialValue = builder.create(loc, sequenceType); llvm::SmallVector rangeBounds; for (int64_t extent : sequenceType.getShape()) { if (extent == fir::SequenceType::getUnknownExtent()) TODO(loc, "default initial value of array component with length parameters"); rangeBounds.push_back(0); rangeBounds.push_back(extent - 1); } return builder.create( loc, sequenceType, arrayInitialValue, initialValue, builder.getIndexVectorAttr(rangeBounds)); } return initialValue; } /// Does this global already have an initializer ? static bool globalIsInitialized(fir::GlobalOp global) { return !global.getRegion().empty() || global.getInitVal(); } /// Call \p genInit to generate code inside \p global initializer region. void Fortran::lower::createGlobalInitialization( fir::FirOpBuilder &builder, fir::GlobalOp global, std::function genInit) { mlir::Region ®ion = global.getRegion(); region.push_back(new mlir::Block); mlir::Block &block = region.back(); auto insertPt = builder.saveInsertionPoint(); builder.setInsertionPointToStart(&block); genInit(builder); builder.restoreInsertionPoint(insertPt); } /// Create the global op and its init if it has one static fir::GlobalOp defineGlobal(Fortran::lower::AbstractConverter &converter, const Fortran::lower::pft::Variable &var, llvm::StringRef globalName, mlir::StringAttr linkage, fir::CUDADataAttributeAttr cudaAttr) { fir::FirOpBuilder &builder = converter.getFirOpBuilder(); const Fortran::semantics::Symbol &sym = var.getSymbol(); mlir::Location loc = genLocation(converter, sym); bool isConst = isConstant(sym); fir::GlobalOp global = builder.getNamedGlobal(globalName); mlir::Type symTy = converter.genType(var); if (global && globalIsInitialized(global)) return global; if (!converter.getLoweringOptions().getLowerToHighLevelFIR() && Fortran::semantics::IsProcedurePointer(sym)) TODO(loc, "procedure pointer globals"); // If this is an array, check to see if we can use a dense attribute // with a tensor mlir type. This optimization currently only supports // Fortran arrays of integer, real, complex, or logical. The tensor // type does not support nested structures. if (symTy.isa() && !Fortran::semantics::IsAllocatableOrPointer(sym)) { mlir::Type eleTy = symTy.cast().getEleTy(); if (eleTy.isa()) { const auto *details = sym.detailsIf(); if (details->init()) { global = Fortran::lower::tryCreatingDenseGlobal( builder, loc, symTy, globalName, linkage, isConst, details->init().value()); if (global) { global.setVisibility(mlir::SymbolTable::Visibility::Public); return global; } } } } if (!global) global = builder.createGlobal(loc, symTy, globalName, linkage, mlir::Attribute{}, isConst, var.isTarget(), cudaAttr); if (Fortran::semantics::IsAllocatableOrPointer(sym) && !Fortran::semantics::IsProcedure(sym)) { const auto *details = sym.detailsIf(); if (details && details->init()) { auto expr = *details->init(); Fortran::lower::createGlobalInitialization( builder, global, [&](fir::FirOpBuilder &b) { mlir::Value box = Fortran::lower::genInitialDataTarget( converter, loc, symTy, expr); b.create(loc, box); }); } else { // Create unallocated/disassociated descriptor if no explicit init Fortran::lower::createGlobalInitialization( builder, global, [&](fir::FirOpBuilder &b) { mlir::Value box = fir::factory::createUnallocatedBox(b, loc, symTy, std::nullopt); b.create(loc, box); }); } } else if (const auto *details = sym.detailsIf()) { if (details->init()) { Fortran::lower::createGlobalInitialization( builder, global, [&](fir::FirOpBuilder &builder) { Fortran::lower::StatementContext stmtCtx( /*cleanupProhibited=*/true); fir::ExtendedValue initVal = genInitializerExprValue( converter, loc, details->init().value(), stmtCtx); mlir::Value castTo = builder.createConvert(loc, symTy, fir::getBase(initVal)); builder.create(loc, castTo); }); } else if (hasDefaultInitialization(sym)) { Fortran::lower::createGlobalInitialization( builder, global, [&](fir::FirOpBuilder &builder) { Fortran::lower::StatementContext stmtCtx( /*cleanupProhibited=*/true); mlir::Value initVal = genDefaultInitializerValue(converter, loc, sym, symTy, stmtCtx); mlir::Value castTo = builder.createConvert(loc, symTy, initVal); builder.create(loc, castTo); }); } } else if (Fortran::semantics::IsProcedurePointer(sym)) { const auto *details{sym.detailsIf()}; if (details && details->init()) { auto sym{*details->init()}; if (sym) // Has a procedure target. Fortran::lower::createGlobalInitialization( builder, global, [&](fir::FirOpBuilder &b) { Fortran::lower::StatementContext stmtCtx( /*cleanupProhibited=*/true); auto box{Fortran::lower::convertProcedureDesignatorInitialTarget( converter, loc, *sym)}; auto castTo{builder.createConvert(loc, symTy, box)}; b.create(loc, castTo); }); else { // Has NULL() target. Fortran::lower::createGlobalInitialization( builder, global, [&](fir::FirOpBuilder &b) { auto box{fir::factory::createNullBoxProc(b, loc, symTy)}; b.create(loc, box); }); } } else { // No initialization. Fortran::lower::createGlobalInitialization( builder, global, [&](fir::FirOpBuilder &b) { auto box{fir::factory::createNullBoxProc(b, loc, symTy)}; b.create(loc, box); }); } } else if (sym.has()) { mlir::emitError(loc, "COMMON symbol processed elsewhere"); } else { TODO(loc, "global"); // Something else } // Creates zero initializer for globals without initializers, this is a common // and expected behavior (although not required by the standard) if (!globalIsInitialized(global)) { // Fortran does not provide means to specify that a BIND(C) module // uninitialized variables will be defined in C. // Add the common linkage to those to allow some level of support // for this use case. Note that this use case will not work if the Fortran // module code is placed in a shared library since, at least for the ELF // format, common symbols are assigned a section in shared libraries. // The best is still to declare C defined variables in a Fortran module file // with no other definitions, and to never link the resulting module object // file. if (sym.attrs().test(Fortran::semantics::Attr::BIND_C)) global.setLinkName(builder.createCommonLinkage()); Fortran::lower::createGlobalInitialization( builder, global, [&](fir::FirOpBuilder &builder) { mlir::Value initValue = builder.create(loc, symTy); builder.create(loc, initValue); }); } // Set public visibility to prevent global definition to be optimized out // even if they have no initializer and are unused in this compilation unit. global.setVisibility(mlir::SymbolTable::Visibility::Public); return global; } /// Return linkage attribute for \p var. static mlir::StringAttr getLinkageAttribute(fir::FirOpBuilder &builder, const Fortran::lower::pft::Variable &var) { // Runtime type info for a same derived type is identical in each compilation // unit. It desired to avoid having to link against module that only define a // type. Therefore the runtime type info is generated everywhere it is needed // with `linkonce_odr` LLVM linkage. if (var.isRuntimeTypeInfoData()) return builder.createLinkOnceODRLinkage(); if (var.isModuleOrSubmoduleVariable()) return {}; // external linkage // Otherwise, the variable is owned by a procedure and must not be visible in // other compilation units. return builder.createInternalLinkage(); } /// Instantiate a global variable. If it hasn't already been processed, add /// the global to the ModuleOp as a new uniqued symbol and initialize it with /// the correct value. It will be referenced on demand using `fir.addr_of`. static void instantiateGlobal(Fortran::lower::AbstractConverter &converter, const Fortran::lower::pft::Variable &var, Fortran::lower::SymMap &symMap) { const Fortran::semantics::Symbol &sym = var.getSymbol(); assert(!var.isAlias() && "must be handled in instantiateAlias"); fir::FirOpBuilder &builder = converter.getFirOpBuilder(); std::string globalName = converter.mangleName(sym); mlir::Location loc = genLocation(converter, sym); mlir::StringAttr linkage = getLinkageAttribute(builder, var); fir::GlobalOp global; if (var.isModuleOrSubmoduleVariable()) { // A non-intrinsic module global is defined when lowering the module. // Emit only a declaration if the global does not exist. global = declareGlobal(converter, var, globalName, linkage); } else { global = defineGlobal(converter, var, globalName, linkage); } auto addrOf = builder.create(loc, global.resultType(), global.getSymbol()); Fortran::lower::StatementContext stmtCtx; mapSymbolAttributes(converter, var, symMap, stmtCtx, addrOf); } //===----------------------------------------------------------------===// // Local variables instantiation (not for alias) //===----------------------------------------------------------------===// /// Create a stack slot for a local variable. Precondition: the insertion /// point of the builder must be in the entry block, which is currently being /// constructed. static mlir::Value createNewLocal(Fortran::lower::AbstractConverter &converter, mlir::Location loc, const Fortran::lower::pft::Variable &var, mlir::Value preAlloc, llvm::ArrayRef shape = {}, llvm::ArrayRef lenParams = {}) { if (preAlloc) return preAlloc; fir::FirOpBuilder &builder = converter.getFirOpBuilder(); std::string nm = converter.mangleName(var.getSymbol()); mlir::Type ty = converter.genType(var); const Fortran::semantics::Symbol &ultimateSymbol = var.getSymbol().GetUltimate(); llvm::StringRef symNm = toStringRef(ultimateSymbol.name()); bool isTarg = var.isTarget(); // Do not allocate storage for cray pointee. The address inside the cray // pointer will be used instead when using the pointee. Allocating space // would be a waste of space, and incorrect if the pointee is a non dummy // assumed-size (possible with cray pointee). if (ultimateSymbol.test(Fortran::semantics::Symbol::Flag::CrayPointee)) return builder.create(loc, fir::ReferenceType::get(ty)); // Let the builder do all the heavy lifting. if (!Fortran::semantics::IsProcedurePointer(ultimateSymbol)) return builder.allocateLocal(loc, ty, nm, symNm, shape, lenParams, isTarg); // Local procedure pointer. auto res{builder.allocateLocal(loc, ty, nm, symNm, shape, lenParams, isTarg)}; auto box{fir::factory::createNullBoxProc(builder, loc, ty)}; builder.create(loc, box, res); return res; } /// Must \p var be default initialized at runtime when entering its scope. static bool mustBeDefaultInitializedAtRuntime(const Fortran::lower::pft::Variable &var) { if (!var.hasSymbol()) return false; const Fortran::semantics::Symbol &sym = var.getSymbol(); if (var.isGlobal()) // Global variables are statically initialized. return false; if (Fortran::semantics::IsDummy(sym) && !Fortran::semantics::IsIntentOut(sym)) return false; // Polymorphic intent(out) dummy might need default initialization // at runtime. if (Fortran::semantics::IsPolymorphic(sym) && Fortran::semantics::IsDummy(sym) && Fortran::semantics::IsIntentOut(sym) && !Fortran::semantics::IsAllocatable(sym) && !Fortran::semantics::IsPointer(sym)) return true; // Local variables (including function results), and intent(out) dummies must // be default initialized at runtime if their type has default initialization. return hasDefaultInitialization(sym); } /// Call default initialization runtime routine to initialize \p var. static void defaultInitializeAtRuntime(Fortran::lower::AbstractConverter &converter, const Fortran::lower::pft::Variable &var, Fortran::lower::SymMap &symMap) { fir::FirOpBuilder &builder = converter.getFirOpBuilder(); mlir::Location loc = converter.getCurrentLocation(); const Fortran::semantics::Symbol &sym = var.getSymbol(); fir::ExtendedValue exv = converter.getSymbolExtendedValue(sym, &symMap); if (Fortran::semantics::IsOptional(sym)) { // 15.5.2.12 point 3, absent optional dummies are not initialized. // Creating descriptor/passing null descriptor to the runtime would // create runtime crashes. auto isPresent = builder.create(loc, builder.getI1Type(), fir::getBase(exv)); builder.genIfThen(loc, isPresent) .genThen([&]() { auto box = builder.createBox(loc, exv); fir::runtime::genDerivedTypeInitialize(builder, loc, box); }) .end(); } else { mlir::Value box = builder.createBox(loc, exv); fir::runtime::genDerivedTypeInitialize(builder, loc, box); } } enum class VariableCleanUp { Finalize, Deallocate }; /// Check whether a local variable needs to be finalized according to clause /// 7.5.6.3 point 3 or if it is an allocatable that must be deallocated. Note /// that deallocation will trigger finalization if the type has any. static std::optional needDeallocationOrFinalization(const Fortran::lower::pft::Variable &var) { if (!var.hasSymbol()) return std::nullopt; const Fortran::semantics::Symbol &sym = var.getSymbol(); const Fortran::semantics::Scope &owner = sym.owner(); if (owner.kind() == Fortran::semantics::Scope::Kind::MainProgram) { // The standard does not require finalizing main program variables. return std::nullopt; } if (!Fortran::semantics::IsPointer(sym) && !Fortran::semantics::IsDummy(sym) && !Fortran::semantics::IsFunctionResult(sym) && !Fortran::semantics::IsSaved(sym)) { if (Fortran::semantics::IsAllocatable(sym)) return VariableCleanUp::Deallocate; if (hasFinalization(sym)) return VariableCleanUp::Finalize; // hasFinalization() check above handled all cases that require // finalization, but we also have to deallocate all allocatable // components of local variables (since they are also local variables // according to F18 5.4.3.2.2, p. 2, note 1). // Here, the variable itself is not allocatable. If it has an allocatable // component the Destroy runtime does the job. Use the Finalize clean-up, // though there will be no finalization in runtime. if (hasAllocatableDirectComponent(sym)) return VariableCleanUp::Finalize; } return std::nullopt; } /// Check whether a variable needs the be finalized according to clause 7.5.6.3 /// point 7. /// Must be nonpointer, nonallocatable, INTENT (OUT) dummy argument. static bool needDummyIntentoutFinalization(const Fortran::lower::pft::Variable &var) { if (!var.hasSymbol()) return false; const Fortran::semantics::Symbol &sym = var.getSymbol(); if (!Fortran::semantics::IsDummy(sym) || !Fortran::semantics::IsIntentOut(sym) || Fortran::semantics::IsAllocatable(sym) || Fortran::semantics::IsPointer(sym)) return false; // Polymorphic and unlimited polymorphic intent(out) dummy argument might need // finalization at runtime. if (Fortran::semantics::IsPolymorphic(sym) || Fortran::semantics::IsUnlimitedPolymorphic(sym)) return true; // Intent(out) dummies must be finalized at runtime if their type has a // finalization. // Allocatable components of INTENT(OUT) dummies must be deallocated (9.7.3.2 // p6). Calling finalization runtime for this works even if the components // have no final procedures. return hasFinalization(sym) || hasAllocatableDirectComponent(sym); } /// Call default initialization runtime routine to initialize \p var. static void finalizeAtRuntime(Fortran::lower::AbstractConverter &converter, const Fortran::lower::pft::Variable &var, Fortran::lower::SymMap &symMap) { fir::FirOpBuilder &builder = converter.getFirOpBuilder(); mlir::Location loc = converter.getCurrentLocation(); const Fortran::semantics::Symbol &sym = var.getSymbol(); fir::ExtendedValue exv = converter.getSymbolExtendedValue(sym, &symMap); if (Fortran::semantics::IsOptional(sym)) { // Only finalize if present. auto isPresent = builder.create(loc, builder.getI1Type(), fir::getBase(exv)); builder.genIfThen(loc, isPresent) .genThen([&]() { auto box = builder.createBox(loc, exv); fir::runtime::genDerivedTypeDestroy(builder, loc, box); }) .end(); } else { mlir::Value box = builder.createBox(loc, exv); fir::runtime::genDerivedTypeDestroy(builder, loc, box); } } // Fortran 2018 - 9.7.3.2 point 6 // When a procedure is invoked, any allocated allocatable object that is an // actual argument corresponding to an INTENT(OUT) allocatable dummy argument // is deallocated; any allocated allocatable object that is a subobject of an // actual argument corresponding to an INTENT(OUT) dummy argument is // deallocated. // Note that allocatable components of non-ALLOCATABLE INTENT(OUT) dummy // arguments are dealt with needDummyIntentoutFinalization (finalization runtime // is called to reach the intended component deallocation effect). static void deallocateIntentOut(Fortran::lower::AbstractConverter &converter, const Fortran::lower::pft::Variable &var, Fortran::lower::SymMap &symMap) { if (!var.hasSymbol()) return; const Fortran::semantics::Symbol &sym = var.getSymbol(); if (Fortran::semantics::IsDummy(sym) && Fortran::semantics::IsIntentOut(sym) && Fortran::semantics::IsAllocatable(sym)) { fir::ExtendedValue extVal = converter.getSymbolExtendedValue(sym, &symMap); if (auto mutBox = extVal.getBoxOf()) { // The dummy argument is not passed in the ENTRY so it should not be // deallocated. if (mlir::Operation *op = mutBox->getAddr().getDefiningOp()) { if (auto declOp = mlir::dyn_cast(op)) op = declOp.getMemref().getDefiningOp(); if (op && mlir::isa(op)) return; } mlir::Location loc = converter.getCurrentLocation(); fir::FirOpBuilder &builder = converter.getFirOpBuilder(); if (Fortran::semantics::IsOptional(sym)) { auto isPresent = builder.create( loc, builder.getI1Type(), fir::getBase(extVal)); builder.genIfThen(loc, isPresent) .genThen([&]() { Fortran::lower::genDeallocateIfAllocated(converter, *mutBox, loc); }) .end(); } else { Fortran::lower::genDeallocateIfAllocated(converter, *mutBox, loc); } } } } /// Instantiate a local variable. Precondition: Each variable will be visited /// such that if its properties depend on other variables, the variables upon /// which its properties depend will already have been visited. static void instantiateLocal(Fortran::lower::AbstractConverter &converter, const Fortran::lower::pft::Variable &var, Fortran::lower::SymMap &symMap) { assert(!var.isAlias()); Fortran::lower::StatementContext stmtCtx; mapSymbolAttributes(converter, var, symMap, stmtCtx); deallocateIntentOut(converter, var, symMap); if (needDummyIntentoutFinalization(var)) finalizeAtRuntime(converter, var, symMap); if (mustBeDefaultInitializedAtRuntime(var)) defaultInitializeAtRuntime(converter, var, symMap); if (std::optional cleanup = needDeallocationOrFinalization(var)) { auto *builder = &converter.getFirOpBuilder(); mlir::Location loc = converter.getCurrentLocation(); fir::ExtendedValue exv = converter.getSymbolExtendedValue(var.getSymbol(), &symMap); switch (*cleanup) { case VariableCleanUp::Finalize: converter.getFctCtx().attachCleanup([builder, loc, exv]() { mlir::Value box = builder->createBox(loc, exv); fir::runtime::genDerivedTypeDestroy(*builder, loc, box); }); break; case VariableCleanUp::Deallocate: auto *converterPtr = &converter; auto *sym = &var.getSymbol(); converter.getFctCtx().attachCleanup([converterPtr, loc, exv, sym]() { const fir::MutableBoxValue *mutableBox = exv.getBoxOf(); assert(mutableBox && "trying to deallocate entity not lowered as allocatable"); Fortran::lower::genDeallocateIfAllocated(*converterPtr, *mutableBox, loc, sym); }); } } } //===----------------------------------------------------------------===// // Aliased (EQUIVALENCE) variables instantiation //===----------------------------------------------------------------===// /// Insert \p aggregateStore instance into an AggregateStoreMap. static void insertAggregateStore(Fortran::lower::AggregateStoreMap &storeMap, const Fortran::lower::pft::Variable &var, mlir::Value aggregateStore) { std::size_t off = var.getAggregateStore().getOffset(); Fortran::lower::AggregateStoreKey key = {var.getOwningScope(), off}; storeMap[key] = aggregateStore; } /// Retrieve the aggregate store instance of \p alias from an /// AggregateStoreMap. static mlir::Value getAggregateStore(Fortran::lower::AggregateStoreMap &storeMap, const Fortran::lower::pft::Variable &alias) { Fortran::lower::AggregateStoreKey key = {alias.getOwningScope(), alias.getAliasOffset()}; auto iter = storeMap.find(key); assert(iter != storeMap.end()); return iter->second; } /// Build the name for the storage of a global equivalence. static std::string mangleGlobalAggregateStore( Fortran::lower::AbstractConverter &converter, const Fortran::lower::pft::Variable::AggregateStore &st) { return converter.mangleName(st.getNamingSymbol()); } /// Build the type for the storage of an equivalence. static mlir::Type getAggregateType(Fortran::lower::AbstractConverter &converter, const Fortran::lower::pft::Variable::AggregateStore &st) { if (const Fortran::semantics::Symbol *initSym = st.getInitialValueSymbol()) return converter.genType(*initSym); mlir::IntegerType byteTy = converter.getFirOpBuilder().getIntegerType(8); return fir::SequenceType::get(std::get<1>(st.interval), byteTy); } /// Define a GlobalOp for the storage of a global equivalence described /// by \p aggregate. The global is named \p aggName and is created with /// the provided \p linkage. /// If any of the equivalence members are initialized, an initializer is /// created for the equivalence. /// This is to be used when lowering the scope that owns the equivalence /// (as opposed to simply using it through host or use association). /// This is not to be used for equivalence of common block members (they /// already have the common block GlobalOp for them, see defineCommonBlock). static fir::GlobalOp defineGlobalAggregateStore( Fortran::lower::AbstractConverter &converter, const Fortran::lower::pft::Variable::AggregateStore &aggregate, llvm::StringRef aggName, mlir::StringAttr linkage) { assert(aggregate.isGlobal() && "not a global interval"); fir::FirOpBuilder &builder = converter.getFirOpBuilder(); fir::GlobalOp global = builder.getNamedGlobal(aggName); if (global && globalIsInitialized(global)) return global; mlir::Location loc = converter.getCurrentLocation(); mlir::Type aggTy = getAggregateType(converter, aggregate); if (!global) global = builder.createGlobal(loc, aggTy, aggName, linkage); if (const Fortran::semantics::Symbol *initSym = aggregate.getInitialValueSymbol()) if (const auto *objectDetails = initSym->detailsIf()) if (objectDetails->init()) { Fortran::lower::createGlobalInitialization( builder, global, [&](fir::FirOpBuilder &builder) { Fortran::lower::StatementContext stmtCtx; mlir::Value initVal = fir::getBase(genInitializerExprValue( converter, loc, objectDetails->init().value(), stmtCtx)); builder.create(loc, initVal); }); return global; } // Equivalence has no Fortran initial value. Create an undefined FIR initial // value to ensure this is consider an object definition in the IR regardless // of the linkage. Fortran::lower::createGlobalInitialization( builder, global, [&](fir::FirOpBuilder &builder) { Fortran::lower::StatementContext stmtCtx; mlir::Value initVal = builder.create(loc, aggTy); builder.create(loc, initVal); }); return global; } /// Declare a GlobalOp for the storage of a global equivalence described /// by \p aggregate. The global is named \p aggName and is created with /// the provided \p linkage. /// No initializer is built for the created GlobalOp. /// This is to be used when lowering the scope that uses members of an /// equivalence it through host or use association. /// This is not to be used for equivalence of common block members (they /// already have the common block GlobalOp for them, see defineCommonBlock). static fir::GlobalOp declareGlobalAggregateStore( Fortran::lower::AbstractConverter &converter, mlir::Location loc, const Fortran::lower::pft::Variable::AggregateStore &aggregate, llvm::StringRef aggName, mlir::StringAttr linkage) { assert(aggregate.isGlobal() && "not a global interval"); fir::FirOpBuilder &builder = converter.getFirOpBuilder(); if (fir::GlobalOp global = builder.getNamedGlobal(aggName)) return global; mlir::Type aggTy = getAggregateType(converter, aggregate); return builder.createGlobal(loc, aggTy, aggName, linkage); } /// This is an aggregate store for a set of EQUIVALENCED variables. Create the /// storage on the stack or global memory and add it to the map. static void instantiateAggregateStore(Fortran::lower::AbstractConverter &converter, const Fortran::lower::pft::Variable &var, Fortran::lower::AggregateStoreMap &storeMap) { assert(var.isAggregateStore() && "not an interval"); fir::FirOpBuilder &builder = converter.getFirOpBuilder(); mlir::IntegerType i8Ty = builder.getIntegerType(8); mlir::Location loc = converter.getCurrentLocation(); std::string aggName = mangleGlobalAggregateStore(converter, var.getAggregateStore()); if (var.isGlobal()) { fir::GlobalOp global; auto &aggregate = var.getAggregateStore(); mlir::StringAttr linkage = getLinkageAttribute(builder, var); if (var.isModuleOrSubmoduleVariable()) { // A module global was or will be defined when lowering the module. Emit // only a declaration if the global does not exist at that point. global = declareGlobalAggregateStore(converter, loc, aggregate, aggName, linkage); } else { global = defineGlobalAggregateStore(converter, aggregate, aggName, linkage); } auto addr = builder.create(loc, global.resultType(), global.getSymbol()); auto size = std::get<1>(var.getInterval()); fir::SequenceType::Shape shape(1, size); auto seqTy = fir::SequenceType::get(shape, i8Ty); mlir::Type refTy = builder.getRefType(seqTy); mlir::Value aggregateStore = builder.createConvert(loc, refTy, addr); insertAggregateStore(storeMap, var, aggregateStore); return; } // This is a local aggregate, allocate an anonymous block of memory. auto size = std::get<1>(var.getInterval()); fir::SequenceType::Shape shape(1, size); auto seqTy = fir::SequenceType::get(shape, i8Ty); mlir::Value local = builder.allocateLocal(loc, seqTy, aggName, "", std::nullopt, std::nullopt, /*target=*/false); insertAggregateStore(storeMap, var, local); } /// Cast an alias address (variable part of an equivalence) to fir.ptr so that /// the optimizer is conservative and avoids doing copy elision in assignment /// involving equivalenced variables. /// TODO: Represent the equivalence aliasing constraint in another way to avoid /// pessimizing array assignments involving equivalenced variables. static mlir::Value castAliasToPointer(fir::FirOpBuilder &builder, mlir::Location loc, mlir::Type aliasType, mlir::Value aliasAddr) { return builder.createConvert(loc, fir::PointerType::get(aliasType), aliasAddr); } /// Instantiate a member of an equivalence. Compute its address in its /// aggregate storage and lower its attributes. static void instantiateAlias(Fortran::lower::AbstractConverter &converter, const Fortran::lower::pft::Variable &var, Fortran::lower::SymMap &symMap, Fortran::lower::AggregateStoreMap &storeMap) { fir::FirOpBuilder &builder = converter.getFirOpBuilder(); assert(var.isAlias()); const Fortran::semantics::Symbol &sym = var.getSymbol(); const mlir::Location loc = genLocation(converter, sym); mlir::IndexType idxTy = builder.getIndexType(); mlir::IntegerType i8Ty = builder.getIntegerType(8); mlir::Type i8Ptr = builder.getRefType(i8Ty); mlir::Type symType = converter.genType(sym); std::size_t off = sym.GetUltimate().offset() - var.getAliasOffset(); mlir::Value storeAddr = getAggregateStore(storeMap, var); mlir::Value offset = builder.createIntegerConstant(loc, idxTy, off); mlir::Value bytePtr = builder.create( loc, i8Ptr, storeAddr, mlir::ValueRange{offset}); mlir::Value typedPtr = castAliasToPointer(builder, loc, symType, bytePtr); Fortran::lower::StatementContext stmtCtx; mapSymbolAttributes(converter, var, symMap, stmtCtx, typedPtr); // Default initialization is possible for equivalence members: see // F2018 19.5.3.4. Note that if several equivalenced entities have // default initialization, they must have the same type, and the standard // allows the storage to be default initialized several times (this has // no consequences other than wasting some execution time). For now, // do not try optimizing this to single default initializations of // the equivalenced storages. Keep lowering simple. if (mustBeDefaultInitializedAtRuntime(var)) defaultInitializeAtRuntime(converter, var, symMap); } //===--------------------------------------------------------------===// // COMMON blocks instantiation //===--------------------------------------------------------------===// /// Does any member of the common block has an initializer ? static bool commonBlockHasInit(const Fortran::semantics::MutableSymbolVector &cmnBlkMems) { for (const Fortran::semantics::MutableSymbolRef &mem : cmnBlkMems) { if (const auto *memDet = mem->detailsIf()) if (memDet->init()) return true; } return false; } /// Build a tuple type for a common block based on the common block /// members and the common block size. /// This type is only needed to build common block initializers where /// the initial value is the collection of the member initial values. static mlir::TupleType getTypeOfCommonWithInit( Fortran::lower::AbstractConverter &converter, const Fortran::semantics::MutableSymbolVector &cmnBlkMems, std::size_t commonSize) { fir::FirOpBuilder &builder = converter.getFirOpBuilder(); llvm::SmallVector members; std::size_t counter = 0; for (const Fortran::semantics::MutableSymbolRef &mem : cmnBlkMems) { if (const auto *memDet = mem->detailsIf()) { if (mem->offset() > counter) { fir::SequenceType::Shape len = { static_cast(mem->offset() - counter)}; mlir::IntegerType byteTy = builder.getIntegerType(8); auto memTy = fir::SequenceType::get(len, byteTy); members.push_back(memTy); counter = mem->offset(); } if (memDet->init()) { mlir::Type memTy = converter.genType(*mem); members.push_back(memTy); counter = mem->offset() + mem->size(); } } } if (counter < commonSize) { fir::SequenceType::Shape len = { static_cast(commonSize - counter)}; mlir::IntegerType byteTy = builder.getIntegerType(8); auto memTy = fir::SequenceType::get(len, byteTy); members.push_back(memTy); } return mlir::TupleType::get(builder.getContext(), members); } /// Common block members may have aliases. They are not in the common block /// member list from the symbol. We need to know about these aliases if they /// have initializer to generate the common initializer. /// This function takes care of adding aliases with initializer to the member /// list. static Fortran::semantics::MutableSymbolVector getCommonMembersWithInitAliases(const Fortran::semantics::Symbol &common) { const auto &commonDetails = common.get(); auto members = commonDetails.objects(); // The number and size of equivalence and common is expected to be small, so // no effort is given to optimize this loop of complexity equivalenced // common members * common members for (const Fortran::semantics::EquivalenceSet &set : common.owner().equivalenceSets()) for (const Fortran::semantics::EquivalenceObject &obj : set) { if (!obj.symbol.test(Fortran::semantics::Symbol::Flag::CompilerCreated)) { if (const auto &details = obj.symbol .detailsIf()) { const Fortran::semantics::Symbol *com = FindCommonBlockContaining(obj.symbol); if (!details->init() || com != &common) continue; // This is an alias with an init that belongs to the list if (!llvm::is_contained(members, obj.symbol)) members.emplace_back(obj.symbol); } } } return members; } /// Return the fir::GlobalOp that was created of COMMON block \p common. /// It is an error if the fir::GlobalOp was not created before this is /// called (it cannot be created on the flight because it is not known here /// what mlir type the GlobalOp should have to satisfy all the /// appearances in the program). static fir::GlobalOp getCommonBlockGlobal(Fortran::lower::AbstractConverter &converter, const Fortran::semantics::Symbol &common) { fir::FirOpBuilder &builder = converter.getFirOpBuilder(); std::string commonName = converter.mangleName(common); fir::GlobalOp global = builder.getNamedGlobal(commonName); // Common blocks are lowered before any subprograms to deal with common // whose size may not be the same in every subprograms. if (!global) fir::emitFatalError(converter.genLocation(common.name()), "COMMON block was not lowered before its usage"); return global; } /// Create the fir::GlobalOp for COMMON block \p common. If \p common has an /// initial value, it is not created yet. Instead, the common block list /// members is returned to later create the initial value in /// finalizeCommonBlockDefinition. static std::optional> declareCommonBlock(Fortran::lower::AbstractConverter &converter, const Fortran::semantics::Symbol &common, std::size_t commonSize) { fir::FirOpBuilder &builder = converter.getFirOpBuilder(); std::string commonName = converter.mangleName(common); fir::GlobalOp global = builder.getNamedGlobal(commonName); if (global) return std::nullopt; Fortran::semantics::MutableSymbolVector cmnBlkMems = getCommonMembersWithInitAliases(common); mlir::Location loc = converter.genLocation(common.name()); mlir::StringAttr linkage = builder.createCommonLinkage(); if (!commonBlockHasInit(cmnBlkMems)) { // A COMMON block sans initializers is initialized to zero. // mlir::Vector types must have a strictly positive size, so at least // temporarily, force a zero size COMMON block to have one byte. const auto sz = static_cast(commonSize > 0 ? commonSize : 1); fir::SequenceType::Shape shape = {sz}; mlir::IntegerType i8Ty = builder.getIntegerType(8); auto commonTy = fir::SequenceType::get(shape, i8Ty); auto vecTy = mlir::VectorType::get(sz, i8Ty); mlir::Attribute zero = builder.getIntegerAttr(i8Ty, 0); auto init = mlir::DenseElementsAttr::get(vecTy, llvm::ArrayRef(zero)); builder.createGlobal(loc, commonTy, commonName, linkage, init); // No need to add any initial value later. return std::nullopt; } // COMMON block with initializer (note that initialized blank common are // accepted as an extension by semantics). Sort members by offset before // generating the type and initializer. std::sort(cmnBlkMems.begin(), cmnBlkMems.end(), [](auto &s1, auto &s2) { return s1->offset() < s2->offset(); }); mlir::TupleType commonTy = getTypeOfCommonWithInit(converter, cmnBlkMems, commonSize); // Create the global object, the initial value will be added later. global = builder.createGlobal(loc, commonTy, commonName); return std::make_tuple(global, std::move(cmnBlkMems), loc); } /// Add initial value to a COMMON block fir::GlobalOp \p global given the list /// \p cmnBlkMems of the common block member symbols that contains symbols with /// an initial value. static void finalizeCommonBlockDefinition( mlir::Location loc, Fortran::lower::AbstractConverter &converter, fir::GlobalOp global, const Fortran::semantics::MutableSymbolVector &cmnBlkMems) { fir::FirOpBuilder &builder = converter.getFirOpBuilder(); mlir::TupleType commonTy = global.getType().cast(); auto initFunc = [&](fir::FirOpBuilder &builder) { mlir::IndexType idxTy = builder.getIndexType(); mlir::Value cb = builder.create(loc, commonTy); unsigned tupIdx = 0; std::size_t offset = 0; LLVM_DEBUG(llvm::dbgs() << "block {\n"); for (const Fortran::semantics::MutableSymbolRef &mem : cmnBlkMems) { if (const auto *memDet = mem->detailsIf()) { if (mem->offset() > offset) { ++tupIdx; offset = mem->offset(); } if (memDet->init()) { LLVM_DEBUG(llvm::dbgs() << "offset: " << mem->offset() << " is " << *mem << '\n'); Fortran::lower::StatementContext stmtCtx; auto initExpr = memDet->init().value(); fir::ExtendedValue initVal = Fortran::semantics::IsPointer(*mem) ? Fortran::lower::genInitialDataTarget( converter, loc, converter.genType(*mem), initExpr) : genInitializerExprValue(converter, loc, initExpr, stmtCtx); mlir::IntegerAttr offVal = builder.getIntegerAttr(idxTy, tupIdx); mlir::Value castVal = builder.createConvert( loc, commonTy.getType(tupIdx), fir::getBase(initVal)); cb = builder.create(loc, commonTy, cb, castVal, builder.getArrayAttr(offVal)); ++tupIdx; offset = mem->offset() + mem->size(); } } } LLVM_DEBUG(llvm::dbgs() << "}\n"); builder.create(loc, cb); }; Fortran::lower::createGlobalInitialization(builder, global, initFunc); } void Fortran::lower::defineCommonBlocks( Fortran::lower::AbstractConverter &converter, const Fortran::semantics::CommonBlockList &commonBlocks) { // Common blocks may depend on another common block address (if they contain // pointers with initial targets). To cover this case, create all common block // fir::Global before creating the initial values (if any). std::vector> delayedInitializations; for (const auto &[common, size] : commonBlocks) if (auto delayedInit = declareCommonBlock(converter, common, size)) delayedInitializations.emplace_back(std::move(*delayedInit)); for (auto &[global, cmnBlkMems, loc] : delayedInitializations) finalizeCommonBlockDefinition(loc, converter, global, cmnBlkMems); } mlir::Value Fortran::lower::genCommonBlockMember( Fortran::lower::AbstractConverter &converter, mlir::Location loc, const Fortran::semantics::Symbol &sym, mlir::Value commonValue) { fir::FirOpBuilder &builder = converter.getFirOpBuilder(); std::size_t byteOffset = sym.GetUltimate().offset(); mlir::IntegerType i8Ty = builder.getIntegerType(8); mlir::Type i8Ptr = builder.getRefType(i8Ty); mlir::Type seqTy = builder.getRefType(builder.getVarLenSeqTy(i8Ty)); mlir::Value base = builder.createConvert(loc, seqTy, commonValue); mlir::Value offs = builder.createIntegerConstant(loc, builder.getIndexType(), byteOffset); mlir::Value varAddr = builder.create( loc, i8Ptr, base, mlir::ValueRange{offs}); mlir::Type symType = converter.genType(sym); return Fortran::semantics::FindEquivalenceSet(sym) != nullptr ? castAliasToPointer(builder, loc, symType, varAddr) : builder.createConvert(loc, builder.getRefType(symType), varAddr); } /// The COMMON block is a global structure. `var` will be at some offset /// within the COMMON block. Adds the address of `var` (COMMON + offset) to /// the symbol map. static void instantiateCommon(Fortran::lower::AbstractConverter &converter, const Fortran::semantics::Symbol &common, const Fortran::lower::pft::Variable &var, Fortran::lower::SymMap &symMap) { fir::FirOpBuilder &builder = converter.getFirOpBuilder(); const Fortran::semantics::Symbol &varSym = var.getSymbol(); mlir::Location loc = converter.genLocation(varSym.name()); mlir::Value commonAddr; if (Fortran::lower::SymbolBox symBox = symMap.lookupSymbol(common)) commonAddr = symBox.getAddr(); if (!commonAddr) { // introduce a local AddrOf and add it to the map fir::GlobalOp global = getCommonBlockGlobal(converter, common); commonAddr = builder.create(loc, global.resultType(), global.getSymbol()); symMap.addSymbol(common, commonAddr); } mlir::Value local = genCommonBlockMember(converter, loc, varSym, commonAddr); Fortran::lower::StatementContext stmtCtx; mapSymbolAttributes(converter, var, symMap, stmtCtx, local); } //===--------------------------------------------------------------===// // Lower Variables specification expressions and attributes //===--------------------------------------------------------------===// /// Helper to decide if a dummy argument must be tracked in an BoxValue. static bool lowerToBoxValue(const Fortran::semantics::Symbol &sym, mlir::Value dummyArg, Fortran::lower::AbstractConverter &converter) { // Only dummy arguments coming as fir.box can be tracked in an BoxValue. if (!dummyArg || !dummyArg.getType().isa()) return false; // Non contiguous arrays must be tracked in an BoxValue. if (sym.Rank() > 0 && !Fortran::evaluate::IsSimplyContiguous( sym, converter.getFoldingContext())) return true; // Assumed rank and optional fir.box cannot yet be read while lowering the // specifications. if (Fortran::evaluate::IsAssumedRank(sym) || Fortran::semantics::IsOptional(sym)) return true; // Polymorphic entity should be tracked through a fir.box that has the // dynamic type info. if (const Fortran::semantics::DeclTypeSpec *type = sym.GetType()) if (type->IsPolymorphic()) return true; return false; } /// Compute extent from lower and upper bound. static mlir::Value computeExtent(fir::FirOpBuilder &builder, mlir::Location loc, mlir::Value lb, mlir::Value ub) { mlir::IndexType idxTy = builder.getIndexType(); // Let the folder deal with the common `ub - + 1` case. auto diff = builder.create(loc, idxTy, ub, lb); mlir::Value one = builder.createIntegerConstant(loc, idxTy, 1); auto rawExtent = builder.create(loc, idxTy, diff, one); return fir::factory::genMaxWithZero(builder, loc, rawExtent); } /// Lower explicit lower bounds into \p result. Does nothing if this is not an /// array, or if the lower bounds are deferred, or all implicit or one. static void lowerExplicitLowerBounds( Fortran::lower::AbstractConverter &converter, mlir::Location loc, const Fortran::lower::BoxAnalyzer &box, llvm::SmallVectorImpl &result, Fortran::lower::SymMap &symMap, Fortran::lower::StatementContext &stmtCtx) { if (!box.isArray() || box.lboundIsAllOnes()) return; fir::FirOpBuilder &builder = converter.getFirOpBuilder(); mlir::IndexType idxTy = builder.getIndexType(); if (box.isStaticArray()) { for (int64_t lb : box.staticLBound()) result.emplace_back(builder.createIntegerConstant(loc, idxTy, lb)); return; } for (const Fortran::semantics::ShapeSpec *spec : box.dynamicBound()) { if (auto low = spec->lbound().GetExplicit()) { auto expr = Fortran::lower::SomeExpr{*low}; mlir::Value lb = builder.createConvert( loc, idxTy, genScalarValue(converter, loc, expr, symMap, stmtCtx)); result.emplace_back(lb); } } assert(result.empty() || result.size() == box.dynamicBound().size()); } /// Return -1 for the last dimension extent/upper bound of assumed-size arrays. /// This value is required to fulfill the requirements for assumed-rank /// associated with assumed-size (see for instance UBOUND in 16.9.196, and /// CFI_desc_t requirements in 18.5.3 point 5.). static mlir::Value getAssumedSizeExtent(mlir::Location loc, fir::FirOpBuilder &builder) { return builder.createMinusOneInteger(loc, builder.getIndexType()); } /// Lower explicit extents into \p result if this is an explicit-shape or /// assumed-size array. Does nothing if this is not an explicit-shape or /// assumed-size array. static void lowerExplicitExtents(Fortran::lower::AbstractConverter &converter, mlir::Location loc, const Fortran::lower::BoxAnalyzer &box, llvm::SmallVectorImpl &lowerBounds, llvm::SmallVectorImpl &result, Fortran::lower::SymMap &symMap, Fortran::lower::StatementContext &stmtCtx) { if (!box.isArray()) return; fir::FirOpBuilder &builder = converter.getFirOpBuilder(); mlir::IndexType idxTy = builder.getIndexType(); if (box.isStaticArray()) { for (int64_t extent : box.staticShape()) result.emplace_back(builder.createIntegerConstant(loc, idxTy, extent)); return; } for (const auto &spec : llvm::enumerate(box.dynamicBound())) { if (auto up = spec.value()->ubound().GetExplicit()) { auto expr = Fortran::lower::SomeExpr{*up}; mlir::Value ub = builder.createConvert( loc, idxTy, genScalarValue(converter, loc, expr, symMap, stmtCtx)); if (lowerBounds.empty()) result.emplace_back(fir::factory::genMaxWithZero(builder, loc, ub)); else result.emplace_back( computeExtent(builder, loc, lowerBounds[spec.index()], ub)); } else if (spec.value()->ubound().isStar()) { result.emplace_back(getAssumedSizeExtent(loc, builder)); } } assert(result.empty() || result.size() == box.dynamicBound().size()); } /// Lower explicit character length if any. Return empty mlir::Value if no /// explicit length. static mlir::Value lowerExplicitCharLen(Fortran::lower::AbstractConverter &converter, mlir::Location loc, const Fortran::lower::BoxAnalyzer &box, Fortran::lower::SymMap &symMap, Fortran::lower::StatementContext &stmtCtx) { if (!box.isChar()) return mlir::Value{}; fir::FirOpBuilder &builder = converter.getFirOpBuilder(); mlir::Type lenTy = builder.getCharacterLengthType(); if (std::optional len = box.getCharLenConst()) return builder.createIntegerConstant(loc, lenTy, *len); if (std::optional lenExpr = box.getCharLenExpr()) // If the length expression is negative, the length is zero. See F2018 // 7.4.4.2 point 5. return fir::factory::genMaxWithZero( builder, loc, genScalarValue(converter, loc, *lenExpr, symMap, stmtCtx)); return mlir::Value{}; } /// Assumed size arrays last extent is -1 in the front end. static mlir::Value genExtentValue(fir::FirOpBuilder &builder, mlir::Location loc, mlir::Type idxTy, long frontEndExtent) { if (frontEndExtent >= 0) return builder.createIntegerConstant(loc, idxTy, frontEndExtent); return getAssumedSizeExtent(loc, builder); } /// If a symbol is an array, it may have been declared with unknown extent /// parameters (e.g., `*`), but if it has an initial value then the actual size /// may be available from the initial array value's type. inline static llvm::SmallVector recoverShapeVector(llvm::ArrayRef shapeVec, mlir::Value initVal) { llvm::SmallVector result; if (initVal) { if (auto seqTy = fir::unwrapUntilSeqType(initVal.getType())) { for (auto [fst, snd] : llvm::zip(shapeVec, seqTy.getShape())) result.push_back(fst == fir::SequenceType::getUnknownExtent() ? snd : fst); return result; } } result.assign(shapeVec.begin(), shapeVec.end()); return result; } fir::FortranVariableFlagsAttr Fortran::lower::translateSymbolAttributes( mlir::MLIRContext *mlirContext, const Fortran::semantics::Symbol &sym, fir::FortranVariableFlagsEnum extraFlags) { fir::FortranVariableFlagsEnum flags = extraFlags; if (sym.test(Fortran::semantics::Symbol::Flag::CrayPointee)) { // CrayPointee are represented as pointers. flags = flags | fir::FortranVariableFlagsEnum::pointer; return fir::FortranVariableFlagsAttr::get(mlirContext, flags); } const auto &attrs = sym.attrs(); if (attrs.test(Fortran::semantics::Attr::ALLOCATABLE)) flags = flags | fir::FortranVariableFlagsEnum::allocatable; if (attrs.test(Fortran::semantics::Attr::ASYNCHRONOUS)) flags = flags | fir::FortranVariableFlagsEnum::asynchronous; if (attrs.test(Fortran::semantics::Attr::BIND_C)) flags = flags | fir::FortranVariableFlagsEnum::bind_c; if (attrs.test(Fortran::semantics::Attr::CONTIGUOUS)) flags = flags | fir::FortranVariableFlagsEnum::contiguous; if (attrs.test(Fortran::semantics::Attr::INTENT_IN)) flags = flags | fir::FortranVariableFlagsEnum::intent_in; if (attrs.test(Fortran::semantics::Attr::INTENT_INOUT)) flags = flags | fir::FortranVariableFlagsEnum::intent_inout; if (attrs.test(Fortran::semantics::Attr::INTENT_OUT)) flags = flags | fir::FortranVariableFlagsEnum::intent_out; if (attrs.test(Fortran::semantics::Attr::OPTIONAL)) flags = flags | fir::FortranVariableFlagsEnum::optional; if (attrs.test(Fortran::semantics::Attr::PARAMETER)) flags = flags | fir::FortranVariableFlagsEnum::parameter; if (attrs.test(Fortran::semantics::Attr::POINTER)) flags = flags | fir::FortranVariableFlagsEnum::pointer; if (attrs.test(Fortran::semantics::Attr::TARGET)) flags = flags | fir::FortranVariableFlagsEnum::target; if (attrs.test(Fortran::semantics::Attr::VALUE)) flags = flags | fir::FortranVariableFlagsEnum::value; if (attrs.test(Fortran::semantics::Attr::VOLATILE)) flags = flags | fir::FortranVariableFlagsEnum::fortran_volatile; if (flags == fir::FortranVariableFlagsEnum::None) return {}; return fir::FortranVariableFlagsAttr::get(mlirContext, flags); } fir::CUDADataAttributeAttr Fortran::lower::translateSymbolCUDADataAttribute( mlir::MLIRContext *mlirContext, const Fortran::semantics::Symbol &sym) { std::optional cudaAttr = Fortran::semantics::GetCUDADataAttr(&sym.GetUltimate()); return fir::getCUDADataAttribute(mlirContext, cudaAttr); } /// Map a symbol to its FIR address and evaluated specification expressions. /// Not for symbols lowered to fir.box. /// Will optionally create fir.declare. static void genDeclareSymbol(Fortran::lower::AbstractConverter &converter, Fortran::lower::SymMap &symMap, const Fortran::semantics::Symbol &sym, mlir::Value base, mlir::Value len = {}, llvm::ArrayRef shape = std::nullopt, llvm::ArrayRef lbounds = std::nullopt, bool force = false) { // In HLFIR, procedure dummy symbols are not added with an hlfir.declare // because they are "values", and hlfir.declare is intended for variables. It // would add too much complexity to hlfir.declare to support this case, and // this would bring very little (the only point being debug info, that are not // yet emitted) since alias analysis is meaningless for those. // Commonblock names are not variables, but in some lowerings (like OpenMP) it // is useful to maintain the address of the commonblock in an MLIR value and // query it. hlfir.declare need not be created for these. if (converter.getLoweringOptions().getLowerToHighLevelFIR() && (!Fortran::semantics::IsProcedure(sym) || Fortran::semantics::IsPointer(sym)) && !sym.detailsIf()) { fir::FirOpBuilder &builder = converter.getFirOpBuilder(); const mlir::Location loc = genLocation(converter, sym); mlir::Value shapeOrShift; if (!shape.empty() && !lbounds.empty()) shapeOrShift = builder.genShape(loc, lbounds, shape); else if (!shape.empty()) shapeOrShift = builder.genShape(loc, shape); else if (!lbounds.empty()) shapeOrShift = builder.genShift(loc, lbounds); llvm::SmallVector lenParams; if (len) lenParams.emplace_back(len); auto name = converter.mangleName(sym); fir::FortranVariableFlagsAttr attributes = Fortran::lower::translateSymbolAttributes(builder.getContext(), sym); fir::CUDADataAttributeAttr cudaAttr = Fortran::lower::translateSymbolCUDADataAttribute(builder.getContext(), sym); if (sym.test(Fortran::semantics::Symbol::Flag::CrayPointee)) { mlir::Type ptrBoxType = Fortran::lower::getCrayPointeeBoxType(base.getType()); mlir::Value boxAlloc = builder.createTemporary(loc, ptrBoxType); // Declare a local pointer variable. auto newBase = builder.create( loc, boxAlloc, name, /*shape=*/nullptr, lenParams, attributes); mlir::Value nullAddr = builder.createNullConstant( loc, llvm::cast(ptrBoxType).getEleTy()); // If the element type is known-length character, then // EmboxOp does not need the length parameters. if (auto charType = mlir::dyn_cast( hlfir::getFortranElementType(base.getType()))) if (!charType.hasDynamicLen()) lenParams.clear(); // Inherit the shape (and maybe length parameters) from the pointee // declaration. mlir::Value initVal = builder.create(loc, ptrBoxType, nullAddr, shapeOrShift, /*slice=*/nullptr, lenParams); builder.create(loc, initVal, newBase.getBase()); // Any reference to the pointee is going to be using the pointer // box from now on. The base_addr of the descriptor must be updated // to hold the value of the Cray pointer at the point of the pointee // access. // Note that the same Cray pointer may be associated with // multiple pointees and each of them has its own descriptor. symMap.addVariableDefinition(sym, newBase, force); return; } auto newBase = builder.create( loc, base, name, shapeOrShift, lenParams, attributes, cudaAttr); symMap.addVariableDefinition(sym, newBase, force); return; } if (len) { if (!shape.empty()) { if (!lbounds.empty()) symMap.addCharSymbolWithBounds(sym, base, len, shape, lbounds, force); else symMap.addCharSymbolWithShape(sym, base, len, shape, force); } else { symMap.addCharSymbol(sym, base, len, force); } } else { if (!shape.empty()) { if (!lbounds.empty()) symMap.addSymbolWithBounds(sym, base, shape, lbounds, force); else symMap.addSymbolWithShape(sym, base, shape, force); } else { symMap.addSymbol(sym, base, force); } } } /// Map a symbol to its FIR address and evaluated specification expressions /// provided as a fir::ExtendedValue. Will optionally create fir.declare. void Fortran::lower::genDeclareSymbol( Fortran::lower::AbstractConverter &converter, Fortran::lower::SymMap &symMap, const Fortran::semantics::Symbol &sym, const fir::ExtendedValue &exv, fir::FortranVariableFlagsEnum extraFlags, bool force) { if (converter.getLoweringOptions().getLowerToHighLevelFIR() && !Fortran::semantics::IsProcedure(sym) && !sym.detailsIf()) { fir::FirOpBuilder &builder = converter.getFirOpBuilder(); const mlir::Location loc = genLocation(converter, sym); // FIXME: Using the ultimate symbol for translating symbol attributes will // lead to situations where the VOLATILE/ASYNCHRONOUS attributes are not // propagated to the hlfir.declare (these attributes can be added when // using module variables). fir::FortranVariableFlagsAttr attributes = Fortran::lower::translateSymbolAttributes( builder.getContext(), sym.GetUltimate(), extraFlags); fir::CUDADataAttributeAttr cudaAttr = Fortran::lower::translateSymbolCUDADataAttribute(builder.getContext(), sym.GetUltimate()); auto name = converter.mangleName(sym); hlfir::EntityWithAttributes declare = hlfir::genDeclare(loc, builder, exv, name, attributes, cudaAttr); symMap.addVariableDefinition(sym, declare.getIfVariableInterface(), force); return; } symMap.addSymbol(sym, exv, force); } /// Map an allocatable or pointer symbol to its FIR address and evaluated /// specification expressions. Will optionally create fir.declare. static void genAllocatableOrPointerDeclare(Fortran::lower::AbstractConverter &converter, Fortran::lower::SymMap &symMap, const Fortran::semantics::Symbol &sym, fir::MutableBoxValue box, bool force = false) { if (!converter.getLoweringOptions().getLowerToHighLevelFIR()) { symMap.addAllocatableOrPointer(sym, box, force); return; } assert(!box.isDescribedByVariables() && "HLFIR alloctables/pointers must be fir.ref"); mlir::Value base = box.getAddr(); mlir::Value explictLength; if (box.hasNonDeferredLenParams()) { if (!box.isCharacter()) TODO(genLocation(converter, sym), "Pointer or Allocatable parametrized derived type"); explictLength = box.nonDeferredLenParams()[0]; } genDeclareSymbol(converter, symMap, sym, base, explictLength, /*shape=*/std::nullopt, /*lbounds=*/std::nullopt, force); } /// Map a procedure pointer static void genProcPointer(Fortran::lower::AbstractConverter &converter, Fortran::lower::SymMap &symMap, const Fortran::semantics::Symbol &sym, mlir::Value addr, bool force = false) { genDeclareSymbol(converter, symMap, sym, addr, mlir::Value{}, /*shape=*/std::nullopt, /*lbounds=*/std::nullopt, force); } /// Map a symbol represented with a runtime descriptor to its FIR fir.box and /// evaluated specification expressions. Will optionally create fir.declare. static void genBoxDeclare(Fortran::lower::AbstractConverter &converter, Fortran::lower::SymMap &symMap, const Fortran::semantics::Symbol &sym, mlir::Value box, llvm::ArrayRef lbounds, llvm::ArrayRef explicitParams, llvm::ArrayRef explicitExtents, bool replace = false) { if (converter.getLoweringOptions().getLowerToHighLevelFIR()) { fir::BoxValue boxValue{box, lbounds, explicitParams, explicitExtents}; Fortran::lower::genDeclareSymbol( converter, symMap, sym, std::move(boxValue), fir::FortranVariableFlagsEnum::None, replace); return; } symMap.addBoxSymbol(sym, box, lbounds, explicitParams, explicitExtents, replace); } /// Lower specification expressions and attributes of variable \p var and /// add it to the symbol map. For a global or an alias, the address must be /// pre-computed and provided in \p preAlloc. A dummy argument for the current /// entry point has already been mapped to an mlir block argument in /// mapDummiesAndResults. Its mapping may be updated here. void Fortran::lower::mapSymbolAttributes( AbstractConverter &converter, const Fortran::lower::pft::Variable &var, Fortran::lower::SymMap &symMap, Fortran::lower::StatementContext &stmtCtx, mlir::Value preAlloc) { fir::FirOpBuilder &builder = converter.getFirOpBuilder(); const Fortran::semantics::Symbol &sym = var.getSymbol(); const mlir::Location loc = genLocation(converter, sym); mlir::IndexType idxTy = builder.getIndexType(); const bool isDeclaredDummy = Fortran::semantics::IsDummy(sym); // An active dummy from the current entry point. const bool isDummy = isDeclaredDummy && symMap.lookupSymbol(sym).getAddr(); // An unused dummy from another entry point. const bool isUnusedEntryDummy = isDeclaredDummy && !isDummy; const bool isResult = Fortran::semantics::IsFunctionResult(sym); const bool replace = isDummy || isResult; fir::factory::CharacterExprHelper charHelp{builder, loc}; if (Fortran::semantics::IsProcedure(sym)) { if (isUnusedEntryDummy) { // Additional discussion below. mlir::Type dummyProcType = Fortran::lower::getDummyProcedureType(sym, converter); mlir::Value undefOp = builder.create(loc, dummyProcType); Fortran::lower::genDeclareSymbol(converter, symMap, sym, undefOp); } // Procedure pointer. if (Fortran::semantics::IsPointer(sym)) { // global mlir::Value boxAlloc = preAlloc; // dummy or passed result if (!boxAlloc) if (Fortran::lower::SymbolBox symbox = symMap.lookupSymbol(sym)) boxAlloc = symbox.getAddr(); // local if (!boxAlloc) boxAlloc = createNewLocal(converter, loc, var, preAlloc); genProcPointer(converter, symMap, sym, boxAlloc, replace); } return; } if (Fortran::evaluate::IsAssumedRank(sym)) TODO(loc, "assumed-rank variable in procedure implemented in Fortran"); Fortran::lower::BoxAnalyzer ba; ba.analyze(sym); // First deal with pointers and allocatables, because their handling here // is the same regardless of their rank. if (Fortran::semantics::IsAllocatableOrPointer(sym)) { // Get address of fir.box describing the entity. // global mlir::Value boxAlloc = preAlloc; // dummy or passed result if (!boxAlloc) if (Fortran::lower::SymbolBox symbox = symMap.lookupSymbol(sym)) boxAlloc = symbox.getAddr(); // local if (!boxAlloc) boxAlloc = createNewLocal(converter, loc, var, preAlloc); // Lower non deferred parameters. llvm::SmallVector nonDeferredLenParams; if (ba.isChar()) { if (mlir::Value len = lowerExplicitCharLen(converter, loc, ba, symMap, stmtCtx)) nonDeferredLenParams.push_back(len); else if (Fortran::semantics::IsAssumedLengthCharacter(sym)) nonDeferredLenParams.push_back( Fortran::lower::getAssumedCharAllocatableOrPointerLen( builder, loc, sym, boxAlloc)); } else if (const Fortran::semantics::DeclTypeSpec *declTy = sym.GetType()) { if (const Fortran::semantics::DerivedTypeSpec *derived = declTy->AsDerived()) if (Fortran::semantics::CountLenParameters(*derived) != 0) TODO(loc, "derived type allocatable or pointer with length parameters"); } fir::MutableBoxValue box = Fortran::lower::createMutableBox( converter, loc, var, boxAlloc, nonDeferredLenParams, /*alwaysUseBox=*/ converter.getLoweringOptions().getLowerToHighLevelFIR()); genAllocatableOrPointerDeclare(converter, symMap, var.getSymbol(), box, replace); return; } if (isDummy) { mlir::Value dummyArg = symMap.lookupSymbol(sym).getAddr(); if (lowerToBoxValue(sym, dummyArg, converter)) { llvm::SmallVector lbounds; llvm::SmallVector explicitExtents; llvm::SmallVector explicitParams; // Lower lower bounds, explicit type parameters and explicit // extents if any. if (ba.isChar()) { if (mlir::Value len = lowerExplicitCharLen(converter, loc, ba, symMap, stmtCtx)) explicitParams.push_back(len); if (sym.Rank() == 0) { // Do not keep scalar characters as fir.box (even when optional). // Lowering and FIR is not meant to deal with scalar characters as // fir.box outside of calls. auto boxTy = dummyArg.getType().dyn_cast(); mlir::Type refTy = builder.getRefType(boxTy.getEleTy()); mlir::Type lenType = builder.getCharacterLengthType(); mlir::Value addr, len; if (Fortran::semantics::IsOptional(sym)) { auto isPresent = builder.create( loc, builder.getI1Type(), dummyArg); auto addrAndLen = builder .genIfOp(loc, {refTy, lenType}, isPresent, /*withElseRegion=*/true) .genThen([&]() { mlir::Value readAddr = builder.create(loc, refTy, dummyArg); mlir::Value readLength = charHelp.readLengthFromBox(dummyArg); builder.create( loc, mlir::ValueRange{readAddr, readLength}); }) .genElse([&] { mlir::Value readAddr = builder.genAbsentOp(loc, refTy); mlir::Value readLength = fir::factory::createZeroValue(builder, loc, lenType); builder.create( loc, mlir::ValueRange{readAddr, readLength}); }) .getResults(); addr = addrAndLen[0]; len = addrAndLen[1]; } else { addr = builder.create(loc, refTy, dummyArg); len = charHelp.readLengthFromBox(dummyArg); } if (!explicitParams.empty()) len = explicitParams[0]; ::genDeclareSymbol(converter, symMap, sym, addr, len, /*extents=*/{}, /*lbounds=*/{}, replace); return; } } // TODO: derived type length parameters. lowerExplicitLowerBounds(converter, loc, ba, lbounds, symMap, stmtCtx); lowerExplicitExtents(converter, loc, ba, lbounds, explicitExtents, symMap, stmtCtx); genBoxDeclare(converter, symMap, sym, dummyArg, lbounds, explicitParams, explicitExtents, replace); return; } } // A dummy from another entry point that is not declared in the current // entry point requires a skeleton definition. Most such "unused" dummies // will not survive into final generated code, but some will. It is illegal // to reference one at run time if it does. Such a dummy is mapped to a // value in one of three ways: // // - Generate a fir::UndefOp value. This is lightweight, easy to clean up, // and often valid, but it may fail for a dummy with dynamic bounds, // or a dummy used to define another dummy. Information to distinguish // valid cases is not generally available here, with the exception of // dummy procedures. See the first function exit above. // // - Allocate an uninitialized stack slot. This is an intermediate-weight // solution that is harder to clean up. It is often valid, but may fail // for an object with dynamic bounds. This option is "automatically" // used by default for cases that do not use one of the other options. // // - Allocate a heap box/descriptor, initialized to zero. This always // works, but is more heavyweight and harder to clean up. It is used // for dynamic objects via calls to genUnusedEntryPointBox. auto genUnusedEntryPointBox = [&]() { if (isUnusedEntryDummy) { assert(!Fortran::semantics::IsAllocatableOrPointer(sym) && "handled above"); // The box is read right away because lowering code does not expect // a non pointer/allocatable symbol to be mapped to a MutableBox. mlir::Type ty = converter.genType(var); bool isPolymorphic = false; if (auto boxTy = ty.dyn_cast()) { isPolymorphic = ty.isa(); ty = boxTy.getEleTy(); } Fortran::lower::genDeclareSymbol( converter, symMap, sym, fir::factory::genMutableBoxRead( builder, loc, fir::factory::createTempMutableBox(builder, loc, ty, {}, {}, isPolymorphic))); return true; } return false; }; // Helper to generate scalars for the symbol properties. auto genValue = [&](const Fortran::lower::SomeExpr &expr) { return genScalarValue(converter, loc, expr, symMap, stmtCtx); }; // For symbols reaching this point, all properties are constant and can be // read/computed already into ssa values. // The origin must be \vec{1}. auto populateShape = [&](auto &shapes, const auto &bounds, mlir::Value box) { for (auto iter : llvm::enumerate(bounds)) { auto *spec = iter.value(); assert(spec->lbound().GetExplicit() && "lbound must be explicit with constant value 1"); if (auto high = spec->ubound().GetExplicit()) { Fortran::lower::SomeExpr highEx{*high}; mlir::Value ub = genValue(highEx); ub = builder.createConvert(loc, idxTy, ub); shapes.emplace_back(fir::factory::genMaxWithZero(builder, loc, ub)); } else if (spec->ubound().isColon()) { assert(box && "assumed bounds require a descriptor"); mlir::Value dim = builder.createIntegerConstant(loc, idxTy, iter.index()); auto dimInfo = builder.create(loc, idxTy, idxTy, idxTy, box, dim); shapes.emplace_back(dimInfo.getResult(1)); } else if (spec->ubound().isStar()) { shapes.emplace_back(getAssumedSizeExtent(loc, builder)); } else { llvm::report_fatal_error("unknown bound category"); } } }; // The origin is not \vec{1}. auto populateLBoundsExtents = [&](auto &lbounds, auto &extents, const auto &bounds, mlir::Value box) { for (auto iter : llvm::enumerate(bounds)) { auto *spec = iter.value(); fir::BoxDimsOp dimInfo; mlir::Value ub, lb; if (spec->lbound().isColon() || spec->ubound().isColon()) { // This is an assumed shape because allocatables and pointers extents // are not constant in the scope and are not read here. assert(box && "deferred bounds require a descriptor"); mlir::Value dim = builder.createIntegerConstant(loc, idxTy, iter.index()); dimInfo = builder.create(loc, idxTy, idxTy, idxTy, box, dim); extents.emplace_back(dimInfo.getResult(1)); if (auto low = spec->lbound().GetExplicit()) { auto expr = Fortran::lower::SomeExpr{*low}; mlir::Value lb = builder.createConvert(loc, idxTy, genValue(expr)); lbounds.emplace_back(lb); } else { // Implicit lower bound is 1 (Fortran 2018 section 8.5.8.3 point 3.) lbounds.emplace_back(builder.createIntegerConstant(loc, idxTy, 1)); } } else { if (auto low = spec->lbound().GetExplicit()) { auto expr = Fortran::lower::SomeExpr{*low}; lb = builder.createConvert(loc, idxTy, genValue(expr)); } else { TODO(loc, "support for assumed rank entities"); } lbounds.emplace_back(lb); if (auto high = spec->ubound().GetExplicit()) { auto expr = Fortran::lower::SomeExpr{*high}; ub = builder.createConvert(loc, idxTy, genValue(expr)); extents.emplace_back(computeExtent(builder, loc, lb, ub)); } else { // An assumed size array. The extent is not computed. assert(spec->ubound().isStar() && "expected assumed size"); extents.emplace_back(getAssumedSizeExtent(loc, builder)); } } } }; //===--------------------------------------------------------------===// // Non Pointer non allocatable scalar, explicit shape, and assumed // size arrays. // Lower the specification expressions. //===--------------------------------------------------------------===// mlir::Value len; llvm::SmallVector extents; llvm::SmallVector lbounds; auto arg = symMap.lookupSymbol(sym).getAddr(); mlir::Value addr = preAlloc; if (arg) if (auto boxTy = arg.getType().dyn_cast()) { // Contiguous assumed shape that can be tracked without a fir.box. mlir::Type refTy = builder.getRefType(boxTy.getEleTy()); addr = builder.create(loc, refTy, arg); } // Compute/Extract character length. if (ba.isChar()) { if (arg) { assert(!preAlloc && "dummy cannot be pre-allocated"); if (mlir::isa(arg.getType())) { std::tie(addr, len) = charHelp.createUnboxChar(arg); } else if (mlir::isa(arg.getType())) { // fir.char<1> passed by value (BIND(C) with VALUE attribute). addr = builder.create(loc, arg.getType()); builder.create(loc, arg, addr); } else if (!addr) { addr = arg; } // Ensure proper type is given to array/scalar that was transmitted as a // fir.boxchar arg or is a statement function actual argument with // a different length than the dummy. mlir::Type castTy = builder.getRefType(converter.genType(var)); addr = builder.createConvert(loc, castTy, addr); } if (std::optional cstLen = ba.getCharLenConst()) { // Static length len = builder.createIntegerConstant(loc, idxTy, *cstLen); } else { // Dynamic length if (genUnusedEntryPointBox()) return; if (std::optional charLenExpr = ba.getCharLenExpr()) { // Explicit length mlir::Value rawLen = genValue(*charLenExpr); // If the length expression is negative, the length is zero. See // F2018 7.4.4.2 point 5. len = fir::factory::genMaxWithZero(builder, loc, rawLen); } else if (!len) { // Assumed length fir.box (possible for contiguous assumed shapes). // Read length from box. assert(arg && arg.getType().isa() && "must be character dummy fir.box"); len = charHelp.readLengthFromBox(arg); } } } // Compute array extents and lower bounds. if (ba.isArray()) { if (ba.isStaticArray()) { if (ba.lboundIsAllOnes()) { for (std::int64_t extent : recoverShapeVector(ba.staticShape(), preAlloc)) extents.push_back(genExtentValue(builder, loc, idxTy, extent)); } else { for (auto [lb, extent] : llvm::zip(ba.staticLBound(), recoverShapeVector(ba.staticShape(), preAlloc))) { lbounds.emplace_back(builder.createIntegerConstant(loc, idxTy, lb)); extents.emplace_back(genExtentValue(builder, loc, idxTy, extent)); } } } else { // Non compile time constant shape. if (genUnusedEntryPointBox()) return; if (ba.lboundIsAllOnes()) populateShape(extents, ba.dynamicBound(), arg); else populateLBoundsExtents(lbounds, extents, ba.dynamicBound(), arg); } } // Allocate or extract raw address for the entity if (!addr) { if (arg) { mlir::Type argType = arg.getType(); const bool isCptrByVal = Fortran::semantics::IsBuiltinCPtr(sym) && Fortran::lower::isCPtrArgByValueType(argType); if (isCptrByVal || !fir::conformsWithPassByRef(argType)) { // Dummy argument passed in register. Place the value in memory at that // point since lowering expect symbols to be mapped to memory addresses. mlir::Type symType = converter.genType(sym); addr = builder.create(loc, symType); if (isCptrByVal) { // Place the void* address into the CPTR address component. mlir::Value addrComponent = fir::factory::genCPtrOrCFunptrAddr(builder, loc, addr, symType); builder.createStoreWithConvert(loc, arg, addrComponent); } else { builder.createStoreWithConvert(loc, arg, addr); } } else { // Dummy address, or address of result whose storage is passed by the // caller. assert(fir::isa_ref_type(argType) && "must be a memory address"); addr = arg; } } else { // Local variables llvm::SmallVector typeParams; if (len) typeParams.emplace_back(len); addr = createNewLocal(converter, loc, var, preAlloc, extents, typeParams); } } ::genDeclareSymbol(converter, symMap, sym, addr, len, extents, lbounds, replace); return; } void Fortran::lower::defineModuleVariable( AbstractConverter &converter, const Fortran::lower::pft::Variable &var) { // Use empty linkage for module variables, which makes them available // for use in another unit. mlir::StringAttr linkage = getLinkageAttribute(converter.getFirOpBuilder(), var); if (!var.isGlobal()) fir::emitFatalError(converter.getCurrentLocation(), "attempting to lower module variable as local"); // Define aggregate storages for equivalenced objects. if (var.isAggregateStore()) { const Fortran::lower::pft::Variable::AggregateStore &aggregate = var.getAggregateStore(); std::string aggName = mangleGlobalAggregateStore(converter, aggregate); defineGlobalAggregateStore(converter, aggregate, aggName, linkage); return; } const Fortran::semantics::Symbol &sym = var.getSymbol(); if (const Fortran::semantics::Symbol *common = Fortran::semantics::FindCommonBlockContaining(var.getSymbol())) { // Nothing to do, common block are generated before everything. Ensure // this was done by calling getCommonBlockGlobal. getCommonBlockGlobal(converter, *common); } else if (var.isAlias()) { // Do nothing. Mapping will be done on user side. } else { std::string globalName = converter.mangleName(sym); fir::CUDADataAttributeAttr cudaAttr = Fortran::lower::translateSymbolCUDADataAttribute( converter.getFirOpBuilder().getContext(), sym); defineGlobal(converter, var, globalName, linkage, cudaAttr); } } void Fortran::lower::instantiateVariable(AbstractConverter &converter, const pft::Variable &var, Fortran::lower::SymMap &symMap, AggregateStoreMap &storeMap) { if (var.hasSymbol()) { // Do not try to instantiate symbols twice, except for dummies and results, // that may have been mapped to the MLIR entry block arguments, and for // which the explicit specifications, if any, has not yet been lowered. const auto &sym = var.getSymbol(); if (!IsDummy(sym) && !IsFunctionResult(sym) && symMap.lookupSymbol(sym)) return; } LLVM_DEBUG(llvm::dbgs() << "instantiateVariable: "; var.dump()); if (var.isAggregateStore()) instantiateAggregateStore(converter, var, storeMap); else if (const Fortran::semantics::Symbol *common = Fortran::semantics::FindCommonBlockContaining( var.getSymbol().GetUltimate())) instantiateCommon(converter, *common, var, symMap); else if (var.isAlias()) instantiateAlias(converter, var, symMap, storeMap); else if (var.isGlobal()) instantiateGlobal(converter, var, symMap); else instantiateLocal(converter, var, symMap); } static void mapCallInterfaceSymbol(const Fortran::semantics::Symbol &interfaceSymbol, Fortran::lower::AbstractConverter &converter, const Fortran::lower::CallerInterface &caller, Fortran::lower::SymMap &symMap) { Fortran::lower::AggregateStoreMap storeMap; for (Fortran::lower::pft::Variable var : Fortran::lower::pft::getDependentVariableList(interfaceSymbol)) { if (var.isAggregateStore()) { instantiateVariable(converter, var, symMap, storeMap); continue; } const Fortran::semantics::Symbol &sym = var.getSymbol(); if (&sym == &interfaceSymbol) continue; const auto *hostDetails = sym.detailsIf(); if (hostDetails && !var.isModuleOrSubmoduleVariable()) { // The callee is an internal procedure `A` whose result properties // depend on host variables. The caller may be the host, or another // internal procedure `B` contained in the same host. In the first // case, the host symbol is obviously mapped, in the second case, it // must also be mapped because // HostAssociations::internalProcedureBindings that was called when // lowering `B` will have mapped all host symbols of captured variables // to the tuple argument containing the composite of all host associated // variables, whether or not the host symbol is actually referred to in // `B`. Hence it is possible to simply lookup the variable associated to // the host symbol without having to go back to the tuple argument. symMap.copySymbolBinding(hostDetails->symbol(), sym); // The SymbolBox associated to the host symbols is complete, skip // instantiateVariable that would try to allocate a new storage. continue; } if (Fortran::semantics::IsDummy(sym) && sym.owner() == interfaceSymbol.owner()) { // Get the argument for the dummy argument symbols of the current call. symMap.addSymbol(sym, caller.getArgumentValue(sym)); // All the properties of the dummy variable may not come from the actual // argument, let instantiateVariable handle this. } // If this is neither a host associated or dummy symbol, it must be a // module or common block variable to satisfy specification expression // requirements in 10.1.11, instantiateVariable will get its address and // properties. instantiateVariable(converter, var, symMap, storeMap); } } void Fortran::lower::mapCallInterfaceSymbolsForResult( AbstractConverter &converter, const Fortran::lower::CallerInterface &caller, SymMap &symMap) { const Fortran::semantics::Symbol &result = caller.getResultSymbol(); mapCallInterfaceSymbol(result, converter, caller, symMap); } void Fortran::lower::mapCallInterfaceSymbolsForDummyArgument( AbstractConverter &converter, const Fortran::lower::CallerInterface &caller, SymMap &symMap, const Fortran::semantics::Symbol &dummySymbol) { mapCallInterfaceSymbol(dummySymbol, converter, caller, symMap); } void Fortran::lower::mapSymbolAttributes( AbstractConverter &converter, const Fortran::semantics::SymbolRef &symbol, Fortran::lower::SymMap &symMap, Fortran::lower::StatementContext &stmtCtx, mlir::Value preAlloc) { mapSymbolAttributes(converter, pft::Variable{symbol}, symMap, stmtCtx, preAlloc); } void Fortran::lower::createIntrinsicModuleGlobal( Fortran::lower::AbstractConverter &converter, const pft::Variable &var) { defineGlobal(converter, var, converter.mangleName(var.getSymbol()), converter.getFirOpBuilder().createLinkOnceODRLinkage()); } void Fortran::lower::createRuntimeTypeInfoGlobal( Fortran::lower::AbstractConverter &converter, const Fortran::semantics::Symbol &typeInfoSym) { fir::FirOpBuilder &builder = converter.getFirOpBuilder(); std::string globalName = converter.mangleName(typeInfoSym); auto var = Fortran::lower::pft::Variable(typeInfoSym, /*global=*/true); mlir::StringAttr linkage = getLinkageAttribute(builder, var); defineGlobal(converter, var, globalName, linkage); } mlir::Type Fortran::lower::getCrayPointeeBoxType(mlir::Type fortranType) { mlir::Type baseType = hlfir::getFortranElementOrSequenceType(fortranType); if (auto seqType = mlir::dyn_cast(baseType)) { // The pointer box's sequence type must be with unknown shape. llvm::SmallVector shape(seqType.getDimension(), fir::SequenceType::getUnknownExtent()); baseType = fir::SequenceType::get(shape, seqType.getEleTy()); } return fir::BoxType::get(fir::PointerType::get(baseType)); }