mirrors/llvm-project
0
0
Fork 0
mirror of https://github.com/llvm/llvm-project.git synced 2025-04-25 11:46:08 +00:00
Code Issues Projects Releases Wiki Activity
llvm-project/flang/lib/Lower/ConvertVariable.cpp
Jean Perier 2c8cb9acb5 [flang] Handle common block with different sizes in same file 
Semantics is not preventing a named common block to appear with
different size in a same file (named common block should always have
the same storage size (see Fortran 2018 8.10.2.5), but it is a common
extension to accept different sizes).

Lowering was not coping with this well, since it just use the first
common block appearance, starting with BLOCK DATAs to define common
blocks (this also was an issue with the blank common block, which can
legally appear with different size in different scoping units).

Semantics is also not preventing named common from being initialized
outside of a BLOCK DATA, and lowering was dealing badly with this,
since it only gave an initial value to common blocks Globals if the
first common block appearance, starting with BLOCK DATAs had an initial
value.

Semantics is also allowing blank common to be initialized, while
lowering was assuming this would never happen, and was never creating
an initial value for it.

Lastly, semantics was not complaining if a COMMON block was initialized
in several scoping unit in a same file, while lowering can only generate
one of these initial value.

To fix this, add a structure to keep track of COMMON block properties
(biggest size, and initial value if any) at the Program level. Once the
size of a common block appearance is know, the common block appearance
is checked against this information. It allows semantics to emit an error
in case of multiple initialization in different scopes of a same common
block, and to warn in case named common blocks appears with different
sizes. Lastly, this allows lowering to use the Program level info about
common blocks to emit the right GlobalOp for a Common Block, regardless
of the COMMON Block appearances order: It emits a GlobalOp with the
biggest size, whose lowest bytes are initialized with the initial value
if any is given in a scope where the common block appears.

Lowering is updated to go emit the common blocks before anything else so
that the related GlobalOps are available when lowering the scopes where
common block appear. It is also updated to not assume that blank common
are never initialized.

Differential Revision: https://reviews.llvm.org/D124622
2022-04-29 14:52:47 +02:00

1901 lines
87 KiB
C++
Raw Blame History

//===-- 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/ConvertExpr.h"
#include "flang/Lower/IntrinsicCall.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/Lower/Todo.h"
#include "flang/Optimizer/Builder/Character.h"
#include "flang/Optimizer/Builder/FIRBuilder.h"
#include "flang/Optimizer/Builder/Runtime/Derived.h"
#include "flang/Optimizer/Dialect/FIRAttr.h"
#include "flang/Optimizer/Dialect/FIRDialect.h"
#include "flang/Optimizer/Dialect/FIROps.h"
#include "flang/Optimizer/Support/FIRContext.h"
#include "flang/Optimizer/Support/FatalError.h"
#include "flang/Semantics/runtime-type-info.h"
#include "flang/Semantics/tools.h"
#include "llvm/Support/Debug.h"
#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.
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<Fortran::semantics::ObjectEntityDetails>() && sym.size())
if (!Fortran::semantics::IsAllocatableOrPointer(sym))
if (const Fortran::semantics::DeclTypeSpec *declTypeSpec = sym.GetType())
if (const Fortran::semantics::DerivedTypeSpec *derivedTypeSpec =
declTypeSpec->AsDerived())
return derivedTypeSpec->HasDefaultInitialization();
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);
}
/// Is this a compiler generated symbol to describe derived types ?
static bool isRuntimeTypeInfoData(const Fortran::semantics::Symbol &sym) {
// So far, use flags to detect if this symbol were generated during
// semantics::BuildRuntimeDerivedTypeTables(). Scope cannot be used since the
// symbols are injected in the user scopes defining the described derived
// types. A robustness improvement for this test could be to get hands on the
// semantics::RuntimeDerivedTypeTables and to check if the symbol names
// belongs to this structure.
return sym.test(Fortran::semantics::Symbol::Flag::CompilerCreated) &&
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);
/// 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 = converter.genLocation(sym.name());
// 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::ObjectEntityDetails>() &&
!ultimate.has<Fortran::semantics::ProcEntityDetails>())
mlir::emitError(loc, "lowering global declaration: symbol '")
<< toStringRef(sym.name()) << "' has unexpected details\n";
return builder.createGlobal(loc, converter.genType(var), globalName, linkage,
mlir::Attribute{}, isConstant(ultimate));
}
/// 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;
}
static mlir::Type unwrapElementType(mlir::Type type) {
if (mlir::Type ty = fir::dyn_cast_ptrOrBoxEleTy(type))
type = ty;
if (auto seqType = type.dyn_cast<fir::SequenceType>())
type = seqType.getEleTy();
return type;
}
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);
}
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) {
Fortran::lower::SymMap globalOpSymMap;
Fortran::lower::AggregateStoreMap storeMap;
Fortran::lower::StatementContext stmtCtx;
fir::FirOpBuilder &builder = converter.getFirOpBuilder();
if (Fortran::evaluate::UnwrapExpr<Fortran::evaluate::NullPointer>(
initialTarget))
return fir::factory::createUnallocatedBox(builder, loc, boxType,
/*nonDeferredParams=*/llvm::None);
// Pointer initial data target, and NULL(mold).
if (const Fortran::semantics::Symbol *sym =
Fortran::evaluate::GetFirstSymbol(initialTarget)) {
// 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);
}
mlir::Value box;
if (initialTarget.Rank() > 0) {
box = fir::getBase(Fortran::lower::createSomeArrayBox(
converter, initialTarget, globalOpSymMap, stmtCtx));
} else {
fir::ExtendedValue addr = Fortran::lower::createInitializerAddress(
loc, converter, initialTarget, globalOpSymMap, stmtCtx);
box = builder.createBox(loc, addr);
}
// box is a fir.box<T>, not a fir.box<fir.ptr<T>> as it should to be used
// for pointers. A fir.convert should not be used here, because it would
// not actually set the pointer attribute in the descriptor.
// In a normal context, fir.rebox would be used to set the pointer attribute
// while copying the projection from another fir.box. But fir.rebox cannot be
// used in initializer because its current codegen expects that the input
// fir.box is in memory, which is not the case in initializers.
// So, just replace the fir.embox that created addr with one with
// fir.box<fir.ptr<T>> result type.
// Note that the descriptor cannot have been created with fir.rebox because
// the initial-data-target cannot be a fir.box itself (it cannot be
// assumed-shape, deferred-shape, or polymorphic as per C765). However the
// case where the initial data target is a derived type with length parameters
// will most likely be a bit trickier, hence the TODO above.
mlir::Operation *op = box.getDefiningOp();
if (!op || !mlir::isa<fir::EmboxOp>(*op))
fir::emitFatalError(
loc, "fir.box must be created with embox in global initializers");
mlir::Type targetEleTy = unwrapElementType(box.getType());
if (!fir::isa_char(targetEleTy))
return builder.create<fir::EmboxOp>(loc, boxType, op->getOperands(),
op->getAttrs());
// Handle the character case length particularities: embox takes a length
// value argument when the result type has unknown length, but not when the
// result type has constant length. The type of the initial target must be
// constant length, but the one of the pointer may not be. In this case, a
// length operand must be added.
auto targetLen = targetEleTy.cast<fir::CharacterType>().getLen();
auto ptrLen = unwrapElementType(boxType).cast<fir::CharacterType>().getLen();
if (ptrLen == targetLen)
// Nothing to do
return builder.create<fir::EmboxOp>(loc, boxType, op->getOperands(),
op->getAttrs());
auto embox = mlir::cast<fir::EmboxOp>(*op);
auto ptrType = boxType.cast<fir::BoxType>().getEleTy();
mlir::Value memref = builder.createConvert(loc, ptrType, embox.getMemref());
if (targetLen == fir::CharacterType::unknownLen())
// Drop the length argument.
return builder.create<fir::EmboxOp>(loc, boxType, memref, embox.getShape(),
embox.getSlice());
// targetLen is constant and ptrLen is unknown. Add a length argument.
mlir::Value targetLenValue =
builder.createIntegerConstant(loc, builder.getIndexType(), targetLen);
return builder.create<fir::EmboxOp>(loc, boxType, memref, embox.getShape(),
embox.getSlice(),
mlir::ValueRange{targetLenValue});
}
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<fir::SequenceType>()) {
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<fir::RecordType>();
auto fieldTy = fir::FieldType::get(scalarType.getContext());
mlir::Value initialValue = builder.create<fir::UndefOp>(loc, scalarType);
const Fortran::semantics::DeclTypeSpec *declTy = sym.GetType();
assert(declTy && "var with default initialization must have a type");
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;
mlir::Value componentValue;
llvm::StringRef name = toStringRef(component.name());
mlir::Type componentTy = recTy.getType(name);
assert(componentTy && "component not found in type");
if (const auto *object{
component.detailsIf<Fortran::semantics::ObjectEntityDetails>()}) {
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, llvm::None);
} else if (hasDefaultInitialization(component)) {
// Component type has default initialization.
componentValue = genDefaultInitializerValue(converter, loc, component,
componentTy, stmtCtx);
} else {
// Component has no initial value.
componentValue = builder.create<fir::UndefOp>(loc, componentTy);
}
} else if (const auto *proc{
component
.detailsIf<Fortran::semantics::ProcEntityDetails>()}) {
if (proc->init().has_value())
TODO(loc, "procedure pointer component default initialization");
else
componentValue = builder.create<fir::UndefOp>(loc, componentTy);
}
assert(componentValue && "must have been computed");
componentValue = builder.createConvert(loc, componentTy, componentValue);
// FIXME: type parameters must come from the derived-type-spec
auto field = builder.create<fir::FieldIndexOp>(
loc, fieldTy, name, scalarType,
/*typeParams=*/mlir::ValueRange{} /*TODO*/);
initialValue = builder.create<fir::InsertValueOp>(
loc, recTy, initialValue, componentValue,
builder.getArrayAttr(field.getAttributes()));
}
if (sequenceType) {
// For arrays, duplicate the scalar value to all elements with an
// fir.insert_range covering the whole array.
auto arrayInitialValue = builder.create<fir::UndefOp>(loc, sequenceType);
llvm::SmallVector<int64_t> 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<fir::InsertOnRangeOp>(
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.
static void
createGlobalInitialization(fir::FirOpBuilder &builder, fir::GlobalOp global,
std::function<void(fir::FirOpBuilder &)> genInit) {
mlir::Region &region = 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::FirOpBuilder &builder = converter.getFirOpBuilder();
const Fortran::semantics::Symbol &sym = var.getSymbol();
mlir::Location loc = converter.genLocation(sym.name());
bool isConst = isConstant(sym);
fir::GlobalOp global = builder.getNamedGlobal(globalName);
mlir::Type symTy = converter.genType(var);
if (global && globalIsInitialized(global))
return global;
// 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
// rank-1 Fortran arrays of integer, real, or logical. The tensor
// type does not support nested structures which are needed for
// complex numbers.
// To get multidimensional arrays to work, we will have to use column major
// array ordering with the tensor type (so it matches column major ordering
// with the Fortran fir.array). By default, tensor types assume row major
// ordering. How to create this tensor type is to be determined.
if (symTy.isa<fir::SequenceType>() && sym.Rank() == 1 &&
!Fortran::semantics::IsAllocatableOrPointer(sym)) {
mlir::Type eleTy = symTy.cast<fir::SequenceType>().getEleTy();
if (eleTy.isa<mlir::IntegerType, mlir::FloatType, fir::LogicalType>()) {
const auto *details =
sym.detailsIf<Fortran::semantics::ObjectEntityDetails>();
if (details->init()) {
global = Fortran::lower::createDenseGlobal(
loc, symTy, globalName, linkage, isConst, details->init().value(),
converter);
if (global) {
global.setVisibility(mlir::SymbolTable::Visibility::Public);
return global;
}
}
}
}
if (!global)
global = builder.createGlobal(loc, symTy, globalName, linkage,
mlir::Attribute{}, isConst);
if (Fortran::semantics::IsAllocatableOrPointer(sym)) {
const auto *details =
sym.detailsIf<Fortran::semantics::ObjectEntityDetails>();
if (details && details->init()) {
auto expr = *details->init();
createGlobalInitialization(builder, global, [&](fir::FirOpBuilder &b) {
mlir::Value box =
Fortran::lower::genInitialDataTarget(converter, loc, symTy, expr);
b.create<fir::HasValueOp>(loc, box);
});
} else {
// Create unallocated/disassociated descriptor if no explicit init
createGlobalInitialization(builder, global, [&](fir::FirOpBuilder &b) {
mlir::Value box =
fir::factory::createUnallocatedBox(b, loc, symTy, llvm::None);
b.create<fir::HasValueOp>(loc, box);
});
}
} else if (const auto *details =
sym.detailsIf<Fortran::semantics::ObjectEntityDetails>()) {
if (details->init()) {
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<fir::HasValueOp>(loc, castTo);
});
} else if (hasDefaultInitialization(sym)) {
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<fir::HasValueOp>(loc, castTo);
});
}
} else if (sym.has<Fortran::semantics::CommonBlockDetails>()) {
mlir::emitError(loc, "COMMON symbol processed elsewhere");
} else {
TODO(loc, "global"); // Procedure pointer or something else
}
// Creates undefined initializer for globals without initializers
if (!globalIsInitialized(global))
createGlobalInitialization(
builder, global, [&](fir::FirOpBuilder &builder) {
builder.create<fir::HasValueOp>(
loc, builder.create<fir::UndefOp>(loc, symTy));
});
// 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.hasSymbol() && isRuntimeTypeInfoData(var.getSymbol()))
return builder.createLinkOnceODRLinkage();
if (var.isModuleVariable())
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 = Fortran::lower::mangle::mangleName(sym);
mlir::Location loc = converter.genLocation(sym.name());
fir::GlobalOp global = builder.getNamedGlobal(globalName);
mlir::StringAttr linkage = getLinkageAttribute(builder, var);
if (var.isModuleVariable()) {
// 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 = declareGlobal(converter, var, globalName, linkage);
} else {
global = defineGlobal(converter, var, globalName, linkage);
}
auto addrOf = builder.create<fir::AddrOfOp>(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<mlir::Value> shape = {},
llvm::ArrayRef<mlir::Value> lenParams = {}) {
if (preAlloc)
return preAlloc;
fir::FirOpBuilder &builder = converter.getFirOpBuilder();
std::string nm = Fortran::lower::mangle::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();
// Let the builder do all the heavy lifting.
return builder.allocateLocal(loc, ty, nm, symNm, shape, lenParams, isTarg);
}
/// 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;
// 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 = symMap.lookupSymbol(sym).toExtendedValue();
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<fir::IsPresentOp>(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);
}
}
/// 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);
if (mustBeDefaultInitializedAtRuntime(var))
defaultInitializeAtRuntime(converter, var, symMap);
}
//===----------------------------------------------------------------===//
// 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.getAlias()};
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(
const Fortran::lower::pft::Variable::AggregateStore &st) {
return Fortran::lower::mangle::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<Fortran::semantics::ObjectEntityDetails>())
if (objectDetails->init()) {
createGlobalInitialization(
builder, global, [&](fir::FirOpBuilder &builder) {
Fortran::lower::StatementContext stmtCtx;
mlir::Value initVal = fir::getBase(genInitializerExprValue(
converter, loc, objectDetails->init().value(), stmtCtx));
builder.create<fir::HasValueOp>(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.
createGlobalInitialization(builder, global, [&](fir::FirOpBuilder &builder) {
Fortran::lower::StatementContext stmtCtx;
mlir::Value initVal = builder.create<fir::UndefOp>(loc, aggTy);
builder.create<fir::HasValueOp>(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(var.getAggregateStore());
if (var.isGlobal()) {
fir::GlobalOp global;
auto &aggregate = var.getAggregateStore();
mlir::StringAttr linkage = getLinkageAttribute(builder, var);
if (var.isModuleVariable()) {
// 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<fir::AddrOfOp>(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, "", llvm::None, llvm::None,
/*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 = converter.genLocation(sym.name());
mlir::IndexType idxTy = builder.getIndexType();
std::size_t aliasOffset = var.getAlias();
mlir::Value store = getAggregateStore(storeMap, var);
mlir::IntegerType i8Ty = builder.getIntegerType(8);
mlir::Type i8Ptr = builder.getRefType(i8Ty);
mlir::Value offset = builder.createIntegerConstant(
loc, idxTy, sym.GetUltimate().offset() - aliasOffset);
auto ptr = builder.create<fir::CoordinateOp>(loc, i8Ptr, store,
mlir::ValueRange{offset});
mlir::Value preAlloc =
castAliasToPointer(builder, loc, converter.genType(sym), ptr);
Fortran::lower::StatementContext stmtCtx;
mapSymbolAttributes(converter, var, symMap, stmtCtx, preAlloc);
// 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<Fortran::semantics::ObjectEntityDetails>())
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<mlir::Type> members;
std::size_t counter = 0;
for (const Fortran::semantics::MutableSymbolRef &mem : cmnBlkMems) {
if (const auto *memDet =
mem->detailsIf<Fortran::semantics::ObjectEntityDetails>()) {
if (mem->offset() > counter) {
fir::SequenceType::Shape len = {
static_cast<fir::SequenceType::Extent>(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<fir::SequenceType::Extent>(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<Fortran::semantics::CommonBlockDetails>();
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<Fortran::semantics::ObjectEntityDetails>()) {
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 (std::find(members.begin(), members.end(), obj.symbol) ==
members.end())
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 = Fortran::lower::mangle::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<std::tuple<
fir::GlobalOp, Fortran::semantics::MutableSymbolVector, mlir::Location>>
declareCommonBlock(Fortran::lower::AbstractConverter &converter,
const Fortran::semantics::Symbol &common,
std::size_t commonSize) {
fir::FirOpBuilder &builder = converter.getFirOpBuilder();
std::string commonName = Fortran::lower::mangle::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<fir::SequenceType::Extent>(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::makeArrayRef(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<mlir::TupleType>();
auto initFunc = [&](fir::FirOpBuilder &builder) {
mlir::IndexType idxTy = builder.getIndexType();
mlir::Value cb = builder.create<fir::UndefOp>(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<Fortran::semantics::ObjectEntityDetails>()) {
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<fir::InsertValueOp>(loc, commonTy, cb, castVal,
builder.getArrayAttr(offVal));
++tupIdx;
offset = mem->offset() + mem->size();
}
}
}
LLVM_DEBUG(llvm::dbgs() << "}\n");
builder.create<fir::HasValueOp>(loc, cb);
};
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<std::tuple<fir::GlobalOp, Fortran::semantics::MutableSymbolVector,
mlir::Location>>
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);
}
/// 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<fir::AddrOfOp>(loc, global.resultType(),
global.getSymbol());
symMap.addSymbol(common, commonAddr);
}
std::size_t byteOffset = varSym.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, commonAddr);
mlir::Value offs =
builder.createIntegerConstant(loc, builder.getIndexType(), byteOffset);
auto varAddr = builder.create<fir::CoordinateOp>(loc, i8Ptr, base,
mlir::ValueRange{offs});
mlir::Type symType = converter.genType(var.getSymbol());
mlir::Value local;
if (Fortran::semantics::FindEquivalenceSet(var.getSymbol()) != nullptr)
local = castAliasToPointer(builder, loc, symType, varAddr);
else
local = builder.createConvert(loc, builder.getRefType(symType), varAddr);
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) {
// Only dummy arguments coming as fir.box can be tracked in an BoxValue.
if (!dummyArg || !dummyArg.getType().isa<fir::BoxType>())
return false;
// Non contiguous arrays must be tracked in an BoxValue.
if (sym.Rank() > 0 && !sym.attrs().test(Fortran::semantics::Attr::CONTIGUOUS))
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 - <const> + 1` case.
auto diff = builder.create<mlir::arith::SubIOp>(loc, idxTy, ub, lb);
mlir::Value one = builder.createIntegerConstant(loc, idxTy, 1);
auto rawExtent = builder.create<mlir::arith::AddIOp>(loc, idxTy, diff, one);
return Fortran::lower::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<mlir::Value> &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());
}
/// 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<mlir::Value> &lowerBounds,
llvm::SmallVectorImpl<mlir::Value> &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(Fortran::lower::genMaxWithZero(builder, loc, ub));
else
result.emplace_back(
computeExtent(builder, loc, lowerBounds[spec.index()], ub));
} else if (spec.value()->ubound().isStar()) {
// Assumed extent is undefined. Must be provided by user's code.
result.emplace_back(builder.create<fir::UndefOp>(loc, idxTy));
}
}
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 (llvm::Optional<int64_t> len = box.getCharLenConst())
return builder.createIntegerConstant(loc, lenTy, *len);
if (llvm::Optional<Fortran::lower::SomeExpr> lenExpr = box.getCharLenExpr())
// If the length expression is negative, the length is zero. See F2018
// 7.4.4.2 point 5.
return Fortran::lower::genMaxWithZero(
builder, loc,
genScalarValue(converter, loc, *lenExpr, symMap, stmtCtx));
return mlir::Value{};
}
/// Treat negative values as undefined. Assumed size arrays will return -1 from
/// the front end for example. Using negative values can produce hard to find
/// bugs much further along in the compilation.
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 builder.create<fir::UndefOp>(loc, idxTy);
}
/// Lower specification expressions and attributes of variable \p var and
/// add it to the symbol map.
/// For global and aliases, the address must be pre-computed and provided
/// in \p preAlloc.
/// Dummy arguments must have already been mapped to mlir block arguments
/// their 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 = converter.genLocation(sym.name());
mlir::IndexType idxTy = builder.getIndexType();
const bool isDummy = Fortran::semantics::IsDummy(sym);
const bool isResult = Fortran::semantics::IsFunctionResult(sym);
const bool replace = isDummy || isResult;
fir::factory::CharacterExprHelper charHelp{builder, loc};
Fortran::lower::BoxAnalyzer ba;
ba.analyze(sym);
// First deal with pointers an 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<mlir::Value> nonDeferredLenParams;
if (ba.isChar()) {
if (mlir::Value len =
lowerExplicitCharLen(converter, loc, ba, symMap, stmtCtx))
nonDeferredLenParams.push_back(len);
else if (Fortran::semantics::IsAssumedLengthCharacter(sym))
TODO(loc, "assumed length character allocatable");
} 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);
symMap.addAllocatableOrPointer(var.getSymbol(), box, replace);
return;
}
if (isDummy) {
mlir::Value dummyArg = symMap.lookupSymbol(sym).getAddr();
if (lowerToBoxValue(sym, dummyArg)) {
llvm::SmallVector<mlir::Value> lbounds;
llvm::SmallVector<mlir::Value> explicitExtents;
llvm::SmallVector<mlir::Value> 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);
// TODO: derived type length parameters.
lowerExplicitLowerBounds(converter, loc, ba, lbounds, symMap, stmtCtx);
lowerExplicitExtents(converter, loc, ba, lbounds, explicitExtents, symMap,
stmtCtx);
symMap.addBoxSymbol(sym, dummyArg, lbounds, explicitParams,
explicitExtents, replace);
return;
}
}
// 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(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<fir::BoxDimsOp>(loc, idxTy, idxTy, idxTy, box, dim);
shapes.emplace_back(dimInfo.getResult(1));
} else if (spec->ubound().isStar()) {
shapes.emplace_back(builder.create<fir::UndefOp>(loc, idxTy));
} 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<fir::BoxDimsOp>(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, "assumed rank lowering");
}
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(builder.create<fir::UndefOp>(loc, idxTy));
}
}
}
};
// Lower length expression for non deferred and non dummy assumed length
// characters.
auto genExplicitCharLen =
[&](llvm::Optional<Fortran::lower::SomeExpr> charLen) -> mlir::Value {
if (!charLen)
fir::emitFatalError(loc, "expected explicit character length");
mlir::Value rawLen = genValue(*charLen);
// If the length expression is negative, the length is zero. See
// F2018 7.4.4.2 point 5.
return genMaxWithZero(builder, loc, rawLen);
};
ba.match(
//===--------------------------------------------------------------===//
// Trivial case.
//===--------------------------------------------------------------===//
[&](const Fortran::lower::details::ScalarSym &) {
if (isDummy) {
// This is an argument.
if (!symMap.lookupSymbol(sym))
mlir::emitError(loc, "symbol \"")
<< toStringRef(sym.name()) << "\" must already be in map";
return;
} else if (isResult) {
// Some Fortran results may be passed by argument (e.g. derived
// types)
if (symMap.lookupSymbol(sym))
return;
}
// Otherwise, it's a local variable or function result.
mlir::Value local = createNewLocal(converter, loc, var, preAlloc);
symMap.addSymbol(sym, local);
},
//===--------------------------------------------------------------===//
// The non-trivial cases are when we have an argument or local that has
// a repetition value. Arguments might be passed as simple pointers and
// need to be cast to a multi-dimensional array with constant bounds
// (possibly with a missing column), bounds computed in the callee
// (here), or with bounds from the caller (boxed somewhere else). Locals
// have the same properties except they are never boxed arguments from
// the caller and never having a missing column size.
//===--------------------------------------------------------------===//
[&](const Fortran::lower::details::ScalarStaticChar &x) {
// type is a CHARACTER, determine the LEN value
auto charLen = x.charLen();
if (replace) {
Fortran::lower::SymbolBox symBox = symMap.lookupSymbol(sym);
std::pair<mlir::Value, mlir::Value> unboxchar =
charHelp.createUnboxChar(symBox.getAddr());
mlir::Value boxAddr = unboxchar.first;
// Set/override LEN with a constant
mlir::Value len = builder.createIntegerConstant(loc, idxTy, charLen);
symMap.addCharSymbol(sym, boxAddr, len, true);
return;
}
mlir::Value len = builder.createIntegerConstant(loc, idxTy, charLen);
if (preAlloc) {
symMap.addCharSymbol(sym, preAlloc, len);
return;
}
mlir::Value local = createNewLocal(converter, loc, var, preAlloc);
symMap.addCharSymbol(sym, local, len);
},
//===--------------------------------------------------------------===//
[&](const Fortran::lower::details::ScalarDynamicChar &x) {
// type is a CHARACTER, determine the LEN value
auto charLen = x.charLen();
if (replace) {
Fortran::lower::SymbolBox symBox = symMap.lookupSymbol(sym);
mlir::Value boxAddr = symBox.getAddr();
mlir::Value len;
mlir::Type addrTy = boxAddr.getType();
if (addrTy.isa<fir::BoxCharType>() || addrTy.isa<fir::BoxType>()) {
std::tie(boxAddr, len) = charHelp.createUnboxChar(symBox.getAddr());
} else {
// dummy from an other entry case: we cannot get a dynamic length
// for it, it's illegal for the user program to use it. However,
// since we are lowering all function unit statements regardless
// of whether the execution will reach them or not, we need to
// fill a value for the length here.
len = builder.createIntegerConstant(
loc, builder.getCharacterLengthType(), 1);
}
// Override LEN with an expression
if (charLen)
len = genExplicitCharLen(charLen);
symMap.addCharSymbol(sym, boxAddr, len, true);
return;
}
// local CHARACTER variable
mlir::Value len = genExplicitCharLen(charLen);
if (preAlloc) {
symMap.addCharSymbol(sym, preAlloc, len);
return;
}
llvm::SmallVector<mlir::Value> lengths = {len};
mlir::Value local =
createNewLocal(converter, loc, var, preAlloc, llvm::None, lengths);
symMap.addCharSymbol(sym, local, len);
},
//===--------------------------------------------------------------===//
[&](const Fortran::lower::details::StaticArray &x) {
// object shape is constant, not a character
mlir::Type castTy = builder.getRefType(converter.genType(var));
mlir::Value addr = symMap.lookupSymbol(sym).getAddr();
if (addr)
addr = builder.createConvert(loc, castTy, addr);
if (x.lboundAllOnes()) {
// if lower bounds are all ones, build simple shaped object
llvm::SmallVector<mlir::Value> shape;
for (int64_t i : x.shapes)
shape.push_back(genExtentValue(builder, loc, idxTy, i));
mlir::Value local =
isDummy ? addr : createNewLocal(converter, loc, var, preAlloc);
symMap.addSymbolWithShape(sym, local, shape, isDummy);
return;
}
// If object is an array process the lower bound and extent values by
// constructing constants and populating the lbounds and extents.
llvm::SmallVector<mlir::Value> extents;
llvm::SmallVector<mlir::Value> lbounds;
for (auto [fst, snd] : llvm::zip(x.lbounds, x.shapes)) {
lbounds.emplace_back(builder.createIntegerConstant(loc, idxTy, fst));
extents.emplace_back(genExtentValue(builder, loc, idxTy, snd));
}
mlir::Value local =
isDummy ? addr
: createNewLocal(converter, loc, var, preAlloc, extents);
assert(isDummy || Fortran::lower::isExplicitShape(sym));
symMap.addSymbolWithBounds(sym, local, extents, lbounds, isDummy);
},
//===--------------------------------------------------------------===//
[&](const Fortran::lower::details::DynamicArray &x) {
// cast to the known constant parts from the declaration
mlir::Type varType = converter.genType(var);
mlir::Value addr = symMap.lookupSymbol(sym).getAddr();
mlir::Value argBox;
mlir::Type castTy = builder.getRefType(varType);
if (addr) {
if (auto boxTy = addr.getType().dyn_cast<fir::BoxType>()) {
argBox = addr;
mlir::Type refTy = builder.getRefType(boxTy.getEleTy());
addr = builder.create<fir::BoxAddrOp>(loc, refTy, argBox);
}
addr = builder.createConvert(loc, castTy, addr);
}
if (x.lboundAllOnes()) {
// if lower bounds are all ones, build simple shaped object
llvm::SmallVector<mlir::Value> shapes;
populateShape(shapes, x.bounds, argBox);
if (isDummy) {
symMap.addSymbolWithShape(sym, addr, shapes, true);
return;
}
// local array with computed bounds
assert(Fortran::lower::isExplicitShape(sym) ||
Fortran::semantics::IsAllocatableOrPointer(sym));
mlir::Value local =
createNewLocal(converter, loc, var, preAlloc, shapes);
symMap.addSymbolWithShape(sym, local, shapes);
return;
}
// if object is an array process the lower bound and extent values
llvm::SmallVector<mlir::Value> extents;
llvm::SmallVector<mlir::Value> lbounds;
populateLBoundsExtents(lbounds, extents, x.bounds, argBox);
if (isDummy) {
symMap.addSymbolWithBounds(sym, addr, extents, lbounds, true);
return;
}
// local array with computed bounds
assert(Fortran::lower::isExplicitShape(sym));
mlir::Value local =
createNewLocal(converter, loc, var, preAlloc, extents);
symMap.addSymbolWithBounds(sym, local, extents, lbounds);
},
//===--------------------------------------------------------------===//
[&](const Fortran::lower::details::StaticArrayStaticChar &x) {
// if element type is a CHARACTER, determine the LEN value
auto charLen = x.charLen();
mlir::Value addr;
mlir::Value len;
if (isDummy) {
Fortran::lower::SymbolBox symBox = symMap.lookupSymbol(sym);
std::pair<mlir::Value, mlir::Value> unboxchar =
charHelp.createUnboxChar(symBox.getAddr());
addr = unboxchar.first;
// Set/override LEN with a constant
len = builder.createIntegerConstant(loc, idxTy, charLen);
} else {
// local CHARACTER variable
len = builder.createIntegerConstant(loc, idxTy, charLen);
}
// object shape is constant
mlir::Type castTy = builder.getRefType(converter.genType(var));
if (addr)
addr = builder.createConvert(loc, castTy, addr);
if (x.lboundAllOnes()) {
// if lower bounds are all ones, build simple shaped object
llvm::SmallVector<mlir::Value> shape;
for (int64_t i : x.shapes)
shape.push_back(genExtentValue(builder, loc, idxTy, i));
mlir::Value local =
isDummy ? addr : createNewLocal(converter, loc, var, preAlloc);
symMap.addCharSymbolWithShape(sym, local, len, shape, isDummy);
return;
}
// if object is an array process the lower bound and extent values
llvm::SmallVector<mlir::Value> extents;
llvm::SmallVector<mlir::Value> lbounds;
// construct constants and populate `bounds`
for (auto [fst, snd] : llvm::zip(x.lbounds, x.shapes)) {
lbounds.emplace_back(builder.createIntegerConstant(loc, idxTy, fst));
extents.emplace_back(genExtentValue(builder, loc, idxTy, snd));
}
if (isDummy) {
symMap.addCharSymbolWithBounds(sym, addr, len, extents, lbounds,
true);
return;
}
// local CHARACTER array with computed bounds
assert(Fortran::lower::isExplicitShape(sym));
mlir::Value local =
createNewLocal(converter, loc, var, preAlloc, extents);
symMap.addCharSymbolWithBounds(sym, local, len, extents, lbounds);
},
//===--------------------------------------------------------------===//
[&](const Fortran::lower::details::StaticArrayDynamicChar &x) {
mlir::Value addr;
mlir::Value len;
[[maybe_unused]] bool mustBeDummy = false;
auto charLen = x.charLen();
// if element type is a CHARACTER, determine the LEN value
if (isDummy) {
Fortran::lower::SymbolBox symBox = symMap.lookupSymbol(sym);
std::pair<mlir::Value, mlir::Value> unboxchar =
charHelp.createUnboxChar(symBox.getAddr());
addr = unboxchar.first;
if (charLen) {
// Set/override LEN with an expression
len = genExplicitCharLen(charLen);
} else {
// LEN is from the boxchar
len = unboxchar.second;
mustBeDummy = true;
}
} else {
// local CHARACTER variable
len = genExplicitCharLen(charLen);
}
llvm::SmallVector<mlir::Value> lengths = {len};
// cast to the known constant parts from the declaration
mlir::Type castTy = builder.getRefType(converter.genType(var));
if (addr)
addr = builder.createConvert(loc, castTy, addr);
if (x.lboundAllOnes()) {
// if lower bounds are all ones, build simple shaped object
llvm::SmallVector<mlir::Value> shape;
for (int64_t i : x.shapes)
shape.push_back(genExtentValue(builder, loc, idxTy, i));
if (isDummy) {
symMap.addCharSymbolWithShape(sym, addr, len, shape, true);
return;
}
// local CHARACTER array with constant size
mlir::Value local = createNewLocal(converter, loc, var, preAlloc,
llvm::None, lengths);
symMap.addCharSymbolWithShape(sym, local, len, shape);
return;
}
// if object is an array process the lower bound and extent values
llvm::SmallVector<mlir::Value> extents;
llvm::SmallVector<mlir::Value> lbounds;
// construct constants and populate `bounds`
for (auto [fst, snd] : llvm::zip(x.lbounds, x.shapes)) {
lbounds.emplace_back(builder.createIntegerConstant(loc, idxTy, fst));
extents.emplace_back(genExtentValue(builder, loc, idxTy, snd));
}
if (isDummy) {
symMap.addCharSymbolWithBounds(sym, addr, len, extents, lbounds,
true);
return;
}
// local CHARACTER array with computed bounds
assert((!mustBeDummy) && (Fortran::lower::isExplicitShape(sym)));
mlir::Value local =
createNewLocal(converter, loc, var, preAlloc, llvm::None, lengths);
symMap.addCharSymbolWithBounds(sym, local, len, extents, lbounds);
},
//===--------------------------------------------------------------===//
[&](const Fortran::lower::details::DynamicArrayStaticChar &x) {
mlir::Value addr;
mlir::Value len;
mlir::Value argBox;
auto charLen = x.charLen();
// if element type is a CHARACTER, determine the LEN value
if (isDummy) {
mlir::Value actualArg = symMap.lookupSymbol(sym).getAddr();
if (auto boxTy = actualArg.getType().dyn_cast<fir::BoxType>()) {
argBox = actualArg;
mlir::Type refTy = builder.getRefType(boxTy.getEleTy());
addr = builder.create<fir::BoxAddrOp>(loc, refTy, argBox);
} else {
addr = charHelp.createUnboxChar(actualArg).first;
}
// Set/override LEN with a constant
len = builder.createIntegerConstant(loc, idxTy, charLen);
} else {
// local CHARACTER variable
len = builder.createIntegerConstant(loc, idxTy, charLen);
}
// cast to the known constant parts from the declaration
mlir::Type castTy = builder.getRefType(converter.genType(var));
if (addr)
addr = builder.createConvert(loc, castTy, addr);
if (x.lboundAllOnes()) {
// if lower bounds are all ones, build simple shaped object
llvm::SmallVector<mlir::Value> shape;
populateShape(shape, x.bounds, argBox);
if (isDummy) {
symMap.addCharSymbolWithShape(sym, addr, len, shape, true);
return;
}
// local CHARACTER array
mlir::Value local =
createNewLocal(converter, loc, var, preAlloc, shape);
symMap.addCharSymbolWithShape(sym, local, len, shape);
return;
}
// if object is an array process the lower bound and extent values
llvm::SmallVector<mlir::Value> extents;
llvm::SmallVector<mlir::Value> lbounds;
populateLBoundsExtents(lbounds, extents, x.bounds, argBox);
if (isDummy) {
symMap.addCharSymbolWithBounds(sym, addr, len, extents, lbounds,
true);
return;
}
// local CHARACTER array with computed bounds
assert(Fortran::lower::isExplicitShape(sym));
mlir::Value local =
createNewLocal(converter, loc, var, preAlloc, extents);
symMap.addCharSymbolWithBounds(sym, local, len, extents, lbounds);
},
//===--------------------------------------------------------------===//
[&](const Fortran::lower::details::DynamicArrayDynamicChar &x) {
mlir::Value addr;
mlir::Value len;
mlir::Value argBox;
auto charLen = x.charLen();
// if element type is a CHARACTER, determine the LEN value
if (isDummy) {
mlir::Value actualArg = symMap.lookupSymbol(sym).getAddr();
if (auto boxTy = actualArg.getType().dyn_cast<fir::BoxType>()) {
argBox = actualArg;
mlir::Type refTy = builder.getRefType(boxTy.getEleTy());
addr = builder.create<fir::BoxAddrOp>(loc, refTy, argBox);
if (charLen)
// Set/override LEN with an expression.
len = genExplicitCharLen(charLen);
else
// Get the length from the actual arguments.
len = charHelp.readLengthFromBox(argBox);
} else {
std::pair<mlir::Value, mlir::Value> unboxchar =
charHelp.createUnboxChar(actualArg);
addr = unboxchar.first;
if (charLen) {
// Set/override LEN with an expression
len = genExplicitCharLen(charLen);
} else {
// Get the length from the actual arguments.
len = unboxchar.second;
}
}
} else {
// local CHARACTER variable
len = genExplicitCharLen(charLen);
}
llvm::SmallVector<mlir::Value> lengths = {len};
// cast to the known constant parts from the declaration
mlir::Type castTy = builder.getRefType(converter.genType(var));
if (addr)
addr = builder.createConvert(loc, castTy, addr);
if (x.lboundAllOnes()) {
// if lower bounds are all ones, build simple shaped object
llvm::SmallVector<mlir::Value> shape;
populateShape(shape, x.bounds, argBox);
if (isDummy) {
symMap.addCharSymbolWithShape(sym, addr, len, shape, true);
return;
}
// local CHARACTER array
mlir::Value local =
createNewLocal(converter, loc, var, preAlloc, shape, lengths);
symMap.addCharSymbolWithShape(sym, local, len, shape);
return;
}
// Process the lower bound and extent values.
llvm::SmallVector<mlir::Value> extents;
llvm::SmallVector<mlir::Value> lbounds;
populateLBoundsExtents(lbounds, extents, x.bounds, argBox);
if (isDummy) {
symMap.addCharSymbolWithBounds(sym, addr, len, extents, lbounds,
true);
return;
}
// local CHARACTER array with computed bounds
assert(Fortran::lower::isExplicitShape(sym));
mlir::Value local =
createNewLocal(converter, loc, var, preAlloc, extents, lengths);
symMap.addCharSymbolWithBounds(sym, local, len, extents, lbounds);
},
//===--------------------------------------------------------------===//
[&](const Fortran::lower::BoxAnalyzer::None &) {
mlir::emitError(loc, "symbol analysis failed on ")
<< toStringRef(sym.name());
});
}
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(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 = Fortran::lower::mangle::mangleName(sym);
defineGlobal(converter, var, globalName, linkage);
}
}
void Fortran::lower::instantiateVariable(AbstractConverter &converter,
const pft::Variable &var,
Fortran::lower::SymMap &symMap,
AggregateStoreMap &storeMap) {
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);
}
}
void Fortran::lower::mapCallInterfaceSymbols(
AbstractConverter &converter, const Fortran::lower::CallerInterface &caller,
SymMap &symMap) {
Fortran::lower::AggregateStoreMap storeMap;
const Fortran::semantics::Symbol &result = caller.getResultSymbol();
for (Fortran::lower::pft::Variable var :
Fortran::lower::pft::buildFuncResultDependencyList(result)) {
if (var.isAggregateStore()) {
instantiateVariable(converter, var, symMap, storeMap);
} else {
const Fortran::semantics::Symbol &sym = var.getSymbol();
const auto *hostDetails =
sym.detailsIf<Fortran::semantics::HostAssocDetails>();
if (hostDetails && !var.isModuleVariable()) {
// 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.
Fortran::lower::SymbolBox hostValue =
symMap.lookupSymbol(hostDetails->symbol());
assert(hostValue && "callee host symbol must be mapped on caller side");
symMap.addSymbol(sym, hostValue.toExtendedValue());
// 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() == result.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::createRuntimeTypeInfoGlobal(
Fortran::lower::AbstractConverter &converter, mlir::Location loc,
const Fortran::semantics::Symbol &typeInfoSym) {
fir::FirOpBuilder &builder = converter.getFirOpBuilder();
std::string globalName = Fortran::lower::mangle::mangleName(typeInfoSym);
auto var = Fortran::lower::pft::Variable(typeInfoSym, /*global=*/true);
mlir::StringAttr linkage = getLinkageAttribute(builder, var);
defineGlobal(converter, var, globalName, linkage);
}
Reference in New Issue View Git Blame Copy Permalink