Google Git Google Git
Sign in
llvm/llvm-project/refs/heads/users/arsenm/codegen/remove-targetoptions-loopalignment/./flang/lib/Lower/Bridge.cpp
blob: c7558806ee241a45f8a55eec13160fcaa0acb95e [file] [edit]
//===-- Bridge.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/Bridge.h"
#include "flang/Evaluate/tools.h"
#include "flang/Lower/Allocatable.h"
#include "flang/Lower/CUDA.h"
#include "flang/Lower/CallInterface.h"
#include "flang/Lower/ConvertCall.h"
#include "flang/Lower/ConvertExprToHLFIR.h"
#include "flang/Lower/ConvertType.h"
#include "flang/Lower/ConvertVariable.h"
#include "flang/Lower/DirectivesCommon.h"
#include "flang/Lower/HostAssociations.h"
#include "flang/Lower/IO.h"
#include "flang/Lower/Mangler.h"
#include "flang/Lower/MultiImageFortran.h"
#include "flang/Lower/OpenACC.h"
#include "flang/Lower/OpenMP.h"
#include "flang/Lower/PFTBuilder.h"
#include "flang/Lower/Runtime.h"
#include "flang/Lower/StatementContext.h"
#include "flang/Lower/Support/LoopAnnotation.h"
#include "flang/Lower/Support/ReductionProcessor.h"
#include "flang/Lower/Support/Utils.h"
#include "flang/Optimizer/Builder/BoxValue.h"
#include "flang/Optimizer/Builder/CUFCommon.h"
#include "flang/Optimizer/Builder/Character.h"
#include "flang/Optimizer/Builder/FIRBuilder.h"
#include "flang/Optimizer/Builder/Runtime/Assign.h"
#include "flang/Optimizer/Builder/Runtime/CUDA/Descriptor.h"
#include "flang/Optimizer/Builder/Runtime/CUDA/Support.h"
#include "flang/Optimizer/Builder/Runtime/Character.h"
#include "flang/Optimizer/Builder/Runtime/Derived.h"
#include "flang/Optimizer/Builder/Runtime/EnvironmentDefaults.h"
#include "flang/Optimizer/Builder/Runtime/Exceptions.h"
#include "flang/Optimizer/Builder/Runtime/Main.h"
#include "flang/Optimizer/Builder/Runtime/Stop.h"
#include "flang/Optimizer/Builder/Todo.h"
#include "flang/Optimizer/Dialect/CUF/Attributes/CUFAttr.h"
#include "flang/Optimizer/Dialect/CUF/CUFOps.h"
#include "flang/Optimizer/Dialect/FIRAttr.h"
#include "flang/Optimizer/Dialect/FIROps.h"
#include "flang/Optimizer/Dialect/Support/FIRContext.h"
#include "flang/Optimizer/HLFIR/HLFIROps.h"
#include "flang/Optimizer/Support/AllocationPolicy.h"
#include "flang/Optimizer/Support/DataLayout.h"
#include "flang/Optimizer/Support/FatalError.h"
#include "flang/Optimizer/Support/InternalNames.h"
#include "flang/Optimizer/Transforms/Passes.h"
#include "flang/Parser/parse-tree.h"
#include "flang/Parser/tools.h"
#include "flang/Runtime/iostat-consts.h"
#include "flang/Semantics/openmp-dsa.h"
#include "flang/Semantics/runtime-type-info.h"
#include "flang/Semantics/symbol.h"
#include "flang/Semantics/tools.h"
#include "flang/Support/Flags.h"
#include "flang/Support/Version.h"
#include "mlir/Dialect/ControlFlow/IR/ControlFlowOps.h"
#include "mlir/Dialect/SCF/IR/SCF.h"
#include "mlir/IR/BuiltinAttributes.h"
#include "mlir/IR/Matchers.h"
#include "mlir/IR/PatternMatch.h"
#include "mlir/Parser/Parser.h"
#include "mlir/Support/StateStack.h"
#include "mlir/Transforms/RegionUtils.h"
#include "llvm/ADT/ScopeExit.h"
#include "llvm/ADT/SmallVector.h"
#include "llvm/ADT/StringSet.h"
#include "llvm/Support/CommandLine.h"
#include "llvm/Support/Debug.h"
#include "llvm/Support/ErrorHandling.h"
#include "llvm/Support/FileSystem.h"
#include "llvm/Support/Path.h"
#include "llvm/Target/TargetMachine.h"
#include <optional>
#define DEBUG_TYPE "flang-lower-bridge"
static llvm::cl::opt<bool> forceLoopToExecuteOnce(
"always-execute-loop-body", llvm::cl::init(false),
llvm::cl::desc("force the body of a loop to execute at least once"));
namespace {
/// Information for generating a structured or unstructured increment loop.
struct IncrementLoopInfo {
template <typename T>
explicit IncrementLoopInfo(Fortran::semantics::Symbol &sym, const T &lower,
const T &upper, const std::optional<T> &step,
bool isConcurrent = false)
: loopVariableSym{&sym}, lowerExpr{Fortran::semantics::GetExpr(lower)},
upperExpr{Fortran::semantics::GetExpr(upper)},
stepExpr{Fortran::semantics::GetExpr(step)},
isConcurrent{isConcurrent} {}
IncrementLoopInfo(IncrementLoopInfo &&) = default;
IncrementLoopInfo &operator=(IncrementLoopInfo &&x) = default;
bool isStructured() const { return !headerBlock; }
mlir::Type getLoopVariableType() const {
assert(loopVariable && "must be set");
return fir::unwrapRefType(loopVariable.getType());
}
bool hasLocalitySpecs() const {
return !localSymList.empty() || !localInitSymList.empty() ||
!reduceSymList.empty() || !sharedSymList.empty();
}
// Data members common to both structured and unstructured loops.
const Fortran::semantics::Symbol *loopVariableSym;
const Fortran::lower::SomeExpr *lowerExpr;
const Fortran::lower::SomeExpr *upperExpr;
const Fortran::lower::SomeExpr *stepExpr;
const Fortran::lower::SomeExpr *maskExpr = nullptr;
bool isConcurrent;
llvm::SmallVector<const Fortran::semantics::Symbol *> localSymList;
llvm::SmallVector<const Fortran::semantics::Symbol *> localInitSymList;
llvm::SmallVector<const Fortran::semantics::Symbol *> reduceSymList;
llvm::SmallVector<fir::ReduceOperationEnum> reduceOperatorList;
llvm::SmallVector<const Fortran::semantics::Symbol *> sharedSymList;
mlir::Value loopVariable = nullptr;
// Data members for structured loops.
mlir::Operation *loopOp = nullptr;
// Data members for unstructured loops.
bool hasRealControl = false;
mlir::Value tripVariable = nullptr;
mlir::Value stepVariable = nullptr;
mlir::Block *headerBlock = nullptr; // loop entry and test block
mlir::Block *maskBlock = nullptr; // concurrent loop mask block
mlir::Block *bodyBlock = nullptr; // first loop body block
mlir::Block *exitBlock = nullptr; // loop exit target block
};
/// Information to support stack management, object deallocation, and
/// object finalization at early and normal construct exits.
struct ConstructContext {
explicit ConstructContext(Fortran::lower::pft::Evaluation &eval,
Fortran::lower::StatementContext &stmtCtx)
: eval{eval}, stmtCtx{stmtCtx} {}
Fortran::lower::pft::Evaluation &eval; // construct eval
Fortran::lower::StatementContext &stmtCtx; // construct exit code
std::optional<hlfir::Entity> selector; // construct selector, if any.
bool pushedScope = false; // was a scoped pushed for this construct?
};
/// Helper to gather the lower bounds of array components with non deferred
/// shape when they are not all ones. Return an empty array attribute otherwise.
static mlir::DenseI64ArrayAttr
gatherComponentNonDefaultLowerBounds(mlir::Location loc,
mlir::MLIRContext *mlirContext,
const Fortran::semantics::Symbol &sym) {
if (Fortran::semantics::IsAllocatableOrObjectPointer(&sym))
return {};
mlir::DenseI64ArrayAttr lbs_attr;
if (const auto *objDetails =
sym.detailsIf<Fortran::semantics::ObjectEntityDetails>()) {
llvm::SmallVector<std::int64_t> lbs;
bool hasNonDefaultLbs = false;
for (const Fortran::semantics::ShapeSpec &bounds : objDetails->shape())
if (auto lb = bounds.lbound().GetExplicit()) {
if (auto constant = Fortran::evaluate::ToInt64(*lb)) {
hasNonDefaultLbs |= (*constant != 1);
lbs.push_back(*constant);
} else {
TODO(loc, "generate fir.dt_component for length parametrized derived "
"types");
}
}
if (hasNonDefaultLbs) {
assert(static_cast<int>(lbs.size()) == sym.Rank() &&
"expected component bounds to be constant or deferred");
lbs_attr = mlir::DenseI64ArrayAttr::get(mlirContext, lbs);
}
}
return lbs_attr;
}
// Helper class to generate name of fir.global containing component explicit
// default value for objects, and initial procedure target for procedure pointer
// components.
static mlir::FlatSymbolRefAttr gatherComponentInit(
mlir::Location loc, Fortran::lower::AbstractConverter &converter,
const Fortran::semantics::Symbol &sym, fir::RecordType derivedType) {
mlir::MLIRContext *mlirContext = &converter.getMLIRContext();
// Return procedure target mangled name for procedure pointer components.
if (const auto *procPtr =
sym.detailsIf<Fortran::semantics::ProcEntityDetails>()) {
if (std::optional<const Fortran::semantics::Symbol *> maybeInitSym =
procPtr->init()) {
// So far, do not make distinction between p => NULL() and p without init,
// f18 always initialize pointers to NULL anyway.
if (!*maybeInitSym)
return {};
return mlir::FlatSymbolRefAttr::get(mlirContext,
converter.mangleName(**maybeInitSym));
}
}
const auto *objDetails =
sym.detailsIf<Fortran::semantics::ObjectEntityDetails>();
if (!objDetails || !objDetails->init().has_value())
return {};
// Object component initial value. Semantic package component object default
// value into compiler generated symbols that are lowered as read-only
// fir.global. Get the name of this global.
std::string name = fir::NameUniquer::getComponentInitName(
derivedType.getName(), toStringRef(sym.name()));
return mlir::FlatSymbolRefAttr::get(mlirContext, name);
}
/// Emit a single fir.use_stmt from preserved frontend USE metadata.
static void emitUseStmtOp(Fortran::lower::AbstractConverter &converter,
mlir::OpBuilder &builder, mlir::Location loc,
const Fortran::semantics::PreservedUseStmt &stmt,
const Fortran::semantics::Scope &lookupScope) {
mlir::MLIRContext *context = builder.getContext();
mlir::StringAttr moduleNameAttr =
mlir::StringAttr::get(context, stmt.moduleName);
// Helper function to get mangled name for a symbol
auto getMangledName = [&](const std::string &localName) -> std::string {
Fortran::parser::CharBlock charBlock{localName.data(), localName.size()};
const auto *sym = lookupScope.FindSymbol(charBlock);
if (!sym)
return "";
const auto &ultimateSym = sym->GetUltimate();
// Skip cases which can cause mangleName to fail.
if (ultimateSym.has<Fortran::semantics::DerivedTypeDetails>())
return "";
if (ultimateSym.has<Fortran::semantics::UseErrorDetails>())
return "";
if (const auto *generic =
ultimateSym.detailsIf<Fortran::semantics::GenericDetails>()) {
if (!generic->specific())
return "";
}
return converter.mangleName(ultimateSym);
};
llvm::SmallVector<mlir::Attribute> onlySymbolAttrs;
llvm::SmallVector<mlir::Attribute> renameAttrs;
for (const auto &name : stmt.onlyNames) {
std::string mangledName = getMangledName(name);
if (!mangledName.empty())
onlySymbolAttrs.push_back(
mlir::FlatSymbolRefAttr::get(context, mangledName));
}
for (const auto &local : stmt.renames) {
std::string mangledName = getMangledName(local);
if (!mangledName.empty()) {
auto localAttr = mlir::StringAttr::get(context, local);
auto symbolRef = mlir::FlatSymbolRefAttr::get(context, mangledName);
renameAttrs.push_back(
fir::UseRenameAttr::get(context, localAttr, symbolRef));
}
}
mlir::ArrayAttr onlySymbolsAttr =
onlySymbolAttrs.empty() ? mlir::ArrayAttr()
: mlir::ArrayAttr::get(context, onlySymbolAttrs);
mlir::ArrayAttr renamesAttr =
renameAttrs.empty() ? mlir::ArrayAttr()
: mlir::ArrayAttr::get(context, renameAttrs);
mlir::BoolAttr hasOnlyWithRenamesAttr =
mlir::BoolAttr::get(context, stmt.hasOnlyWithRenames);
fir::UseStmtOp::create(builder, loc, moduleNameAttr, onlySymbolsAttr,
renamesAttr, hasOnlyWithRenamesAttr);
}
/// Emit fir.module_debug_imports for USE statements in a module. The operation
/// is emitted for every module, even one with no USE statement, because its
/// location is also what tells AddDebugInfo the line of the MODULE statement.
static void
emitModuleDebugImports(Fortran::lower::AbstractConverter &converter,
mlir::OpBuilder &builder, mlir::Location loc,
const Fortran::lower::pft::ModuleLikeUnit &mod) {
if (!converter.getLoweringOptions().getPreserveUseDebugInfo())
return;
const Fortran::semantics::Scope &modScope = mod.getScope();
const Fortran::semantics::Symbol *modSym = modScope.symbol();
if (!modSym)
return;
mlir::ModuleOp mlirModule = converter.getModuleOp();
mlir::OpBuilder::InsertionGuard guard(builder);
builder.setInsertionPoint(mlirModule.getBody(), mlirModule.getBody()->end());
// A submodule is named after its ancestor module in the debug info, and has
// access to everything in the submodule directly above it, so record both.
mlir::StringAttr ancestorNameAttr;
mlir::StringAttr parentNameAttr;
if (const auto *details{
modSym->detailsIf<Fortran::semantics::ModuleDetails>()};
details && details->isSubmodule()) {
if (const Fortran::semantics::Scope *ancestor{details->ancestor()};
ancestor && ancestor->symbol())
ancestorNameAttr = mlir::StringAttr::get(
builder.getContext(), ancestor->symbol()->name().ToString());
if (const Fortran::semantics::Scope *parent{details->parent()};
parent && parent->symbol())
parentNameAttr = mlir::StringAttr::get(
builder.getContext(), parent->symbol()->name().ToString());
}
auto op = fir::ModuleDebugImportsOp::create(
builder, loc,
mlir::StringAttr::get(builder.getContext(), modSym->name().ToString()),
ancestorNameAttr, parentNameAttr);
mlir::Region &region = op.getUses();
mlir::Block *block = new mlir::Block();
region.push_back(block);
builder.setInsertionPointToStart(block);
for (const auto &stmt : mod.preservedUseStmts)
emitUseStmtOp(converter, builder, loc, stmt, modScope);
fir::FirEndOp::create(builder, loc);
}
/// Emit `fir.use_stmt` operations for USE statements that appear in the given
/// function unit.
static void
emitUseStatementsFromFunit(Fortran::lower::AbstractConverter &converter,
mlir::OpBuilder &builder, mlir::Location loc,
const Fortran::lower::pft::FunctionLikeUnit &funit) {
const Fortran::semantics::Scope &scope = funit.getScope();
for (const auto &preservedStmt : funit.preservedUseStmts)
emitUseStmtOp(converter, builder, loc, preservedStmt, scope);
}
/// Record the submodule that defines a separate module procedure. Its name is
/// mangled with the module that declares its interface, so the submodule would
/// otherwise be lost and its debug info would point at the module instead.
static void setDefiningSubmoduleForDebug(
Fortran::lower::AbstractConverter &converter, mlir::func::FuncOp func,
const Fortran::lower::pft::FunctionLikeUnit &funit) {
// This option is set whenever more than line tables are asked for, which is
// also when a module is described, so it stands in for full debug info here.
if (!converter.getLoweringOptions().getPreserveUseDebugInfo())
return;
const Fortran::semantics::Scope &scope = funit.getScope();
if (!scope.parent().IsSubmodule())
return;
const Fortran::semantics::Symbol *sym = scope.symbol();
if (!sym || !sym->attrs().test(Fortran::semantics::Attr::MODULE))
return;
const Fortran::semantics::Symbol *submodule = scope.parent().symbol();
if (!submodule)
return;
func->setAttr(
fir::getDefiningSubmoduleAttrName(),
mlir::StringAttr::get(func.getContext(), submodule->name().ToString()));
}
/// Helper class to generate the runtime type info global data and the
/// fir.type_info operations that contain the dipatch tables (if any).
/// The type info global data is required to describe the derived type to the
/// runtime so that it can operate over it.
/// It must be ensured these operations will be generated for every derived type
/// lowered in the current translated unit. However, these operations
/// cannot be generated before FuncOp have been created for functions since the
/// initializers may take their address (e.g for type bound procedures). This
/// class allows registering all the required type info while it is not
/// possible to create GlobalOp/TypeInfoOp, and to generate this data afte
/// function lowering.
class TypeInfoConverter {
/// Store the location and symbols of derived type info to be generated.
/// The location of the derived type instantiation is also stored because
/// runtime type descriptor symbols are compiler generated and cannot be
/// mapped to user code on their own.
struct TypeInfo {
Fortran::semantics::SymbolRef symbol;
const Fortran::semantics::DerivedTypeSpec &typeSpec;
fir::RecordType type;
mlir::Location loc;
};
public:
void registerTypeInfo(Fortran::lower::AbstractConverter &converter,
mlir::Location loc,
Fortran::semantics::SymbolRef typeInfoSym,
const Fortran::semantics::DerivedTypeSpec &typeSpec,
fir::RecordType type) {
if (seen.contains(typeInfoSym))
return;
seen.insert(typeInfoSym);
currentTypeInfoStack->emplace_back(
TypeInfo{typeInfoSym, typeSpec, type, loc});
return;
}
void createTypeInfo(Fortran::lower::AbstractConverter &converter) {
createTypeInfoForTypeDescriptorBuiltinType(converter);
while (!registeredTypeInfoA.empty()) {
currentTypeInfoStack = &registeredTypeInfoB;
for (const TypeInfo &info : registeredTypeInfoA)
createTypeInfoOpAndGlobal(converter, info);
registeredTypeInfoA.clear();
currentTypeInfoStack = &registeredTypeInfoA;
for (const TypeInfo &info : registeredTypeInfoB)
createTypeInfoOpAndGlobal(converter, info);
registeredTypeInfoB.clear();
}
}
private:
void createTypeInfoOpAndGlobal(Fortran::lower::AbstractConverter &converter,
const TypeInfo &info) {
if (!converter.getLoweringOptions().getSkipExternalRttiDefinition())
Fortran::lower::createRuntimeTypeInfoGlobal(converter, info.symbol.get());
createTypeInfoOp(converter, info);
}
void createTypeInfoForTypeDescriptorBuiltinType(
Fortran::lower::AbstractConverter &converter) {
if (registeredTypeInfoA.empty())
return;
auto builtinTypeInfoType = llvm::cast<fir::RecordType>(
converter.genType(registeredTypeInfoA[0].symbol.get()));
converter.getFirOpBuilder().createTypeInfoOp(
registeredTypeInfoA[0].loc, builtinTypeInfoType,
/*parentType=*/fir::RecordType{});
}
void createTypeInfoOp(Fortran::lower::AbstractConverter &converter,
const TypeInfo &info) {
fir::RecordType parentType{};
if (const Fortran::semantics::DerivedTypeSpec *parent =
Fortran::evaluate::GetParentTypeSpec(info.typeSpec))
parentType = mlir::cast<fir::RecordType>(converter.genType(*parent));
fir::FirOpBuilder &builder = converter.getFirOpBuilder();
fir::TypeInfoOp dt;
mlir::OpBuilder::InsertPoint insertPointIfCreated;
std::tie(dt, insertPointIfCreated) =
builder.createTypeInfoOp(info.loc, info.type, parentType);
if (!insertPointIfCreated.isSet())
return; // fir.type_info was already built in a previous call.
// Set abstract, init, destroy, and nofinal attributes.
const Fortran::semantics::Symbol &dtSymbol = info.typeSpec.typeSymbol();
if (dtSymbol.attrs().test(Fortran::semantics::Attr::ABSTRACT))
dt->setAttr(dt.getAbstractAttrName(), builder.getUnitAttr());
if (!info.typeSpec.HasDefaultInitialization(/*ignoreAllocatable=*/false,
/*ignorePointer=*/false))
dt->setAttr(dt.getNoInitAttrName(), builder.getUnitAttr());
if (!info.typeSpec.HasDestruction())
dt->setAttr(dt.getNoDestroyAttrName(), builder.getUnitAttr());
if (!Fortran::semantics::MayRequireFinalization(info.typeSpec))
dt->setAttr(dt.getNoFinalAttrName(), builder.getUnitAttr());
const Fortran::semantics::Scope &derivedScope =
DEREF(info.typeSpec.GetScope());
// Fill binding table region if the derived type has bindings.
Fortran::semantics::SymbolVector bindings =
Fortran::semantics::CollectBindings(derivedScope);
if (!bindings.empty()) {
builder.createBlock(&dt.getDispatchTable());
for (const Fortran::semantics::SymbolRef &binding : bindings) {
const auto &details =
binding.get().get<Fortran::semantics::ProcBindingDetails>();
std::string tbpName = binding.get().name().ToString();
if (details.numPrivatesNotOverridden() > 0)
tbpName += "."s + std::to_string(details.numPrivatesNotOverridden());
std::string bindingName = converter.mangleName(details.symbol());
auto dtEntry = fir::DTEntryOp::create(
builder, info.loc,
mlir::StringAttr::get(builder.getContext(), tbpName),
mlir::SymbolRefAttr::get(builder.getContext(), bindingName));
// Propagate DEFERRED attribute on the binding to fir.dt_entry.
if (binding.get().attrs().test(Fortran::semantics::Attr::DEFERRED))
dtEntry->setAttr(fir::DTEntryOp::getDeferredAttrNameStr(),
builder.getUnitAttr());
}
fir::FirEndOp::create(builder, info.loc);
}
// Gather info about components that is not reflected in fir.type and may be
// needed later: component initial values and array component non default
// lower bounds.
mlir::Block *componentInfo = nullptr;
for (const auto &componentName :
info.typeSpec.typeSymbol()
.get<Fortran::semantics::DerivedTypeDetails>()
.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();
mlir::FlatSymbolRefAttr init_val =
gatherComponentInit(info.loc, converter, component, info.type);
mlir::DenseI64ArrayAttr lbs = gatherComponentNonDefaultLowerBounds(
info.loc, builder.getContext(), component);
if (init_val || lbs) {
if (!componentInfo)
componentInfo = builder.createBlock(&dt.getComponentInfo());
auto compName = mlir::StringAttr::get(builder.getContext(),
toStringRef(component.name()));
fir::DTComponentOp::create(builder, info.loc, compName, lbs, init_val);
}
}
if (componentInfo)
fir::FirEndOp::create(builder, info.loc);
builder.restoreInsertionPoint(insertPointIfCreated);
}
/// Store the front-end data that will be required to generate the type info
/// for the derived types that have been converted to fir.type<>. There are
/// two stacks since the type info may visit new types, so the new types must
/// be added to a new stack.
llvm::SmallVector<TypeInfo> registeredTypeInfoA;
llvm::SmallVector<TypeInfo> registeredTypeInfoB;
llvm::SmallVector<TypeInfo> *currentTypeInfoStack = &registeredTypeInfoA;
/// Track symbols symbols processed during and after the registration
/// to avoid infinite loops between type conversions and global variable
/// creation.
llvm::SmallSetVector<Fortran::semantics::SymbolRef, 32> seen;
};
using IncrementLoopNestInfo = llvm::SmallVector<IncrementLoopInfo, 8>;
} // namespace
//===----------------------------------------------------------------------===//
// FirConverter
//===----------------------------------------------------------------------===//
namespace {
/// Traverse the pre-FIR tree (PFT) to generate the FIR dialect of MLIR.
class FirConverter : public Fortran::lower::AbstractConverter {
public:
explicit FirConverter(Fortran::lower::LoweringBridge &bridge)
: Fortran::lower::AbstractConverter(bridge.getLoweringOptions()),
bridge{bridge}, foldingContext{bridge.createFoldingContext()},
mlirSymbolTable{bridge.getModule()} {}
virtual ~FirConverter() = default;
/// Convert the PFT to FIR.
void run(Fortran::lower::pft::Program &pft) {
// Preliminary translation pass.
// Lower common blocks, taking into account initialization and the largest
// size of all instances of each common block. This is done before lowering
// since the global definition may differ from any one local definition.
lowerCommonBlocks(pft.getCommonBlocks());
// - Declare all functions that have definitions so that definition
// signatures prevail over call site signatures.
// - Module variables are lowered once all the function declarations are
// available.
bool hasMainProgram = false;
Fortran::parser::CharBlock mainProgramPosition{};
llvm::SmallVector<const Fortran::semantics::Symbol *>
globalOmpRequiresSymbols;
createBuilderOutsideOfFuncOpAndDo([&]() {
for (Fortran::lower::pft::Program::Units &u : pft.getUnits()) {
Fortran::common::visit(
Fortran::common::visitors{
[&](Fortran::lower::pft::FunctionLikeUnit &f) {
if (f.isMainProgram()) {
hasMainProgram = true;
mainProgramPosition = f.getStartingSourceLoc();
}
declareFunction(f);
globalOmpRequiresSymbols.push_back(f.getScope().symbol());
},
[&](Fortran::lower::pft::ModuleLikeUnit &m) {
for (Fortran::lower::pft::ContainedUnit &unit :
m.containedUnitList)
if (auto *f =
std::get_if<Fortran::lower::pft::FunctionLikeUnit>(
&unit)) {
declareFunction(*f);
globalOmpRequiresSymbols.push_back(
f->getScope().symbol());
}
globalOmpRequiresSymbols.push_back(m.getScope().symbol());
},
[&](Fortran::lower::pft::BlockDataUnit &b) {
globalOmpRequiresSymbols.push_back(b.symTab.symbol());
},
[&](Fortran::lower::pft::CompilerDirectiveUnit &d) {},
[&](Fortran::lower::pft::OpenACCDirectiveUnit &d) {},
},
u);
}
});
// Lower module declaration scopes now that all function
// declarations are available with their final signatures.
createBuilderOutsideOfFuncOpAndDo([&]() {
for (Fortran::lower::pft::Program::Units &u : pft.getUnits()) {
if (auto *m = std::get_if<Fortran::lower::pft::ModuleLikeUnit>(&u))
lowerModuleDeclScope(*m);
}
});
// Ensure imported OpenMP declare mappers are materialized at module
// scope before lowering any constructs that may reference them.
createBuilderOutsideOfFuncOpAndDo([&]() {
Fortran::lower::materializeOpenMPDeclareMappers(
*this, bridge.getSemanticsContext());
});
// Create definitions of intrinsic module constants.
createBuilderOutsideOfFuncOpAndDo(
[&]() { createIntrinsicModuleDefinitions(pft); });
// Primary translation pass.
for (Fortran::lower::pft::Program::Units &u : pft.getUnits()) {
Fortran::common::visit(
Fortran::common::visitors{
[&](Fortran::lower::pft::FunctionLikeUnit &f) { lowerFunc(f); },
[&](Fortran::lower::pft::ModuleLikeUnit &m) { lowerMod(m); },
[&](Fortran::lower::pft::BlockDataUnit &b) {},
[&](Fortran::lower::pft::CompilerDirectiveUnit &d) {},
[&](Fortran::lower::pft::OpenACCDirectiveUnit &d) {},
},
u);
}
// Declare any `acc routine` bind(name) targets not otherwise declared, so a
// live symbol exists for later passes. No-op for targets already lowered in
// this unit.
if (getFoldingContext().languageFeatures().IsEnabled(
Fortran::common::LanguageFeature::OpenACC))
createBuilderOutsideOfFuncOpAndDo([&]() {
Fortran::lower::materializeOpenACCRoutineBindTargets(*this,
getModuleOp());
});
// Once all the code has been translated, create global runtime type info
// data structures for the derived types that have been processed, as well
// as fir.type_info operations for the dispatch tables.
createBuilderOutsideOfFuncOpAndDo(
[&]() { typeInfoConverter.createTypeInfo(*this); });
// Generate the `main` entry point if necessary
if (hasMainProgram)
createBuilderOutsideOfFuncOpAndDo([&]() {
// Lowering has walked every unit, so the current position is the END
// statement of the last one. Reset it to the main program's start.
setCurrentPosition(mainProgramPosition);
fir::runtime::genMain(
*builder, toLocation(), bridge.getEnvironmentDefaults(),
(getFoldingContext().languageFeatures().IsEnabled(
Fortran::common::LanguageFeature::CUDA) &&
getFoldingContext().languageFeatures().IsEnabled(
Fortran::common::LanguageFeature::CUDAInit)),
getFoldingContext().languageFeatures().IsEnabled(
Fortran::common::LanguageFeature::Coarray),
bridge.getLoweringOptions().getFPExceptionTraps());
});
// Marking of OpenMP declare target functions and globals imported
// from a module file needs to happen after the primary
// translation pass has run, because that is where the ops that
// need marking are created.
createBuilderOutsideOfFuncOpAndDo([&]() {
Fortran::lower::markOpenMPImportedDeclareTargets(
*this, bridge.getSemanticsContext());
});
finalizeOpenMPLowering(globalOmpRequiresSymbols);
}
/// Declare a function.
void declareFunction(Fortran::lower::pft::FunctionLikeUnit &funit) {
CHECK(builder && "declareFunction called with uninitialized builder");
setCurrentPosition(funit.getStartingSourceLoc());
for (int entryIndex = 0, last = funit.entryPointList.size();
entryIndex < last; ++entryIndex) {
funit.setActiveEntry(entryIndex);
// Calling CalleeInterface ctor will build a declaration
// mlir::func::FuncOp with no other side effects.
// TODO: when doing some compiler profiling on real apps, it may be worth
// to check it's better to save the CalleeInterface instead of recomputing
// it later when lowering the body. CalleeInterface ctor should be linear
// with the number of arguments, so it is not awful to do it that way for
// now, but the linear coefficient might be non negligible. Until
// measured, stick to the solution that impacts the code less.
Fortran::lower::CalleeInterface{funit, *this};
}
funit.setActiveEntry(0);
// Compute the set of host associated entities from the nested functions.
llvm::SetVector<const Fortran::semantics::Symbol *> escapeHost;
for (Fortran::lower::pft::ContainedUnit &unit : funit.containedUnitList)
if (auto *f = std::get_if<Fortran::lower::pft::FunctionLikeUnit>(&unit))
collectHostAssociatedVariables(*f, escapeHost);
funit.setHostAssociatedSymbols(escapeHost);
// Declare internal procedures
for (Fortran::lower::pft::ContainedUnit &unit : funit.containedUnitList)
if (auto *f = std::get_if<Fortran::lower::pft::FunctionLikeUnit>(&unit))
declareFunction(*f);
}
/// Get the scope that is defining or using \p sym. The returned scope is not
/// the ultimate scope, since this helper does not traverse use association.
/// This allows capturing module variables that are referenced in an internal
/// procedure but whose use statement is inside the host program.
const Fortran::semantics::Scope &
getSymbolHostScope(const Fortran::semantics::Symbol &sym) {
const Fortran::semantics::Symbol *hostSymbol = &sym;
while (const auto *details =
hostSymbol->detailsIf<Fortran::semantics::HostAssocDetails>())
hostSymbol = &details->symbol();
return hostSymbol->owner();
}
/// Collects the canonical list of all host associated symbols. These bindings
/// must be aggregated into a tuple which can then be added to each of the
/// internal procedure declarations and passed at each call site.
void collectHostAssociatedVariables(
Fortran::lower::pft::FunctionLikeUnit &funit,
llvm::SetVector<const Fortran::semantics::Symbol *> &escapees) {
const Fortran::semantics::Scope *internalScope =
funit.getSubprogramSymbol().scope();
assert(internalScope && "internal procedures symbol must create a scope");
auto addToListIfEscapee = [&](const Fortran::semantics::Symbol &sym) {
const Fortran::semantics::Symbol &ultimate = sym.GetUltimate();
const auto *namelistDetails =
ultimate.detailsIf<Fortran::semantics::NamelistDetails>();
if (ultimate.has<Fortran::semantics::ObjectEntityDetails>() ||
Fortran::semantics::IsProcedurePointer(ultimate) ||
Fortran::semantics::IsDummy(sym) || namelistDetails) {
const Fortran::semantics::Scope &symbolScope = getSymbolHostScope(sym);
if (symbolScope.kind() ==
Fortran::semantics::Scope::Kind::MainProgram ||
symbolScope.kind() == Fortran::semantics::Scope::Kind::Subprogram)
if (symbolScope != *internalScope &&
symbolScope.Contains(*internalScope)) {
if (namelistDetails) {
// So far, namelist symbols are processed on the fly in IO and
// the related namelist data structure is not added to the symbol
// map, so it cannot be passed to the internal procedures.
// Instead, all the symbols of the host namelist used in the
// internal procedure must be considered as host associated so
// that IO lowering can find them when needed.
for (const auto &namelistObject : namelistDetails->objects())
escapees.insert(&*namelistObject);
} else {
escapees.insert(&ultimate);
}
}
}
};
Fortran::lower::pft::visitAllSymbols(funit, addToListIfEscapee);
}
//===--------------------------------------------------------------------===//
// AbstractConverter overrides
//===--------------------------------------------------------------------===//
mlir::Value getSymbolAddress(Fortran::lower::SymbolRef sym) override final {
return lookupSymbol(sym).getAddr();
}
fir::ExtendedValue symBoxToExtendedValue(
const Fortran::lower::SymbolBox &symBox) override final {
return symBox.match(
[](const Fortran::lower::SymbolBox::Intrinsic &box)
-> fir::ExtendedValue { return box.getAddr(); },
[](const Fortran::lower::SymbolBox::None &) -> fir::ExtendedValue {
llvm::report_fatal_error("symbol not mapped");
},
[&](const fir::FortranVariableOpInterface &x) -> fir::ExtendedValue {
return hlfir::translateToExtendedValue(getCurrentLocation(),
getFirOpBuilder(), x);
},
[](const auto &box) -> fir::ExtendedValue { return box; });
}
fir::ExtendedValue
getSymbolExtendedValue(const Fortran::semantics::Symbol &sym,
Fortran::lower::SymMap *symMap) override final {
Fortran::lower::SymbolBox sb = lookupSymbol(sym, symMap);
if (!sb) {
LLVM_DEBUG(llvm::dbgs() << "unknown symbol: " << sym << "\nmap: "
<< (symMap ? *symMap : localSymbols) << '\n');
fir::emitFatalError(getCurrentLocation(),
"symbol is not mapped to any IR value");
}
return symBoxToExtendedValue(sb);
}
mlir::Value impliedDoBinding(llvm::StringRef name) override final {
mlir::Value val = localSymbols.lookupImpliedDo(name);
if (!val)
fir::emitFatalError(toLocation(), "ac-do-variable has no binding");
return val;
}
void copySymbolBinding(Fortran::lower::SymbolRef src,
Fortran::lower::SymbolRef target) override final {
localSymbols.copySymbolBinding(src, target);
}
/// Add the symbol binding to the inner-most level of the symbol map and
/// return true if it is not already present. Otherwise, return false.
bool bindIfNewSymbol(Fortran::lower::SymbolRef sym,
const fir::ExtendedValue &exval) {
if (shallowLookupSymbol(sym))
return false;
bindSymbol(sym, exval);
return true;
}
void bindSymbol(Fortran::lower::SymbolRef sym,
const fir::ExtendedValue &exval) override final {
addSymbol(sym, exval, /*forced=*/true);
}
void bindSymbolStorage(
Fortran::lower::SymbolRef sym,
Fortran::lower::SymMap::StorageDesc storage) override final {
localSymbols.registerStorage(sym, std::move(storage));
}
Fortran::lower::SymMap::StorageDesc
getSymbolStorage(Fortran::lower::SymbolRef sym) override final {
return localSymbols.lookupStorage(sym);
}
Fortran::lower::SymMap &getSymbolMap() override final { return localSymbols; }
void
overrideExprValues(const Fortran::lower::ExprToValueMap *map) override final {
exprValueOverrides = map;
}
const Fortran::lower::ExprToValueMap *getExprOverrides() override final {
return exprValueOverrides;
}
bool lookupLabelSet(Fortran::lower::SymbolRef sym,
Fortran::lower::pft::LabelSet &labelSet) override final {
Fortran::lower::pft::FunctionLikeUnit &owningProc =
*getEval().getOwningProcedure();
auto iter = owningProc.assignSymbolLabelMap.find(sym);
if (iter == owningProc.assignSymbolLabelMap.end())
return false;
labelSet = iter->second;
return true;
}
Fortran::lower::pft::Evaluation *
lookupLabel(Fortran::lower::pft::Label label) override final {
Fortran::lower::pft::FunctionLikeUnit &owningProc =
*getEval().getOwningProcedure();
return owningProc.labelEvaluationMap.lookup(label);
}
fir::ExtendedValue
genExprAddr(const Fortran::lower::SomeExpr &expr,
Fortran::lower::StatementContext &context,
mlir::Location *locPtr = nullptr) override final {
mlir::Location loc = locPtr ? *locPtr : toLocation();
auto coarrayRef = Fortran::evaluate::ExtractCoarrayRef(expr);
if (coarrayRef.has_value())
TODO(loc, "coarray: genExprAddr of coarray reference.");
return Fortran::lower::convertExprToAddress(loc, *this, expr, localSymbols,
context);
}
fir::ExtendedValue
genExprValue(const Fortran::lower::SomeExpr &expr,
Fortran::lower::StatementContext &context,
mlir::Location *locPtr = nullptr) override final {
mlir::Location loc = locPtr ? *locPtr : toLocation();
auto coarrayRef = Fortran::evaluate::ExtractCoarrayRef(expr);
if (coarrayRef.has_value())
TODO(loc, "coarray: genExprValue of coarray reference.");
return Fortran::lower::convertExprToValue(loc, *this, expr, localSymbols,
context);
}
fir::ExtendedValue
genExprBox(mlir::Location loc, const Fortran::lower::SomeExpr &expr,
Fortran::lower::StatementContext &stmtCtx) override final {
auto coarrayRef = Fortran::evaluate::ExtractCoarrayRef(expr);
if (coarrayRef.has_value())
TODO(loc, "coarray: genExprBox of coarray reference.");
return Fortran::lower::convertExprToBox(loc, *this, expr, localSymbols,
stmtCtx);
}
Fortran::evaluate::FoldingContext &getFoldingContext() override final {
return foldingContext;
}
mlir::Type genType(const Fortran::lower::SomeExpr &expr) override final {
return Fortran::lower::translateSomeExprToFIRType(*this, expr);
}
mlir::Type genType(const Fortran::lower::pft::Variable &var) override final {
return Fortran::lower::translateVariableToFIRType(*this, var);
}
mlir::Type genType(Fortran::lower::SymbolRef sym) override final {
return Fortran::lower::translateSymbolToFIRType(*this, sym);
}
mlir::Type
genType(Fortran::common::TypeCategory tc, int kind,
llvm::ArrayRef<std::int64_t> lenParameters) override final {
return Fortran::lower::getFIRType(&getMLIRContext(), tc, kind,
lenParameters);
}
mlir::Type
genType(const Fortran::semantics::DerivedTypeSpec &tySpec) override final {
return Fortran::lower::translateDerivedTypeToFIRType(*this, tySpec);
}
mlir::Type genType(Fortran::common::TypeCategory tc) override final {
return Fortran::lower::getFIRType(
&getMLIRContext(), tc, bridge.getDefaultKinds().GetDefaultKind(tc), {});
}
Fortran::lower::TypeConstructionStack &
getTypeConstructionStack() override final {
return typeConstructionStack;
}
bool
isPresentShallowLookup(const Fortran::semantics::Symbol &sym) override final {
return bool(shallowLookupSymbol(sym));
}
bool createHostAssociateVarClone(const Fortran::semantics::Symbol &sym,
bool skipDefaultInit) override final {
mlir::Location loc = genLocation(sym.name());
mlir::Type symType = genType(sym);
const auto *details = sym.detailsIf<Fortran::semantics::HostAssocDetails>();
assert(details && "No host-association found");
const Fortran::semantics::Symbol &hsym = details->symbol();
mlir::Type hSymType = genType(hsym.GetUltimate());
Fortran::lower::SymbolBox hsb =
lookupSymbol(hsym, /*symMap=*/nullptr, /*forceHlfirBase=*/true);
auto allocate = [&](llvm::ArrayRef<mlir::Value> shape,
llvm::ArrayRef<mlir::Value> typeParams) -> mlir::Value {
mlir::Value allocVal = builder->allocateLocal(
loc,
Fortran::semantics::IsAllocatableOrObjectPointer(&hsym.GetUltimate())
? hSymType
: symType,
mangleName(sym), toStringRef(sym.GetUltimate().name()),
/*pinned=*/true, shape, typeParams,
sym.GetUltimate().attrs().test(Fortran::semantics::Attr::TARGET));
return allocVal;
};
fir::ExtendedValue hexv = symBoxToExtendedValue(hsb);
fir::ExtendedValue exv = hexv.match(
[&](const fir::BoxValue &box) -> fir::ExtendedValue {
const Fortran::semantics::DeclTypeSpec *type = sym.GetType();
if (type && type->IsPolymorphic())
TODO(loc, "create polymorphic host associated copy");
// Create a contiguous temp with the same shape and length as
// the original variable described by a fir.box.
llvm::SmallVector<mlir::Value> extents =
fir::factory::getExtents(loc, *builder, hexv);
if (box.isDerivedWithLenParameters())
TODO(loc, "get length parameters from derived type BoxValue");
if (box.isCharacter()) {
mlir::Value len = fir::factory::readCharLen(*builder, loc, box);
mlir::Value temp = allocate(extents, {len});
return fir::CharArrayBoxValue{temp, len, extents};
}
return fir::ArrayBoxValue{allocate(extents, {}), extents};
},
[&](const fir::MutableBoxValue &box) -> fir::ExtendedValue {
// Allocate storage for a pointer/allocatble descriptor.
// No shape/lengths to be passed to the alloca.
return fir::MutableBoxValue(allocate({}, {}), {}, {});
},
[&](const auto &) -> fir::ExtendedValue {
mlir::Value temp =
allocate(fir::factory::getExtents(loc, *builder, hexv),
fir::factory::getTypeParams(loc, *builder, hexv));
return fir::substBase(hexv, temp);
});
// Initialise cloned allocatable
hexv.match(
[&](const fir::MutableBoxValue &box) -> void {
const auto new_box = exv.getBoxOf<fir::MutableBoxValue>();
if (Fortran::semantics::IsPointer(sym.GetUltimate())) {
// Establish the pointer descriptors. The rank and type code/size
// at least must be set properly for later inquiry of the pointer
// to work, and new pointers are always given disassociated status
// by flang for safety, even if this is not required by the
// language.
auto empty = fir::factory::createUnallocatedBox(
*builder, loc, new_box->getBoxTy(), box.nonDeferredLenParams(),
{});
fir::StoreOp::create(*builder, loc, empty, new_box->getAddr());
return;
}
// Copy allocation status of Allocatables, creating new storage if
// needed.
// allocate if allocated
mlir::Value isAllocated =
fir::factory::genIsAllocatedOrAssociatedTest(*builder, loc, box);
auto if_builder = builder->genIfThenElse(loc, isAllocated);
if_builder.genThen([&]() {
std::string name = mangleName(sym) + ".alloc";
fir::ExtendedValue read = fir::factory::genMutableBoxRead(
*builder, loc, box, /*mayBePolymorphic=*/false);
if (auto read_arr_box = read.getBoxOf<fir::ArrayBoxValue>()) {
fir::factory::genInlinedAllocation(*builder, loc, *new_box,
read_arr_box->getLBounds(),
read_arr_box->getExtents(),
/*lenParams=*/{}, name,
/*mustBeHeap=*/true);
} else if (auto read_char_arr_box =
read.getBoxOf<fir::CharArrayBoxValue>()) {
fir::factory::genInlinedAllocation(
*builder, loc, *new_box, read_char_arr_box->getLBounds(),
read_char_arr_box->getExtents(), read_char_arr_box->getLen(),
name,
/*mustBeHeap=*/true);
} else if (auto read_char_box =
read.getBoxOf<fir::CharBoxValue>()) {
fir::factory::genInlinedAllocation(*builder, loc, *new_box,
/*lbounds=*/{},
/*extents=*/{},
read_char_box->getLen(), name,
/*mustBeHeap=*/true);
} else {
fir::factory::genInlinedAllocation(
*builder, loc, *new_box, box.getMutableProperties().lbounds,
box.getMutableProperties().extents,
box.nonDeferredLenParams(), name,
/*mustBeHeap=*/true);
}
});
if_builder.genElse([&]() {
// nullify box
auto empty = fir::factory::createUnallocatedBox(
*builder, loc, new_box->getBoxTy(),
new_box->nonDeferredLenParams(), {});
fir::StoreOp::create(*builder, loc, empty, new_box->getAddr());
});
if_builder.end();
},
[&](const auto &) -> void {
// Always initialize allocatable component descriptor, even when the
// value is later copied from the host (e.g. firstprivate) because the
// assignment from the host to the copy will fail if the component
// descriptors are not initialized.
if (skipDefaultInit && !hlfir::mayHaveAllocatableComponent(hSymType))
return;
// Initialize local/private derived types with default
// initialization (Fortran 2023 section 11.1.7.5 and OpenMP 5.2
// section 5.3). Pointer and allocatable components, when allowed,
// also need to be established so that flang runtime can later work
// with them.
if (const Fortran::semantics::DeclTypeSpec *declTypeSpec =
sym.GetType())
if (const Fortran::semantics::DerivedTypeSpec *derivedTypeSpec =
declTypeSpec->AsDerived())
if (derivedTypeSpec->HasDefaultInitialization(
/*ignoreAllocatable=*/false, /*ignorePointer=*/false)) {
mlir::Value box = builder->createBox(loc, exv);
fir::runtime::genDerivedTypeInitialize(*builder, loc, box);
}
});
return bindIfNewSymbol(sym, exv);
}
void createHostAssociateVarCloneDealloc(
const Fortran::semantics::Symbol &sym) override final {
mlir::Location loc = genLocation(sym.name());
Fortran::lower::SymbolBox hsb =
lookupSymbol(sym, /*symMap=*/nullptr, /*forceHlfirBase=*/true);
fir::ExtendedValue hexv = symBoxToExtendedValue(hsb);
hexv.match(
[&](const fir::MutableBoxValue &new_box) -> void {
// Do not process pointers
if (Fortran::semantics::IsPointer(sym.GetUltimate())) {
return;
}
// deallocate allocated in createHostAssociateVarClone value
Fortran::lower::genDeallocateIfAllocated(*this, new_box, loc);
},
[&](const auto &) -> void {
// Do nothing
});
}
void copyVar(mlir::Location loc, mlir::Value dst, mlir::Value src,
fir::FortranVariableFlagsEnum attrs) override final {
bool isAllocatable =
bitEnumContainsAny(attrs, fir::FortranVariableFlagsEnum::allocatable);
bool isPointer =
bitEnumContainsAny(attrs, fir::FortranVariableFlagsEnum::pointer);
copyVarHLFIR(loc, Fortran::lower::SymbolBox::Intrinsic{dst},
Fortran::lower::SymbolBox::Intrinsic{src}, isAllocatable,
isPointer, Fortran::semantics::Symbol::Flags());
}
void
copyHostAssociateVar(const Fortran::semantics::Symbol &sym,
mlir::OpBuilder::InsertPoint *copyAssignIP = nullptr,
bool hostIsSource = true) override final {
// 1) Fetch the original copy of the variable.
assert(sym.has<Fortran::semantics::HostAssocDetails>() &&
"No host-association found");
const Fortran::semantics::Symbol &hsym = sym.GetUltimate();
Fortran::lower::SymbolBox hsb = lookupOneLevelUpSymbol(hsym);
assert(hsb && "Host symbol box not found");
// 2) Fetch the copied one that will mask the original.
Fortran::lower::SymbolBox sb = shallowLookupSymbol(sym);
assert(sb && "Host-associated symbol box not found");
assert(hsb.getAddr() != sb.getAddr() &&
"Host and associated symbol boxes are the same");
// 3) Perform the assignment.
mlir::OpBuilder::InsertionGuard guard(*builder);
if (copyAssignIP && copyAssignIP->isSet())
builder->restoreInsertionPoint(*copyAssignIP);
else
builder->setInsertionPointAfter(sb.getAddr().getDefiningOp());
Fortran::lower::SymbolBox *lhs_sb, *rhs_sb;
if (!hostIsSource) {
lhs_sb = &hsb;
rhs_sb = &sb;
} else {
lhs_sb = &sb;
rhs_sb = &hsb;
}
copyVar(sym, *lhs_sb, *rhs_sb, sym.flags());
}
void genEval(Fortran::lower::pft::Evaluation &eval,
bool unstructuredContext) override final {
genFIR(eval, unstructuredContext);
}
//===--------------------------------------------------------------------===//
// Utility methods
//===--------------------------------------------------------------------===//
void collectSymbolSet(
Fortran::lower::pft::Evaluation &eval,
llvm::SetVector<const Fortran::semantics::Symbol *> &symbolSet,
Fortran::semantics::Symbol::Flag flag, bool collectSymbols,
bool checkHostAssociatedSymbols) override final {
auto addToList = [&](const Fortran::semantics::Symbol &sym) {
std::function<void(const Fortran::semantics::Symbol &, bool)>
insertSymbols = [&](const Fortran::semantics::Symbol &oriSymbol,
bool collectSymbol) {
if (collectSymbol && oriSymbol.test(flag)) {
symbolSet.insert(&oriSymbol);
} else if (const auto *commonDetails =
oriSymbol.detailsIf<
Fortran::semantics::CommonBlockDetails>()) {
for (const auto &mem : commonDetails->objects())
if (collectSymbol && mem->test(flag))
symbolSet.insert(&(*mem).GetUltimate());
} else if (checkHostAssociatedSymbols) {
if (const auto *details{
oriSymbol
.detailsIf<Fortran::semantics::HostAssocDetails>()})
insertSymbols(details->symbol(), true);
}
};
insertSymbols(sym, collectSymbols);
};
Fortran::lower::pft::visitAllSymbols(eval, addToList);
}
mlir::Location getCurrentLocation() override final { return toLocation(); }
/// Generate a dummy location.
mlir::Location genUnknownLocation() override final {
// Note: builder may not be instantiated yet
return mlir::UnknownLoc::get(&getMLIRContext());
}
static mlir::Location genLocation(Fortran::parser::SourcePosition pos,
mlir::MLIRContext &ctx) {
llvm::SmallString<256> path(*pos.path);
// Preserve the file path as it was presented on the command line (matching
// Clang): relative paths stay relative and absolute paths stay absolute.
// Only normalize '.' components; do not force the path to be absolute.
llvm::sys::path::remove_dots(path);
return mlir::FileLineColLoc::get(&ctx, path.str(), pos.line, pos.column);
}
/// Generate a `Location` from the `CharBlock`.
mlir::Location
genLocation(const Fortran::parser::CharBlock &block) override final {
mlir::Location mainLocation = genUnknownLocation();
if (const Fortran::parser::AllCookedSources *cooked =
bridge.getCookedSource()) {
if (std::optional<Fortran::parser::ProvenanceRange> provenance =
cooked->GetProvenanceRange(block)) {
if (std::optional<Fortran::parser::SourcePosition> filePos =
cooked->allSources().GetSourcePosition(provenance->start()))
mainLocation = genLocation(*filePos, getMLIRContext());
llvm::SmallVector<mlir::Location> locs;
locs.push_back(mainLocation);
llvm::SmallVector<fir::LocationKindAttr> locAttrs;
locAttrs.push_back(fir::LocationKindAttr::get(&getMLIRContext(),
fir::LocationKind::Base));
// Gather include location information if any.
std::optional<Fortran::parser::ProvenanceRange> prov = provenance;
while (prov) {
if (std::optional<Fortran::parser::ProvenanceRange> include =
cooked->allSources().GetInclusionInfo(*prov)) {
if (std::optional<Fortran::parser::SourcePosition> incPos =
cooked->allSources().GetSourcePosition(include->start())) {
locs.push_back(genLocation(*incPos, getMLIRContext()));
locAttrs.push_back(fir::LocationKindAttr::get(
&getMLIRContext(), fir::LocationKind::Inclusion));
}
prov = include;
} else {
prov.reset();
}
}
if (locs.size() > 1) {
assert(locs.size() == locAttrs.size() &&
"expect as many attributes as locations");
return mlir::FusedLocWith<fir::LocationKindArrayAttr>::get(
&getMLIRContext(), locs,
fir::LocationKindArrayAttr::get(&getMLIRContext(), locAttrs));
}
}
}
return mainLocation;
}
const Fortran::semantics::Scope &getCurrentScope() override final {
return bridge.getSemanticsContext().FindScope(currentPosition);
}
fir::FirOpBuilder &getFirOpBuilder() override final {
CHECK(builder && "builder is not set before calling getFirOpBuilder");
return *builder;
}
mlir::ModuleOp getModuleOp() override final { return bridge.getModule(); }
mlir::MLIRContext &getMLIRContext() override final {
return bridge.getMLIRContext();
}
std::string
mangleName(const Fortran::semantics::Symbol &symbol) override final {
std::string mangledName = Fortran::lower::mangle::mangleName(
symbol, scopeBlockIdMap, /*keepExternalInScope=*/false,
getLoweringOptions().getUnderscoring());
const std::string &hash = bridge.getModuleNameHash();
if (!hash.empty() &&
Fortran::semantics::ClassifyProcedure(symbol) ==
Fortran::semantics::ProcedureDefinitionClass::Internal)
mangledName += hash;
return mangledName;
}
std::string mangleName(
const Fortran::semantics::DerivedTypeSpec &derivedType) override final {
return Fortran::lower::mangle::mangleName(derivedType, scopeBlockIdMap);
}
std::string mangleName(std::string &name) override final {
return Fortran::lower::mangle::mangleName(name, getCurrentScope(),
scopeBlockIdMap);
}
std::string
mangleName(std::string &name,
const Fortran::semantics::Scope &myScope) override final {
return Fortran::lower::mangle::mangleName(name, myScope, scopeBlockIdMap);
}
std::string getRecordTypeFieldName(
const Fortran::semantics::Symbol &component) override final {
return Fortran::lower::mangle::getRecordTypeFieldName(component,
scopeBlockIdMap);
}
const fir::KindMapping &getKindMap() override final {
return bridge.getKindMap();
}
/// Return the current function context, which may be a nested BLOCK context
/// or a full subprogram context.
Fortran::lower::StatementContext &getFctCtx() override final {
if (!activeConstructStack.empty() &&
activeConstructStack.back().eval.isA<Fortran::parser::BlockConstruct>())
return activeConstructStack.back().stmtCtx;
return bridge.fctCtx();
}
Fortran::lower::StatementContext &getCudaCleanupCtx() override final {
if (!activeConstructStack.empty() &&
activeConstructStack.back().eval.isA<Fortran::parser::BlockConstruct>())
return activeConstructStack.back().stmtCtx;
return bridge.cudaCleanupCtx();
}
/// Initializes values for STAT and ERRMSG
std::pair<mlir::Value, mlir::Value>
genStatAndErrmsg(mlir::Location loc,
const std::list<Fortran::parser::StatOrErrmsg>
&statOrErrList) override final {
Fortran::lower::StatementContext stmtCtx;
mlir::Value errMsgExpr, statExpr;
for (const Fortran::parser::StatOrErrmsg &statOrErr : statOrErrList) {
std::visit(Fortran::common::visitors{
[&](const Fortran::parser::StatVariable &statVar) {
const Fortran::semantics::SomeExpr *expr =
Fortran::semantics::GetExpr(statVar);
statExpr =
fir::getBase(genExprAddr(*expr, stmtCtx, &loc));
},
[&](const Fortran::parser::MsgVariable &errMsgVar) {
const Fortran::semantics::SomeExpr *expr =
Fortran::semantics::GetExpr(errMsgVar);
errMsgExpr =
fir::getBase(genExprBox(loc, *expr, stmtCtx));
}},
statOrErr.u);
}
return {statExpr, errMsgExpr};
}
mlir::Value hostAssocTupleValue() override final { return hostAssocTuple; }
/// Record a binding for the ssa-value of the tuple for this function.
void bindHostAssocTuple(mlir::Value val) override final {
assert(!hostAssocTuple && val);
hostAssocTuple = val;
}
mlir::Value dummyArgsScopeValue() const override final {
return dummyArgsScope;
}
bool isRegisteredDummySymbol(
Fortran::semantics::SymbolRef symRef) const override final {
auto *sym = &*symRef;
return registeredDummySymbols.contains(sym);
}
unsigned getDummyArgPosition(
const Fortran::semantics::Symbol &sym) const override final {
auto it = dummyArgPositions.find(&sym);
return (it != dummyArgPositions.end()) ? it->second : 0;
}
const Fortran::lower::pft::FunctionLikeUnit *
getCurrentFunctionUnit() const override final {
return currentFunctionUnit;
}
bool isVisibleCrayPointerTarget(
const Fortran::semantics::Symbol &sym) const override final {
return visibleCrayPointerTargets.contains(&sym.GetUltimate());
}
void checkCoarrayEnabled() override final {
if (!getFoldingContext().languageFeatures().IsEnabled(
Fortran::common::LanguageFeature::Coarray))
fir::emitFatalError(
getCurrentLocation(),
"Not yet implemented: Multi-image features are experimental and are "
"disabled by default, use '-fcoarray' to enable.",
false);
}
void registerTypeInfo(mlir::Location loc,
Fortran::lower::SymbolRef typeInfoSym,
const Fortran::semantics::DerivedTypeSpec &typeSpec,
fir::RecordType type) override final {
typeInfoConverter.registerTypeInfo(*this, loc, typeInfoSym, typeSpec, type);
}
llvm::StringRef
getUniqueLitName(mlir::Location loc,
std::unique_ptr<Fortran::lower::SomeExpr> expr,
mlir::Type eleTy) override final {
std::string namePrefix =
getConstantExprManglePrefix(loc, *expr.get(), eleTy);
auto [it, inserted] = literalNamesMap.try_emplace(
expr.get(), namePrefix + std::to_string(uniqueLitId));
const auto &name = it->second;
if (inserted) {
// Keep ownership of the expr key.
literalExprsStorage.push_back(std::move(expr));
// If we've just added a new name, we have to make sure
// there is no global object with the same name in the module.
fir::GlobalOp global = builder->getNamedGlobal(name);
if (global)
fir::emitFatalError(loc, llvm::Twine("global object with name '") +
llvm::Twine(name) +
llvm::Twine("' already exists"));
++uniqueLitId;
return name;
}
// The name already exists. Verify that the prefix is the same.
if (!llvm::StringRef(name).starts_with(namePrefix))
fir::emitFatalError(loc, llvm::Twine("conflicting prefixes: '") +
llvm::Twine(name) +
llvm::Twine("' does not start with '") +
llvm::Twine(namePrefix) + llvm::Twine("'"));
return name;
}
/// Find the symbol in the inner-most level of the local map or return null.
Fortran::lower::SymbolBox
shallowLookupSymbol(const Fortran::semantics::Symbol &sym) override {
if (Fortran::lower::SymbolBox v = localSymbols.shallowLookupSymbol(sym))
return v;
return {};
}
private:
FirConverter() = delete;
FirConverter(const FirConverter &) = delete;
FirConverter &operator=(const FirConverter &) = delete;
//===--------------------------------------------------------------------===//
// Helper member functions
//===--------------------------------------------------------------------===//
mlir::Value createFIRExpr(mlir::Location loc,
const Fortran::lower::SomeExpr *expr,
Fortran::lower::StatementContext &stmtCtx) {
return fir::getBase(genExprValue(*expr, stmtCtx, &loc));
}
/// Find the symbol in the local map or return null.
Fortran::lower::SymbolBox
lookupSymbol(const Fortran::semantics::Symbol &sym,
Fortran::lower::SymMap *symMap = nullptr,
bool forceHlfirBase = false) {
symMap = symMap ? symMap : &localSymbols;
if (std::optional<fir::FortranVariableOpInterface> var =
symMap->lookupVariableDefinition(sym)) {
auto exv = hlfir::translateToExtendedValue(toLocation(), *builder, *var,
forceHlfirBase);
return exv.match(
[](mlir::Value x) -> Fortran::lower::SymbolBox {
return Fortran::lower::SymbolBox::Intrinsic{x};
},
[](auto x) -> Fortran::lower::SymbolBox { return x; });
}
// Entry character result represented as an argument pair
// needs to be represented in the symbol table even before
// we can create DeclareOp for it. The temporary mapping
// is EmboxCharOp that conveys the address and length information.
// After mapSymbolAttributes is done, the mapping is replaced
// with the new DeclareOp, and the following table lookups
// do not reach here.
if (sym.IsFuncResult())
if (const Fortran::semantics::DeclTypeSpec *declTy = sym.GetType())
if (declTy->category() ==
Fortran::semantics::DeclTypeSpec::Category::Character)
return symMap->lookupSymbol(sym);
// Procedure dummies are not mapped with an hlfir.declare because
// they are not "variable" (cannot be assigned to), and it would
// make hlfir.declare more complex than it needs to to allow this.
// Do a regular lookup.
if (Fortran::semantics::IsProcedure(sym))
return symMap->lookupSymbol(sym);
// 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 (sym.detailsIf<Fortran::semantics::CommonBlockDetails>())
return symMap->lookupSymbol(sym);
// For symbols to be privatized in OMP, the symbol is mapped to an
// instance of `SymbolBox::Intrinsic` (i.e. a direct mapping to an MLIR
// SSA value). This MLIR SSA value is the block argument to the
// `omp.private`'s `alloc` block. If this is the case, we return this
// `SymbolBox::Intrinsic` value.
if (Fortran::lower::SymbolBox v = symMap->lookupSymbol(sym))
return v;
return {};
}
/// Find the symbol in one level up of symbol map such as for host-association
/// in OpenMP code or return null.
Fortran::lower::SymbolBox
lookupOneLevelUpSymbol(const Fortran::semantics::Symbol &sym) override {
if (Fortran::lower::SymbolBox v = localSymbols.lookupOneLevelUpSymbol(sym))
return v;
return {};
}
mlir::SymbolTable *getMLIRSymbolTable() override { return &mlirSymbolTable; }
mlir::StateStack &getStateStack() override { return stateStack; }
/// Add the symbol to the local map and return `true`. If the symbol is
/// already in the map and \p forced is `false`, the map is not updated.
/// Instead the value `false` is returned.
bool addSymbol(const Fortran::semantics::SymbolRef sym,
fir::ExtendedValue val, bool forced = false) {
if (!forced && lookupSymbol(sym))
return false;
Fortran::lower::genDeclareSymbol(*this, localSymbols, sym, val,
fir::FortranVariableFlagsEnum::None,
forced);
return true;
}
void copyVar(const Fortran::semantics::Symbol &sym,
const Fortran::lower::SymbolBox &lhs_sb,
const Fortran::lower::SymbolBox &rhs_sb,
Fortran::semantics::Symbol::Flags flags) {
mlir::Location loc = genLocation(sym.name());
copyVarHLFIR(loc, lhs_sb, rhs_sb, flags);
}
void copyVarHLFIR(mlir::Location loc, Fortran::lower::SymbolBox dst,
Fortran::lower::SymbolBox src,
Fortran::semantics::Symbol::Flags flags) {
bool isBoxAllocatable = dst.match(
[](const fir::MutableBoxValue &box) { return box.isAllocatable(); },
[](const fir::FortranVariableOpInterface &box) {
return fir::FortranVariableOpInterface(box).isAllocatable();
},
[](const auto &box) { return false; });
bool isBoxPointer = dst.match(
[](const fir::MutableBoxValue &box) { return box.isPointer(); },
[](const fir::FortranVariableOpInterface &box) {
return fir::FortranVariableOpInterface(box).isPointer();
},
[](const fir::AbstractBox &box) {
return fir::isBoxProcAddressType(box.getAddr().getType());
},
[](const auto &box) { return false; });
copyVarHLFIR(loc, dst, src, isBoxAllocatable, isBoxPointer, flags);
}
void copyVarHLFIR(mlir::Location loc, Fortran::lower::SymbolBox dst,
Fortran::lower::SymbolBox src, bool isAllocatable,
bool isPointer, Fortran::semantics::Symbol::Flags flags) {
hlfir::Entity lhs{dst.getAddr()};
hlfir::Entity rhs{src.getAddr()};
auto copyData = [&](hlfir::Entity l, hlfir::Entity r) {
// Dereference RHS and load it if trivial scalar.
r = hlfir::loadTrivialScalar(loc, *builder, r);
hlfir::AssignOp::create(*builder, loc, r, l, isAllocatable);
};
if (isPointer) {
// Set LHS target to the target of RHS (do not copy the RHS
// target data into the LHS target storage).
auto loadVal = fir::LoadOp::create(*builder, loc, rhs);
fir::StoreOp::create(*builder, loc, loadVal, lhs);
} else if (isAllocatable &&
flags.test(Fortran::semantics::Symbol::Flag::OmpCopyIn)) {
// For copyin allocatable variables, RHS must be copied to lhs
// only when rhs is allocated.
hlfir::Entity temp =
hlfir::derefPointersAndAllocatables(loc, *builder, rhs);
mlir::Value addr = hlfir::genVariableRawAddress(loc, *builder, temp);
mlir::Value isAllocated = builder->genIsNotNullAddr(loc, addr);
builder->genIfThenElse(loc, isAllocated)
.genThen([&]() { copyData(lhs, rhs); })
.genElse([&]() {
fir::ExtendedValue hexv = symBoxToExtendedValue(dst);
hexv.match(
[&](const fir::MutableBoxValue &new_box) -> void {
// if the allocation status of original list item is
// unallocated, unallocate the copy if it is allocated, else
// do nothing.
Fortran::lower::genDeallocateIfAllocated(*this, new_box, loc);
},
[&](const auto &) -> void {});
})
.end();
} else if (isAllocatable &&
flags.test(Fortran::semantics::Symbol::Flag::OmpFirstPrivate)) {
// For firstprivate allocatable variables, RHS must be copied
// only when LHS is allocated.
hlfir::Entity temp =
hlfir::derefPointersAndAllocatables(loc, *builder, lhs);
mlir::Value addr = hlfir::genVariableRawAddress(loc, *builder, temp);
mlir::Value isAllocated = builder->genIsNotNullAddr(loc, addr);
builder->genIfThen(loc, isAllocated)
.genThen([&]() { copyData(lhs, rhs); })
.end();
} else if (!isAllocatable &&
flags.test(Fortran::semantics::Symbol::Flag::OmpCopyIn) &&
hlfir::mayHaveAllocatableComponent(lhs.getType())) {
// For copyin of derived types with allocatable components where the
// variable itself is not allocatable: the threadprivate copy's
// allocatable component descriptors may be uninitialized (e.g.,
// zero-filled by the OpenMP runtime). Use temporary_lhs semantics
// which routes through AssignTemporary at runtime. AssignTemporary
// first initializes the LHS descriptor metadata (setting
// attribute=CFI_attribute_allocatable, base_addr=nullptr for
// allocatable components via the Initialize runtime call), then
// performs the assignment with MaybeReallocate semantics for proper
// deep copy of allocatable components.
//
// On the master thread, the LHS and RHS resolve to the same
// threadprivate storage, so we must skip the temporary_lhs path
// (which would destroy the source data via Initialize before the
// copy). Use a runtime address comparison to distinguish threads.
mlir::Value lhsAddr =
fir::ConvertOp::create(*builder, loc, builder->getIndexType(), lhs);
mlir::Value rhsAddr =
fir::ConvertOp::create(*builder, loc, builder->getIndexType(), rhs);
mlir::Value sameAddr = mlir::arith::CmpIOp::create(
*builder, loc, mlir::arith::CmpIPredicate::eq, lhsAddr, rhsAddr);
builder->genIfThenElse(loc, sameAddr)
.genThen([&]() {
// Master thread: lhs and rhs are the same, nothing to do.
})
.genElse([&]() {
hlfir::Entity r = hlfir::loadTrivialScalar(loc, *builder, rhs);
hlfir::AssignOp::create(*builder, loc, r, lhs,
/*realloc=*/false,
/*keep_lhs_length_if_realloc=*/false,
/*temporary_lhs=*/true);
})
.end();
} else {
copyData(lhs, rhs);
}
}
/// Map a block argument to a result or dummy symbol. This is not the
/// definitive mapping. The specification expression have not been lowered
/// yet. The final mapping will be done using this pre-mapping in
/// Fortran::lower::mapSymbolAttributes.
/// \param argNo The 1-based source position of this argument (0 if
/// unknown/result)
bool mapBlockArgToDummyOrResult(const Fortran::semantics::SymbolRef sym,
mlir::Value val, bool isResult,
unsigned argNo = 0) {
localSymbols.addSymbol(sym, val);
if (!isResult)
registerDummySymbol(sym, argNo);
return true;
}
/// Generate the address of loop variable \p sym.
/// If \p sym is not mapped yet, allocate local storage for it.
mlir::Value genLoopVariableAddress(mlir::Location loc,
const Fortran::semantics::Symbol &sym,
bool isUnordered) {
if (!shallowLookupSymbol(sym) &&
(isUnordered ||
GetSymbolDSA(sym).test(Fortran::semantics::Symbol::Flag::OmpPrivate) ||
GetSymbolDSA(sym).test(
Fortran::semantics::Symbol::Flag::OmpFirstPrivate) ||
GetSymbolDSA(sym).test(
Fortran::semantics::Symbol::Flag::OmpLastPrivate) ||
GetSymbolDSA(sym).test(Fortran::semantics::Symbol::Flag::OmpLinear))) {
// Do concurrent loop variables are not mapped yet since they are
// local to the Do concurrent scope (same for OpenMP loops).
mlir::OpBuilder::InsertPoint insPt = builder->saveInsertionPoint();
builder->setInsertionPointToStart(builder->getAllocaBlock());
mlir::Type tempTy = genType(sym);
mlir::Value temp =
builder->createTemporaryAlloc(loc, tempTy, toStringRef(sym.name()));
bindIfNewSymbol(sym, temp);
builder->restoreInsertionPoint(insPt);
}
auto entry = lookupSymbol(sym);
(void)entry;
assert(entry && "loop control variable must already be in map");
Fortran::lower::StatementContext stmtCtx;
return fir::getBase(
genExprAddr(Fortran::evaluate::AsGenericExpr(sym).value(), stmtCtx));
}
static bool isNumericScalarCategory(Fortran::common::TypeCategory cat) {
return cat == Fortran::common::TypeCategory::Integer ||
cat == Fortran::common::TypeCategory::Real ||
cat == Fortran::common::TypeCategory::Complex ||
cat == Fortran::common::TypeCategory::Logical;
}
static bool isLogicalCategory(Fortran::common::TypeCategory cat) {
return cat == Fortran::common::TypeCategory::Logical;
}
static bool isCharacterCategory(Fortran::common::TypeCategory cat) {
return cat == Fortran::common::TypeCategory::Character;
}
static bool isDerivedCategory(Fortran::common::TypeCategory cat) {
return cat == Fortran::common::TypeCategory::Derived;
}
/// Insert a new block before \p block. Leave the insertion point unchanged.
mlir::Block *insertBlock(mlir::Block *block) {
mlir::OpBuilder::InsertPoint insertPt = builder->saveInsertionPoint();
mlir::Block *newBlock = builder->createBlock(block);
builder->restoreInsertionPoint(insertPt);
return newBlock;
}
Fortran::lower::pft::Evaluation &evalOfLabel(Fortran::parser::Label label) {
const Fortran::lower::pft::LabelEvalMap &labelEvaluationMap =
getEval().getOwningProcedure()->labelEvaluationMap;
const auto iter = labelEvaluationMap.find(label);
assert(iter != labelEvaluationMap.end() && "label missing from map");
return *iter->second;
}
void genBranch(mlir::Block *targetBlock) {
assert(targetBlock && "missing unconditional target block");
if (!accRegionExitStack.empty()) {
mlir::Region *curRegion = builder->getBlock()->getParent();
if (targetBlock->getParent() != curRegion) {
auto &exitInfo = accRegionExitStack.back();
int exitId = exitInfo.nextId++;
exitInfo.exits.push_back({exitId, targetBlock});
mlir::Value id = builder->createIntegerConstant(
toLocation(), builder->getI32Type(), exitId);
fir::StoreOp::create(*builder, toLocation(), id, exitInfo.selector);
Fortran::lower::genOpenACCRegionExitBranch(*builder, toLocation(),
targetBlock);
return;
}
}
mlir::cf::BranchOp::create(*builder, toLocation(), targetBlock);
}
void genConditionalBranch(mlir::Value cond, mlir::Block *trueTarget,
mlir::Block *falseTarget) {
assert(trueTarget && "missing conditional branch true block");
assert(falseTarget && "missing conditional branch false block");
mlir::Location loc = toLocation();
mlir::Value bcc = builder->createConvert(loc, builder->getI1Type(), cond);
mlir::cf::CondBranchOp::create(*builder, loc, bcc, trueTarget,
mlir::ValueRange{}, falseTarget,
mlir::ValueRange{});
}
void genConditionalBranch(mlir::Value cond,
Fortran::lower::pft::Evaluation *trueTarget,
Fortran::lower::pft::Evaluation *falseTarget) {
genConditionalBranch(cond, trueTarget->block, falseTarget->block);
}
void genConditionalBranch(const Fortran::parser::ScalarLogicalExpr &expr,
mlir::Block *trueTarget, mlir::Block *falseTarget) {
Fortran::lower::StatementContext stmtCtx;
mlir::Value cond =
createFIRExpr(toLocation(), Fortran::semantics::GetExpr(expr), stmtCtx);
stmtCtx.finalizeAndReset();
genConditionalBranch(cond, trueTarget, falseTarget);
}
void genConditionalBranch(const Fortran::parser::ScalarLogicalExpr &expr,
Fortran::lower::pft::Evaluation *trueTarget,
Fortran::lower::pft::Evaluation *falseTarget) {
Fortran::lower::StatementContext stmtCtx;
mlir::Value cond =
createFIRExpr(toLocation(), Fortran::semantics::GetExpr(expr), stmtCtx);
stmtCtx.finalizeAndReset();
genConditionalBranch(cond, trueTarget->block, falseTarget->block);
}
void
genDoWhileAsSCFWhile(const Fortran::parser::ScalarLogicalExpr &whileCondition,
Fortran::lower::pft::Evaluation &doConstructEval,
Fortran::lower::pft::Evaluation &doStmtEval) {
mlir::Location loc = toLocation();
auto scfWhile =
mlir::scf::WhileOp::create(*builder, loc,
/*resultTypes=*/mlir::TypeRange{},
/*inits=*/mlir::ValueRange{});
// Fill the "before" region: compute condition.
mlir::Block *beforeBlock =
builder->createBlock(&scfWhile.getBefore(), scfWhile.getBefore().end());
builder->setInsertionPointToStart(beforeBlock);
Fortran::lower::StatementContext stmtCtx;
mlir::Value cond = createFIRExpr(
loc, Fortran::semantics::GetExpr(whileCondition), stmtCtx);
stmtCtx.finalizeAndReset();
cond = builder->createConvert(loc, builder->getI1Type(), cond);
mlir::scf::ConditionOp::create(*builder, loc, cond, mlir::ValueRange{});
// Fill the "after" region: loop body.
mlir::Block *afterBlock =
builder->createBlock(&scfWhile.getAfter(), scfWhile.getAfter().end());
builder->setInsertionPointToStart(afterBlock);
// Lower nested evaluations excluding the loop control statement (the
// NonLabelDoStmt) and the EndDoStmt.
auto iter = doConstructEval.getNestedEvaluations().begin();
auto end = doConstructEval.getNestedEvaluations().end();
assert(iter != end && "malformed DoConstruct evaluation list");
++iter; // skip the NonLabelDoStmt
assert(iter != end && "malformed DoConstruct evaluation list");
auto endDoIter = std::prev(end);
for (; iter != endDoIter; ++iter)
genFIR(*iter, /*unstructuredContext=*/false);
mlir::scf::YieldOp::create(*builder, loc);
builder->setInsertionPointAfter(scfWhile);
}
/// Return the nearest active ancestor construct of \p eval, or nullptr.
Fortran::lower::pft::Evaluation *
getActiveAncestor(const Fortran::lower::pft::Evaluation &eval) {
Fortran::lower::pft::Evaluation *ancestor = eval.parentConstruct;
for (; ancestor; ancestor = ancestor->parentConstruct)
if (ancestor->activeConstruct)
break;
return ancestor;
}
/// Return the predicate: "a branch to \p targetEval has exit code".
bool hasExitCode(const Fortran::lower::pft::Evaluation &targetEval) {
Fortran::lower::pft::Evaluation *activeAncestor =
getActiveAncestor(targetEval);
for (auto it = activeConstructStack.rbegin(),
rend = activeConstructStack.rend();
it != rend; ++it) {
if (&it->eval == activeAncestor)
break;
if (it->stmtCtx.hasCode())
return true;
}
return false;
}
/// Generate a branch to \p targetEval after generating on-exit code for
/// any enclosing construct scopes that are exited by taking the branch.
void
genConstructExitBranch(const Fortran::lower::pft::Evaluation &targetEval) {
Fortran::lower::pft::Evaluation *activeAncestor =
getActiveAncestor(targetEval);
for (auto it = activeConstructStack.rbegin(),
rend = activeConstructStack.rend();
it != rend; ++it) {
if (&it->eval == activeAncestor)
break;
it->stmtCtx.finalizeAndKeep();
}
genBranch(targetEval.block);
}
/// A construct contains nested evaluations. Some of these evaluations
/// may start a new basic block, others will add code to an existing
/// block.
/// Collect the list of nested evaluations that are last in their block,
/// organize them into two sets:
/// 1. Exiting evaluations: they may need a branch exiting from their
/// parent construct,
/// 2. Fall-through evaluations: they will continue to the following
/// evaluation. They may still need a branch, but they do not exit
/// the construct. They appear in cases where the following evaluation
/// is a target of some branch.
void collectFinalEvaluations(
Fortran::lower::pft::Evaluation &construct,
llvm::SmallVector<Fortran::lower::pft::Evaluation *> &exits,
llvm::SmallVector<Fortran::lower::pft::Evaluation *> &fallThroughs) {
Fortran::lower::pft::EvaluationList &nested =
construct.getNestedEvaluations();
if (nested.empty())
return;
Fortran::lower::pft::Evaluation *exit = construct.constructExit;
Fortran::lower::pft::Evaluation *previous = &nested.front();
for (auto it = ++nested.begin(), end = nested.end(); it != end;
previous = &*it++) {
if (it->block == nullptr)
continue;
// "*it" starts a new block, check what to do with "previous"
if (it->isIntermediateConstructStmt() && previous != exit)
exits.push_back(previous);
else if (previous->lexicalSuccessor && previous->lexicalSuccessor->block)
fallThroughs.push_back(previous);
}
if (previous != exit)
exits.push_back(previous);
}
/// Generate a SelectOp or branch sequence that compares \p selector against
/// values in \p valueList and targets corresponding labels in \p labelList.
/// If no value matches the selector, branch to \p defaultEval.
///
/// Three cases require special processing.
///
/// An empty \p valueList indicates an ArithmeticIfStmt context that requires
/// two comparisons against 0 or 0.0. The selector may have either INTEGER
/// or REAL type.
///
/// A nonpositive \p valuelist value indicates an IO statement context
/// (0 for ERR, -1 for END, -2 for EOR). An ERR branch must be taken for
/// any positive (IOSTAT) value. A missing (zero) label requires a branch
/// to \p defaultEval for that value.
///
/// A non-null \p errorBlock indicates an AssignedGotoStmt context that
/// must always branch to an explicit target. There is no valid defaultEval
/// in this case. Generate a branch to \p errorBlock for an AssignedGotoStmt
/// that violates this program requirement.
///
/// If this is not an ArithmeticIfStmt and no targets have exit code,
/// generate a SelectOp. Otherwise, for each target, if it has exit code,
/// branch to a new block, insert exit code, and then branch to the target.
/// Otherwise, branch directly to the target.
void genMultiwayBranch(mlir::Value selector,
llvm::SmallVector<int64_t> valueList,
llvm::SmallVector<Fortran::parser::Label> labelList,
const Fortran::lower::pft::Evaluation &defaultEval,
mlir::Block *errorBlock = nullptr) {
bool inArithmeticIfContext = valueList.empty();
assert(((inArithmeticIfContext && labelList.size() == 2) ||
(valueList.size() && labelList.size() == valueList.size())) &&
"mismatched multiway branch targets");
mlir::Block *defaultBlock = errorBlock ? errorBlock : defaultEval.block;
bool defaultHasExitCode = !errorBlock && hasExitCode(defaultEval);
bool hasAnyExitCode = defaultHasExitCode;
if (!hasAnyExitCode)
for (auto label : labelList)
if (label && hasExitCode(evalOfLabel(label))) {
hasAnyExitCode = true;
break;
}
mlir::Location loc = toLocation();
size_t branchCount = labelList.size();
if (!inArithmeticIfContext && !hasAnyExitCode &&
!getEval().forceAsUnstructured()) { // from -no-structured-fir option
// Generate a SelectOp.
llvm::SmallVector<mlir::Block *> blockList;
for (auto label : labelList) {
mlir::Block *block =
label ? evalOfLabel(label).block : defaultEval.block;
assert(block && "missing multiway branch block");
blockList.push_back(block);
}
blockList.push_back(defaultBlock);
if (valueList[branchCount - 1] == 0) // Swap IO ERR and default blocks.
std::swap(blockList[branchCount - 1], blockList[branchCount]);
fir::SelectOp::create(*builder, loc, selector, valueList, blockList);
return;
}
mlir::Type selectorType = selector.getType();
bool realSelector = mlir::isa<mlir::FloatType>(selectorType);
assert((inArithmeticIfContext || !realSelector) && "invalid selector type");
mlir::Value zero;
if (inArithmeticIfContext)
zero = realSelector
? mlir::arith::ConstantOp::create(
*builder, loc, selectorType,
builder->getFloatAttr(selectorType, 0.0))
: builder->createIntegerConstant(loc, selectorType, 0);
for (auto label : llvm::enumerate(labelList)) {
mlir::Value cond;
if (realSelector) // inArithmeticIfContext
cond = mlir::arith::CmpFOp::create(
*builder, loc,
label.index() == 0 ? mlir::arith::CmpFPredicate::OLT
: mlir::arith::CmpFPredicate::OGT,
selector, zero);
else if (inArithmeticIfContext) // INTEGER selector
cond = mlir::arith::CmpIOp::create(
*builder, loc,
label.index() == 0 ? mlir::arith::CmpIPredicate::slt
: mlir::arith::CmpIPredicate::sgt,
selector, zero);
else // A value of 0 is an IO ERR branch: invert comparison.
cond = mlir::arith::CmpIOp::create(
*builder, loc,
valueList[label.index()] == 0 ? mlir::arith::CmpIPredicate::ne
: mlir::arith::CmpIPredicate::eq,
selector,
builder->createIntegerConstant(loc, selectorType,
valueList[label.index()]));
// Branch to a new block with exit code and then to the target, or branch
// directly to the target. defaultBlock is the "else" target.
bool lastBranch = label.index() == branchCount - 1;
mlir::Block *nextBlock =
lastBranch && !defaultHasExitCode
? defaultBlock
: builder->getBlock()->splitBlock(builder->getInsertionPoint());
const Fortran::lower::pft::Evaluation &targetEval =
label.value() ? evalOfLabel(label.value()) : defaultEval;
if (hasExitCode(targetEval)) {
mlir::Block *jumpBlock =
builder->getBlock()->splitBlock(builder->getInsertionPoint());
genConditionalBranch(cond, jumpBlock, nextBlock);
startBlock(jumpBlock);
genConstructExitBranch(targetEval);
} else {
genConditionalBranch(cond, targetEval.block, nextBlock);
}
if (!lastBranch) {
startBlock(nextBlock);
} else if (defaultHasExitCode) {
startBlock(nextBlock);
genConstructExitBranch(defaultEval);
}
}
}
void pushActiveConstruct(Fortran::lower::pft::Evaluation &eval,
Fortran::lower::StatementContext &stmtCtx) {
activeConstructStack.push_back(ConstructContext{eval, stmtCtx});
eval.activeConstruct = true;
}
void popActiveConstruct() {
assert(!activeConstructStack.empty() && "invalid active construct stack");
activeConstructStack.back().eval.activeConstruct = false;
if (activeConstructStack.back().pushedScope)
localSymbols.popScope();
activeConstructStack.pop_back();
}
//===--------------------------------------------------------------------===//
// Termination of symbolically referenced execution units
//===--------------------------------------------------------------------===//
/// Exit of a routine
///
/// Generate the cleanup block before the routine exits
void genExitRoutine(bool earlyReturn, mlir::ValueRange retval = {}) {
if (blockIsUnterminated()) {
bridge.openAccCtx().finalizeAndKeep();
if (bridge.cudaCleanupCtx().hasCode()) {
mlir::Location loc = toLocation();
mlir::Value active = cuf::DeviceIsActiveOp::create(*builder, loc);
builder->genIfThen(loc, active)
.genThen([&]() {
fir::runtime::cuda::genCUDADeviceSynchronize(*builder, loc);
bridge.cudaCleanupCtx().finalizeAndKeep();
})
.end();
}
bridge.fctCtx().finalizeAndKeep();
mlir::func::ReturnOp::create(*builder, toLocation(), retval);
}
if (!earlyReturn) {
bridge.openAccCtx().pop();
bridge.cudaCleanupCtx().pop();
bridge.fctCtx().pop();
}
}
/// END of procedure-like constructs
///
/// Generate the cleanup block before the procedure exits
void genReturnSymbol(const Fortran::semantics::Symbol &functionSymbol) {
const Fortran::semantics::Symbol &resultSym =
functionSymbol.get<Fortran::semantics::SubprogramDetails>().result();
Fortran::lower::SymbolBox resultSymBox = lookupSymbol(resultSym);
mlir::Location loc = toLocation();
if (!resultSymBox) {
// Create a dummy undefined value of the expected return type.
// This prevents improper cleanup of StatementContext, which would lead
// to a crash due to a block with no terminator. See issue #126452.
mlir::FunctionType funcType = builder->getFunction().getFunctionType();
mlir::Type resultType = funcType.getResult(0);
mlir::Value undefResult = fir::UndefOp::create(*builder, loc, resultType);
genExitRoutine(false, undefResult);
return;
}
mlir::Value resultVal = resultSymBox.match(
[&](const fir::CharBoxValue &x) -> mlir::Value {
if (Fortran::semantics::IsBindCProcedure(functionSymbol))
return fir::LoadOp::create(*builder, loc, x.getBuffer());
return fir::factory::CharacterExprHelper{*builder, loc}
.createEmboxChar(x.getBuffer(), x.getLen());
},
[&](const fir::MutableBoxValue &x) -> mlir::Value {
mlir::Value resultRef = resultSymBox.getAddr();
mlir::Value load = fir::LoadOp::create(*builder, loc, resultRef);
unsigned rank = x.rank();
if (x.isAllocatable() && rank > 0) {
// ALLOCATABLE array result must have default lower bounds.
// At the call site the result box of a function reference
// might be considered having default lower bounds, but
// the runtime box should probably comply with this assumption
// as well. If the result box has proper lbounds in runtime,
// this may improve the debugging experience of Fortran apps.
// We may consider removing this, if the overhead of setting
// default lower bounds is too big.
mlir::Value one =
builder->createIntegerConstant(loc, builder->getIndexType(), 1);
llvm::SmallVector<mlir::Value> lbounds{rank, one};
auto shiftTy = fir::ShiftType::get(builder->getContext(), rank);
mlir::Value shiftOp =
fir::ShiftOp::create(*builder, loc, shiftTy, lbounds);
load = fir::ReboxOp::create(*builder, loc, load.getType(), load,
shiftOp, /*slice=*/mlir::Value{});
}
return load;
},
[&](const auto &) -> mlir::Value {
mlir::Value resultRef = resultSymBox.getAddr();
mlir::Type resultType = genType(resultSym);
mlir::Type resultRefType = builder->getRefType(resultType);
// A function with multiple entry points returning different types
// tags all result variables with one of the largest types to allow
// them to share the same storage. Convert this to the actual type.
if (resultRef.getType() != resultRefType)
resultRef = builder->createConvertWithVolatileCast(
loc, resultRefType, resultRef);
return fir::LoadOp::create(*builder, loc, resultRef);
});
// CUDA function-result descriptors are allocated with cuf.alloc and freed
// on exit. Abstract-result rewrites `return %v` into a store to the hidden
// result argument at the return point, which would run after that free if
// %v is still a load or rebox of the CUDA descriptor. Spill %v to a stack
// temporary first so the rewrite stores to the hidden argument before the
// free.
if (bridge.cudaCleanupCtx().hasCode() &&
mlir::isa<fir::BaseBoxType>(resultVal.getType()))
if (std::optional<Fortran::common::CUDADataAttr> cudaAttr =
Fortran::semantics::GetCUDADataAttr(&resultSym.GetUltimate()))
if (*cudaAttr != Fortran::common::CUDADataAttr::Shared) {
mlir::Value tmp = builder->createTemporary(loc, resultVal.getType());
fir::StoreOp::create(*builder, loc, resultVal, tmp);
resultVal = fir::LoadOp::create(*builder, loc, tmp);
}
genExitRoutine(false, resultVal);
}
/// Get the return value of a call to \p symbol, which is a subroutine entry
/// point that has alternative return specifiers.
const mlir::Value
getAltReturnResult(const Fortran::semantics::Symbol &symbol) {
assert(Fortran::semantics::HasAlternateReturns(symbol) &&
"subroutine does not have alternate returns");
return getSymbolAddress(symbol);
}
void genFIRProcedureExit(Fortran::lower::pft::FunctionLikeUnit &funit,
const Fortran::semantics::Symbol &symbol) {
if (mlir::Block *finalBlock = funit.finalBlock) {
// The current block must end with a terminator.
if (blockIsUnterminated())
mlir::cf::BranchOp::create(*builder, toLocation(), finalBlock);
// Set insertion point to final block.
builder->setInsertionPoint(finalBlock, finalBlock->end());
}
if (Fortran::semantics::IsFunction(symbol)) {
genReturnSymbol(symbol);
} else if (Fortran::semantics::HasAlternateReturns(symbol)) {
mlir::Value retval = fir::LoadOp::create(*builder, toLocation(),
getAltReturnResult(symbol));
genExitRoutine(false, retval);
} else {
genExitRoutine(false);
}
}
//
// Statements that have control-flow semantics
//
/// Generate an If[Then]Stmt condition or its negation.
template <typename A>
mlir::Value genIfCondition(const A *stmt, bool negate = false) {
mlir::Location loc = toLocation();
Fortran::lower::StatementContext stmtCtx;
mlir::Value condExpr = createFIRExpr(
loc,
Fortran::semantics::GetExpr(
std::get<Fortran::parser::ScalarLogicalExpr>(stmt->t)),
stmtCtx);
stmtCtx.finalizeAndReset();
mlir::Value cond =
builder->createConvert(loc, builder->getI1Type(), condExpr);
if (negate)
cond = mlir::arith::XOrIOp::create(
*builder, loc, cond,
builder->createIntegerConstant(loc, cond.getType(), 1));
return cond;
}
mlir::func::FuncOp getFunc(llvm::StringRef name, mlir::FunctionType ty) {
if (mlir::func::FuncOp func = builder->getNamedFunction(name)) {
assert(func.getFunctionType() == ty);
return func;
}
return builder->createFunction(toLocation(), name, ty);
}
/// Lowering of CALL statement
void genFIR(const Fortran::parser::CallStmt &stmt) {
Fortran::lower::StatementContext stmtCtx;
Fortran::lower::pft::Evaluation &eval = getEval();
setCurrentPosition(stmt.source);
assert(stmt.typedCall && "Call was not analyzed");
mlir::Value res{};
// Set 'no_inline', 'inline_hint' or 'always_inline' to true on the
// ProcedureRef. The NoInline and AlwaysInline attribute will be set in
// genProcedureRef later.
for (const auto *dir : eval.dirs) {
Fortran::common::visit(
Fortran::common::visitors{
[&](const Fortran::parser::CompilerDirective::ForceInline &) {
stmt.typedCall->setAlwaysInline(true);
},
[&](const Fortran::parser::CompilerDirective::InlineAlways &) {
stmt.typedCall->setAlwaysInline(true);
},
[&](const Fortran::parser::CompilerDirective::Inline &) {
stmt.typedCall->setInlineHint(true);
},
[&](const Fortran::parser::CompilerDirective::NoInline &) {
stmt.typedCall->setNoInline(true);
},
[&](const auto &) {}},
dir->u);
}
std::optional<mlir::Type> resultType;
if (stmt.typedCall->hasAlternateReturns())
resultType = builder->getIndexType();
auto hlfirRes =
Fortran::lower::convertCallToHLFIR(toLocation(), *this, *stmt.typedCall,
resultType, localSymbols, stmtCtx);
if (hlfirRes)
res = *hlfirRes;
stmtCtx.finalizeAndReset();
if (!res)
return; // "Normal" subroutine call.
// Call with alternate return specifiers.
// The call returns an index that selects an alternate return branch target.
llvm::SmallVector<int64_t> indexList;
llvm::SmallVector<Fortran::parser::Label> labelList;
int64_t index = 0;
const auto &call{std::get<Fortran::parser::Call>(stmt.t)};
for (const Fortran::parser::ActualArgSpec &arg :
std::get<std::list<Fortran::parser::ActualArgSpec>>(call.t)) {
const auto &actual = std::get<Fortran::parser::ActualArg>(arg.t);
if (const auto *altReturn =
std::get_if<Fortran::parser::AltReturnSpec>(&actual.u)) {
indexList.push_back(++index);
labelList.push_back(altReturn->v);
}
}
genMultiwayBranch(res, indexList, labelList, eval.nonNopSuccessor());
}
void genFIR(const Fortran::parser::ComputedGotoStmt &stmt) {
Fortran::lower::StatementContext stmtCtx;
Fortran::lower::pft::Evaluation &eval = getEval();
mlir::Value selectExpr =
createFIRExpr(toLocation(),
Fortran::semantics::GetExpr(
std::get<Fortran::parser::ScalarIntExpr>(stmt.t)),
stmtCtx);
stmtCtx.finalizeAndReset();
llvm::SmallVector<int64_t> indexList;
llvm::SmallVector<Fortran::parser::Label> labelList;
int64_t index = 0;
for (Fortran::parser::Label label :
std::get<std::list<Fortran::parser::Label>>(stmt.t)) {
indexList.push_back(++index);
labelList.push_back(label);
}
genMultiwayBranch(selectExpr, indexList, labelList, eval.nonNopSuccessor());
}
void genFIR(const Fortran::parser::ArithmeticIfStmt &stmt) {
Fortran::lower::StatementContext stmtCtx;
mlir::Value expr = createFIRExpr(
toLocation(),
Fortran::semantics::GetExpr(std::get<Fortran::parser::Expr>(stmt.t)),
stmtCtx);
stmtCtx.finalizeAndReset();
// Raise an exception if REAL expr is a NaN.
if (mlir::isa<mlir::FloatType>(expr.getType()))
expr = mlir::arith::AddFOp::create(*builder, toLocation(), expr, expr);
// An empty valueList indicates to genMultiwayBranch that the branch is
// an ArithmeticIfStmt that has two branches on value 0 or 0.0.
llvm::SmallVector<int64_t> valueList;
llvm::SmallVector<Fortran::parser::Label> labelList;
labelList.push_back(std::get<1>(stmt.t));
labelList.push_back(std::get<3>(stmt.t));
const Fortran::lower::pft::LabelEvalMap &labelEvaluationMap =
getEval().getOwningProcedure()->labelEvaluationMap;
const auto iter = labelEvaluationMap.find(std::get<2>(stmt.t));
assert(iter != labelEvaluationMap.end() && "label missing from map");
genMultiwayBranch(expr, valueList, labelList, *iter->second);
}
void genFIR(const Fortran::parser::AssignedGotoStmt &stmt) {
// See Fortran 90 Clause 8.2.4.
// Relax the requirement that the GOTO variable must have a value in the
// label list when a list is present, and allow a branch to any non-format
// target that has an ASSIGN statement for the variable.
//
// (Both PFT builder and MLIR lowering bridge apply the same relaxation)
mlir::Location loc = toLocation();
Fortran::lower::pft::Evaluation &eval = getEval();
Fortran::lower::pft::FunctionLikeUnit &owningProc =
*eval.getOwningProcedure();
const Fortran::lower::pft::SymbolLabelMap &symbolLabelMap =
owningProc.assignSymbolLabelMap;
const Fortran::lower::pft::LabelEvalMap &labelEvalMap =
owningProc.labelEvaluationMap;
const Fortran::semantics::Symbol &symbol =
*std::get<Fortran::parser::Name>(stmt.t).symbol;
auto labelSetIter = symbolLabelMap.find(symbol);
llvm::SmallVector<int64_t> valueList;
llvm::SmallVector<Fortran::parser::Label> labelList;
if (labelSetIter != symbolLabelMap.end()) {
for (auto &label : labelSetIter->second) {
const auto evalIter = labelEvalMap.find(label);
assert(evalIter != labelEvalMap.end() && "assigned goto label missing");
if (evalIter->second->block) { // non-format statement
valueList.push_back(label); // label as an integer
labelList.push_back(label);
}
}
}
if (!labelList.empty()) {
mlir::Value selectExpr = hlfir::loadTrivialScalar(
loc, *builder, hlfir::Entity{getSymbolAddress(symbol)});
// Add a default error target in case the goto is nonconforming.
mlir::Block *errorBlock =
builder->getBlock()->splitBlock(builder->getInsertionPoint());
genMultiwayBranch(selectExpr, valueList, labelList,
eval.nonNopSuccessor(), errorBlock);
startBlock(errorBlock);
}
fir::runtime::genReportFatalUserError(
*builder, loc,
"Assigned GOTO variable '" + symbol.name().ToString() +
"' does not have a valid target label value");
fir::UnreachableOp::create(*builder, loc);
}
fir::ReduceOperationEnum
getReduceOperationEnum(const Fortran::parser::ReductionOperator &rOpr) {
switch (rOpr.v) {
case Fortran::parser::ReductionOperator::Operator::Plus:
return fir::ReduceOperationEnum::Add;
case Fortran::parser::ReductionOperator::Operator::Minus:
// '-' is not a valid reduction operator for DO CONCURRENT REDUCE or
// !$CUF KERNEL DO REDUCE; both are rejected during semantic checking
// before lowering is reached, so it is never lowered here.
llvm_unreachable("minus is not a valid reduction operator");
case Fortran::parser::ReductionOperator::Operator::Multiply:
return fir::ReduceOperationEnum::Multiply;
case Fortran::parser::ReductionOperator::Operator::And:
return fir::ReduceOperationEnum::AND;
case Fortran::parser::ReductionOperator::Operator::Or:
return fir::ReduceOperationEnum::OR;
case Fortran::parser::ReductionOperator::Operator::Eqv:
return fir::ReduceOperationEnum::EQV;
case Fortran::parser::ReductionOperator::Operator::Neqv:
return fir::ReduceOperationEnum::NEQV;
case Fortran::parser::ReductionOperator::Operator::Max:
return fir::ReduceOperationEnum::MAX;
case Fortran::parser::ReductionOperator::Operator::Min:
return fir::ReduceOperationEnum::MIN;
case Fortran::parser::ReductionOperator::Operator::Iand:
return fir::ReduceOperationEnum::IAND;
case Fortran::parser::ReductionOperator::Operator::Ior:
return fir::ReduceOperationEnum::IOR;
case Fortran::parser::ReductionOperator::Operator::Ieor:
return fir::ReduceOperationEnum::IEOR;
}
llvm_unreachable("illegal reduction operator");
}
/// Collect DO CONCURRENT loop control information.
IncrementLoopNestInfo getConcurrentControl(
const Fortran::parser::ConcurrentHeader &header,
const std::list<Fortran::parser::LocalitySpec> &localityList = {}) {
IncrementLoopNestInfo incrementLoopNestInfo;
for (const Fortran::parser::ConcurrentControl &control :
std::get<std::list<Fortran::parser::ConcurrentControl>>(header.t))
incrementLoopNestInfo.emplace_back(
*std::get<0>(control.t).symbol, std::get<1>(control.t),
std::get<2>(control.t), std::get<3>(control.t), /*isUnordered=*/true);
IncrementLoopInfo &info = incrementLoopNestInfo.back();
info.maskExpr = Fortran::semantics::GetExpr(
std::get<std::optional<Fortran::parser::ScalarLogicalExpr>>(header.t));
for (const Fortran::parser::LocalitySpec &x : localityList) {
if (const auto *localList =
std::get_if<Fortran::parser::LocalitySpec::Local>(&x.u))
for (const Fortran::parser::Name &x : localList->v)
info.localSymList.push_back(x.symbol);
if (const auto *localInitList =
std::get_if<Fortran::parser::LocalitySpec::LocalInit>(&x.u))
for (const Fortran::parser::Name &x : localInitList->v)
info.localInitSymList.push_back(x.symbol);
for (IncrementLoopInfo &info : incrementLoopNestInfo) {
if (const auto *reduceList =
std::get_if<Fortran::parser::LocalitySpec::Reduce>(&x.u)) {
fir::ReduceOperationEnum reduce_operation = getReduceOperationEnum(
std::get<Fortran::parser::ReductionOperator>(reduceList->t));
for (const Fortran::parser::Name &x :
std::get<std::list<Fortran::parser::Name>>(reduceList->t)) {
info.reduceSymList.push_back(x.symbol);
info.reduceOperatorList.push_back(reduce_operation);
}
}
}
if (const auto *sharedList =
std::get_if<Fortran::parser::LocalitySpec::Shared>(&x.u))
for (const Fortran::parser::Name &x : sharedList->v)
info.sharedSymList.push_back(x.symbol);
}
return incrementLoopNestInfo;
}
/// Create DO CONCURRENT construct symbol bindings and generate LOCAL_INIT
/// assignments.
void handleLocalitySpecs(const IncrementLoopInfo &info) {
Fortran::semantics::SemanticsContext &semanticsContext =
bridge.getSemanticsContext();
fir::LocalitySpecifierOperands privateClauseOps;
auto doConcurrentLoopOp =
mlir::dyn_cast_if_present<fir::DoConcurrentLoopOp>(info.loopOp);
// TODO Promote to using `enableDelayedPrivatization` (which is enabled by
// default unlike the staging flag) once the implementation of this is more
// complete.
bool useDelayedPriv = enableDelayedPrivatization && doConcurrentLoopOp;
llvm::SetVector<const Fortran::semantics::Symbol *> allPrivatizedSymbols;
llvm::SmallPtrSet<const Fortran::semantics::Symbol *, 16>
mightHaveReadHostSym;
for (const Fortran::semantics::Symbol *symToPrivatize : info.localSymList) {
if (useDelayedPriv) {
Fortran::lower::privatizeSymbol<fir::LocalitySpecifierOp>(
*this, this->getFirOpBuilder(), localSymbols, allPrivatizedSymbols,
mightHaveReadHostSym, symToPrivatize, &privateClauseOps);
continue;
}
createHostAssociateVarClone(*symToPrivatize, /*skipDefaultInit=*/false);
}
for (const Fortran::semantics::Symbol *symToPrivatize :
info.localInitSymList) {
if (useDelayedPriv) {
Fortran::lower::privatizeSymbol<fir::LocalitySpecifierOp>(
*this, this->getFirOpBuilder(), localSymbols, allPrivatizedSymbols,
mightHaveReadHostSym, symToPrivatize, &privateClauseOps);
continue;
}
createHostAssociateVarClone(*symToPrivatize, /*skipDefaultInit=*/true);
const auto *hostDetails =
symToPrivatize->detailsIf<Fortran::semantics::HostAssocDetails>();
assert(hostDetails && "missing locality spec host symbol");
const Fortran::semantics::Symbol *hostSym = &hostDetails->symbol();
Fortran::evaluate::ExpressionAnalyzer ea{semanticsContext};
Fortran::evaluate::Assignment assign{
ea.Designate(Fortran::evaluate::DataRef{*symToPrivatize}).value(),
ea.Designate(Fortran::evaluate::DataRef{*hostSym}).value()};
if (Fortran::semantics::IsPointer(*symToPrivatize))
assign.u = Fortran::evaluate::Assignment::BoundsSpec{};
genAssignment(assign);
}
for (const Fortran::semantics::Symbol *sym : info.sharedSymList) {
const auto *hostDetails =
sym->detailsIf<Fortran::semantics::HostAssocDetails>();
copySymbolBinding(hostDetails->symbol(), *sym);
}
if (useDelayedPriv) {
doConcurrentLoopOp.getLocalVarsMutable().assign(
privateClauseOps.privateVars);
doConcurrentLoopOp.setLocalSymsAttr(
builder->getArrayAttr(privateClauseOps.privateSyms));
for (auto [sym, privateVar] : llvm::zip_equal(
allPrivatizedSymbols, privateClauseOps.privateVars)) {
auto arg = doConcurrentLoopOp.getRegion().begin()->addArgument(
privateVar.getType(), doConcurrentLoopOp.getLoc());
bindSymbol(*sym, hlfir::translateToExtendedValue(
privateVar.getLoc(), *builder, hlfir::Entity{arg},
/*contiguousHint=*/true)
.first);
}
}
if (!doConcurrentLoopOp)
return;
llvm::SmallVector<bool> reduceVarByRef;
llvm::SmallVector<mlir::Attribute> reductionDeclSymbols;
llvm::SmallVector<mlir::Attribute> nestReduceAttrs;
for (const auto &reduceOp : info.reduceOperatorList)
nestReduceAttrs.push_back(
fir::ReduceAttr::get(builder->getContext(), reduceOp));
llvm::SmallVector<mlir::Value> reduceVars;
Fortran::lower::omp::ReductionProcessor rp;
bool result = rp.processReductionArguments<fir::DeclareReductionOp>(
toLocation(), *this, info.reduceOperatorList, reduceVars,
reduceVarByRef, reductionDeclSymbols, info.reduceSymList);
if (!result)
TODO(toLocation(), "Lowering unrecognised reduction type");
doConcurrentLoopOp.getReduceVarsMutable().assign(reduceVars);
doConcurrentLoopOp.setReduceSymsAttr(
reductionDeclSymbols.empty()
? nullptr
: mlir::ArrayAttr::get(builder->getContext(),
reductionDeclSymbols));
doConcurrentLoopOp.setReduceAttrsAttr(
nestReduceAttrs.empty()
? nullptr
: mlir::ArrayAttr::get(builder->getContext(), nestReduceAttrs));
doConcurrentLoopOp.setReduceByrefAttr(
reduceVarByRef.empty() ? nullptr
: mlir::DenseBoolArrayAttr::get(
builder->getContext(), reduceVarByRef));
for (auto [sym, reduceVar] :
llvm::zip_equal(info.reduceSymList, reduceVars)) {
auto arg = doConcurrentLoopOp.getRegion().begin()->addArgument(
reduceVar.getType(), doConcurrentLoopOp.getLoc());
bindSymbol(*sym, hlfir::translateToExtendedValue(
reduceVar.getLoc(), *builder, hlfir::Entity{arg},
/*contiguousHint=*/true)
.first);
}
// Note that allocatable, types with ultimate components, and type
// requiring finalization are forbidden in LOCAL/LOCAL_INIT (F2023 C1130),
// so no clean-up needs to be generated for these entities.
}
void attachInlineAttributes(
mlir::Operation &op,
const llvm::ArrayRef<const Fortran::parser::CompilerDirective *> &dirs) {
if (dirs.empty())
return;
for (mlir::Value operand : op.getOperands()) {
if (operand.getDefiningOp())
attachInlineAttributes(*operand.getDefiningOp(), dirs);
}
if (fir::CallOp callOp = mlir::dyn_cast<fir::CallOp>(op)) {
for (const auto *dir : dirs) {
Fortran::common::visit(
Fortran::common::visitors{
[&](const Fortran::parser::CompilerDirective::NoInline &) {
callOp.setInlineAttr(fir::FortranInlineEnum::no_inline);
},
[&](const Fortran::parser::CompilerDirective::Inline &) {
callOp.setInlineAttr(fir::FortranInlineEnum::inline_hint);
},
[&](const Fortran::parser::CompilerDirective::ForceInline &) {
callOp.setInlineAttr(fir::FortranInlineEnum::always_inline);
},
[&](const Fortran::parser::CompilerDirective::InlineAlways &) {
callOp.setInlineAttr(fir::FortranInlineEnum::always_inline);
},
[&](const auto &) {}},
dir->u);
}
}
}
void attachAttributesToDoLoopOperations(
fir::DoLoopOp &doLoop,
llvm::SmallVectorImpl<const Fortran::parser::CompilerDirective *> &dirs) {
if (!doLoop.getOperation() || dirs.empty())
return;
for (mlir::Block &block : doLoop.getRegion()) {
for (mlir::Operation &op : block.getOperations()) {
if (!dirs.empty())
attachInlineAttributes(op, dirs);
}
}
}
// Add AccessGroups attribute on operations in fir::DoLoopOp if this
// operation has the parallelAccesses attribute.
void attachAccessGroupAttrToDoLoopOperations(fir::DoLoopOp &doLoop) {
if (auto loopAnnotAttr = doLoop.getLoopAnnotationAttr()) {
if (loopAnnotAttr.getParallelAccesses().size()) {
llvm::SmallVector<mlir::Attribute> accessGroupAttrs(
loopAnnotAttr.getParallelAccesses().begin(),
loopAnnotAttr.getParallelAccesses().end());
mlir::ArrayAttr attrs =
mlir::ArrayAttr::get(builder->getContext(), accessGroupAttrs);
doLoop.walk([&](mlir::Operation *op) {
if (fir::StoreOp storeOp = mlir::dyn_cast<fir::StoreOp>(op)) {
storeOp.setAccessGroupsAttr(attrs);
} else if (fir::LoadOp loadOp = mlir::dyn_cast<fir::LoadOp>(op)) {
loadOp.setAccessGroupsAttr(attrs);
} else if (hlfir::AssignOp assignOp =
mlir::dyn_cast<hlfir::AssignOp>(op)) {
// In some loops, the HLFIR AssignOp operation can be translated
// into FIR operation(s) containing StoreOp. It is therefore
// necessary to forward the AccessGroups attribute.
assignOp.getOperation()->setAttr(fir::getAccessGroupsAttrName(),
attrs);
} else if (hlfir::RegionAssignOp regionAssignOp =
mlir::dyn_cast<hlfir::RegionAssignOp>(op)) {
// User defined assignment, WHERE and FORALL assignments are
// abstracted via hlfir.region_assign at that stage. Set the
// access group on it so that it can later be propagated to
// hlfir.assign/fir.store/fir.loads created to implement it.
regionAssignOp.getOperation()->setAttr(
fir::getAccessGroupsAttrName(), attrs);
} else if (fir::CallOp callOp = mlir::dyn_cast<fir::CallOp>(op)) {
callOp.setAccessGroupsAttr(attrs);
}
});
}
}
}
/// Wrap an unstructured construct's CFG in a self-contained
/// scf.execute_region and set the builder insertion point inside it. Returns
/// the created op (null if the construct isn't wrappable).
mlir::scf::ExecuteRegionOp
wrapUnstructuredConstruct(Fortran::lower::pft::Evaluation &eval,
mlir::Block *&savedExitBlock) {
if (!Fortran::lower::pft::isWrappableConstruct(
eval, bridge.getSemanticsContext()))
return nullptr;
mlir::Location loc = toLocation();
auto wrapOp =
mlir::scf::ExecuteRegionOp::create(*builder, loc, mlir::TypeRange{},
/*noInline=*/builder->getUnitAttr());
++wrapUnstructuredCount;
mlir::Block *entry = builder->createBlock(&wrapOp.getRegion());
builder->setInsertionPointToEnd(entry);
createEmptyBlocks(eval.getNestedEvaluations());
mlir::Block *yieldBlock = builder->createBlock(&wrapOp.getRegion());
builder->setInsertionPointToEnd(yieldBlock);
mlir::scf::YieldOp::create(*builder, loc);
if (eval.constructExit) {
savedExitBlock = eval.constructExit->block;
eval.constructExit->block = yieldBlock;
}
builder->setInsertionPointToEnd(entry);
return wrapOp;
}
/// Finalize a wrap created by wrapUnstructuredConstruct: restore the
/// original exit block and set the insertion point after the wrap op.
void closeUnstructuredWrap(mlir::scf::ExecuteRegionOp wrapOp,
Fortran::lower::pft::Evaluation &eval,
mlir::Block *savedExitBlock) {
if (!wrapOp)
return;
if (eval.constructExit)
eval.constructExit->block = savedExitBlock;
builder->setInsertionPointAfter(wrapOp);
}
/// Generate FIR for a DO construct. There are six variants:
/// - unstructured infinite and while loops
/// - structured and unstructured increment loops
/// - structured and unstructured concurrent loops
void genFIR(const Fortran::parser::DoConstruct &doConstruct) {
setCurrentPositionAt(doConstruct);
Fortran::lower::pft::Evaluation &eval = getEval();
bool unstructuredContext = eval.lowerAsUnstructured();
// If this do-loop was absorbed by a collapse clause on a parent acc.loop,
// skip generating any loop — just lower the body. The IV value is
// already available from the parent acc.loop's block argument.
if (Fortran::lower::isCollapsedDoConstruct(doConstruct)) {
auto iter = eval.getNestedEvaluations().begin();
for (auto end = --eval.getNestedEvaluations().end(); iter != end; ++iter)
genFIR(*iter, unstructuredContext);
return;
}
// Loops with induction variables inside OpenACC compute constructs or
// explicit `!$acc routine` procedures need special handling to ensure that
// the IVs are privatized.
if (Fortran::lower::shouldLowerDoConstructAsAccLoop(*builder)) {
// Open up a new scope for the loop variables.
localSymbols.pushScope();
llvm::scope_exit scopeGuard([&]() { localSymbols.popScope(); });
mlir::Operation *loopOp = Fortran::lower::genOpenACCLoopFromDoConstruct(
*this, bridge.getSemanticsContext(), localSymbols, doConstruct, eval);
bool success = loopOp != nullptr;
if (success) {
// Sanity check that the builder insertion point is inside the newly
// generated loop.
assert(
loopOp->getRegion(0).isAncestor(
builder->getInsertionPoint()->getBlock()->getParent()) &&
"builder insertion point is not inside the newly generated loop");
// Loop body code.
auto iter = eval.getNestedEvaluations().begin();
for (auto end = --eval.getNestedEvaluations().end(); iter != end;
++iter)
genFIR(*iter, unstructuredContext);
builder->setInsertionPointAfter(loopOp);
return;
}
// Fall back to normal loop handling.
}
// Collect loop nest information.
// Generate begin loop code directly for infinite and while loops.
Fortran::lower::pft::Evaluation &doStmtEval =
eval.getFirstNestedEvaluation();
auto *doStmt = doStmtEval.getIf<Fortran::parser::NonLabelDoStmt>();
const auto &loopControl =
std::get<std::optional<Fortran::parser::LoopControl>>(doStmt->t);
mlir::Block *preheaderBlock = doStmtEval.block;
mlir::Block *beginBlock =
preheaderBlock ? preheaderBlock : builder->getBlock();
auto createNextBeginBlock = [&]() {
// Step beginBlock through unstructured preheader, header, and mask
// blocks, created in outermost to innermost order.
return beginBlock = beginBlock->splitBlock(beginBlock->end());
};
// headerBlock is computed per-branch below, after wrapping, so that
// beginBlock can be corrected to the scf entry when wrapping occurs.
mlir::Block *headerBlock = nullptr;
mlir::Block *bodyBlock = doStmtEval.lexicalSuccessor->block;
mlir::Block *exitBlock = doStmtEval.parentConstruct->constructExit->block;
mlir::Block *savedExitBlock = nullptr;
mlir::scf::ExecuteRegionOp wrapOp = nullptr;
// Helper: called after maybeStartBlock(preheaderBlock) to create the
// scf.execute_region (if the construct is wrappable) and then update
// beginBlock/bodyBlock/exitBlock so that all loop structure lands inside
// the newly created region.
auto maybeWrapAndRecalc = [&]() {
wrapOp = unstructuredContext
? wrapUnstructuredConstruct(eval, savedExitBlock)
: nullptr;
if (wrapOp) {
LLVM_DEBUG({
llvm::dbgs() << "[wrap-unstructured] wrapped DO at ";
wrapOp.getLoc().print(llvm::dbgs());
llvm::dbgs() << "\n";
});
// After wrapping, the builder is positioned at the scf entry block.
// createEmptyBlocks (called inside wrapUnstructuredConstruct) may have
// allocated a dedicated preheader block inside the scf region and
// stored it in doStmtEval.block. If so, branch to it from scf_entry
// and use it as beginBlock; otherwise use scf_entry directly.
mlir::Block *newPreheader = doStmtEval.block;
if (newPreheader && newPreheader != preheaderBlock) {
beginBlock = newPreheader;
maybeStartBlock(beginBlock);
} else {
beginBlock = builder->getBlock();
}
bodyBlock = doStmtEval.lexicalSuccessor->block;
exitBlock = doStmtEval.parentConstruct->constructExit->block;
}
headerBlock = createNextBeginBlock();
};
IncrementLoopNestInfo incrementLoopNestInfo;
const Fortran::parser::ScalarLogicalExpr *whileCondition = nullptr;
bool infiniteLoop = !loopControl.has_value();
if (infiniteLoop) {
assert(unstructuredContext && "infinite loop must be unstructured");
// Infinite loops are never wrappable; maybeWrapAndRecalc is a no-op here,
// but call it for uniformity so wrapOp stays null.
maybeWrapAndRecalc();
startBlock(headerBlock);
} else if ((whileCondition =
std::get_if<Fortran::parser::ScalarLogicalExpr>(
&loopControl->u))) {
// Optionally lower a restricted subset of DO WHILE loops directly to
// scf.while. This subset excludes early-exit constructs (EXIT/CYCLE/GOTO,
// etc.) by requiring that the loop body is structured (as decided by the
// PFT branch analysis), allowing the loop to exit only when the condition
// becomes false.
if (!unstructuredContext) {
genDoWhileAsSCFWhile(*whileCondition, eval, doStmtEval);
return;
}
assert(unstructuredContext && "while loop must be unstructured");
maybeStartBlock(preheaderBlock); // no block or empty block
maybeWrapAndRecalc();
startBlock(headerBlock);
genConditionalBranch(*whileCondition, bodyBlock, exitBlock);
} else if (const auto *bounds =
std::get_if<Fortran::parser::LoopControl::Bounds>(
&loopControl->u)) {
// Non-concurrent increment loop.
IncrementLoopInfo &info = incrementLoopNestInfo.emplace_back(
*bounds->Name().thing.symbol, bounds->Lower(), bounds->Upper(),
bounds->Step());
if (unstructuredContext) {
maybeStartBlock(preheaderBlock);
maybeWrapAndRecalc();
info.hasRealControl = info.loopVariableSym->GetType()->IsNumeric(
Fortran::common::TypeCategory::Real);
info.headerBlock = headerBlock;
info.bodyBlock = bodyBlock;
info.exitBlock = exitBlock;
}
} else {
const auto *concurrent =
std::get_if<Fortran::parser::LoopControl::Concurrent>(
&loopControl->u);
assert(concurrent && "invalid DO loop variant");
incrementLoopNestInfo = getConcurrentControl(
std::get<Fortran::parser::ConcurrentHeader>(concurrent->t),
std::get<std::list<Fortran::parser::LocalitySpec>>(concurrent->t));
if (unstructuredContext) {
maybeStartBlock(preheaderBlock);
maybeWrapAndRecalc();
for (IncrementLoopInfo &info : incrementLoopNestInfo) {
// The original loop body provides the body and latch blocks of the
// innermost dimension. The (first) body block of a non-innermost
// dimension is the preheader block of the immediately enclosed
// dimension. The latch block of a non-innermost dimension is the
// exit block of the immediately enclosed dimension.
auto createNextExitBlock = [&]() {
// Create unstructured loop exit blocks, outermost to innermost.
return exitBlock = insertBlock(exitBlock);
};
bool isInnermost = &info == &incrementLoopNestInfo.back();
bool isOutermost = &info == &incrementLoopNestInfo.front();
info.headerBlock = isOutermost ? headerBlock : createNextBeginBlock();
info.bodyBlock = isInnermost ? bodyBlock : createNextBeginBlock();
info.exitBlock = isOutermost ? exitBlock : createNextExitBlock();
if (info.maskExpr)
info.maskBlock = createNextBeginBlock();
}
}
}
// Introduce a `do concurrent` scope to bind symbols corresponding to local,
// local_init, and reduce region arguments.
if (!incrementLoopNestInfo.empty() &&
incrementLoopNestInfo.back().isConcurrent)
localSymbols.pushScope();
// Increment loop begin code. (Infinite/while code was already generated.)
if (!infiniteLoop && !whileCondition)
genFIRIncrementLoopBegin(incrementLoopNestInfo, doStmtEval.dirs);
// Loop body code.
auto iter = eval.getNestedEvaluations().begin();
for (auto end = --eval.getNestedEvaluations().end(); iter != end; ++iter)
genFIR(*iter, unstructuredContext);
// An EndDoStmt in unstructured code may start a new block.
Fortran::lower::pft::Evaluation &endDoEval = *iter;
assert(endDoEval.getIf<Fortran::parser::EndDoStmt>() && "no enddo stmt");
if (unstructuredContext)
maybeStartBlock(endDoEval.block);
// Loop end code.
if (infiniteLoop || whileCondition)
genBranch(headerBlock);
else
genFIRIncrementLoopEnd(incrementLoopNestInfo);
// This call may generate a branch in some contexts.
genFIR(endDoEval, unstructuredContext);
// Add AccessGroups attribute on operations in fir::DoLoopOp if necessary
for (IncrementLoopInfo &info : incrementLoopNestInfo)
if (auto loopOp = mlir::dyn_cast_if_present<fir::DoLoopOp>(info.loopOp))
attachAccessGroupAttrToDoLoopOperations(loopOp);
if (!incrementLoopNestInfo.empty() &&
incrementLoopNestInfo.back().isConcurrent)
localSymbols.popScope();
// Add attribute(s) on operations in fir::DoLoopOp if necessary
for (IncrementLoopInfo &info : incrementLoopNestInfo)
if (auto loopOp = mlir::dyn_cast_if_present<fir::DoLoopOp>(info.loopOp))
attachAttributesToDoLoopOperations(loopOp, doStmtEval.dirs);
closeUnstructuredWrap(wrapOp, eval, savedExitBlock);
}
/// Generate FIR to evaluate loop control values (lower, upper and step).
mlir::Value genControlValue(const Fortran::lower::SomeExpr *expr,
const IncrementLoopInfo &info,
bool *isConst = nullptr) {
mlir::Location loc = toLocation();
mlir::Type controlType = info.isStructured() && info.isConcurrent
? builder->getIndexType()
: info.getLoopVariableType();
Fortran::lower::StatementContext stmtCtx;
if (expr) {
if (isConst)
*isConst = Fortran::evaluate::IsConstantExpr(*expr);
return builder->createConvert(loc, controlType,
createFIRExpr(loc, expr, stmtCtx));
}
if (isConst)
*isConst = true;
if (info.hasRealControl)
return builder->createRealConstant(loc, controlType, 1u);
return builder->createIntegerConstant(loc, controlType, 1); // step
}
void addLoopAnnotationAttr(
IncrementLoopInfo &info,
llvm::SmallVectorImpl<const Fortran::parser::CompilerDirective *> &dirs) {
mlir::LLVM::LoopAnnotationAttr la =
Fortran::lower::genLoopAnnotationAttr(builder->getContext(), dirs);
if (!la)
return;
if (auto loopOp = mlir::dyn_cast<fir::DoLoopOp>(info.loopOp))
loopOp.setLoopAnnotationAttr(la);
if (auto doConcurrentOp =
mlir::dyn_cast<fir::DoConcurrentLoopOp>(info.loopOp))
doConcurrentOp.setLoopAnnotationAttr(la);
}
/// Generate FIR to begin a structured or unstructured increment loop nest.
void genFIRIncrementLoopBegin(
IncrementLoopNestInfo &incrementLoopNestInfo,
llvm::SmallVectorImpl<const Fortran::parser::CompilerDirective *> &dirs) {
assert(!incrementLoopNestInfo.empty() && "empty loop nest");
mlir::Location loc = toLocation();
mlir::arith::IntegerOverflowFlags iofBackup{};
llvm::SmallVector<mlir::Value> nestLBs;
llvm::SmallVector<mlir::Value> nestUBs;
llvm::SmallVector<mlir::Value> nestSts;
llvm::SmallVector<mlir::Value> nestReduceOperands;
llvm::SmallVector<mlir::Attribute> nestReduceAttrs;
bool genDoConcurrent = false;
for (IncrementLoopInfo &info : incrementLoopNestInfo) {
genDoConcurrent = info.isStructured() && info.isConcurrent;
if (!genDoConcurrent)
info.loopVariable = genLoopVariableAddress(loc, *info.loopVariableSym,
info.isConcurrent);
if (!getLoweringOptions().getIntegerWrapAround()) {
iofBackup = builder->getIntegerOverflowFlags();
builder->setIntegerOverflowFlags(
mlir::arith::IntegerOverflowFlags::nsw);
}
nestLBs.push_back(genControlValue(info.lowerExpr, info));
nestUBs.push_back(genControlValue(info.upperExpr, info));
bool isConst = true;
nestSts.push_back(genControlValue(
info.stepExpr, info, info.isStructured() ? nullptr : &isConst));
if (!getLoweringOptions().getIntegerWrapAround())
builder->setIntegerOverflowFlags(iofBackup);
// Use a temp variable for unstructured loops with non-const step.
if (!isConst) {
mlir::Value stepValue = nestSts.back();
info.stepVariable = builder->createTemporary(loc, stepValue.getType());
fir::StoreOp::create(*builder, loc, stepValue, info.stepVariable);
}
}
for (auto [info, lowerValue, upperValue, stepValue] :
llvm::zip_equal(incrementLoopNestInfo, nestLBs, nestUBs, nestSts)) {
// Structured loop - generate fir.do_loop.
if (info.isStructured()) {
if (genDoConcurrent)
continue;
// Lower the loop without the secondary-induction iter_arg so memory
// recurrences (e.g. reductions) stay visible to later analyses. The DO
// variable is recomputed from the induction variable in the body; its
// post-loop value is materialized in genFIRIncrementLoopEnd.
auto loopOp = fir::DoLoopOp::create(
*builder, loc, lowerValue, upperValue, stepValue,
/*unordered=*/false, /*finalCountValue=*/false,
/*iterArgs=*/mlir::ValueRange{});
info.loopOp = loopOp;
builder->setInsertionPointToStart(loopOp.getBody());
fir::StoreOp::create(*builder, loc, loopOp.getInductionVar(),
info.loopVariable);
addLoopAnnotationAttr(info, dirs);
continue;
}
// Unstructured loop preheader - initialize tripVariable and loopVariable.
mlir::Value tripCount;
if (info.hasRealControl) {
auto diff1 =
mlir::arith::SubFOp::create(*builder, loc, upperValue, lowerValue);
auto diff2 =
mlir::arith::AddFOp::create(*builder, loc, diff1, stepValue);
tripCount =
mlir::arith::DivFOp::create(*builder, loc, diff2, stepValue);
tripCount =
builder->createConvert(loc, builder->getIndexType(), tripCount);
} else {
auto diff1 =
mlir::arith::SubIOp::create(*builder, loc, upperValue, lowerValue);
auto diff2 =
mlir::arith::AddIOp::create(*builder, loc, diff1, stepValue);
tripCount =
mlir::arith::DivSIOp::create(*builder, loc, diff2, stepValue);
}
if (forceLoopToExecuteOnce) { // minimum tripCount is 1
mlir::Value one =
builder->createIntegerConstant(loc, tripCount.getType(), 1);
auto cond = mlir::arith::CmpIOp::create(
*builder, loc, mlir::arith::CmpIPredicate::slt, tripCount, one);
tripCount =
mlir::arith::SelectOp::create(*builder, loc, cond, one, tripCount);
}
info.tripVariable = builder->createTemporary(loc, tripCount.getType());
fir::StoreOp::create(*builder, loc, tripCount, info.tripVariable);
fir::StoreOp::create(*builder, loc, lowerValue, info.loopVariable);
// Unstructured loop header - generate loop condition and mask.
// Note - Currently there is no way to tag a loop as a concurrent loop.
startBlock(info.headerBlock);
tripCount = fir::LoadOp::create(*builder, loc, info.tripVariable);
mlir::Value zero =
builder->createIntegerConstant(loc, tripCount.getType(), 0);
auto cond = mlir::arith::CmpIOp::create(
*builder, loc, mlir::arith::CmpIPredicate::sgt, tripCount, zero);
if (info.maskExpr) {
genConditionalBranch(cond, info.maskBlock, info.exitBlock);
startBlock(info.maskBlock);
mlir::Block *latchBlock = getEval().getLastNestedEvaluation().block;
assert(latchBlock && "missing masked concurrent loop latch block");
Fortran::lower::StatementContext stmtCtx;
mlir::Value maskCond = createFIRExpr(loc, info.maskExpr, stmtCtx);
stmtCtx.finalizeAndReset();
genConditionalBranch(maskCond, info.bodyBlock, latchBlock);
} else {
genConditionalBranch(cond, info.bodyBlock, info.exitBlock);
if (&info != &incrementLoopNestInfo.back()) // not innermost
startBlock(info.bodyBlock); // preheader block of enclosed dimension
}
if (info.hasLocalitySpecs()) {
mlir::OpBuilder::InsertPoint insertPt = builder->saveInsertionPoint();
builder->setInsertionPointToStart(info.bodyBlock);
handleLocalitySpecs(info);
builder->restoreInsertionPoint(insertPt);
}
}
if (genDoConcurrent) {
auto loopWrapperOp = fir::DoConcurrentOp::create(*builder, loc);
builder->setInsertionPointToStart(
builder->createBlock(&loopWrapperOp.getRegion()));
for (IncrementLoopInfo &info : llvm::reverse(incrementLoopNestInfo)) {
info.loopVariable = genLoopVariableAddress(loc, *info.loopVariableSym,
info.isConcurrent);
}
builder->setInsertionPointToEnd(loopWrapperOp.getBody());
auto loopOp = fir::DoConcurrentLoopOp::create(
*builder, loc, nestLBs, nestUBs, nestSts, /*loopAnnotation=*/nullptr,
/*local_vars=*/mlir::ValueRange{},
/*local_syms=*/nullptr, /*reduce_vars=*/mlir::ValueRange{},
/*reduce_byref=*/nullptr, /*reduce_syms=*/nullptr,
/*reduce_attrs=*/nullptr);
llvm::SmallVector<mlir::Type> loopBlockArgTypes(
incrementLoopNestInfo.size(), builder->getIndexType());
llvm::SmallVector<mlir::Location> loopBlockArgLocs(
incrementLoopNestInfo.size(), loc);
mlir::Region &loopRegion = loopOp.getRegion();
mlir::Block *loopBlock = builder->createBlock(
&loopRegion, loopRegion.begin(), loopBlockArgTypes, loopBlockArgLocs);
builder->setInsertionPointToStart(loopBlock);
for (auto [info, blockArg] :
llvm::zip_equal(incrementLoopNestInfo, loopBlock->getArguments())) {
info.loopOp = loopOp;
mlir::Value loopValue =
builder->createConvert(loc, info.getLoopVariableType(), blockArg);
fir::StoreOp::create(*builder, loc, loopValue, info.loopVariable);
if (info.maskExpr) {
Fortran::lower::StatementContext stmtCtx;
mlir::Value maskCond = createFIRExpr(loc, info.maskExpr, stmtCtx);
stmtCtx.finalizeAndReset();
mlir::Value maskCondCast =
builder->createConvert(loc, builder->getI1Type(), maskCond);
auto ifOp = fir::IfOp::create(*builder, loc, maskCondCast,
/*withElseRegion=*/false);
builder->setInsertionPointToStart(&ifOp.getThenRegion().front());
}
}
IncrementLoopInfo &innermostInfo = incrementLoopNestInfo.back();
if (innermostInfo.hasLocalitySpecs())
handleLocalitySpecs(innermostInfo);
addLoopAnnotationAttr(innermostInfo, dirs);
}
}
/// Generate FIR to end a structured or unstructured increment loop nest.
void genFIRIncrementLoopEnd(IncrementLoopNestInfo &incrementLoopNestInfo) {
assert(!incrementLoopNestInfo.empty() && "empty loop nest");
mlir::Location loc = toLocation();
mlir::arith::IntegerOverflowFlags flags{};
if (!getLoweringOptions().getIntegerWrapAround())
flags = bitEnumSet(flags, mlir::arith::IntegerOverflowFlags::nsw);
auto iofAttr = mlir::arith::IntegerOverflowFlagsAttr::get(
builder->getContext(), flags);
for (auto it = incrementLoopNestInfo.rbegin(),
rend = incrementLoopNestInfo.rend();
it != rend; ++it) {
IncrementLoopInfo &info = *it;
if (info.isStructured()) {
// End fir.do_concurent.loop.
if (info.isConcurrent) {
builder->setInsertionPointAfter(info.loopOp->getParentOp());
continue;
}
// End fir.do_loop. The loop carries no secondary-induction iter_arg, so
// materialize the Fortran post-loop value lb + tripCount*step after the
// loop for later uses of the DO variable. Compute it in the loop's
// index type (matching how the loop counts iterations) so the trip
// arithmetic does not overflow the DO variable's type for empty
// range-extreme loops.
auto doLoopOp = mlir::cast<fir::DoLoopOp>(info.loopOp);
builder->setInsertionPointAfter(doLoopOp);
mlir::Type idxTy = builder->getIndexType();
mlir::Value lb =
builder->createConvert(loc, idxTy, doLoopOp.getLowerBound());
mlir::Value ub =
builder->createConvert(loc, idxTy, doLoopOp.getUpperBound());
mlir::Value st = builder->createConvert(loc, idxTy, doLoopOp.getStep());
mlir::Value zero = builder->createIntegerConstant(loc, idxTy, 0);
mlir::Value trip = mlir::arith::SubIOp::create(*builder, loc, ub, lb);
trip = mlir::arith::AddIOp::create(*builder, loc, trip, st);
trip = mlir::arith::DivSIOp::create(*builder, loc, trip, st);
mlir::Value empty = mlir::arith::CmpIOp::create(
*builder, loc, mlir::arith::CmpIPredicate::slt, trip, zero);
trip = mlir::arith::SelectOp::create(*builder, loc, empty, zero, trip);
mlir::Value last = mlir::arith::MulIOp::create(*builder, loc, trip, st);
last = mlir::arith::AddIOp::create(*builder, loc, lb, last);
last = builder->createConvert(loc, info.getLoopVariableType(), last);
fir::StoreOp::create(*builder, loc, last, info.loopVariable);
continue;
}
// Unstructured loop - decrement tripVariable and step loopVariable.
mlir::Value tripCount =
fir::LoadOp::create(*builder, loc, info.tripVariable);
mlir::Value one =
builder->createIntegerConstant(loc, tripCount.getType(), 1);
tripCount = mlir::arith::SubIOp::create(*builder, loc, tripCount, one);
fir::StoreOp::create(*builder, loc, tripCount, info.tripVariable);
mlir::Value value = fir::LoadOp::create(*builder, loc, info.loopVariable);
mlir::Value step;
if (info.stepVariable)
step = fir::LoadOp::create(*builder, loc, info.stepVariable);
else
step = genControlValue(info.stepExpr, info);
if (info.hasRealControl)
value = mlir::arith::AddFOp::create(*builder, loc, value, step);
else
value =
mlir::arith::AddIOp::create(*builder, loc, value, step, iofAttr);
fir::StoreOp::create(*builder, loc, value, info.loopVariable);
genBranch(info.headerBlock);
if (&info != &incrementLoopNestInfo.front()) // not outermost
startBlock(info.exitBlock); // latch block of enclosing dimension
}
}
/// Generate structured or unstructured FIR for an IF construct.
/// The initial statement may be either an IfStmt or an IfThenStmt.
void genFIR(const Fortran::parser::IfConstruct &) {
Fortran::lower::pft::Evaluation &eval = getEval();
// Structured fir.if nest.
if (eval.lowerAsStructured()) {
fir::IfOp topIfOp, currentIfOp;
for (Fortran::lower::pft::Evaluation &e : eval.getNestedEvaluations()) {
auto genIfOp = [&](mlir::Value cond) {
Fortran::lower::pft::Evaluation &succ = *e.controlSuccessor;
bool hasElse = succ.isA<Fortran::parser::ElseIfStmt>() ||
succ.isA<Fortran::parser::ElseStmt>();
auto ifOp = fir::IfOp::create(*builder, toLocation(), cond,
/*withElseRegion=*/hasElse);
builder->setInsertionPointToStart(&ifOp.getThenRegion().front());
return ifOp;
};
setCurrentPosition(e.position);
if (auto *s = e.getIf<Fortran::parser::IfThenStmt>()) {
topIfOp = currentIfOp = genIfOp(genIfCondition(s, e.negateCondition));
} else if (auto *s = e.getIf<Fortran::parser::IfStmt>()) {
topIfOp = currentIfOp = genIfOp(genIfCondition(s, e.negateCondition));
} else if (auto *s = e.getIf<Fortran::parser::ElseIfStmt>()) {
builder->setInsertionPointToStart(
&currentIfOp.getElseRegion().front());
currentIfOp = genIfOp(genIfCondition(s));
} else if (e.isA<Fortran::parser::ElseStmt>()) {
builder->setInsertionPointToStart(
&currentIfOp.getElseRegion().front());
} else if (e.isA<Fortran::parser::EndIfStmt>()) {
builder->setInsertionPointAfter(topIfOp);
genFIR(e, /*unstructuredContext=*/false); // may generate branch
} else {
genFIR(e, /*unstructuredContext=*/false);
}
}
return;
}
// Start a new block before generating the scf.execute_region op if needed.
// This avoids generating the region directly after a terminator (e.g. a
// conditional branch from a parent construct). A non-null firstStmt.block
// here is a landing pad the enclosing wrap's createEmptyBlocks pre-
// allocated for us — startNewFunction runs resetEvaluationBlocks before
// each entry-point pass, so we can trust the pointer isn't stale from a
// previous pass.
if (Fortran::lower::pft::isWrappableConstruct(
eval, bridge.getSemanticsContext()) &&
eval.hasNestedEvaluations()) {
Fortran::lower::pft::Evaluation &firstStmt =
eval.getFirstNestedEvaluation();
if (firstStmt.block)
maybeStartBlock(firstStmt.block);
}
mlir::Block *savedExitBlock = nullptr;
mlir::scf::ExecuteRegionOp wrapOp =
wrapUnstructuredConstruct(eval, savedExitBlock);
if (wrapOp) {
LLVM_DEBUG({
llvm::dbgs() << "[wrap-unstructured] wrapped IF at ";
wrapOp.getLoc().print(llvm::dbgs());
llvm::dbgs() << "\n";
});
}
llvm::SmallVector<Fortran::lower::pft::Evaluation *> exits, fallThroughs;
collectFinalEvaluations(eval, exits, fallThroughs);
for (Fortran::lower::pft::Evaluation &e : eval.getNestedEvaluations()) {
auto genIfBranch = [&](mlir::Value cond) {
if (e.lexicalSuccessor == e.controlSuccessor) // empty block -> exit
genConditionalBranch(cond, e.parentConstruct->constructExit,
e.controlSuccessor);
else // non-empty block
genConditionalBranch(cond, e.lexicalSuccessor, e.controlSuccessor);
};
setCurrentPosition(e.position);
if (auto *s = e.getIf<Fortran::parser::IfThenStmt>()) {
maybeStartBlock(e.block);
genIfBranch(genIfCondition(s, e.negateCondition));
} else if (auto *s = e.getIf<Fortran::parser::IfStmt>()) {
maybeStartBlock(e.block);
genIfBranch(genIfCondition(s, e.negateCondition));
} else if (auto *s = e.getIf<Fortran::parser::ElseIfStmt>()) {
startBlock(e.block);
genIfBranch(genIfCondition(s));
} else {
genFIR(e);
if (blockIsUnterminated()) {
if (llvm::is_contained(exits, &e))
genConstructExitBranch(*eval.constructExit);
else if (llvm::is_contained(fallThroughs, &e))
genBranch(e.lexicalSuccessor->block);
}
}
}
closeUnstructuredWrap(wrapOp, eval, savedExitBlock);
}
void genCaseOrRankConstruct() {
Fortran::lower::pft::Evaluation &eval = getEval();
Fortran::lower::StatementContext stmtCtx;
pushActiveConstruct(eval, stmtCtx);
llvm::SmallVector<Fortran::lower::pft::Evaluation *> exits, fallThroughs;
collectFinalEvaluations(eval, exits, fallThroughs);
for (Fortran::lower::pft::Evaluation &e : eval.getNestedEvaluations()) {
if (e.getIf<Fortran::parser::EndSelectStmt>())
maybeStartBlock(e.block);
else
genFIR(e);
if (blockIsUnterminated()) {
if (llvm::is_contained(exits, &e))
genConstructExitBranch(*eval.constructExit);
else if (llvm::is_contained(fallThroughs, &e))
genBranch(e.lexicalSuccessor->block);
}
}
popActiveConstruct();
}
void genFIR(const Fortran::parser::CaseConstruct &) {
genCaseOrRankConstruct();
}
template <typename A>
void genNestedStatement(const Fortran::parser::Statement<A> &stmt) {
setCurrentPosition(stmt.source);
genFIR(stmt.statement);
}
void genFIR(const Fortran::parser::ForallAssignmentStmt &stmt) {
Fortran::common::visit([&](const auto &x) { genFIR(x); }, stmt.u);
}
void genFIR(const Fortran::parser::EndForallStmt &) {}
/// Generate FIR for a FORALL statement.
void genFIR(const Fortran::parser::ForallStmt &stmt) {
const auto &concurrentHeader =
std::get<
Fortran::common::Indirection<Fortran::parser::ConcurrentHeader>>(
stmt.t)
.value();
mlir::OpBuilder::InsertionGuard guard(*builder);
Fortran::lower::SymMapScope scope(localSymbols);
genForallNest(concurrentHeader);
genFIR(std::get<Fortran::parser::UnlabeledStatement<
Fortran::parser::ForallAssignmentStmt>>(stmt.t)
.statement);
}
/// Generate FIR for a FORALL construct.
void genFIR(const Fortran::parser::ForallConstruct &forall) {
setCurrentPositionAt(forall);
mlir::OpBuilder::InsertPoint insertPt = builder->saveInsertionPoint();
localSymbols.pushScope();
genNestedStatement(
std::get<
Fortran::parser::Statement<Fortran::parser::ForallConstructStmt>>(
forall.t));
for (const Fortran::parser::ForallBodyConstruct &s :
std::get<std::list<Fortran::parser::ForallBodyConstruct>>(forall.t)) {
Fortran::common::visit(
Fortran::common::visitors{
[&](const Fortran::parser::WhereConstruct &b) { genFIR(b); },
[&](const Fortran::common::Indirection<
Fortran::parser::ForallConstruct> &b) { genFIR(b.value()); },
[&](const auto &b) { genNestedStatement(b); }},
s.u);
}
genNestedStatement(
std::get<Fortran::parser::Statement<Fortran::parser::EndForallStmt>>(
forall.t));
localSymbols.popScope();
builder->restoreInsertionPoint(insertPt);
}
/// Lower the concurrent header specification.
void genFIR(const Fortran::parser::ForallConstructStmt &stmt) {
const auto &concurrentHeader =
std::get<
Fortran::common::Indirection<Fortran::parser::ConcurrentHeader>>(
stmt.t)
.value();
genForallNest(concurrentHeader);
}
/// Generate hlfir.forall and hlfir.forall_mask nest given a Forall
/// concurrent header
void genForallNest(const Fortran::parser::ConcurrentHeader &header) {
mlir::Location loc = getCurrentLocation();
const bool isOutterForall = !isInsideHlfirForallOrWhere();
hlfir::ForallOp outerForall;
auto evaluateControl = [&](const auto &parserExpr, mlir::Region &region,
bool isMask = false) {
if (region.empty())
builder->createBlock(&region);
Fortran::lower::StatementContext localStmtCtx;
const Fortran::semantics::SomeExpr *anlalyzedExpr =
Fortran::semantics::GetExpr(parserExpr);
assert(anlalyzedExpr && "expression semantics failed");
// Generate the controls of outer forall outside of the hlfir.forall
// region. They do not depend on any previous forall indices (C1123) and
// no assignment has been made yet that could modify their value. This
// will simplify hlfir.forall analysis because the SSA integer value
// yielded will obviously not depend on any variable modified by the
// forall when produced outside of it.
// This is not done for the mask because it may (and in usual code, does)
// depend on the forall indices that have just been defined as
// hlfir.forall block arguments.
mlir::OpBuilder::InsertPoint innerInsertionPoint;
if (outerForall && !isMask) {
innerInsertionPoint = builder->saveInsertionPoint();
builder->setInsertionPoint(outerForall);
}
mlir::Value exprVal =
fir::getBase(genExprValue(*anlalyzedExpr, localStmtCtx, &loc));
localStmtCtx.finalizeAndPop();
if (isMask)
exprVal = builder->createConvert(loc, builder->getI1Type(), exprVal);
if (innerInsertionPoint.isSet())
builder->restoreInsertionPoint(innerInsertionPoint);
hlfir::YieldOp::create(*builder, loc, exprVal);
};
for (const Fortran::parser::ConcurrentControl &control :
std::get<std::list<Fortran::parser::ConcurrentControl>>(header.t)) {
auto forallOp = hlfir::ForallOp::create(*builder, loc);
if (isOutterForall && !outerForall)
outerForall = forallOp;
evaluateControl(std::get<1>(control.t), forallOp.getLbRegion());
evaluateControl(std::get<2>(control.t), forallOp.getUbRegion());
if (const auto &optionalStep =
std::get<std::optional<Fortran::parser::ScalarIntExpr>>(
control.t))
evaluateControl(*optionalStep, forallOp.getStepRegion());
// Create block argument and map it to a symbol via an hlfir.forall_index
// op (symbols must be mapped to in memory values).
const Fortran::semantics::Symbol *controlVar =
std::get<Fortran::parser::Name>(control.t).symbol;
assert(controlVar && "symbol analysis failed");
mlir::Type controlVarType = genType(*controlVar);
mlir::Block *forallBody = builder->createBlock(&forallOp.getBody(), {},
{controlVarType}, {loc});
auto forallIndex = hlfir::ForallIndexOp::create(
*builder, loc, fir::ReferenceType::get(controlVarType),
forallBody->getArguments()[0],
builder->getStringAttr(controlVar->name().ToString()));
localSymbols.addVariableDefinition(*controlVar, forallIndex,
/*force=*/true);
auto end = fir::FirEndOp::create(*builder, loc);
builder->setInsertionPoint(end);
}
if (const auto &maskExpr =
std::get<std::optional<Fortran::parser::ScalarLogicalExpr>>(
header.t)) {
// Create hlfir.forall_mask and set insertion point in its body.
auto forallMaskOp = hlfir::ForallMaskOp::create(*builder, loc);
evaluateControl(*maskExpr, forallMaskOp.getMaskRegion(), /*isMask=*/true);
builder->createBlock(&forallMaskOp.getBody());
auto end = fir::FirEndOp::create(*builder, loc);
builder->setInsertionPoint(end);
}
}
void attachDirectiveToLoop(const Fortran::parser::CompilerDirective &dir,
Fortran::lower::pft::Evaluation *e) {
auto attachToDoStmt = [&](Fortran::lower::pft::Evaluation *doEval) {
if (doEval && doEval->isA<Fortran::parser::NonLabelDoStmt>())
doEval->dirs.push_back(&dir);
};
// Dive into an OpenACC loop/combined construct to find its NonLabelDoStmt.
auto findDoStmtInOpenACC = [](Fortran::lower::pft::Evaluation *eval)
-> Fortran::lower::pft::Evaluation * {
const auto *acc = eval->getIf<Fortran::parser::OpenACCConstruct>();
if (!acc)
return nullptr;
if (!std::holds_alternative<Fortran::parser::OpenACCLoopConstruct>(
acc->u) &&
!std::holds_alternative<Fortran::parser::OpenACCCombinedConstruct>(
acc->u))
return nullptr;
if (!eval->hasNestedEvaluations())
return nullptr;
for (Fortran::lower::pft::Evaluation &nested :
eval->getNestedEvaluations()) {
if (nested.isA<Fortran::parser::DoConstruct>() &&
nested.hasNestedEvaluations())
return &nested.getFirstNestedEvaluation();
}
return nullptr;
};
while (e->isDirective()) {
if (Fortran::lower::pft::Evaluation *doStmt = findDoStmtInOpenACC(e)) {
attachToDoStmt(doStmt);
return;
}
e = e->lexicalSuccessor;
if (!e)
return;
}
attachToDoStmt(e);
}
/// Diagnose each evaluation in \p skipped: these are evaluations that
/// were skipped over while descending a collapsed or tiled loop nest to
/// find the next inner DO CONSTRUCT (see findNestedDoConstructEvaluation).
///
/// The NonLabelDoStmt heading the level being searched is always present
/// and is silently expected. A compiler directive (e.g. !DIR$ IVDEP) is
/// the only other kind of skipped evaluation known to legitimately
/// appear here (OpenACC's collapse/tile clauses do not otherwise require
/// the loop nest to be tightly nested, unlike e.g. CUDA Fortran's
/// `!$cuf kernel do`; an ordinary statement between loop levels is
/// already rejected earlier, in semantic analysis). A directive is
/// neither part of the collapsed loop's body nor attached to a DO
/// statement that is separately lowered, so it has no effect: warn about
/// it rather than silently dropping it.
///
/// A directive on the outer loop of a construct is moved ahead of the
/// OpenACC directive during parse-tree canonicalization (#106522) and
/// can be attached to the resulting acc.loop as a real annotation via
/// attachDirectiveToLoop (#216769). A directive between inner loop
/// levels, as handled here, cannot be moved that way -- it must stay
/// directly above the loop it modifies -- so it is only warned about for
/// now. Propagating it onto the acc.loop the same way outer-loop
/// directives are, instead of only warning, would be worth doing later.
///
/// Anything else means the loop nest was not tightly nested in a way
/// this code does not know how to handle -- rather than silently
/// discarding unknown statements (the original failure mode this whole
/// descent fix addresses), fail loudly with TODO so an unsupported case
/// gets reported instead of miscompiled.
///
/// This uses mlir::emitWarning rather than SemanticsContext::Warn:
/// SemanticsContext::EmitMessages runs once, immediately after semantic
/// analysis and before lowering ever starts (see FrontendAction.cpp and
/// bbc.cpp), so a Warn() call made here during lowering would be buffered
/// into the SemanticsContext's message list and never flushed to output.
void diagnoseSkippedEvaluations(
llvm::ArrayRef<Fortran::lower::pft::Evaluation *> skipped) {
for (Fortran::lower::pft::Evaluation *e : skipped) {
// The NonLabelDoStmt heading the level being searched is always a
// sibling of whatever comes next (a directive, or the inner
// DoConstruct) and is expected here on every call, not just when a
// directive is present.
if (e->isA<Fortran::parser::NonLabelDoStmt>())
continue;
if (e->isDirective()) {
// Directive evaluations carry no position (enterConstructOrDirective
// in PFTBuilder.cpp creates them without one), so e->position maps to
// an unknown location; point the warning at the directive's own
// source text instead.
mlir::Location loc = genLocation(e->position);
if (const auto *dir = e->getIf<Fortran::parser::CompilerDirective>())
loc = genLocation(dir->source);
mlir::emitWarning(loc, "compiler directive ignored: it appears between "
"loop levels of a collapsed or tiled loop nest");
continue;
}
TODO(genLocation(e->position),
"unsupported statement between the levels of a collapsed or "
"tiled loop nest");
}
}
void markCurrentFuncAsAlwaysInline(
const Fortran::parser::CompilerDirective::InlineAlways &dir) {
mlir::func::FuncOp func = builder->getFunction();
if (currentFunctionUnit && !currentFunctionUnit->isMainProgram()) {
const std::string symName =
currentFunctionUnit->getSubprogramSymbol().name().ToString();
if (dir.v.value().ToString() == symName) {
func->setAttr("llvm.always_inline", builder->getUnitAttr());
}
}
}
void
attachInliningDirectiveToStmt(const Fortran::parser::CompilerDirective &dir,
Fortran::lower::pft::Evaluation *e) {
while (e->isDirective())
e = e->lexicalSuccessor;
// If the successor is a statement or a do loop, the compiler
// will perform inlining.
if (e->isA<Fortran::parser::CallStmt>() ||
e->isA<Fortran::parser::NonLabelDoStmt>() ||
e->isA<Fortran::parser::AssignmentStmt>()) {
e->dirs.push_back(&dir);
} else {
mlir::Location loc = toLocation();
mlir::emitWarning(loc,
"Inlining directive not in front of loops, function"
"call or assignment.\n");
}
}
void genFIR(const Fortran::parser::CompilerDirective &dir) {
Fortran::lower::pft::Evaluation &eval = getEval();
Fortran::common::visit(
Fortran::common::visitors{
[&](const Fortran::parser::CompilerDirective::VectorAlways &) {
attachDirectiveToLoop(dir, &eval);
},
[&](const Fortran::parser::CompilerDirective::VectorLength &) {
attachDirectiveToLoop(dir, &eval);
},
[&](const Fortran::parser::CompilerDirective::Unroll &) {
attachDirectiveToLoop(dir, &eval);
},
[&](const Fortran::parser::CompilerDirective::UnrollAndJam &) {
attachDirectiveToLoop(dir, &eval);
},
[&](const Fortran::parser::CompilerDirective::NoVector &) {
attachDirectiveToLoop(dir, &eval);
},
[&](const Fortran::parser::CompilerDirective::NoUnroll &) {
attachDirectiveToLoop(dir, &eval);
},
[&](const Fortran::parser::CompilerDirective::NoUnrollAndJam &) {
attachDirectiveToLoop(dir, &eval);
},
[&](const Fortran::parser::CompilerDirective::ForceInline &) {
attachInliningDirectiveToStmt(dir, &eval);
},
[&](const Fortran::parser::CompilerDirective::Inline &) {
attachInliningDirectiveToStmt(dir, &eval);
},
[&](const Fortran::parser::CompilerDirective::NoInline &) {
attachInliningDirectiveToStmt(dir, &eval);
},
[&](const Fortran::parser::CompilerDirective::Prefetch &prefetch) {
for (const auto &p : prefetch.v) {
Fortran::evaluate::ExpressionAnalyzer ea{
bridge.getSemanticsContext()};
Fortran::lower::SomeExpr expr{*ea.Analyze(
std::get<Fortran::parser::DataRef>(p.value().u))};
Fortran::lower::StatementContext stmtCtx;
mlir::Location loc = genLocation(dir.source);
hlfir::Entity var = Fortran::lower::convertExprToHLFIR(
loc, *this, expr, localSymbols, stmtCtx);
mlir::Value memRef =
hlfir::genVariableRawAddress(loc, *builder, var);
// TODO: Don't use default value, instead get the following
// info from the directive
uint32_t isRead{0}, localityHint{3}, isData{1};
fir::PrefetchOp::create(*builder, loc, memRef, isRead,
localityHint, isData);
}
},
[&](const Fortran::parser::CompilerDirective::IVDep &) {
attachDirectiveToLoop(dir, &eval);
},
[&](const Fortran::parser::CompilerDirective::InlineAlways
&inlineAlways) {
if (inlineAlways.v.has_value())
markCurrentFuncAsAlwaysInline(inlineAlways);
else
attachInliningDirectiveToStmt(dir, &eval);
},
[&](const Fortran::parser::CompilerDirective::Simd &) {
attachDirectiveToLoop(dir, &eval);
},
[&](const auto &) {}},
dir.u);
}
void genFIR(const Fortran::parser::OpenACCConstruct &acc) {
setCurrentPositionAt(acc);
Fortran::lower::clearCollapsedDoConstructs();
mlir::OpBuilder::InsertPoint insertPt = builder->saveInsertionPoint();
// Cache constructs should not push/pop a scope because they need to update
// the symbol map for subsequent statements in the same loop body.
bool isCacheConstruct =
std::holds_alternative<Fortran::parser::OpenACCCacheConstruct>(acc.u);
if (!isCacheConstruct)
localSymbols.pushScope();
// Allocate exit selector for GOTO jump table if the construct is
// unstructured (may contain GOTOs that exit the ACC region).
bool needsExitSelector = getEval().lowerAsUnstructured();
if (needsExitSelector) {
AccRegionExitInfo exitInfo;
exitInfo.selector =
builder->createTemporary(toLocation(), builder->getI32Type());
mlir::Value zero = builder->createIntegerConstant(
toLocation(), builder->getI32Type(), 0);
fir::StoreOp::create(*builder, toLocation(), zero, exitInfo.selector);
accRegionExitStack.push_back(std::move(exitInfo));
}
mlir::Value exitCond = genOpenACCConstruct(
*this, bridge.getSemanticsContext(), getEval(), acc, localSymbols);
const Fortran::parser::OpenACCLoopConstruct *accLoop =
std::get_if<Fortran::parser::OpenACCLoopConstruct>(&acc.u);
const Fortran::parser::OpenACCCombinedConstruct *accCombined =
std::get_if<Fortran::parser::OpenACCCombinedConstruct>(&acc.u);
// TODO: Determining curEval here re-walks the nested evaluations to the
// collapse/DO CONCURRENT depth that the construct absorbs, mirroring the
// descent genOpenACCConstruct already performs (visitLoopControl in
// OpenACC.cpp). That duplication is fragile and couples this code to
// genOpenACCConstruct's internals. Move the responsibility for determining
// curEval into genOpenACCConstruct -- where the absorbed evaluations are
// actually decided -- and return it from there.
Fortran::lower::pft::Evaluation *curEval = &getEval();
// Determine collapse depth/force and loopCount
bool collapseForce = false;
uint64_t collapseDepth = 1;
uint64_t loopCount = 1;
if (accLoop || accCombined) {
if (accLoop) {
const Fortran::parser::AccBeginLoopDirective &beginLoopDir =
std::get<Fortran::parser::AccBeginLoopDirective>(accLoop->t);
const Fortran::parser::AccClauseList &clauseList =
std::get<Fortran::parser::AccClauseList>(beginLoopDir.t);
loopCount = Fortran::lower::getLoopCountForCollapseAndTile(clauseList);
std::tie(collapseDepth, collapseForce) =
Fortran::lower::getCollapseSizeAndForce(clauseList);
} else if (accCombined) {
const Fortran::parser::AccBeginCombinedDirective &beginCombinedDir =
std::get<Fortran::parser::AccBeginCombinedDirective>(
accCombined->t);
const Fortran::parser::AccClauseList &clauseList =
std::get<Fortran::parser::AccClauseList>(beginCombinedDir.t);
loopCount = Fortran::lower::getLoopCountForCollapseAndTile(clauseList);
std::tie(collapseDepth, collapseForce) =
Fortran::lower::getCollapseSizeAndForce(clauseList);
}
if (curEval->lowerAsStructured()) {
curEval = &curEval->getFirstNestedEvaluation();
// A DO CONCURRENT holds all controls in one construct; the per-level
// descent would overshoot into its body and drop it. collapse(force:
// ...) explicitly allows prologue/epilogue statements between loop
// levels and has its own descent below to sink them, so this
// strict per-level descent -- which does not expect them -- must
// not run for it; curEval's value here is unused in that case.
const auto *outerDo = curEval->getIf<Fortran::parser::DoConstruct>();
if (!collapseForce && !(outerDo && outerDo->IsDoConcurrent()))
for (uint64_t i = 1; i < loopCount; i++) {
llvm::SmallVector<Fortran::lower::pft::Evaluation *> skipped;
Fortran::lower::pft::Evaluation *nextDo =
Fortran::lower::findNestedDoConstructEvaluation(*curEval,
&skipped);
diagnoseSkippedEvaluations(skipped);
if (!nextDo)
break;
curEval = nextDo;
}
}
}
const bool isStructured = curEval && curEval->lowerAsStructured();
if (isStructured && collapseForce && collapseDepth > 1) {
// force: collect prologue/epilogue for the first collapseDepth nested
// loops and sink them into the innermost loop body at that depth
llvm::SmallVector<Fortran::lower::pft::Evaluation *> prologue, epilogue;
Fortran::lower::pft::Evaluation *parent = &getEval();
Fortran::lower::pft::Evaluation *innermostLoopEval = nullptr;
for (uint64_t lvl = 0; lvl + 1 < collapseDepth; ++lvl) {
epilogue.clear();
auto &kids = parent->getNestedEvaluations();
// Collect all non-loop statements before the next inner loop as
// prologue, then mark remaining siblings as epilogue and descend into
// the inner loop.
Fortran::lower::pft::Evaluation *childLoop = nullptr;
for (auto it = kids.begin(); it != kids.end(); ++it) {
if (it->getIf<Fortran::parser::DoConstruct>()) {
childLoop = &*it;
for (auto it2 = std::next(it); it2 != kids.end(); ++it2)
epilogue.push_back(&*it2);
break;
}
prologue.push_back(&*it);
}
if (!childLoop)
break;
parent = childLoop;
innermostLoopEval = childLoop;
}
// Track sunk evaluations (avoid double-lowering)
llvm::SmallPtrSet<const Fortran::lower::pft::Evaluation *, 16> sunk;
for (auto *e : prologue)
sunk.insert(e);
for (auto *e : epilogue)
sunk.insert(e);
auto sink =
[&](llvm::SmallVector<Fortran::lower::pft::Evaluation *> &lst) {
for (auto *e : lst)
genFIR(*e);
};
sink(prologue);
// Lower innermost loop body, skipping sunk
if (innermostLoopEval && innermostLoopEval->hasNestedEvaluations())
for (Fortran::lower::pft::Evaluation &e :
innermostLoopEval->getNestedEvaluations())
if (!sunk.contains(&e))
genFIR(e);
sink(epilogue);
} else {
// Normal lowering
if (curEval->hasNestedEvaluations())
for (Fortran::lower::pft::Evaluation &e :
curEval->getNestedEvaluations())
genFIR(e);
}
if (!isCacheConstruct)
localSymbols.popScope();
builder->restoreInsertionPoint(insertPt);
// Generate jump table for GOTO exits from the ACC region.
if (needsExitSelector) {
auto exitInfo = accRegionExitStack.pop_back_val();
if (!exitInfo.exits.empty()) {
mlir::Location loc = toLocation();
mlir::Value sel = fir::LoadOp::create(*builder, loc, exitInfo.selector);
for (auto &[id, target] : exitInfo.exits) {
mlir::Value idVal =
builder->createIntegerConstant(loc, builder->getI32Type(), id);
mlir::Value cmp = mlir::arith::CmpIOp::create(
*builder, loc, mlir::arith::CmpIPredicate::eq, sel, idVal);
mlir::Block *nextBlock =
builder->getBlock()->splitBlock(builder->getBlock()->end());
mlir::cf::CondBranchOp::create(*builder, loc, cmp, target, nextBlock);
builder->setInsertionPointToEnd(nextBlock);
}
}
}
if (accLoop && exitCond) {
Fortran::lower::pft::FunctionLikeUnit *funit =
getEval().getOwningProcedure();
assert(funit && "not inside main program, function or subroutine");
mlir::Block *continueBlock =
builder->getBlock()->splitBlock(builder->getBlock()->end());
mlir::cf::CondBranchOp::create(*builder, toLocation(), exitCond,
funit->finalBlock, continueBlock);
builder->setInsertionPointToEnd(continueBlock);
}
}
void genFIR(const Fortran::parser::OpenACCDeclarativeConstruct &accDecl) {
setCurrentPositionAt(accDecl);
genOpenACCDeclarativeConstruct(*this, bridge.getSemanticsContext(),
bridge.openAccCtx(), accDecl);
for (Fortran::lower::pft::Evaluation &e : getEval().getNestedEvaluations())
genFIR(e);
}
void genFIR(const Fortran::parser::OpenACCRoutineConstruct &acc) {
// Handled by genFIR(const Fortran::parser::OpenACCDeclarativeConstruct &)
}
void genFIR(const Fortran::parser::CUFKernelDoConstruct &kernel) {
setCurrentPositionAt(kernel);
Fortran::lower::SymMapScope scope(localSymbols);
const Fortran::parser::CUFKernelDoConstruct::Directive &dir =
std::get<Fortran::parser::CUFKernelDoConstruct::Directive>(kernel.t);
mlir::Location loc = genLocation(dir.source);
Fortran::lower::StatementContext stmtCtx;
unsigned nestedLoops = 1;
const auto &nLoops =
std::get<std::optional<Fortran::parser::ScalarIntConstantExpr>>(dir.t);
if (nLoops)
nestedLoops = *Fortran::semantics::GetIntValue(*nLoops);
mlir::IntegerAttr n;
if (nestedLoops > 1)
n = builder->getIntegerAttr(builder->getI64Type(), nestedLoops);
const auto &launchConfig = std::get<std::optional<
Fortran::parser::CUFKernelDoConstruct::LaunchConfiguration>>(dir.t);
const std::list<Fortran::parser::CUFReduction> &cufreds =
std::get<2>(dir.t);
llvm::SmallVector<mlir::Value> reduceOperands;
llvm::SmallVector<mlir::Attribute> reduceAttrs;
for (const Fortran::parser::CUFReduction &cufred : cufreds) {
fir::ReduceOperationEnum redOpEnum = getReduceOperationEnum(
std::get<Fortran::parser::ReductionOperator>(cufred.t));
const std::list<Fortran::parser::Scalar<Fortran::parser::Variable>>
&scalarvars = std::get<1>(cufred.t);
for (const Fortran::parser::Scalar<Fortran::parser::Variable> &scalarvar :
scalarvars) {
auto reduce_attr =
fir::ReduceAttr::get(builder->getContext(), redOpEnum);
reduceAttrs.push_back(reduce_attr);
const Fortran::parser::Variable &var = scalarvar.thing;
if (const auto *iDesignator = std::get_if<
Fortran::common::Indirection<Fortran::parser::Designator>>(
&var.u)) {
const Fortran::parser::Designator &designator = iDesignator->value();
if (const auto *name =
Fortran::parser::GetDesignatorNameIfDataRef(designator)) {
auto val = getSymbolAddress(*name->symbol);
reduceOperands.push_back(val);
}
}
}
}
auto isOnlyStars =
[&](const std::list<Fortran::parser::CUFKernelDoConstruct::StarOrExpr>
&list) -> bool {
for (const Fortran::parser::CUFKernelDoConstruct::StarOrExpr &expr :
list) {
if (expr.v)
return false;
}
return true;
};
mlir::Value zero =
builder->createIntegerConstant(loc, builder->getI32Type(), 0);
llvm::SmallVector<mlir::Value> gridValues;
llvm::SmallVector<mlir::Value> blockValues;
mlir::Value streamAddr;
if (launchConfig) {
const std::list<Fortran::parser::CUFKernelDoConstruct::StarOrExpr> &grid =
std::get<0>(launchConfig->t);
const std::list<Fortran::parser::CUFKernelDoConstruct::StarOrExpr>
&block = std::get<1>(launchConfig->t);
const std::optional<Fortran::parser::ScalarIntExpr> &stream =
std::get<2>(launchConfig->t);
if (!isOnlyStars(grid)) {
for (const Fortran::parser::CUFKernelDoConstruct::StarOrExpr &expr :
grid) {
if (expr.v) {
gridValues.push_back(fir::getBase(
genExprValue(*Fortran::semantics::GetExpr(*expr.v), stmtCtx)));
} else {
gridValues.push_back(zero);
}
}
}
if (!isOnlyStars(block)) {
for (const Fortran::parser::CUFKernelDoConstruct::StarOrExpr &expr :
block) {
if (expr.v) {
blockValues.push_back(fir::getBase(
genExprValue(*Fortran::semantics::GetExpr(*expr.v), stmtCtx)));
} else {
blockValues.push_back(zero);
}
}
}
if (stream)
streamAddr = fir::getBase(
genExprAddr(*Fortran::semantics::GetExpr(*stream), stmtCtx));
}
const auto &outerDoConstruct =
std::get<std::optional<Fortran::parser::DoConstruct>>(kernel.t);
llvm::SmallVector<mlir::Location> locs;
locs.push_back(loc);
llvm::SmallVector<mlir::Value> lbs, ubs, steps;
mlir::Type idxTy = builder->getIndexType();
llvm::SmallVector<mlir::Type> ivTypes;
llvm::SmallVector<mlir::Location> ivLocs;
llvm::SmallVector<mlir::Value> ivValues;
Fortran::lower::pft::Evaluation *loopEval =
&getEval().getFirstNestedEvaluation();
if (outerDoConstruct->IsDoConcurrent()) {
// Handle DO CONCURRENT
locs.push_back(
genLocation(Fortran::parser::FindSourceLocation(outerDoConstruct)));
const Fortran::parser::LoopControl *loopControl =
&*outerDoConstruct->GetLoopControl();
const auto &concurrent =
std::get<Fortran::parser::LoopControl::Concurrent>(loopControl->u);
if (!std::get<std::list<Fortran::parser::LocalitySpec>>(concurrent.t)
.empty())
TODO(loc, "DO CONCURRENT with locality spec");
const auto &concurrentHeader =
std::get<Fortran::parser::ConcurrentHeader>(concurrent.t);
const auto &controls =
std::get<std::list<Fortran::parser::ConcurrentControl>>(
concurrentHeader.t);
for (const auto &control : controls) {
mlir::Value lb = fir::getBase(genExprValue(
*Fortran::semantics::GetExpr(std::get<1>(control.t)), stmtCtx));
mlir::Value ub = fir::getBase(genExprValue(
*Fortran::semantics::GetExpr(std::get<2>(control.t)), stmtCtx));
mlir::Value step;
if (const auto &expr =
std::get<std::optional<Fortran::parser::ScalarIntExpr>>(
control.t))
step = fir::getBase(
genExprValue(*Fortran::semantics::GetExpr(*expr), stmtCtx));
else
step = mlir::arith::ConstantIndexOp::create(
*builder, loc, 1); // Use index type directly
// Ensure lb, ub, and step are of index type using fir.convert
lb = fir::ConvertOp::create(*builder, loc, idxTy, lb);
ub = fir::ConvertOp::create(*builder, loc, idxTy, ub);
step = fir::ConvertOp::create(*builder, loc, idxTy, step);
lbs.push_back(lb);
ubs.push_back(ub);
steps.push_back(step);
const auto &name = std::get<Fortran::parser::Name>(control.t);
// Handle induction variable
mlir::Value ivValue = getSymbolAddress(*name.symbol);
if (!ivValue) {
// DO CONCURRENT induction variables are not mapped yet since they are
// local to the DO CONCURRENT scope.
mlir::OpBuilder::InsertPoint insPt = builder->saveInsertionPoint();
builder->setInsertionPointToStart(builder->getAllocaBlock());
ivValue = builder->createTemporaryAlloc(
loc, genType(*name.symbol), toStringRef(name.symbol->name()));
builder->restoreInsertionPoint(insPt);
}
// Bind the symbol to the declared variable
bindSymbol(*name.symbol, ivValue);
Fortran::lower::SymbolBox hsb = localSymbols.lookupSymbol(*name.symbol);
fir::ExtendedValue extIvValue = symBoxToExtendedValue(hsb);
ivValue = fir::getBase(extIvValue);
ivValues.push_back(ivValue);
ivTypes.push_back(idxTy);
ivLocs.push_back(loc);
}
} else {
for (unsigned i = 0; i < nestedLoops; ++i) {
const Fortran::parser::LoopControl *loopControl;
mlir::Location crtLoc = loc;
if (i == 0) {
loopControl = &*outerDoConstruct->GetLoopControl();
crtLoc = genLocation(
Fortran::parser::FindSourceLocation(outerDoConstruct));
} else {
auto *doCons = loopEval->getIf<Fortran::parser::DoConstruct>();
assert(doCons && "expect do construct");
loopControl = &*doCons->GetLoopControl();
crtLoc = genLocation(Fortran::parser::FindSourceLocation(*doCons));
}
locs.push_back(crtLoc);
const Fortran::parser::LoopControl::Bounds *bounds =
std::get_if<Fortran::parser::LoopControl::Bounds>(&loopControl->u);
assert(bounds && "Expected bounds on the loop construct");
Fortran::semantics::Symbol &ivSym =
bounds->Name().thing.symbol->GetUltimate();
ivValues.push_back(getSymbolAddress(ivSym));
lbs.push_back(builder->createConvert(
crtLoc, idxTy,
fir::getBase(genExprValue(
*Fortran::semantics::GetExpr(bounds->Lower()), stmtCtx))));
ubs.push_back(builder->createConvert(
crtLoc, idxTy,
fir::getBase(genExprValue(
*Fortran::semantics::GetExpr(bounds->Upper()), stmtCtx))));
if (auto &step = bounds->Step())
steps.push_back(builder->createConvert(
crtLoc, idxTy,
fir::getBase(
genExprValue(*Fortran::semantics::GetExpr(step), stmtCtx))));
else // If `step` is not present, assume it is `1`.
steps.push_back(builder->createIntegerConstant(loc, idxTy, 1));
ivTypes.push_back(idxTy);
ivLocs.push_back(crtLoc);
if (i < nestedLoops - 1) {
llvm::SmallVector<Fortran::lower::pft::Evaluation *> skipped;
Fortran::lower::pft::Evaluation *nextDo =
Fortran::lower::findNestedDoConstructEvaluation(*loopEval,
&skipped);
diagnoseSkippedEvaluations(skipped);
assert(nextDo && "expected a nested DO CONSTRUCT");
loopEval = nextDo;
}
}
}
auto op = cuf::KernelOp::create(
*builder, loc, gridValues, blockValues, streamAddr, lbs, ubs, steps, n,
mlir::ValueRange(reduceOperands), builder->getArrayAttr(reduceAttrs));
builder->createBlock(&op.getRegion(), op.getRegion().end(), ivTypes,
ivLocs);
mlir::Block &b = op.getRegion().back();
builder->setInsertionPointToStart(&b);
Fortran::lower::pft::Evaluation *crtEval = &getEval();
if (crtEval->lowerAsUnstructured())
Fortran::lower::createEmptyRegionBlocks<fir::FirEndOp>(
*builder, crtEval->getNestedEvaluations());
builder->setInsertionPointToStart(&b);
for (auto [arg, value] : llvm::zip(
op.getLoopRegions().front()->front().getArguments(), ivValues)) {
mlir::Value convArg =
builder->createConvert(loc, fir::unwrapRefType(value.getType()), arg);
fir::StoreOp::create(*builder, loc, convArg, value);
}
if (crtEval->lowerAsStructured()) {
crtEval = &crtEval->getFirstNestedEvaluation();
if (!outerDoConstruct->IsDoConcurrent())
for (int64_t i = 1; i < nestedLoops; i++) {
llvm::SmallVector<Fortran::lower::pft::Evaluation *> skipped;
Fortran::lower::pft::Evaluation *nextDo =
Fortran::lower::findNestedDoConstructEvaluation(*crtEval,
&skipped);
diagnoseSkippedEvaluations(skipped);
if (!nextDo)
break;
crtEval = nextDo;
}
}
// Generate loop body
for (Fortran::lower::pft::Evaluation &e : crtEval->getNestedEvaluations())
genFIR(e);
fir::FirEndOp::create(*builder, loc);
builder->setInsertionPointAfter(op);
}
void genFIR(const Fortran::parser::OpenMPConstruct &omp) {
setCurrentPositionAt(omp);
mlir::OpBuilder::InsertPoint insertPt = builder->saveInsertionPoint();
genOpenMPConstruct(*this, localSymbols, bridge.getSemanticsContext(),
getEval(), omp);
builder->restoreInsertionPoint(insertPt);
// Register if a target region was found
ompDeviceCodeFound =
ompDeviceCodeFound || Fortran::lower::isOpenMPTargetConstruct(omp);
}
void genFIR(const Fortran::parser::OpenMPDeclarativeConstruct &ompDecl) {
setCurrentPositionAt(ompDecl);
mlir::OpBuilder::InsertPoint insertPt = builder->saveInsertionPoint();
// Register if a declare target construct intended for a target device was
// found
ompDeviceCodeFound =
ompDeviceCodeFound ||
Fortran::lower::isOpenMPDeviceDeclareTarget(
*this, bridge.getSemanticsContext(), getEval(), ompDecl);
Fortran::lower::gatherOpenMPDeferredDeclareTargets(
*this, bridge.getSemanticsContext(), getEval(), ompDecl,
ompDeferredDeclareTarget);
genOpenMPDeclarativeConstruct(
*this, localSymbols, bridge.getSemanticsContext(), getEval(), ompDecl);
builder->restoreInsertionPoint(insertPt);
}
/// Generate FIR for a SELECT CASE statement.
/// The selector may have CHARACTER, INTEGER, UNSIGNED, or LOGICAL type.
void genFIR(const Fortran::parser::SelectCaseStmt &stmt) {
Fortran::lower::pft::Evaluation &eval = getEval();
Fortran::lower::pft::Evaluation *parentConstruct = eval.parentConstruct;
assert(!activeConstructStack.empty() &&
&activeConstructStack.back().eval == parentConstruct &&
"select case construct is not active");
Fortran::lower::StatementContext &stmtCtx =
activeConstructStack.back().stmtCtx;
const Fortran::lower::SomeExpr *expr = Fortran::semantics::GetExpr(
std::get<Fortran::parser::Scalar<Fortran::parser::Expr>>(stmt.t));
bool isCharSelector = isCharacterCategory(expr->GetType()->category());
bool isLogicalSelector = isLogicalCategory(expr->GetType()->category());
mlir::MLIRContext *context = builder->getContext();
mlir::Location loc = toLocation();
auto charValue = [&](const Fortran::lower::SomeExpr *expr) {
fir::ExtendedValue exv = genExprAddr(*expr, stmtCtx, &loc);
return exv.match(
[&](const fir::CharBoxValue &cbv) {
return fir::factory::CharacterExprHelper{*builder, loc}
.createEmboxChar(cbv.getAddr(), cbv.getLen());
},
[&](auto) {
fir::emitFatalError(loc, "not a character");
return mlir::Value{};
});
};
mlir::Value selector;
if (isCharSelector) {
selector = charValue(expr);
} else {
selector = createFIRExpr(loc, expr, stmtCtx);
if (isLogicalSelector)
selector = builder->createConvert(loc, builder->getI1Type(), selector);
}
mlir::Type selectType = selector.getType();
if (selectType.isUnsignedInteger())
selectType = mlir::IntegerType::get(
builder->getContext(), selectType.getIntOrFloatBitWidth(),
mlir::IntegerType::SignednessSemantics::Signless);
llvm::SmallVector<mlir::Attribute> attrList;
llvm::SmallVector<mlir::Value> valueList;
llvm::SmallVector<mlir::Block *> blockList;
mlir::Block *defaultBlock = parentConstruct->constructExit->block;
using CaseValue = Fortran::parser::Scalar<Fortran::parser::ConstantExpr>;
auto addValue = [&](const CaseValue &caseValue) {
const Fortran::lower::SomeExpr *expr =
Fortran::semantics::GetExpr(caseValue.thing);
if (isCharSelector)
valueList.push_back(charValue(expr));
else if (isLogicalSelector)
valueList.push_back(builder->createConvert(
loc, selectType, createFIRExpr(toLocation(), expr, stmtCtx)));
else {
valueList.push_back(builder->createIntegerConstant(
loc, selectType, *Fortran::evaluate::ToInt64(*expr)));
}
};
for (Fortran::lower::pft::Evaluation *e = eval.controlSuccessor; e;
e = e->controlSuccessor) {
const auto &caseStmt = e->getIf<Fortran::parser::CaseStmt>();
assert(e->block && "missing CaseStmt block");
const auto &caseSelector =
std::get<Fortran::parser::CaseSelector>(caseStmt->t);
const auto *caseValueRangeList =
std::get_if<std::list<Fortran::parser::CaseValueRange>>(
&caseSelector.u);
if (!caseValueRangeList) {
defaultBlock = e->block;
continue;
}
for (const Fortran::parser::CaseValueRange &caseValueRange :
*caseValueRangeList) {
blockList.push_back(e->block);
if (const auto *caseValue = std::get_if<CaseValue>(&caseValueRange.u)) {
attrList.push_back(fir::PointIntervalAttr::get(context));
addValue(*caseValue);
continue;
}
const auto &caseRange =
std::get<Fortran::parser::CaseValueRange::Range>(caseValueRange.u);
const auto &[lower, upper]{caseRange.t};
if (lower && upper) {
attrList.push_back(fir::ClosedIntervalAttr::get(context));
addValue(*lower);
addValue(*upper);
} else if (lower) {
attrList.push_back(fir::LowerBoundAttr::get(context));
addValue(*lower);
} else {
attrList.push_back(fir::UpperBoundAttr::get(context));
addValue(*upper);
}
}
}
// Skip a logical default block that can never be referenced.
if (isLogicalSelector && attrList.size() == 2)
defaultBlock = parentConstruct->constructExit->block;
attrList.push_back(mlir::UnitAttr::get(context));
blockList.push_back(defaultBlock);
// Generate a fir::SelectCaseOp. Explicit branch code is better for the
// LOGICAL type. The CHARACTER type does not have downstream SelectOp
// support. The -no-structured-fir option can be used to force generation
// of INTEGER type branch code.
if (!isLogicalSelector && !isCharSelector &&
!getEval().forceAsUnstructured()) {
// The selector is in an ssa register. Any temps that may have been
// generated while evaluating it can be cleaned up now.
stmtCtx.finalizeAndReset();
fir::SelectCaseOp::create(*builder, loc, selector, attrList, valueList,
blockList);
return;
}
// Generate a sequence of case value comparisons and branches.
auto caseValue = valueList.begin();
auto caseBlock = blockList.begin();
for (mlir::Attribute attr : attrList) {
if (mlir::isa<mlir::UnitAttr>(attr)) {
genBranch(*caseBlock++);
break;
}
auto genCond = [&](mlir::Value rhs,
mlir::arith::CmpIPredicate pred) -> mlir::Value {
if (!isCharSelector)
return mlir::arith::CmpIOp::create(*builder, loc, pred, selector,
rhs);
else
return hlfir::CmpCharOp::create(*builder, loc, pred, selector, rhs);
};
mlir::Block *newBlock = insertBlock(*caseBlock);
if (mlir::isa<fir::ClosedIntervalAttr>(attr)) {
mlir::Block *newBlock2 = insertBlock(*caseBlock);
mlir::Value cond =
genCond(*caseValue++, mlir::arith::CmpIPredicate::sge);
genConditionalBranch(cond, newBlock, newBlock2);
builder->setInsertionPointToEnd(newBlock);
mlir::Value cond2 =
genCond(*caseValue++, mlir::arith::CmpIPredicate::sle);
genConditionalBranch(cond2, *caseBlock++, newBlock2);
builder->setInsertionPointToEnd(newBlock2);
continue;
}
mlir::arith::CmpIPredicate pred;
if (mlir::isa<fir::PointIntervalAttr>(attr)) {
pred = mlir::arith::CmpIPredicate::eq;
} else if (mlir::isa<fir::LowerBoundAttr>(attr)) {
pred = mlir::arith::CmpIPredicate::sge;
} else {
assert(mlir::isa<fir::UpperBoundAttr>(attr) && "unexpected predicate");
pred = mlir::arith::CmpIPredicate::sle;
}
mlir::Value cond = genCond(*caseValue++, pred);
genConditionalBranch(cond, *caseBlock++, newBlock);
builder->setInsertionPointToEnd(newBlock);
}
assert(caseValue == valueList.end() && caseBlock == blockList.end() &&
"select case list mismatch");
}
fir::ExtendedValue
genAssociateSelector(const Fortran::lower::SomeExpr &selector,
Fortran::lower::StatementContext &stmtCtx) {
return genExprAddr(selector, stmtCtx);
}
void genFIR(const Fortran::parser::AssociateConstruct &) {
Fortran::lower::pft::Evaluation &eval = getEval();
Fortran::lower::StatementContext stmtCtx;
pushActiveConstruct(eval, stmtCtx);
for (Fortran::lower::pft::Evaluation &e : eval.getNestedEvaluations()) {
setCurrentPosition(e.position);
if (auto *stmt = e.getIf<Fortran::parser::AssociateStmt>()) {
if (eval.lowerAsUnstructured())
maybeStartBlock(e.block);
localSymbols.pushScope();
for (const Fortran::parser::Association &assoc :
std::get<std::list<Fortran::parser::Association>>(stmt->t)) {
Fortran::semantics::Symbol &sym =
*std::get<Fortran::parser::Name>(assoc.t).symbol;
const Fortran::lower::SomeExpr &selector =
*sym.get<Fortran::semantics::AssocEntityDetails>().expr();
addSymbol(sym, genAssociateSelector(selector, stmtCtx));
}
} else if (e.getIf<Fortran::parser::EndAssociateStmt>()) {
if (eval.lowerAsUnstructured())
maybeStartBlock(e.block);
localSymbols.popScope();
} else {
genFIR(e);
}
}
popActiveConstruct();
}
void genFIR(const Fortran::parser::BlockConstruct &blockConstruct) {
Fortran::lower::pft::Evaluation &eval = getEval();
Fortran::lower::StatementContext stmtCtx;
pushActiveConstruct(eval, stmtCtx);
for (Fortran::lower::pft::Evaluation &e : eval.getNestedEvaluations()) {
setCurrentPosition(e.position);
if (e.getIf<Fortran::parser::BlockStmt>()) {
if (eval.lowerAsUnstructured())
maybeStartBlock(e.block);
const Fortran::parser::CharBlock &endPosition =
eval.getLastNestedEvaluation().position;
localSymbols.pushScope();
mlir::Value stackPtr = builder->genStackSave(toLocation());
mlir::Location endLoc = genLocation(endPosition);
stmtCtx.attachCleanup(
[=]() { builder->genStackRestore(endLoc, stackPtr); });
Fortran::semantics::Scope &scope =
bridge.getSemanticsContext().FindScope(endPosition);
scopeBlockIdMap.try_emplace(&scope, ++blockId);
Fortran::lower::AggregateStoreMap storeMap;
for (const Fortran::lower::pft::Variable &var :
Fortran::lower::pft::getScopeVariableList(scope)) {
// Do no instantiate again variables from the block host
// that appears in specification of block variables.
if (!var.hasSymbol() || !lookupSymbol(var.getSymbol()))
instantiateVar(var, storeMap);
}
} else if (e.getIf<Fortran::parser::EndBlockStmt>()) {
if (eval.lowerAsUnstructured())
maybeStartBlock(e.block);
localSymbols.popScope();
} else {
genFIR(e);
}
}
popActiveConstruct();
}
void genFIR(const Fortran::parser::ChangeTeamConstruct &construct) {
setCurrentPositionAt(construct);
Fortran::lower::StatementContext stmtCtx;
pushActiveConstruct(getEval(), stmtCtx);
Fortran::lower::pft::Evaluation &eval = getEval();
bool unstructuredContext = eval.lowerAsUnstructured();
// CHANGE TEAM statement
Fortran::lower::pft::Evaluation &changeTeamStmtEval =
eval.getFirstNestedEvaluation();
auto *changeTeamStmt =
changeTeamStmtEval.getIf<Fortran::parser::ChangeTeamStmt>();
assert(changeTeamStmt && "ChangeTeamStmt not found");
mif::ChangeTeamOp changeOp =
genChangeTeamStmt(*this, changeTeamStmtEval, *changeTeamStmt);
mlir::Block *entryBlock = changeOp.getBody();
builder->setInsertionPointToStart(entryBlock);
if (unstructuredContext)
Fortran::lower::createEmptyRegionBlocks<mif::EndTeamOp>(
*builder, eval.getNestedEvaluations());
builder->setInsertionPointToStart(entryBlock);
// CHANGE TEAM body code.
auto iter = eval.getNestedEvaluations().begin()++;
for (auto end = --eval.getNestedEvaluations().end(); iter != end; ++iter)
genFIR(*iter, unstructuredContext);
// END TEAM statement
Fortran::lower::pft::Evaluation &endTeamEval = *iter;
auto *endTeamStmt = endTeamEval.getIf<Fortran::parser::EndChangeTeamStmt>();
assert(endTeamStmt && "EndChangeTeamStmt not found");
if (unstructuredContext)
maybeStartBlock(endTeamEval.block);
mlir::Block &endBody = changeOp.getRegion().back();
builder->setInsertionPointToEnd(&endBody);
genEndChangeTeamStmt(*this, endTeamEval, *endTeamStmt);
assert(mlir::isa_and_nonnull<mif::EndTeamOp>(endBody.getTerminator()) &&
"missing end team terminator");
builder->setInsertionPointAfter(changeOp.getOperation());
popActiveConstruct();
}
void genFIR(const Fortran::parser::CriticalConstruct &criticalConstruct) {
setCurrentPositionAt(criticalConstruct);
TODO(toLocation(), "coarray: CriticalConstruct");
}
void genFIR(const Fortran::parser::CriticalStmt &) {
TODO(toLocation(), "coarray: CriticalStmt");
}
void genFIR(const Fortran::parser::EndCriticalStmt &) {
TODO(toLocation(), "coarray: EndCriticalStmt");
}
void genFIR(const Fortran::parser::SelectRankConstruct &selectRankConstruct) {
setCurrentPositionAt(selectRankConstruct);
genCaseOrRankConstruct();
}
void genFIR(const Fortran::parser::SelectRankStmt &selectRankStmt) {
// Generate a fir.select_case with the selector rank. The RANK(*) case,
// if any, is handles with a conditional branch before the fir.select_case.
mlir::Type rankType = builder->getIntegerType(8);
mlir::MLIRContext *context = builder->getContext();
mlir::Location loc = toLocation();
// Build block list for fir.select_case, and identify RANK(*) block, if any.
// Default block must be placed last in the fir.select_case block list.
mlir::Block *rankStarBlock = nullptr;
Fortran::lower::pft::Evaluation &eval = getEval();
mlir::Block *defaultBlock = eval.parentConstruct->constructExit->block;
llvm::SmallVector<mlir::Attribute> attrList;
llvm::SmallVector<mlir::Value> valueList;
llvm::SmallVector<mlir::Block *> blockList;
for (Fortran::lower::pft::Evaluation *e = eval.controlSuccessor; e;
e = e->controlSuccessor) {
if (const auto *rankCaseStmt =
e->getIf<Fortran::parser::SelectRankCaseStmt>()) {
const auto &rank = std::get<Fortran::parser::SelectRankCaseStmt::Rank>(
rankCaseStmt->t);
assert(e->block && "missing SelectRankCaseStmt block");
Fortran::common::visit(
Fortran::common::visitors{
[&](const Fortran::parser::ScalarIntConstantExpr &rankExpr) {
blockList.emplace_back(e->block);
attrList.emplace_back(fir::PointIntervalAttr::get(context));
std::optional<std::int64_t> rankCst =
Fortran::evaluate::ToInt64(
Fortran::semantics::GetExpr(rankExpr));
assert(rankCst.has_value() &&
"rank expr must be constant integer");
valueList.emplace_back(
builder->createIntegerConstant(loc, rankType, *rankCst));
},
[&](const Fortran::parser::Star &) {
rankStarBlock = e->block;
},
[&](const Fortran::parser::Default &) {
defaultBlock = e->block;
}},
rank.u);
}
}
attrList.push_back(mlir::UnitAttr::get(context));
blockList.push_back(defaultBlock);
// Lower selector.
assert(!activeConstructStack.empty() && "must be inside construct");
assert(!activeConstructStack.back().selector &&
"selector should not yet be set");
Fortran::lower::StatementContext &stmtCtx =
activeConstructStack.back().stmtCtx;
const Fortran::lower::SomeExpr *selectorExpr = Fortran::common::visit(
[](const auto &x) { return Fortran::semantics::GetExpr(x); },
std::get<Fortran::parser::Selector>(selectRankStmt.t).u);
assert(selectorExpr && "failed to retrieve selector expr");
hlfir::Entity selector = Fortran::lower::convertExprToHLFIR(
loc, *this, *selectorExpr, localSymbols, stmtCtx);
activeConstructStack.back().selector = selector;
// Deal with assumed-size first. They must fall into RANK(*) if present, or
// the default case (F'2023 11.1.10.2.). The selector cannot be an
// assumed-size if it is allocatable or pointer, so the check is skipped.
if (!Fortran::evaluate::IsAllocatableOrPointerObject(*selectorExpr)) {
mlir::Value isAssumedSize = fir::IsAssumedSizeOp::create(
*builder, loc, builder->getI1Type(), selector);
// Create new block to hold the fir.select_case for the non assumed-size
// cases.
mlir::Block *selectCaseBlock = insertBlock(blockList[0]);
mlir::Block *assumedSizeBlock =
rankStarBlock ? rankStarBlock : defaultBlock;
mlir::cf::CondBranchOp::create(*builder, loc, isAssumedSize,
assumedSizeBlock, mlir::ValueRange{},
selectCaseBlock, mlir::ValueRange{});
startBlock(selectCaseBlock);
}
// Create fir.select_case for the other rank cases.
mlir::Value rank =
fir::BoxRankOp::create(*builder, loc, rankType, selector);
stmtCtx.finalizeAndReset();
fir::SelectCaseOp::create(*builder, loc, rank, attrList, valueList,
blockList);
}
// Get associating entity symbol inside case statement scope.
static const Fortran::semantics::Symbol &
getAssociatingEntitySymbol(const Fortran::semantics::Scope &scope) {
const Fortran::semantics::Symbol *assocSym = nullptr;
for (const auto &sym : scope.GetSymbols()) {
if (sym->has<Fortran::semantics::AssocEntityDetails>()) {
assert(!assocSym &&
"expect only one associating entity symbol in this scope");
assocSym = &*sym;
}
}
assert(assocSym && "should contain associating entity symbol");
return *assocSym;
}
void genFIR(const Fortran::parser::SelectRankCaseStmt &stmt) {
assert(!activeConstructStack.empty() &&
"must be inside select rank construct");
// Pop previous associating entity mapping, if any, and push scope for new
// mapping.
if (activeConstructStack.back().pushedScope)
localSymbols.popScope();
localSymbols.pushScope();
activeConstructStack.back().pushedScope = true;
const Fortran::semantics::Symbol &assocEntitySymbol =
getAssociatingEntitySymbol(
bridge.getSemanticsContext().FindScope(getEval().position));
const auto &details =
assocEntitySymbol.get<Fortran::semantics::AssocEntityDetails>();
assert(!activeConstructStack.empty() &&
activeConstructStack.back().selector.has_value() &&
"selector must have been created");
// Get lowered value for the selector.
hlfir::Entity selector = *activeConstructStack.back().selector;
assert(selector.isVariable() && "assumed-rank selector are variables");
// Cook selector mlir::Value according to rank case and map it to
// associating entity symbol.
Fortran::lower::StatementContext stmtCtx;
mlir::Location loc = toLocation();
if (details.IsAssumedRank()) {
fir::ExtendedValue selectorExv = Fortran::lower::translateToExtendedValue(
loc, *builder, selector, stmtCtx);
addSymbol(assocEntitySymbol, selectorExv);
} else if (details.IsAssumedSize()) {
// Create rank-1 assumed-size from descriptor. Assumed-size are contiguous
// so a new entity can be built from scratch using the base address, type
// parameters and dynamic type. The selector cannot be a
// POINTER/ALLOCATBLE as per F'2023 C1160.
fir::ExtendedValue newExv;
llvm::SmallVector<mlir::Value> assumeSizeExtents{
fir::AssumedSizeExtentOp::create(*builder, loc)};
mlir::Value baseAddr =
hlfir::genVariableRawAddress(loc, *builder, selector);
const bool isVolatile = fir::isa_volatile_type(selector.getType());
mlir::Type eleType =
fir::unwrapSequenceType(fir::unwrapRefType(baseAddr.getType()));
mlir::Type rank1Type = fir::ReferenceType::get(
builder->getVarLenSeqTy(eleType, 1), isVolatile);
baseAddr = builder->createConvert(loc, rank1Type, baseAddr);
if (selector.isCharacter()) {
mlir::Value len = hlfir::genCharLength(loc, *builder, selector);
newExv = fir::CharArrayBoxValue{baseAddr, len, assumeSizeExtents};
} else if (selector.isDerivedWithLengthParameters()) {
TODO(loc, "RANK(*) with parameterized derived type selector");
} else if (selector.isPolymorphic()) {
TODO(loc, "RANK(*) with polymorphic selector");
} else {
// Simple intrinsic or derived type.
newExv = fir::ArrayBoxValue{baseAddr, assumeSizeExtents};
}
addSymbol(assocEntitySymbol, newExv);
} else {
int rank = details.rank().value();
auto boxTy =
mlir::cast<fir::BaseBoxType>(fir::unwrapRefType(selector.getType()));
mlir::Type newBoxType = boxTy.getBoxTypeWithNewShape(rank);
if (fir::isa_ref_type(selector.getType()))
newBoxType = fir::ReferenceType::get(
newBoxType, fir::isa_volatile_type(selector.getType()));
// Give rank info to value via cast, and get rid of the box if not needed
// (simple scalars, contiguous arrays... This is done by
// translateVariableToExtendedValue).
hlfir::Entity rankedBox{
builder->createConvert(loc, newBoxType, selector)};
bool isSimplyContiguous = Fortran::evaluate::IsSimplyContiguous(
assocEntitySymbol, getFoldingContext());
fir::ExtendedValue newExv = Fortran::lower::translateToExtendedValue(
loc, *builder, rankedBox, stmtCtx, isSimplyContiguous);
// Non deferred length parameters of character allocatable/pointer
// MutableBoxValue should be properly set before binding it to a symbol in
// order to get correct assignment semantics.
if (const fir::MutableBoxValue *mutableBox =
newExv.getBoxOf<fir::MutableBoxValue>()) {
if (selector.isCharacter()) {
auto dynamicType =
Fortran::evaluate::DynamicType::From(assocEntitySymbol);
if (!dynamicType.value().HasDeferredTypeParameter()) {
llvm::SmallVector<mlir::Value> lengthParams;
hlfir::genLengthParameters(loc, *builder, selector, lengthParams);
newExv = fir::MutableBoxValue{rankedBox, lengthParams,
mutableBox->getMutableProperties()};
}
}
}
addSymbol(assocEntitySymbol, newExv);
}
// Statements inside rank case are lowered by SelectRankConstruct visit.
}
void genFIR(const Fortran::parser::SelectTypeConstruct &selectTypeConstruct) {
mlir::MLIRContext *context = builder->getContext();
Fortran::lower::StatementContext stmtCtx;
fir::ExtendedValue selector;
llvm::SmallVector<mlir::Attribute> attrList;
llvm::SmallVector<mlir::Block *> blockList;
unsigned typeGuardIdx = 0;
std::size_t defaultAttrPos = std::numeric_limits<size_t>::max();
bool hasLocalScope = false;
llvm::SmallVector<const Fortran::semantics::Scope *> typeCaseScopes;
const auto &typeCaseList =
std::get<std::list<Fortran::parser::SelectTypeConstruct::TypeCase>>(
selectTypeConstruct.t);
for (const auto &typeCase : typeCaseList) {
const auto &stmt =
std::get<Fortran::parser::Statement<Fortran::parser::TypeGuardStmt>>(
typeCase.t);
const Fortran::semantics::Scope &scope =
bridge.getSemanticsContext().FindScope(stmt.source);
typeCaseScopes.push_back(&scope);
}
pushActiveConstruct(getEval(), stmtCtx);
llvm::SmallVector<Fortran::lower::pft::Evaluation *> exits, fallThroughs;
collectFinalEvaluations(getEval(), exits, fallThroughs);
Fortran::lower::pft::Evaluation &constructExit = *getEval().constructExit;
for (Fortran::lower::pft::Evaluation &eval :
getEval().getNestedEvaluations()) {
setCurrentPosition(eval.position);
mlir::Location loc = toLocation();
if (auto *selectTypeStmt =
eval.getIf<Fortran::parser::SelectTypeStmt>()) {
// A genFIR(SelectTypeStmt) call would have unwanted side effects.
maybeStartBlock(eval.block);
// Retrieve the selector
const auto &s = std::get<Fortran::parser::Selector>(selectTypeStmt->t);
if (const auto *v = std::get_if<Fortran::parser::Variable>(&s.u))
selector = genExprBox(loc, *Fortran::semantics::GetExpr(*v), stmtCtx);
else if (const auto *e = std::get_if<Fortran::parser::Expr>(&s.u))
selector = genExprBox(loc, *Fortran::semantics::GetExpr(*e), stmtCtx);
// Going through the controlSuccessor first to create the
// fir.select_type operation.
mlir::Block *defaultBlock = eval.parentConstruct->constructExit->block;
for (Fortran::lower::pft::Evaluation *e = eval.controlSuccessor; e;
e = e->controlSuccessor) {
const auto &typeGuardStmt =
e->getIf<Fortran::parser::TypeGuardStmt>();
const auto &guard =
std::get<Fortran::parser::TypeGuardStmt::Guard>(typeGuardStmt->t);
assert(e->block && "missing TypeGuardStmt block");
// CLASS DEFAULT
if (std::holds_alternative<Fortran::parser::Default>(guard.u)) {
defaultBlock = e->block;
// Keep track of the actual position of the CLASS DEFAULT type guard
// in the SELECT TYPE construct.
defaultAttrPos = attrList.size();
continue;
}
blockList.push_back(e->block);
if (const auto *typeSpec =
std::get_if<Fortran::parser::TypeSpec>(&guard.u)) {
// TYPE IS
mlir::Type ty;
if (std::holds_alternative<Fortran::parser::IntrinsicTypeSpec>(
typeSpec->u)) {
const Fortran::semantics::IntrinsicTypeSpec *intrinsic =
typeSpec->declTypeSpec->AsIntrinsic();
int kind =
Fortran::evaluate::ToInt64(intrinsic->kind()).value_or(kind);
llvm::SmallVector<Fortran::lower::LenParameterTy> params;
ty = genType(intrinsic->category(), kind, params);
} else {
const Fortran::semantics::DerivedTypeSpec *derived =
typeSpec->declTypeSpec->AsDerived();
ty = genType(*derived);
}
attrList.push_back(fir::ExactTypeAttr::get(ty));
} else if (const auto *derived =
std::get_if<Fortran::parser::DerivedTypeSpec>(
&guard.u)) {
// CLASS IS
assert(derived->derivedTypeSpec && "derived type spec is null");
mlir::Type ty = genType(*(derived->derivedTypeSpec));
attrList.push_back(fir::SubclassAttr::get(ty));
}
}
attrList.push_back(mlir::UnitAttr::get(context));
blockList.push_back(defaultBlock);
fir::SelectTypeOp::create(*builder, loc, fir::getBase(selector),
attrList, blockList);
// If the actual position of CLASS DEFAULT type guard is not the last
// one, it needs to be put back at its correct position for the rest of
// the processing. TypeGuardStmt are processed in the same order they
// appear in the Fortran code.
if (defaultAttrPos < attrList.size() - 1) {
auto attrIt = attrList.begin();
attrIt = attrIt + defaultAttrPos;
auto blockIt = blockList.begin();
blockIt = blockIt + defaultAttrPos;
attrList.insert(attrIt, mlir::UnitAttr::get(context));
blockList.insert(blockIt, defaultBlock);
attrList.pop_back();
blockList.pop_back();
}
} else if (auto *typeGuardStmt =
eval.getIf<Fortran::parser::TypeGuardStmt>()) {
// Map the type guard local symbol for the selector to a more precise
// typed entity in the TypeGuardStmt when necessary.
genFIR(eval);
const auto &guard =
std::get<Fortran::parser::TypeGuardStmt::Guard>(typeGuardStmt->t);
if (hasLocalScope)
localSymbols.popScope();
localSymbols.pushScope();
hasLocalScope = true;
assert(attrList.size() >= typeGuardIdx &&
"TypeGuard attribute missing");
mlir::Attribute typeGuardAttr = attrList[typeGuardIdx];
mlir::Block *typeGuardBlock = blockList[typeGuardIdx];
mlir::OpBuilder::InsertPoint crtInsPt = builder->saveInsertionPoint();
builder->setInsertionPointToStart(typeGuardBlock);
auto addAssocEntitySymbol = [&](fir::ExtendedValue exv) {
for (auto &symbol : typeCaseScopes[typeGuardIdx]->GetSymbols()) {
if (symbol->GetUltimate()
.detailsIf<Fortran::semantics::AssocEntityDetails>()) {
addSymbol(symbol, exv);
break;
}
}
};
mlir::Type baseTy = fir::getBase(selector).getType();
auto selectorBoxType = llvm::cast<fir::BaseBoxType>(baseTy);
const bool isArray = selectorBoxType.isArray();
const fir::BoxValue *selectorBox = selector.getBoxOf<fir::BoxValue>();
if (std::holds_alternative<Fortran::parser::Default>(guard.u)) {
// CLASS DEFAULT
addAssocEntitySymbol(selector);
} else if (const auto *typeSpec =
std::get_if<Fortran::parser::TypeSpec>(&guard.u)) {
// TYPE IS
fir::ExactTypeAttr attr =
mlir::dyn_cast<fir::ExactTypeAttr>(typeGuardAttr);
fir::BaseBoxType newBoxType =
selectorBoxType.getBoxTypeWithNewElementType(
attr.getType(), /*polymorphic=*/false);
mlir::Type addrTy =
newBoxType.getBaseAddressType(/*dropHeapOrPtr=*/true);
mlir::Value rawPointer = fir::BoxAddrOp::create(
*builder, loc, addrTy, fir::getBase(selector));
if (std::holds_alternative<Fortran::parser::IntrinsicTypeSpec>(
typeSpec->u)) {
const Fortran::semantics::IntrinsicTypeSpec *intrinsic =
typeSpec->declTypeSpec->AsIntrinsic();
if (isArray) {
mlir::Value boxCast = fir::ConvertOp::create(
*builder, loc, newBoxType, fir::getBase(selector));
addAssocEntitySymbol(selectorBox->clone(boxCast));
} else if (intrinsic->category() ==
Fortran::common::TypeCategory::Character) {
auto charTy = mlir::dyn_cast<fir::CharacterType>(attr.getType());
mlir::Value charLen =
fir::factory::CharacterExprHelper(*builder, loc)
.readLengthFromBox(fir::getBase(selector), charTy);
addAssocEntitySymbol(fir::CharBoxValue(rawPointer, charLen));
} else {
addAssocEntitySymbol(rawPointer);
}
} else if (std::holds_alternative<Fortran::parser::DerivedTypeSpec>(
typeSpec->u)) {
if (isArray) {
mlir::Value boxCast = fir::ConvertOp::create(
*builder, loc, newBoxType, fir::getBase(selector));
addAssocEntitySymbol(selectorBox->clone(boxCast));
} else {
addAssocEntitySymbol(rawPointer);
}
}
} else if (std::holds_alternative<Fortran::parser::DerivedTypeSpec>(
guard.u)) {
// CLASS IS
fir::SubclassAttr attr =
mlir::dyn_cast<fir::SubclassAttr>(typeGuardAttr);
fir::BaseBoxType newClassType =
selectorBoxType.getBoxTypeWithNewElementType(
attr.getType(), /*polymorphic=*/true);
if (newClassType == baseTy) {
addAssocEntitySymbol(selector);
} else {
mlir::Value derived = fir::ConvertOp::create(
*builder, loc, newClassType, fir::getBase(selector));
addAssocEntitySymbol(selectorBox->clone(derived));
}
}
builder->restoreInsertionPoint(crtInsPt);
++typeGuardIdx;
} else if (eval.getIf<Fortran::parser::EndSelectStmt>()) {
maybeStartBlock(eval.block);
if (hasLocalScope)
localSymbols.popScope();
} else {
genFIR(eval);
}
if (blockIsUnterminated()) {
if (llvm::is_contained(exits, &eval))
genConstructExitBranch(constructExit);
else if (llvm::is_contained(fallThroughs, &eval))
genBranch(eval.lexicalSuccessor->block);
}
}
popActiveConstruct();
}
//===--------------------------------------------------------------------===//
// IO statements (see io.h)
//===--------------------------------------------------------------------===//
void genFIR(const Fortran::parser::BackspaceStmt &stmt) {
mlir::Value iostat = genBackspaceStatement(*this, stmt);
genIoConditionBranches(getEval(), stmt.v, iostat);
}
void genFIR(const Fortran::parser::CloseStmt &stmt) {
mlir::Value iostat = genCloseStatement(*this, stmt);
genIoConditionBranches(getEval(), stmt.v, iostat);
}
void genFIR(const Fortran::parser::EndfileStmt &stmt) {
mlir::Value iostat = genEndfileStatement(*this, stmt);
genIoConditionBranches(getEval(), stmt.v, iostat);
}
void genFIR(const Fortran::parser::FlushStmt &stmt) {
mlir::Value iostat = genFlushStatement(*this, stmt);
genIoConditionBranches(getEval(), stmt.v, iostat);
}
void genFIR(const Fortran::parser::InquireStmt &stmt) {
mlir::Value iostat = genInquireStatement(*this, stmt);
if (const auto *specs =
std::get_if<std::list<Fortran::parser::InquireSpec>>(&stmt.u))
genIoConditionBranches(getEval(), *specs, iostat);
}
void genFIR(const Fortran::parser::OpenStmt &stmt) {
mlir::Value iostat = genOpenStatement(*this, stmt);
genIoConditionBranches(getEval(), stmt.v, iostat);
}
void genFIR(const Fortran::parser::PrintStmt &stmt) {
genPrintStatement(*this, stmt);
}
void genFIR(const Fortran::parser::ReadStmt &stmt) {
mlir::Value iostat = genReadStatement(*this, stmt);
genIoConditionBranches(getEval(), stmt.controls, iostat);
}
void genFIR(const Fortran::parser::RewindStmt &stmt) {
mlir::Value iostat = genRewindStatement(*this, stmt);
genIoConditionBranches(getEval(), stmt.v, iostat);
}
void genFIR(const Fortran::parser::WaitStmt &stmt) {
mlir::Value iostat = genWaitStatement(*this, stmt);
genIoConditionBranches(getEval(), stmt.v, iostat);
}
void genFIR(const Fortran::parser::WriteStmt &stmt) {
mlir::Value iostat = genWriteStatement(*this, stmt);
genIoConditionBranches(getEval(), stmt.controls, iostat);
}
template <typename A>
void genIoConditionBranches(Fortran::lower::pft::Evaluation &eval,
const A &specList, mlir::Value iostat) {
if (!iostat)
return;
Fortran::parser::Label endLabel{};
Fortran::parser::Label eorLabel{};
Fortran::parser::Label errLabel{};
bool hasIostat{};
for (const auto &spec : specList) {
Fortran::common::visit(
Fortran::common::visitors{
[&](const Fortran::parser::EndLabel &label) {
endLabel = label.v;
},
[&](const Fortran::parser::EorLabel &label) {
eorLabel = label.v;
},
[&](const Fortran::parser::ErrLabel &label) {
errLabel = label.v;
},
[&](const Fortran::parser::StatVariable &) { hasIostat = true; },
[](const auto &) {}},
spec.u);
}
if (!endLabel && !eorLabel && !errLabel)
return;
// An ERR specifier branch is taken on any positive error value rather than
// some single specific value. If ERR and IOSTAT specifiers are given and
// END and EOR specifiers are allowed, the latter two specifiers must have
// explicit branch targets to allow the ERR branch to be implemented as a
// default/else target. A label=0 target for an absent END or EOR specifier
// indicates that these specifiers have a fallthrough target. END and EOR
// specifiers may appear on READ and WAIT statements.
bool allSpecifiersRequired = errLabel && hasIostat &&
(eval.isA<Fortran::parser::ReadStmt>() ||
eval.isA<Fortran::parser::WaitStmt>());
mlir::Value selector =
builder->createConvert(toLocation(), builder->getIndexType(), iostat);
llvm::SmallVector<int64_t> valueList;
llvm::SmallVector<Fortran::parser::Label> labelList;
if (eorLabel || allSpecifiersRequired) {
valueList.push_back(Fortran::runtime::io::IostatEor);
labelList.push_back(eorLabel ? eorLabel : 0);
}
if (endLabel || allSpecifiersRequired) {
valueList.push_back(Fortran::runtime::io::IostatEnd);
labelList.push_back(endLabel ? endLabel : 0);
}
if (errLabel) {
// Must be last. Value 0 is interpreted as any positive value, or
// equivalently as any value other than 0, IostatEor, or IostatEnd.
valueList.push_back(0);
labelList.push_back(errLabel);
}
genMultiwayBranch(selector, valueList, labelList, eval.nonNopSuccessor());
}
//===--------------------------------------------------------------------===//
// Memory allocation and deallocation
//===--------------------------------------------------------------------===//
void genFIR(const Fortran::parser::AllocateStmt &stmt) {
Fortran::lower::genAllocateStmt(*this, stmt, toLocation());
}
void genFIR(const Fortran::parser::DeallocateStmt &stmt) {
Fortran::lower::genDeallocateStmt(*this, stmt, toLocation());
}
/// Nullify pointer object list
///
/// For each pointer object, reset the pointer to a disassociated status.
/// We do this by setting each pointer to null.
void genFIR(const Fortran::parser::NullifyStmt &stmt) {
mlir::Location loc = toLocation();
for (auto &pointerObject : stmt.v) {
const Fortran::lower::SomeExpr *expr =
Fortran::semantics::GetExpr(pointerObject);
assert(expr);
if (Fortran::evaluate::IsProcedurePointer(*expr)) {
Fortran::lower::StatementContext stmtCtx;
hlfir::Entity pptr = Fortran::lower::convertExprToHLFIR(
loc, *this, *expr, localSymbols, stmtCtx);
auto boxTy{
Fortran::lower::getUntypedBoxProcType(builder->getContext())};
hlfir::Entity nullBoxProc(
fir::factory::createNullBoxProc(*builder, loc, boxTy));
builder->createStoreWithConvert(loc, nullBoxProc, pptr);
} else {
fir::MutableBoxValue box = genExprMutableBox(loc, *expr);
fir::factory::disassociateMutableBox(*builder, loc, box);
cuf::genPointerSync(box.getAddr(), *builder);
}
}
}
//===--------------------------------------------------------------------===//
void genFIR(const Fortran::parser::NotifyWaitStmt &stmt) {
genNotifyWaitStatement(*this, stmt);
}
void genFIR(const Fortran::parser::EventPostStmt &stmt) {
genEventPostStatement(*this, stmt);
}
void genFIR(const Fortran::parser::EventWaitStmt &stmt) {
genEventWaitStatement(*this, stmt);
}
void genFIR(const Fortran::parser::FormTeamStmt &stmt) {
genFormTeamStatement(*this, getEval(), stmt);
}
void genFIR(const Fortran::parser::LockStmt &stmt) {
genLockStatement(*this, stmt);
}
inline fir::MutableBoxValue
genExprMutableBox(mlir::Location loc,
const Fortran::lower::SomeExpr &expr) override final {
return Fortran::lower::convertExprToMutableBox(loc, *this, expr,
localSymbols);
}
// Create the [newRank] array with the lower bounds to be passed to the
// runtime as a descriptor.
mlir::Value createLboundArray(llvm::ArrayRef<mlir::Value> lbounds,
mlir::Location loc) {
mlir::Type indexTy = builder->getIndexType();
mlir::Type boundArrayTy = fir::SequenceType::get(
{static_cast<int64_t>(lbounds.size())}, builder->getI64Type());
mlir::Value boundArray = fir::AllocaOp::create(*builder, loc, boundArrayTy);
mlir::Value array = fir::UndefOp::create(*builder, loc, boundArrayTy);
for (unsigned i = 0; i < lbounds.size(); ++i) {
array = fir::InsertValueOp::create(
*builder, loc, boundArrayTy, array, lbounds[i],
builder->getArrayAttr({builder->getIntegerAttr(
builder->getIndexType(), static_cast<int>(i))}));
}
fir::StoreOp::create(*builder, loc, array, boundArray);
mlir::Type boxTy = fir::BoxType::get(boundArrayTy);
mlir::Value ext =
builder->createIntegerConstant(loc, indexTy, lbounds.size());
llvm::SmallVector<mlir::Value> shapes = {ext};
mlir::Value shapeOp = builder->genShape(loc, shapes);
return fir::EmboxOp::create(*builder, loc, boxTy, boundArray, shapeOp);
}
void genPointerAssignment(mlir::Location loc,
const Fortran::evaluate::Assignment &assign) {
if (isInsideHlfirForallOrWhere()) {
// Generate Pointer assignment as hlfir.region_assign.
genForallPointerAssignment(loc, assign);
return;
}
Fortran::lower::StatementContext stmtCtx;
hlfir::Entity lhs = Fortran::lower::convertExprToHLFIR(
loc, *this, assign.lhs, localSymbols, stmtCtx);
mlir::Value rhs = genPointerAssignmentRhs(loc, lhs, assign, stmtCtx);
builder->createStoreWithConvert(loc, rhs, lhs);
cuf::genPointerSync(lhs, *builder);
}
void genForallPointerAssignment(mlir::Location loc,
const Fortran::evaluate::Assignment &assign) {
// Lower pointer assignment inside forall with hlfir.region_assign with
// descriptor address/value and later implemented with a store.
// The RHS is fully prepared in lowering, so that all that is left
// in hlfir.region_assign code generation is the store.
auto regionAssignOp = hlfir::RegionAssignOp::create(*builder, loc);
// Lower LHS in its own region.
builder->createBlock(&regionAssignOp.getLhsRegion());
Fortran::lower::StatementContext lhsContext;
hlfir::Entity lhs = Fortran::lower::convertExprToHLFIR(
loc, *this, assign.lhs, localSymbols, lhsContext);
auto lhsYieldOp = hlfir::YieldOp::create(*builder, loc, lhs);
Fortran::lower::genCleanUpInRegionIfAny(
loc, *builder, lhsYieldOp.getCleanup(), lhsContext);
// Lower RHS in its own region.
builder->createBlock(&regionAssignOp.getRhsRegion());
Fortran::lower::StatementContext rhsContext;
mlir::Value rhs = genPointerAssignmentRhs(loc, lhs, assign, rhsContext);
auto rhsYieldOp = hlfir::YieldOp::create(*builder, loc, rhs);
Fortran::lower::genCleanUpInRegionIfAny(
loc, *builder, rhsYieldOp.getCleanup(), rhsContext);
builder->setInsertionPointAfter(regionAssignOp);
}
mlir::Value lowerToIndexValue(mlir::Location loc,
const Fortran::evaluate::ExtentExpr &expr,
Fortran::lower::StatementContext &stmtCtx) {
mlir::Value val = fir::getBase(genExprValue(toEvExpr(expr), stmtCtx));
return builder->createConvert(loc, builder->getIndexType(), val);
}
mlir::Value
genPointerAssignmentRhs(mlir::Location loc, hlfir::Entity lhs,
const Fortran::evaluate::Assignment &assign,
Fortran::lower::StatementContext &rhsContext) {
if (Fortran::evaluate::IsProcedureDesignator(assign.lhs)) {
if (Fortran::evaluate::UnwrapExpr<Fortran::evaluate::NullPointer>(
assign.rhs))
return fir::factory::createNullBoxProc(
*builder, loc, fir::unwrapRefType(lhs.getType()));
return fir::getBase(Fortran::lower::convertExprToAddress(
loc, *this, assign.rhs, localSymbols, rhsContext));
}
// Data target.
auto lhsBoxType =
llvm::cast<fir::BaseBoxType>(fir::unwrapRefType(lhs.getType()));
// For NULL, create disassociated descriptor whose dynamic type is the
// static type of the LHS (fulfills 7.3.2.3 requirements that the dynamic
// type of a deallocated polymorphic pointer is its static type).
if (Fortran::evaluate::UnwrapExpr<Fortran::evaluate::NullPointer>(
assign.rhs)) {
llvm::SmallVector<mlir::Value, 1> nonDeferredLenParams;
if (auto lhsVar =
llvm::dyn_cast_if_present<fir::FortranVariableOpInterface>(
lhs.getDefiningOp()))
nonDeferredLenParams = lhsVar.getExplicitTypeParams();
if (isInsideHlfirForallOrWhere()) {
// Inside FORALL, the non deferred type parameters may only be
// accessible in the hlfir.region_assign lhs region if they were
// computed there.
for (mlir::Value &param : nonDeferredLenParams)
if (!param.getParentRegion()->isAncestor(
builder->getBlock()->getParent())) {
if (llvm::isa_and_nonnull<mlir::arith::ConstantOp>(
param.getDefiningOp()))
param = builder->clone(*param.getDefiningOp())->getResult(0);
else
TODO(loc, "Pointer assignment with non deferred type parameter "
"inside FORALL");
}
}
return fir::factory::createUnallocatedBox(*builder, loc, lhsBoxType,
nonDeferredLenParams);
}
hlfir::Entity rhs = Fortran::lower::convertExprToHLFIR(
loc, *this, assign.rhs, localSymbols, rhsContext);
auto rhsBoxType = rhs.getBoxType();
// Create pointer descriptor value from the RHS.
if (rhs.isMutableBox())
rhs = hlfir::Entity{fir::LoadOp::create(*builder, loc, rhs)};
// Use LHS type if LHS is not polymorphic.
fir::BaseBoxType targetBoxType;
if (assign.lhs.GetType()->IsPolymorphic())
targetBoxType = rhsBoxType.getBoxTypeWithNewAttr(
fir::BaseBoxType::Attribute::Pointer);
else
targetBoxType = lhsBoxType.getBoxTypeWithNewShape(rhs.getRank());
mlir::Value rhsBox =
hlfir::genVariableBox(loc, *builder, rhs, targetBoxType);
// Apply lower bounds or reshaping if any.
if (const auto *lbExprs =
std::get_if<Fortran::evaluate::Assignment::BoundsSpec>(&assign.u);
lbExprs && !lbExprs->empty()) {
// Override target lower bounds with the LHS bounds spec.
llvm::SmallVector<mlir::Value> lbounds;
for (const Fortran::evaluate::ExtentExpr &lbExpr : *lbExprs)
lbounds.push_back(lowerToIndexValue(loc, lbExpr, rhsContext));
mlir::Value shift = builder->genShift(loc, lbounds);
rhsBox = fir::ReboxOp::create(*builder, loc, lhsBoxType, rhsBox, shift,
/*slice=*/mlir::Value{});
} else if (const auto *boundExprs =
std::get_if<Fortran::evaluate::Assignment::BoundsRemapping>(
&assign.u);
boundExprs && !boundExprs->empty()) {
// Reshape the target according to the LHS bounds remapping.
llvm::SmallVector<mlir::Value> lbounds;
llvm::SmallVector<mlir::Value> extents;
mlir::Type indexTy = builder->getIndexType();
mlir::Value zero = builder->createIntegerConstant(loc, indexTy, 0);
mlir::Value one = builder->createIntegerConstant(loc, indexTy, 1);
for (const auto &[lbExpr, ubExpr] : *boundExprs) {
lbounds.push_back(lowerToIndexValue(loc, lbExpr, rhsContext));
mlir::Value ub = lowerToIndexValue(loc, ubExpr, rhsContext);
extents.push_back(fir::factory::computeExtent(
*builder, loc, lbounds.back(), ub, zero, one));
}
mlir::Value shape = builder->genShape(loc, lbounds, extents);
rhsBox = fir::ReboxOp::create(*builder, loc, lhsBoxType, rhsBox, shape,
/*slice=*/mlir::Value{});
} else if (fir::isClassStarType(lhsBoxType) &&
!fir::ConvertOp::canBeConverted(rhsBoxType, lhsBoxType)) {
rhsBox = fir::ReboxOp::create(*builder, loc, lhsBoxType, rhsBox,
mlir::Value{}, mlir::Value{});
}
return rhsBox;
}
// Create the 2 x newRank array with the bounds to be passed to the runtime as
// a descriptor.
mlir::Value createBoundArray(llvm::ArrayRef<mlir::Value> lbounds,
llvm::ArrayRef<mlir::Value> ubounds,
mlir::Location loc) {
assert(lbounds.size() && ubounds.size());
mlir::Type indexTy = builder->getIndexType();
mlir::Type boundArrayTy = fir::SequenceType::get(
{2, static_cast<int64_t>(lbounds.size())}, builder->getI64Type());
mlir::Value boundArray = fir::AllocaOp::create(*builder, loc, boundArrayTy);
mlir::Value array = fir::UndefOp::create(*builder, loc, boundArrayTy);
for (unsigned i = 0; i < lbounds.size(); ++i) {
array = fir::InsertValueOp::create(
*builder, loc, boundArrayTy, array, lbounds[i],
builder->getArrayAttr(
{builder->getIntegerAttr(builder->getIndexType(), 0),
builder->getIntegerAttr(builder->getIndexType(),
static_cast<int>(i))}));
array = fir::InsertValueOp::create(
*builder, loc, boundArrayTy, array, ubounds[i],
builder->getArrayAttr(
{builder->getIntegerAttr(builder->getIndexType(), 1),
builder->getIntegerAttr(builder->getIndexType(),
static_cast<int>(i))}));
}
fir::StoreOp::create(*builder, loc, array, boundArray);
mlir::Type boxTy = fir::BoxType::get(boundArrayTy);
mlir::Value ext =
builder->createIntegerConstant(loc, indexTy, lbounds.size());
mlir::Value c2 = builder->createIntegerConstant(loc, indexTy, 2);
llvm::SmallVector<mlir::Value> shapes = {c2, ext};
mlir::Value shapeOp = builder->genShape(loc, shapes);
return fir::EmboxOp::create(*builder, loc, boxTy, boundArray, shapeOp);
}
/// Given converted LHS and RHS of the assignment, materialize any
/// implicit conversion of the RHS to the LHS type. The front-end
/// usually already makes those explicit, except for non-standard
/// LOGICAL <-> INTEGER, or if the LHS is a whole allocatable
/// (making the conversion explicit in the front-end would prevent
/// propagation of the LHS lower bound in the reallocation).
/// If array temporaries or values are created, the cleanups are
/// added in the statement context.
hlfir::Entity genImplicitConvert(const Fortran::evaluate::Assignment &assign,
hlfir::Entity rhs, bool preserveLowerBounds,
Fortran::lower::StatementContext &stmtCtx) {
mlir::Location loc = toLocation();
auto &builder = getFirOpBuilder();
mlir::Type toType = genType(assign.lhs);
auto valueAndPair = hlfir::genTypeAndKindConvert(loc, builder, rhs, toType,
preserveLowerBounds);
if (valueAndPair.second)
stmtCtx.attachCleanup(*valueAndPair.second);
return hlfir::Entity{valueAndPair.first};
}
bool firstDummyIsPointerOrAllocatable(
const Fortran::evaluate::ProcedureRef &userDefinedAssignment) {
using DummyAttr = Fortran::evaluate::characteristics::DummyDataObject::Attr;
if (auto procedure =
Fortran::evaluate::characteristics::Procedure::Characterize(
userDefinedAssignment.proc(), getFoldingContext(),
/*emitError=*/false))
if (!procedure->dummyArguments.empty())
if (const auto *dataArg = std::get_if<
Fortran::evaluate::characteristics::DummyDataObject>(
&procedure->dummyArguments[0].u))
return dataArg->attrs.test(DummyAttr::Pointer) ||
dataArg->attrs.test(DummyAttr::Allocatable);
return false;
}
// Return true if the right-hand side of the assignment is a reference to a
// function whose result carries a managed, unified, or device CUDA data
// attribute. Such a result may be produced by an asynchronous kernel, so
// consuming it in an assignment must be a synchronizing data transfer rather
// than a plain host assignment. A whole-allocatable left-hand side is
// excluded: it has reallocation semantics and is performed on the host, and
// so is a scalar character result: it carries its length outside of a
// descriptor, so a transfer would copy raw bytes instead of padding or
// truncating the destination.
bool
isCUDAFunctionResultTransfer(const Fortran::evaluate::Assignment &assign) {
if (Fortran::evaluate::IsAllocatableDesignator(assign.lhs))
return false;
if (assign.rhs.Rank() == 0)
if (std::optional<Fortran::evaluate::DynamicType> type{
assign.rhs.GetType()})
if (type->category() == Fortran::common::TypeCategory::Character)
return false;
const Fortran::evaluate::ProcedureRef *procRef =
Fortran::evaluate::UnwrapProcedureRef(assign.rhs);
if (!procRef)
return false;
auto procedure =
Fortran::evaluate::characteristics::Procedure::Characterize(
procRef->proc(), getFoldingContext(), /*emitError=*/false);
if (!procedure || !procedure->functionResult ||
!procedure->functionResult->cudaDataAttr)
return false;
Fortran::common::CUDADataAttr attr =
*procedure->functionResult->cudaDataAttr;
return attr == Fortran::common::CUDADataAttr::Managed ||
attr == Fortran::common::CUDADataAttr::Unified ||
attr == Fortran::common::CUDADataAttr::Device;
}
void genCUDADataTransfer(fir::FirOpBuilder &builder, mlir::Location loc,
const Fortran::evaluate::Assignment &assign,
hlfir::Entity &lhs, hlfir::Entity &rhs,
bool isWholeAllocatableAssignment,
bool keepLhsLengthInAllocatableAssignment) {
bool lhsIsDevice = Fortran::evaluate::HasCUDADeviceAttrs(assign.lhs);
// A managed/unified/device function result is not visible to the symbol
// collection used by HasCUDADeviceAttrs (a ProcedureRef contributes no
// symbols), so treat such a result as a device side for transfer direction.
bool rhsIsDevice = Fortran::evaluate::HasCUDADeviceAttrs(assign.rhs) ||
isCUDAFunctionResultTransfer(assign);
mlir::UnitAttr hasManagedOrUnifedSymbols =
(Fortran::evaluate::GetNbOfCUDAManagedOrUnifiedSymbols(assign.lhs) >
0 ||
Fortran::evaluate::GetNbOfCUDAManagedOrUnifiedSymbols(assign.rhs) > 0)
? mlir::UnitAttr::get(builder.getContext())
: nullptr;
auto getRefFromValue = [](mlir::Value val) -> mlir::Value {
if (auto loadOp =
mlir::dyn_cast_or_null<fir::LoadOp>(val.getDefiningOp()))
return loadOp.getMemref();
if (!mlir::isa<fir::BaseBoxType>(val.getType()))
return val;
if (auto declOp =
mlir::dyn_cast_or_null<hlfir::DeclareOp>(val.getDefiningOp())) {
if (!declOp.getShape())
return val;
if (mlir::isa<fir::ReferenceType>(declOp.getMemref().getType()))
return declOp.getResults()[1];
}
return val;
};
auto getShapeFromDecl = [](mlir::Value val) -> mlir::Value {
if (!mlir::isa<fir::BaseBoxType>(val.getType()))
return {};
if (auto declOp =
mlir::dyn_cast_or_null<hlfir::DeclareOp>(val.getDefiningOp()))
return declOp.getShape();
return {};
};
mlir::Value rhsVal = getRefFromValue(rhs.getBase());
mlir::Value lhsVal = getRefFromValue(lhs.getBase());
// Get shape from the rhs if available otherwise get it from lhs.
mlir::Value shape;
if (fir::isa_ref_type(rhsVal.getType()) ||
fir::isa_ref_type(lhsVal.getType())) {
if (mlir::Value rhsShape = getShapeFromDecl(rhs.getBase()))
shape = rhsShape;
else
shape = getShapeFromDecl(lhs.getBase());
}
// device = host
if (lhsIsDevice && !rhsIsDevice) {
auto transferKindAttr = cuf::DataTransferKindAttr::get(
builder.getContext(), cuf::DataTransferKind::HostDevice);
if (!rhs.isVariable()) {
mlir::Value base = rhs;
if (auto convertOp =
mlir::dyn_cast<fir::ConvertOp>(rhs.getDefiningOp()))
base = convertOp.getValue();
// Special case if the rhs is a constant.
if (matchPattern(base.getDefiningOp(), mlir::m_Constant())) {
cuf::DataTransferOp::create(builder, loc, base, lhsVal, shape,
transferKindAttr,
hasManagedOrUnifedSymbols);
} else {
auto associate = hlfir::genAssociateExpr(
loc, builder, rhs, rhs.getType(), ".cuf_host_tmp");
cuf::DataTransferOp::create(builder, loc, associate.getBase(), lhsVal,
shape, transferKindAttr,
hasManagedOrUnifedSymbols);
hlfir::EndAssociateOp::create(builder, loc, associate);
}
} else {
cuf::DataTransferOp::create(builder, loc, rhsVal, lhsVal, shape,
transferKindAttr,
hasManagedOrUnifedSymbols);
}
return;
}
// host = device
if (!lhsIsDevice && rhsIsDevice) {
auto [firstElOp, elOp] = Fortran::lower::isTransferWithConversion(rhs);
if (firstElOp) {
mlir::OpBuilder::InsertionGuard insertionGuard(builder);
auto designateOp =
*firstElOp.getBody()->getOps<hlfir::DesignateOp>().begin();
builder.setInsertionPoint(firstElOp);
// Create a temp to transfer the rhs before applying the conversion.
hlfir::Entity entity{designateOp.getMemref()};
auto [temp, cleanup] = hlfir::createTempFromMold(loc, builder, entity);
auto transferKindAttr = cuf::DataTransferKindAttr::get(
builder.getContext(), cuf::DataTransferKind::DeviceHost);
cuf::DataTransferOp::create(builder, loc, designateOp.getMemref(), temp,
/*shape=*/mlir::Value{}, transferKindAttr,
hasManagedOrUnifedSymbols);
designateOp.getMemrefMutable().assign(temp);
builder.setInsertionPointAfter(elOp);
hlfir::AssignOp::create(builder, loc, elOp, lhs,
isWholeAllocatableAssignment,
keepLhsLengthInAllocatableAssignment);
return;
}
auto transferKindAttr = cuf::DataTransferKindAttr::get(
builder.getContext(), cuf::DataTransferKind::DeviceHost);
if (fir::isa_trivial(rhsVal.getType())) {
fir::StoreOp::create(builder, loc, rhsVal, lhsVal);
} else {
cuf::DataTransferOp::create(builder, loc, rhsVal, lhsVal, shape,
transferKindAttr,
hasManagedOrUnifedSymbols);
}
return;
}
// device = device
if (lhsIsDevice && rhsIsDevice) {
auto transferKindAttr = cuf::DataTransferKindAttr::get(
builder.getContext(), cuf::DataTransferKind::DeviceDevice);
cuf::DataTransferOp::create(builder, loc, rhsVal, lhsVal, shape,
transferKindAttr, hasManagedOrUnifedSymbols);
return;
}
llvm_unreachable("Unhandled CUDA data transfer");
}
llvm::SmallVector<mlir::Value>
genCUDAImplicitDataTransfer(fir::FirOpBuilder &builder, mlir::Location loc,
const Fortran::evaluate::Assignment &assign) {
llvm::SmallVector<mlir::Value> temps;
localSymbols.pushScope();
auto transferKindAttr = cuf::DataTransferKindAttr::get(
builder.getContext(), cuf::DataTransferKind::DeviceHost);
[[maybe_unused]] unsigned nbDeviceResidentObject = 0;
for (const Fortran::semantics::Symbol &sym :
Fortran::evaluate::CollectSymbols(assign.rhs)) {
if (const auto *details =
sym.GetUltimate()
.detailsIf<Fortran::semantics::ObjectEntityDetails>()) {
if (details->cudaDataAttr() &&
*details->cudaDataAttr() != Fortran::common::CUDADataAttr::Pinned) {
assert(
nbDeviceResidentObject <= 1 &&
"Only one reference to the device resident object is supported");
auto addr = getSymbolAddress(sym);
mlir::Value baseValue;
if (auto declareOp =
llvm::dyn_cast<hlfir::DeclareOp>(addr.getDefiningOp()))
baseValue = declareOp.getBase();
else
baseValue = addr;
hlfir::Entity entity{baseValue};
auto [temp, cleanup] =
hlfir::createTempFromMold(loc, builder, entity);
if (cleanup) {
if (auto declareOp =
mlir::dyn_cast<hlfir::DeclareOp>(temp.getDefiningOp()))
temps.push_back(declareOp.getMemref());
else
temps.push_back(temp);
}
addSymbol(sym,
hlfir::translateToExtendedValue(loc, builder, temp).first,
/*forced=*/true);
cuf::DataTransferOp::create(builder, loc, addr, temp,
/*shape=*/mlir::Value{},
transferKindAttr);
++nbDeviceResidentObject;
}
}
}
return temps;
}
void genDataAssignment(
const Fortran::evaluate::Assignment &assign,
const Fortran::evaluate::ProcedureRef *userDefinedAssignment,
const llvm::ArrayRef<const Fortran::parser::CompilerDirective *> &dirs =
{}) {
mlir::Location loc = getCurrentLocation();
fir::FirOpBuilder &builder = getFirOpBuilder();
bool isInDeviceContext = cuf::isCUDADeviceContext(
builder.getRegion(),
getFoldingContext().languageFeatures().IsEnabled(
Fortran::common::LanguageFeature::DoConcurrentOffload));
bool isCUDATransfer = (IsCUDADataTransfer(assign.lhs, assign.rhs) ||
isCUDAFunctionResultTransfer(assign)) &&
!isInDeviceContext;
bool hasCUDAImplicitTransfer =
isCUDATransfer &&
Fortran::evaluate::HasCUDAImplicitTransfer(assign.rhs);
llvm::SmallVector<mlir::Value> implicitTemps;
if (hasCUDAImplicitTransfer && !isInDeviceContext)
implicitTemps = genCUDAImplicitDataTransfer(builder, loc, assign);
if (Fortran::evaluate::ExtractCoarrayRef(assign.lhs) ||
Fortran::evaluate::ExtractCoarrayRef(assign.rhs))
TODO(loc, "coarray: assignment");
// Gather some information about the assignment that will impact how it is
// lowered.
const bool lhsIsWholeAllocatable =
!userDefinedAssignment && !isInsideHlfirWhere() &&
Fortran::lower::isWholeAllocatable(assign.lhs);
std::optional<Fortran::evaluate::DynamicType> lhsType =
assign.lhs.GetType();
// Polymorphic allocatable LHS always requires reallocation semantics
// regardless of -fno-realloc-lhs: assignment to a polymorphic variable
// is a F2003+ feature that requires dynamic type tracking, which cannot
// be safely skipped. A warning is emitted by the semantics phase.
const bool lhsIsPolymorphic =
lhsType.has_value() && lhsType->IsPolymorphic();
const bool isWholeAllocatableAssignment =
lhsIsWholeAllocatable &&
(bridge.getLoweringOptions().getReallocateLHS() || lhsIsPolymorphic);
const bool isUserDefAssignToPointerOrAllocatable =
userDefinedAssignment &&
firstDummyIsPointerOrAllocatable(*userDefinedAssignment);
const bool keepLhsLengthInAllocatableAssignment =
isWholeAllocatableAssignment && lhsType.has_value() &&
lhsType->category() == Fortran::common::TypeCategory::Character &&
!lhsType->HasDeferredTypeParameter();
const bool lhsHasVectorSubscripts =
Fortran::evaluate::HasVectorSubscript(assign.lhs);
const bool rhsIsCUDADeviceDesignator = [&]() {
if (!userDefinedAssignment || !Fortran::evaluate::IsVariable(assign.rhs))
return false;
for (const Fortran::semantics::Symbol &sym :
Fortran::evaluate::CollectCudaSymbols(assign.rhs))
if (Fortran::semantics::IsCUDADevice(sym))
return true;
return false;
}();
// Helper to generate the code evaluating the right-hand side.
auto evaluateRhs = [&](Fortran::lower::StatementContext &stmtCtx) {
const Fortran::lower::SomeExpr *rhsExpr = &assign.rhs;
std::optional<Fortran::lower::SomeExpr> rewritten;
if (bridge.getLoweringOptions().getSplitSumExpressionTree() &&
Fortran::evaluate::CanBuildSplitSumExpressionTree(
getFoldingContext(), assign.lhs, assign.rhs)) {
rewritten =
Fortran::evaluate::TryBuildSplitSumExpressionTrees(assign.rhs);
if (rewritten)
rhsExpr = &*rewritten;
}
hlfir::Entity rhs = Fortran::lower::convertExprToHLFIR(
loc, *this, *rhsExpr, localSymbols, stmtCtx);
// Load trivial scalar RHS to allow the loads to be hoisted outside of
// loops early if possible. This also dereferences pointer and
// allocatable RHS: the target is being assigned from.
rhs = hlfir::loadTrivialScalar(loc, builder, rhs);
// In intrinsic assignments, the LHS type may not match the RHS type, in
// which case an implicit conversion of the LHS must be done. The
// front-end usually makes it explicit, unless it cannot (whole
// allocatable LHS or Logical<->Integer assignment extension). Recognize
// any type mismatches here and insert explicit scalar convert or
// ElementalOp for array assignment. Preserve the RHS lower bounds on the
// converted entity in case of assignment to whole allocatables so to
// propagate the lower bounds to the LHS in case of reallocation.
if (!userDefinedAssignment)
rhs = genImplicitConvert(assign, rhs, isWholeAllocatableAssignment,
stmtCtx);
return rhs;
};
// Helper to generate the code evaluating the left-hand side.
auto evaluateLhs = [&](Fortran::lower::StatementContext &stmtCtx) {
hlfir::Entity lhs = Fortran::lower::convertExprToHLFIR(
loc, *this, assign.lhs, localSymbols, stmtCtx);
// Dereference pointer LHS: the target is being assigned to.
// Same for allocatables outside of whole allocatable assignments.
if (!isWholeAllocatableAssignment &&
!isUserDefAssignToPointerOrAllocatable)
lhs = hlfir::derefPointersAndAllocatables(loc, builder, lhs);
return lhs;
};
auto cleanupImplicitTemps = [&]() {
if (hasCUDAImplicitTransfer && !isInDeviceContext) {
localSymbols.popScope();
for (mlir::Value temp : implicitTemps)
fir::FreeMemOp::create(builder, loc, temp);
}
};
// Keep CUDA DEVICE designator RHS values as call actuals for user-defined
// assignment. A region_assign would later try to enforce RHS value
// semantics with a host-side copy, which cannot be formed for DEVICE data.
if (!isInsideHlfirForallOrWhere() && !lhsHasVectorSubscripts &&
rhsIsCUDADeviceDesignator) {
Fortran::lower::StatementContext localStmtCtx;
hlfir::Entity rhs = evaluateRhs(localStmtCtx);
hlfir::Entity lhs = evaluateLhs(localStmtCtx);
Fortran::lower::convertUserDefinedAssignmentToHLFIR(
loc, *this, *userDefinedAssignment, lhs, rhs, localSymbols);
cleanupImplicitTemps();
return;
}
if (!isInsideHlfirForallOrWhere() && !lhsHasVectorSubscripts &&
!userDefinedAssignment) {
Fortran::lower::StatementContext localStmtCtx;
hlfir::Entity rhs = evaluateRhs(localStmtCtx);
hlfir::Entity lhs = evaluateLhs(localStmtCtx);
if (isCUDATransfer && !hasCUDAImplicitTransfer)
genCUDADataTransfer(builder, loc, assign, lhs, rhs,
isWholeAllocatableAssignment,
keepLhsLengthInAllocatableAssignment);
else {
// If RHS or LHS have a CallOp in their expression, this operation will
// have the 'no_inline' or 'always_inline' attribute if there is a
// directive just before the assignement.
if (!dirs.empty()) {
if (rhs.getDefiningOp())
attachInlineAttributes(*rhs.getDefiningOp(), dirs);
if (lhs.getDefiningOp())
attachInlineAttributes(*lhs.getDefiningOp(), dirs);
}
if (isCUDATransfer && hasCUDAImplicitTransfer &&
Fortran::evaluate::HasCUDADeviceAttrs(assign.lhs)) {
auto [temp, cleanup] = hlfir::createTempFromMold(loc, builder, lhs);
hlfir::AssignOp::create(builder, loc, rhs, temp,
isWholeAllocatableAssignment,
keepLhsLengthInAllocatableAssignment);
auto transferKindAttr = cuf::DataTransferKindAttr::get(
builder.getContext(), cuf::DataTransferKind::HostDevice);
cuf::DataTransferOp::create(builder, loc, temp, lhs,
/*shape=*/mlir::Value{},
transferKindAttr);
} else {
hlfir::AssignOp::create(builder, loc, rhs, lhs,
isWholeAllocatableAssignment,
keepLhsLengthInAllocatableAssignment);
}
}
cleanupImplicitTemps();
return;
}
// Assignments inside Forall, Where, or assignments to a vector subscripted
// left-hand side requires using an hlfir.region_assign in HLFIR. The
// right-hand side and left-hand side must be evaluated inside the
// hlfir.region_assign regions.
auto regionAssignOp = hlfir::RegionAssignOp::create(builder, loc);
// Lower RHS in its own region.
builder.createBlock(&regionAssignOp.getRhsRegion());
Fortran::lower::StatementContext rhsContext;
hlfir::Entity rhs = evaluateRhs(rhsContext);
auto rhsYieldOp = hlfir::YieldOp::create(builder, loc, rhs);
Fortran::lower::genCleanUpInRegionIfAny(
loc, builder, rhsYieldOp.getCleanup(), rhsContext);
// Lower LHS in its own region.
builder.createBlock(&regionAssignOp.getLhsRegion());
Fortran::lower::StatementContext lhsContext;
mlir::Value lhsYield = nullptr;
if (!lhsHasVectorSubscripts) {
hlfir::Entity lhs = evaluateLhs(lhsContext);
auto lhsYieldOp = hlfir::YieldOp::create(builder, loc, lhs);
Fortran::lower::genCleanUpInRegionIfAny(
loc, builder, lhsYieldOp.getCleanup(), lhsContext);
lhsYield = lhs;
} else {
hlfir::ElementalAddrOp elementalAddr =
Fortran::lower::convertVectorSubscriptedExprToElementalAddr(
loc, *this, assign.lhs, localSymbols, lhsContext);
Fortran::lower::genCleanUpInRegionIfAny(
loc, builder, elementalAddr.getCleanup(), lhsContext);
lhsYield = elementalAddr.getYieldOp().getEntity();
}
assert(lhsYield && "must have been set");
// Add "realloc" flag to hlfir.region_assign.
if (isWholeAllocatableAssignment)
TODO(loc, "assignment to a whole allocatable inside FORALL");
// Generate the hlfir.region_assign userDefinedAssignment region.
if (userDefinedAssignment) {
mlir::Type rhsType = rhs.getType();
mlir::Type lhsType = lhsYield.getType();
if (userDefinedAssignment->IsElemental()) {
rhsType = hlfir::getEntityElementType(rhs);
lhsType = hlfir::getEntityElementType(hlfir::Entity{lhsYield});
}
builder.createBlock(&regionAssignOp.getUserDefinedAssignment(),
mlir::Region::iterator{}, {rhsType, lhsType},
{loc, loc});
auto end = fir::FirEndOp::create(builder, loc);
builder.setInsertionPoint(end);
hlfir::Entity lhsBlockArg{regionAssignOp.getUserAssignmentLhs()};
hlfir::Entity rhsBlockArg{regionAssignOp.getUserAssignmentRhs()};
Fortran::lower::convertUserDefinedAssignmentToHLFIR(
loc, *this, *userDefinedAssignment, lhsBlockArg, rhsBlockArg,
localSymbols);
}
builder.setInsertionPointAfter(regionAssignOp);
}
/// Shared for both assignments and pointer assignments.
void
genAssignment(const Fortran::evaluate::Assignment &assign,
const llvm::ArrayRef<const Fortran::parser::CompilerDirective *>
&dirs = {}) {
mlir::Location loc = toLocation();
Fortran::common::visit(
Fortran::common::visitors{
[&](const Fortran::evaluate::Assignment::Intrinsic &) {
genDataAssignment(assign, /*userDefinedAssignment=*/nullptr,
dirs);
},
[&](const Fortran::evaluate::ProcedureRef &procRef) {
genDataAssignment(assign, /*userDefinedAssignment=*/&procRef,
dirs);
},
[&](const Fortran::evaluate::Assignment::BoundsSpec &lbExprs) {
genPointerAssignment(loc, assign);
},
[&](const Fortran::evaluate::Assignment::BoundsRemapping
&boundExprs) { genPointerAssignment(loc, assign); },
},
assign.u);
}
// Is the insertion point of the builder directly or indirectly set
// inside any operation of type "Op"?
template <typename... Op>
bool isInsideOp() const {
mlir::Block *block = builder->getInsertionBlock();
mlir::Operation *op = block ? block->getParentOp() : nullptr;
while (op) {
if (mlir::isa<Op...>(op))
return true;
op = op->getParentOp();
}
return false;
}
bool isInsideHlfirForallOrWhere() const {
return isInsideOp<hlfir::ForallOp, hlfir::WhereOp>();
}
bool isInsideHlfirWhere() const { return isInsideOp<hlfir::WhereOp>(); }
void genFIR(const Fortran::parser::WhereConstruct &c) {
setCurrentPositionAt(c);
mlir::Location loc = getCurrentLocation();
auto whereOp = hlfir::WhereOp::create(*builder, loc);
builder->createBlock(&whereOp.getMaskRegion());
// Lower the where mask in the hlfir.where mask region.
genNestedStatement(
std::get<
Fortran::parser::Statement<Fortran::parser::WhereConstructStmt>>(
c.t));
// Lower WHERE body in the hlfir.where body region.
builder->createBlock(&whereOp.getBody());
for (const auto &body :
std::get<std::list<Fortran::parser::WhereBodyConstruct>>(c.t))
genFIR(body);
for (const auto &e :
std::get<std::list<Fortran::parser::WhereConstruct::MaskedElsewhere>>(
c.t))
genFIR(e);
if (const auto &e =
std::get<std::optional<Fortran::parser::WhereConstruct::Elsewhere>>(
c.t);
e.has_value())
genFIR(*e);
genNestedStatement(
std::get<Fortran::parser::Statement<Fortran::parser::EndWhereStmt>>(
c.t));
// Create fir.end terminator in the last hlfir.elsewhere, or in the
// hlfir.where if it had no elsewhere.
fir::FirEndOp::create(*builder, loc);
builder->setInsertionPointAfter(whereOp);
}
void genFIR(const Fortran::parser::WhereBodyConstruct &body) {
Fortran::common::visit(
Fortran::common::visitors{
[&](const Fortran::parser::Statement<
Fortran::parser::AssignmentStmt> &stmt) {
genNestedStatement(stmt);
},
[&](const Fortran::parser::Statement<Fortran::parser::WhereStmt>
&stmt) { genNestedStatement(stmt); },
[&](const Fortran::common::Indirection<
Fortran::parser::WhereConstruct> &c) { genFIR(c.value()); },
},
body.u);
}
/// Lower a Where or Elsewhere mask into an hlfir mask region.
void lowerWhereMaskToHlfir(mlir::Location loc,
const Fortran::semantics::SomeExpr *maskExpr) {
assert(maskExpr && "mask semantic analysis failed");
Fortran::lower::StatementContext maskContext;
hlfir::Entity mask = Fortran::lower::convertExprToHLFIR(
loc, *this, *maskExpr, localSymbols, maskContext);
mask = hlfir::loadTrivialScalar(loc, *builder, mask);
auto yieldOp = hlfir::YieldOp::create(*builder, loc, mask);
Fortran::lower::genCleanUpInRegionIfAny(loc, *builder, yieldOp.getCleanup(),
maskContext);
}
void genFIR(const Fortran::parser::WhereConstructStmt &stmt) {
const Fortran::semantics::SomeExpr *maskExpr = Fortran::semantics::GetExpr(
std::get<Fortran::parser::LogicalExpr>(stmt.t));
lowerWhereMaskToHlfir(getCurrentLocation(), maskExpr);
}
void genFIR(const Fortran::parser::WhereConstruct::MaskedElsewhere &ew) {
setCurrentPositionAt(ew);
mlir::Location loc = getCurrentLocation();
auto elsewhereOp = hlfir::ElseWhereOp::create(*builder, loc);
// Lower mask in the mask region.
builder->createBlock(&elsewhereOp.getMaskRegion());
genNestedStatement(
std::get<
Fortran::parser::Statement<Fortran::parser::MaskedElsewhereStmt>>(
ew.t));
// Lower the body in the hlfir.elsewhere body region.
builder->createBlock(&elsewhereOp.getBody());
for (const auto &body :
std::get<std::list<Fortran::parser::WhereBodyConstruct>>(ew.t))
genFIR(body);
}
void genFIR(const Fortran::parser::MaskedElsewhereStmt &stmt) {
const auto *maskExpr = Fortran::semantics::GetExpr(
std::get<Fortran::parser::LogicalExpr>(stmt.t));
lowerWhereMaskToHlfir(getCurrentLocation(), maskExpr);
}
void genFIR(const Fortran::parser::WhereConstruct::Elsewhere &ew) {
setCurrentPositionAt(ew);
auto elsewhereOp =
hlfir::ElseWhereOp::create(*builder, getCurrentLocation());
builder->createBlock(&elsewhereOp.getBody());
genNestedStatement(
std::get<Fortran::parser::Statement<Fortran::parser::ElsewhereStmt>>(
ew.t));
for (const auto &body :
std::get<std::list<Fortran::parser::WhereBodyConstruct>>(ew.t))
genFIR(body);
}
void genFIR(const Fortran::parser::ElsewhereStmt &stmt) {}
void genFIR(const Fortran::parser::EndWhereStmt &) {}
void genFIR(const Fortran::parser::WhereStmt &stmt) {
Fortran::lower::StatementContext stmtCtx;
const auto &assign = std::get<Fortran::parser::AssignmentStmt>(stmt.t);
const auto *mask = Fortran::semantics::GetExpr(
std::get<Fortran::parser::LogicalExpr>(stmt.t));
mlir::Location loc = getCurrentLocation();
auto whereOp = hlfir::WhereOp::create(*builder, loc);
builder->createBlock(&whereOp.getMaskRegion());
lowerWhereMaskToHlfir(loc, mask);
builder->createBlock(&whereOp.getBody());
genAssignment(*assign.typedAssignment->v);
fir::FirEndOp::create(*builder, loc);
builder->setInsertionPointAfter(whereOp);
}
void genFIR(const Fortran::parser::PointerAssignmentStmt &stmt) {
genAssignment(*stmt.typedAssignment->v);
}
void genFIR(const Fortran::parser::AssignmentStmt &stmt) {
Fortran::lower::pft::Evaluation &eval = getEval();
genAssignment(*stmt.typedAssignment->v, eval.dirs);
}
void genFIR(const Fortran::parser::SyncAllStmt &stmt) {
genSyncAllStatement(*this, stmt);
}
void genFIR(const Fortran::parser::SyncImagesStmt &stmt) {
genSyncImagesStatement(*this, stmt);
}
void genFIR(const Fortran::parser::SyncMemoryStmt &stmt) {
genSyncMemoryStatement(*this, stmt);
}
void genFIR(const Fortran::parser::SyncTeamStmt &stmt) {
genSyncTeamStatement(*this, stmt);
}
void genFIR(const Fortran::parser::UnlockStmt &stmt) {
genUnlockStatement(*this, stmt);
}
void genFIR(const Fortran::parser::AssignStmt &stmt) {
const Fortran::semantics::Symbol &symbol =
*std::get<Fortran::parser::Name>(stmt.t).symbol;
mlir::Location loc = toLocation();
mlir::Type symbolType = genType(symbol);
mlir::Value addr = getSymbolAddress(symbol);
// Handle the case where the assigned variable is declared as a pointer
if (auto eleTy = fir::dyn_cast_ptrOrBoxEleTy(symbolType)) {
if (auto ptrType = mlir::dyn_cast<fir::PointerType>(eleTy)) {
symbolType = ptrType.getEleTy();
} else {
symbolType = eleTy;
}
} else if (auto ptrType = mlir::dyn_cast<fir::PointerType>(symbolType)) {
symbolType = ptrType.getEleTy();
}
mlir::Value labelValue = builder->createIntegerConstant(
loc, symbolType, std::get<Fortran::parser::Label>(stmt.t));
// If the address points to a boxed pointer, we need to dereference it
if (auto refType = mlir::dyn_cast<fir::ReferenceType>(addr.getType())) {
if (auto boxType = mlir::dyn_cast<fir::BoxType>(refType.getEleTy())) {
mlir::Value boxValue = fir::LoadOp::create(*builder, loc, addr);
addr = fir::BoxAddrOp::create(*builder, loc, boxValue);
}
}
fir::StoreOp::create(*builder, loc, labelValue, addr);
}
void genFIR(const Fortran::parser::FormatStmt &) {
// do nothing.
// FORMAT statements have no semantics. They may be lowered if used by a
// data transfer statement.
}
void genFIR(const Fortran::parser::PauseStmt &stmt) {
genPauseStatement(*this, stmt);
}
// call FAIL IMAGE in runtime
void genFIR(const Fortran::parser::FailImageStmt &stmt) {
genFailImageStatement(*this);
}
// call STOP, ERROR STOP in runtime
void genFIR(const Fortran::parser::StopStmt &stmt) {
genStopStatement(*this, stmt);
}
void genFIR(const Fortran::parser::ReturnStmt &stmt) {
Fortran::lower::pft::FunctionLikeUnit *funit =
getEval().getOwningProcedure();
assert(funit && "not inside main program, function or subroutine");
for (auto it = activeConstructStack.rbegin(),
rend = activeConstructStack.rend();
it != rend; ++it) {
it->stmtCtx.finalizeAndKeep();
}
if (funit->isMainProgram()) {
genExitRoutine(true);
return;
}
mlir::Location loc = toLocation();
if (stmt.v) {
// Alternate return statement - If this is a subroutine where some
// alternate entries have alternate returns, but the active entry point
// does not, ignore the alternate return value. Otherwise, assign it
// to the compiler-generated result variable.
const Fortran::semantics::Symbol &symbol = funit->getSubprogramSymbol();
if (Fortran::semantics::HasAlternateReturns(symbol)) {
Fortran::lower::StatementContext stmtCtx;
const Fortran::lower::SomeExpr *expr =
Fortran::semantics::GetExpr(*stmt.v);
assert(expr && "missing alternate return expression");
mlir::Value altReturnIndex = builder->createConvert(
loc, builder->getIndexType(), createFIRExpr(loc, expr, stmtCtx));
fir::StoreOp::create(*builder, loc, altReturnIndex,
getAltReturnResult(symbol));
}
}
// Branch to the last block of the SUBROUTINE, which has the actual return.
if (!funit->finalBlock) {
mlir::OpBuilder::InsertPoint insPt = builder->saveInsertionPoint();
Fortran::lower::setInsertionPointAfterOpenACCLoopIfInside(*builder);
funit->finalBlock = builder->createBlock(&builder->getRegion());
builder->restoreInsertionPoint(insPt);
}
if (Fortran::lower::isInOpenACCLoop(*builder))
Fortran::lower::genEarlyReturnInOpenACCLoop(*builder, loc);
else
mlir::cf::BranchOp::create(*builder, loc, funit->finalBlock);
}
void genFIR(const Fortran::parser::CycleStmt &) {
genConstructExitBranch(*getEval().controlSuccessor);
}
void genFIR(const Fortran::parser::ExitStmt &) {
genConstructExitBranch(*getEval().controlSuccessor);
}
void genFIR(const Fortran::parser::GotoStmt &) {
genConstructExitBranch(*getEval().controlSuccessor);
}
// Nop statements - No code, or code is generated at the construct level.
// But note that the genFIR call immediately below that wraps one of these
// calls does block management, possibly starting a new block, and possibly
// generating a branch to end a block. So these calls may still be required
// for that functionality.
void genFIR(const Fortran::parser::AssociateStmt &) {} // nop
void genFIR(const Fortran::parser::BlockStmt &) {} // nop
void genFIR(const Fortran::parser::CaseStmt &) {} // nop
void genFIR(const Fortran::parser::ContinueStmt &) {} // nop
void genFIR(const Fortran::parser::ElseIfStmt &) {} // nop
void genFIR(const Fortran::parser::ElseStmt &) {} // nop
void genFIR(const Fortran::parser::EndAssociateStmt &) {} // nop
void genFIR(const Fortran::parser::EndBlockStmt &) {} // nop
void genFIR(const Fortran::parser::EndDoStmt &) {} // nop
void genFIR(const Fortran::parser::EndFunctionStmt &) {} // nop
void genFIR(const Fortran::parser::EndIfStmt &) {} // nop
void genFIR(const Fortran::parser::EndMpSubprogramStmt &) {} // nop
void genFIR(const Fortran::parser::EndProgramStmt &) {} // nop
void genFIR(const Fortran::parser::EndSelectStmt &) {} // nop
void genFIR(const Fortran::parser::EndSubroutineStmt &) {} // nop
void genFIR(const Fortran::parser::EntryStmt &) {} // nop
void genFIR(const Fortran::parser::IfStmt &) {} // nop
void genFIR(const Fortran::parser::IfThenStmt &) {} // nop
void genFIR(const Fortran::parser::NonLabelDoStmt &) {} // nop
void genFIR(const Fortran::parser::SelectTypeStmt &) {} // nop
void genFIR(const Fortran::parser::TypeGuardStmt &) {} // nop
void genFIR(const Fortran::parser::ChangeTeamStmt &stmt) {} // nop
void genFIR(const Fortran::parser::EndChangeTeamStmt &stmt) {} // nop
/// Generate FIR for Evaluation \p eval.
void genFIR(Fortran::lower::pft::Evaluation &eval,
bool unstructuredContext = true) {
// Start a new unstructured block when applicable. When transitioning
// from unstructured to structured code, unstructuredContext is true,
// which accounts for the possibility that the structured code could be
// a target that starts a new block.
if (unstructuredContext)
maybeStartBlock(eval.isConstruct() && eval.lowerAsStructured()
? eval.getFirstNestedEvaluation().block
: eval.block);
if (eval.skipNextLowering) {
eval.skipNextLowering = false;
return;
}
// Add scope for constructs inside acc.loop to properly contain symbol
// bindings (e.g., from cache directive) within the construct.
bool needsAccScope =
eval.isConstruct() && Fortran::lower::isInOpenACCLoop(*builder);
if (needsAccScope)
localSymbols.pushScope();
llvm::scope_exit popAccScope([&]() {
if (needsAccScope)
localSymbols.popScope();
});
// Generate evaluation specific code. Even nop calls should usually reach
// here in case they start a new block or require generation of a generic
// end-of-block branch. An alternative is to add special case code
// elsewhere, such as in the genFIR code for a parent construct.
setCurrentEval(eval);
setCurrentPosition(eval.position);
eval.visit([&](const auto &stmt) { genFIR(stmt); });
}
/// Map mlir function block arguments to the corresponding Fortran dummy
/// variables. When the result is passed as a hidden argument, the Fortran
/// result is also mapped. The symbol map is used to hold this mapping.
void mapDummiesAndResults(Fortran::lower::pft::FunctionLikeUnit &funit,
const Fortran::lower::CalleeInterface &callee) {
assert(builder && "require a builder object at this point");
using PassBy = Fortran::lower::CalleeInterface::PassEntityBy;
// Track the source-level argument position (1-based)
unsigned argPosition = 0;
auto mapPassedEntity = [&](const auto arg, bool isResult = false) {
// Count only actual source-level dummy arguments (not results or
// host assoc tuples)
if (!isResult && arg.entity.has_value())
argPosition++;
if (arg.passBy == PassBy::AddressAndLength) {
if (callee.characterize().IsBindC())
return;
// TODO: now that fir call has some attributes regarding character
// return, PassBy::AddressAndLength should be retired.
mlir::Location loc = toLocation();
fir::factory::CharacterExprHelper charHelp{*builder, loc};
mlir::Value casted =
builder->createVolatileCast(loc, false, arg.firArgument);
mlir::Value box = charHelp.createEmboxChar(casted, arg.firLength);
mapBlockArgToDummyOrResult(arg.entity->get(), box, isResult,
isResult ? 0 : argPosition);
} else {
if (arg.entity.has_value()) {
mapBlockArgToDummyOrResult(arg.entity->get(), arg.firArgument,
isResult, isResult ? 0 : argPosition);
} else {
assert(funit.parentHasTupleHostAssoc() && "expect tuple argument");
}
}
};
for (const Fortran::lower::CalleeInterface::PassedEntity &arg :
callee.getPassedArguments())
mapPassedEntity(arg);
// Always generate fir.dummy_scope even if there are no arguments.
// It is currently used to create proper TBAA forest.
{
mlir::Value scopeOp = fir::DummyScopeOp::create(*builder, toLocation());
setDummyArgsScope(scopeOp);
}
if (std::optional<Fortran::lower::CalleeInterface::PassedEntity>
passedResult = callee.getPassedResult()) {
mapPassedEntity(*passedResult, /*isResult=*/true);
// FIXME: need to make sure things are OK here. addSymbol may not be OK
if (funit.primaryResult &&
passedResult->entity->get() != *funit.primaryResult)
mapBlockArgToDummyOrResult(
*funit.primaryResult, getSymbolAddress(passedResult->entity->get()),
/*isResult=*/true);
}
}
/// Instantiate variable \p var and add it to the symbol map.
/// See ConvertVariable.cpp.
void instantiateVar(const Fortran::lower::pft::Variable &var,
Fortran::lower::AggregateStoreMap &storeMap) {
Fortran::lower::instantiateVariable(*this, var, localSymbols, storeMap);
if (var.hasSymbol())
genOpenMPSymbolProperties(*this, var);
}
/// Where applicable, save the exception state and halting, rounding, and
/// underflow modes at function entry, and restore them at function exits.
void manageFPEnvironment(Fortran::lower::pft::FunctionLikeUnit &funit) {
mlir::Location loc = toLocation();
mlir::Location endLoc =
toLocation(Fortran::lower::pft::stmtSourceLoc(funit.endStmt));
if (funit.hasIeeeAccess) {
// Subject to F18 Clause 17.1p3, 17.3p3 states: If a flag is signaling
// on entry to a procedure [...], the processor will set it to quiet
// on entry and restore it to signaling on return. If a flag signals
// during execution of a procedure, the processor shall not set it to
// quiet on return.
mlir::func::FuncOp testExcept = fir::factory::getFetestexcept(*builder);
mlir::func::FuncOp clearExcept = fir::factory::getFeclearexcept(*builder);
mlir::func::FuncOp raiseExcept = fir::factory::getFeraiseexcept(*builder);
mlir::Value ones = builder->createIntegerConstant(
loc, testExcept.getFunctionType().getInput(0), -1);
mlir::Value exceptSet =
fir::CallOp::create(*builder, loc, testExcept, ones).getResult(0);
fir::CallOp::create(*builder, loc, clearExcept, exceptSet);
bridge.fctCtx().attachCleanup([=]() {
fir::CallOp::create(*builder, endLoc, raiseExcept, exceptSet);
});
}
if (funit.mayModifyHaltingMode) {
// F18 Clause 17.6p1: In a procedure [...], the processor shall not
// change the halting mode on entry, and on return shall ensure that
// the halting mode is the same as it was on entry.
mlir::func::FuncOp getExcept = fir::factory::getFegetexcept(*builder);
mlir::func::FuncOp disableExcept =
fir::factory::getFedisableexcept(*builder);
mlir::func::FuncOp enableExcept =
fir::factory::getFeenableexcept(*builder);
mlir::Value exceptSet =
fir::CallOp::create(*builder, loc, getExcept).getResult(0);
mlir::Value ones = builder->createIntegerConstant(
loc, disableExcept.getFunctionType().getInput(0), -1);
bridge.fctCtx().attachCleanup([=]() {
fir::CallOp::create(*builder, endLoc, disableExcept, ones);
fir::CallOp::create(*builder, endLoc, enableExcept, exceptSet);
});
}
if (funit.mayModifyRoundingMode) {
// F18 Clause 17.4p5: In a procedure [...], the processor shall not
// change the rounding modes on entry, and on return shall ensure that
// the rounding modes are the same as they were on entry.
mlir::func::FuncOp getRounding =
fir::factory::getLlvmGetRounding(*builder);
mlir::func::FuncOp setRounding =
fir::factory::getLlvmSetRounding(*builder);
mlir::Value roundingMode =
fir::CallOp::create(*builder, loc, getRounding).getResult(0);
bridge.fctCtx().attachCleanup([=]() {
fir::CallOp::create(*builder, endLoc, setRounding, roundingMode);
});
}
if ((funit.mayModifyUnderflowMode) &&
(bridge.getTargetCharacteristics().hasSubnormalFlushingControl(
/*any=*/true))) {
// F18 Clause 17.5p2: In a procedure [...], the processor shall not
// change the underflow mode on entry, and on return shall ensure that
// the underflow mode is the same as it was on entry.
mlir::Value underflowMode =
fir::runtime::genGetUnderflowMode(*builder, loc);
bridge.fctCtx().attachCleanup([=]() {
fir::runtime::genSetUnderflowMode(*builder, loc, {underflowMode});
});
}
}
/// Start translation of a function.
void startNewFunction(Fortran::lower::pft::FunctionLikeUnit &funit) {
assert(!builder && "expected nullptr");
bridge.fctCtx().pushScope();
bridge.cudaCleanupCtx().pushScope();
bridge.openAccCtx().pushScope();
const Fortran::semantics::Scope &scope = funit.getScope();
LLVM_DEBUG(llvm::dbgs() << "\n[bridge - startNewFunction]";
if (auto *sym = scope.symbol()) llvm::dbgs() << " " << *sym;
llvm::dbgs() << "\n");
// Setting the builder is not necessary here, because callee
// always looks up the FuncOp from the module. If there was a function that
// was not declared yet, this call to callee will cause an assertion
// failure.
Fortran::lower::CalleeInterface callee(funit, *this);
mlir::func::FuncOp func = callee.addEntryBlockAndMapArguments();
builder =
new fir::FirOpBuilder(func, bridge.getKindMap(), &mlirSymbolTable);
assert(builder && "FirOpBuilder did not instantiate");
builder->setComplexDivisionToRuntimeFlag(
bridge.getLoweringOptions().getComplexDivisionToRuntime());
builder->setFastMathFlags(bridge.getLoweringOptions().getMathOptions());
builder->setFPMaxminBehavior(
bridge.getLoweringOptions().getFPMaxminBehavior());
builder->setInsertionPointToStart(&func.front());
if (funit.parent.isA<Fortran::lower::pft::FunctionLikeUnit>()) {
// Give internal linkage to internal functions. There are no name clash
// risks, but giving global linkage to internal procedure will break the
// static link register in shared libraries because of the system calls.
// Also, it should be possible to eliminate the procedure code if all the
// uses have been inlined.
fir::factory::setInternalLinkage(func);
} else {
func.setVisibility(mlir::SymbolTable::Visibility::Public);
}
assert(blockId == 0 && "invalid blockId");
assert(activeConstructStack.empty() && "invalid construct stack state");
// Manage floating point exception, halting mode, and rounding mode
// settings at function entry and exit.
if (!funit.isMainProgram())
manageFPEnvironment(funit);
mapDummiesAndResults(funit, callee);
// Emit USE statement operations for debug info generation
emitUseStatementsFromFunit(*this, *builder, toLocation(), funit);
setDefiningSubmoduleForDebug(*this, func, funit);
// Map host associated symbols from parent procedure if any.
if (funit.parentHasHostAssoc())
funit.parentHostAssoc().internalProcedureBindings(*this, localSymbols);
// Non-primary results of a function with multiple entry points.
// These result values share storage with the primary result.
llvm::SmallVector<Fortran::lower::pft::Variable> deferredFuncResultList;
// Backup actual argument for entry character results with different
// lengths. It needs to be added to the non-primary results symbol before
// mapSymbolAttributes is called.
Fortran::lower::SymbolBox resultArg;
if (std::optional<Fortran::lower::CalleeInterface::PassedEntity>
passedResult = callee.getPassedResult())
resultArg = lookupSymbol(passedResult->entity->get());
Fortran::lower::AggregateStoreMap storeMap;
// Map containing [sub]module equivalences and variables that are
// referenced in this function-like unit. Only referenced host module
// variables are instantiated to avoid generating IR for unused module
// variables. Equivalenced variables are handled via the aggregate store
// analysis performed on the host [sub]module scopes.
const bool hasHostModuleScope = [&]() {
for (auto *scp = &scope.parent(); !scp->IsGlobal(); scp = &scp->parent())
if (scp->kind() == Fortran::semantics::Scope::Kind::Module)
return true;
return false;
}();
if (hasHostModuleScope)
for (const auto &var :
Fortran::lower::pft::getHostModuleVariableList(funit))
instantiateVar(var, storeMap);
// Map function equivalences and variables.
mlir::Value primaryFuncResultStorage;
for (const Fortran::lower::pft::Variable &var :
Fortran::lower::pft::getScopeVariableList(scope)) {
// Always instantiate aggregate storage blocks.
if (var.isAggregateStore()) {
instantiateVar(var, storeMap);
continue;
}
const Fortran::semantics::Symbol &sym = var.getSymbol();
if (funit.parentHasHostAssoc()) {
// Never instantiate host associated variables, as they are already
// instantiated from an argument tuple. Instead, just bind the symbol
// to the host variable, which must be in the map.
const Fortran::semantics::Symbol &ultimate = sym.GetUltimate();
if (funit.parentHostAssoc().isAssociated(ultimate)) {
copySymbolBinding(ultimate, sym);
continue;
}
}
if (!sym.IsFuncResult() || !funit.primaryResult) {
instantiateVar(var, storeMap);
} else if (&sym == funit.primaryResult) {
instantiateVar(var, storeMap);
primaryFuncResultStorage = getSymbolAddress(sym);
} else {
deferredFuncResultList.push_back(var);
}
}
// TODO: should use same mechanism as equivalence?
// One blocking point is character entry returns that need special handling
// since they are not locally allocated but come as argument. CHARACTER(*)
// is not something that fits well with equivalence lowering.
for (const Fortran::lower::pft::Variable &altResult :
deferredFuncResultList) {
Fortran::lower::StatementContext stmtCtx;
if (std::optional<Fortran::lower::CalleeInterface::PassedEntity>
passedResult = callee.getPassedResult()) {
mapBlockArgToDummyOrResult(altResult.getSymbol(), resultArg.getAddr(),
/*isResult=*/true);
Fortran::lower::mapSymbolAttributes(*this, altResult, localSymbols,
stmtCtx);
} else {
// catch cases where the allocation for the function result storage type
// doesn't match the type of this symbol
mlir::Value preAlloc = primaryFuncResultStorage;
mlir::Type resTy = primaryFuncResultStorage.getType();
mlir::Type symTy = genType(altResult);
mlir::Type wrappedSymTy = fir::ReferenceType::get(symTy);
if (resTy != wrappedSymTy) {
// check size of the pointed to type so we can't overflow by writing
// double precision to a single precision allocation, etc
[[maybe_unused]] auto getBitWidth = [this](mlir::Type ty) {
// 15.6.2.6.3: differering result types should be integer, real,
// complex or logical
if (auto cmplx = mlir::dyn_cast_or_null<mlir::ComplexType>(ty))
return 2 * cmplx.getElementType().getIntOrFloatBitWidth();
if (auto logical = mlir::dyn_cast_or_null<fir::LogicalType>(ty)) {
fir::KindTy kind = logical.getFKind();
return builder->getKindMap().getLogicalBitsize(kind);
}
return ty.getIntOrFloatBitWidth();
};
assert(getBitWidth(fir::unwrapRefType(resTy)) >= getBitWidth(symTy));
// convert the storage to the symbol type so that the hlfir.declare
// gets the correct type for this symbol
preAlloc = fir::ConvertOp::create(*builder, getCurrentLocation(),
wrappedSymTy, preAlloc);
}
Fortran::lower::mapSymbolAttributes(*this, altResult, localSymbols,
stmtCtx, preAlloc);
}
}
// If this is a host procedure with host associations, then create the tuple
// of pointers for passing to the internal procedures.
if (!funit.getHostAssoc().empty())
funit.getHostAssoc().hostProcedureBindings(*this, localSymbols);
// Unregister all dummy symbols, so that their cloning (e.g. for OpenMP
// privatization) does not create the cloned hlfir.declare operations
// with dummy_scope operands.
resetRegisteredDummySymbols();
// Clear any Evaluation::block pointers left over from a previous
// entry-point pass over this shared PFT.
resetEvaluationBlocks(funit.evaluationList);
// Create most function blocks in advance.
createEmptyBlocks(funit.evaluationList);
// Reinstate entry block as the current insertion point.
builder->setInsertionPointToEnd(&func.front());
if (callee.hasAlternateReturns()) {
// Create a local temp to hold the alternate return index.
// Give it an integer index type and the subroutine name (for dumps).
// Attach it to the subroutine symbol in the localSymbols map.
// Initialize it to zero, the "fallthrough" alternate return value.
const Fortran::semantics::Symbol &symbol = funit.getSubprogramSymbol();
mlir::Location loc = toLocation();
mlir::Type idxTy = builder->getIndexType();
mlir::Value altResult =
builder->createTemporary(loc, idxTy, toStringRef(symbol.name()));
addSymbol(symbol, altResult);
mlir::Value zero = builder->createIntegerConstant(loc, idxTy, 0);
fir::StoreOp::create(*builder, loc, zero, altResult);
}
if (Fortran::lower::pft::Evaluation *alternateEntryEval =
funit.getEntryEval())
genBranch(alternateEntryEval->lexicalSuccessor->block);
}
/// Recursively null every Evaluation::block in \p evaluationList. Called
/// once per entry-point pass over a shared PFT so a later pass never sees
/// block pointers that belong to a prior pass's function or wrap region.
void resetEvaluationBlocks(
std::list<Fortran::lower::pft::Evaluation> &evaluationList) {
for (Fortran::lower::pft::Evaluation &eval : evaluationList) {
eval.block = nullptr;
if (eval.evaluationList)
resetEvaluationBlocks(*eval.evaluationList);
}
}
/// Create global blocks for the current function. This eliminates the
/// distinction between forward and backward targets when generating
/// branches. A block is "global" if it can be the target of a GOTO or
/// other source code branch. A block that can only be targeted by a
/// compiler generated branch is "local". For example, a DO loop preheader
/// block containing loop initialization code is global. A loop header
/// block, which is the target of the loop back edge, is local. Blocks
/// belong to a region. Any block within a nested region must be replaced
/// with a block belonging to that region. Branches may not cross region
/// boundaries.
void createEmptyBlocks(
std::list<Fortran::lower::pft::Evaluation> &evaluationList) {
mlir::Region *region = &builder->getRegion();
for (Fortran::lower::pft::Evaluation &eval : evaluationList) {
if (eval.isNewBlock)
eval.block = builder->createBlock(region);
if (eval.isConstruct() || eval.isDirective()) {
if (Fortran::lower::pft::isWrappableConstruct(
eval, bridge.getSemanticsContext())) {
// The wrap owns internal blocks; only create the entry block here
// so the enclosing CFG can branch to it.
if (eval.hasNestedEvaluations()) {
Fortran::lower::pft::Evaluation &constructStmt =
eval.getFirstNestedEvaluation();
if (constructStmt.isNewBlock)
constructStmt.block = builder->createBlock(region);
}
} else if (eval.lowerAsUnstructured()) {
createEmptyBlocks(eval.getNestedEvaluations());
} else if (eval.hasNestedEvaluations()) {
// A structured construct that is a target starts a new block.
Fortran::lower::pft::Evaluation &constructStmt =
eval.getFirstNestedEvaluation();
if (constructStmt.isNewBlock)
constructStmt.block = builder->createBlock(region);
}
}
}
}
/// Return the predicate: "current block does not have a terminator branch".
bool blockIsUnterminated() {
mlir::Block *currentBlock = builder->getBlock();
return currentBlock->empty() ||
!currentBlock->back().hasTrait<mlir::OpTrait::IsTerminator>();
}
/// Unconditionally switch code insertion to a new block.
void startBlock(mlir::Block *newBlock) {
assert(newBlock && "missing block");
// Default termination for the current block is a fallthrough branch to
// the new block.
if (blockIsUnterminated())
genBranch(newBlock);
// Some blocks may be re/started more than once, and might not be empty.
// If the new block already has (only) a terminator, set the insertion
// point to the start of the block. Otherwise set it to the end.
builder->setInsertionPointToStart(newBlock);
if (blockIsUnterminated())
builder->setInsertionPointToEnd(newBlock);
}
/// Conditionally switch code insertion to a new block.
void maybeStartBlock(mlir::Block *newBlock) {
if (newBlock)
startBlock(newBlock);
}
void eraseDeadCodeAndBlocks(mlir::RewriterBase &rewriter,
llvm::MutableArrayRef<mlir::Region> regions) {
// WARNING: Do not add passes that can do folding or code motion here
// because they might cross omp.target region boundaries, which can result
// in incorrect code. Optimization passes like these must be added after
// OMP early outlining has been done.
(void)mlir::eraseUnreachableBlocks(rewriter, regions);
(void)mlir::runRegionDCE(rewriter, regions);
}
/// Finish translation of a function.
void endNewFunction(Fortran::lower::pft::FunctionLikeUnit &funit) {
setCurrentPosition(Fortran::lower::pft::stmtSourceLoc(funit.endStmt));
if (funit.isMainProgram()) {
genExitRoutine(false);
} else {
genFIRProcedureExit(funit, funit.getSubprogramSymbol());
}
funit.finalBlock = nullptr;
LLVM_DEBUG(llvm::dbgs() << "\n[bridge - endNewFunction";
if (auto *sym = funit.scope->symbol()) llvm::dbgs()
<< " " << sym->name();
llvm::dbgs() << "] generated IR:\n\n"
<< *builder->getFunction() << '\n');
// Eliminate dead code as a prerequisite to calling other IR passes.
// FIXME: This simplification should happen in a normal pass, not here.
mlir::IRRewriter rewriter(*builder);
(void)eraseDeadCodeAndBlocks(rewriter, {builder->getRegion()});
delete builder;
builder = nullptr;
hostAssocTuple = mlir::Value{};
localSymbols.clear();
blockId = 0;
dummyArgsScope = mlir::Value{};
resetRegisteredDummySymbols();
}
/// Helper to generate GlobalOps when the builder is not positioned in any
/// region block. This is required because the FirOpBuilder assumes it is
/// always positioned inside a region block when creating globals, the easiest
/// way to comply is to create a dummy function and to throw it away
/// afterwards.
void createBuilderOutsideOfFuncOpAndDo(
const std::function<void()> &createGlobals) {
// FIXME: get rid of the bogus function context and instantiate the
// globals directly into the module.
mlir::MLIRContext *context = &getMLIRContext();
mlir::SymbolTable *symbolTable = getMLIRSymbolTable();
mlir::func::FuncOp func = fir::FirOpBuilder::createFunction(
mlir::UnknownLoc::get(context), getModuleOp(),
fir::NameUniquer::doGenerated("Sham"),
mlir::FunctionType::get(context, {}, {}), symbolTable);
func.addEntryBlock();
CHECK(!builder && "Expected builder to be uninitialized");
builder = new fir::FirOpBuilder(func, bridge.getKindMap(), symbolTable);
assert(builder && "FirOpBuilder did not instantiate");
builder->setFastMathFlags(bridge.getLoweringOptions().getMathOptions());
builder->setFPMaxminBehavior(
bridge.getLoweringOptions().getFPMaxminBehavior());
createGlobals();
if (mlir::Region *region = func.getCallableRegion())
region->dropAllReferences();
func.erase();
delete builder;
builder = nullptr;
localSymbols.clear();
resetRegisteredDummySymbols();
}
/// Instantiate the data from a BLOCK DATA unit.
void lowerBlockData(Fortran::lower::pft::BlockDataUnit &bdunit) {
createBuilderOutsideOfFuncOpAndDo([&]() {
Fortran::lower::AggregateStoreMap fakeMap;
for (const auto &[_, sym] : bdunit.symTab) {
if (sym->has<Fortran::semantics::ObjectEntityDetails>()) {
Fortran::lower::pft::Variable var(*sym, true);
instantiateVar(var, fakeMap);
}
}
});
}
/// Create fir::Global for all the common blocks that appear in the program.
void
lowerCommonBlocks(const Fortran::semantics::CommonBlockList &commonBlocks) {
createBuilderOutsideOfFuncOpAndDo(
[&]() { Fortran::lower::defineCommonBlocks(*this, commonBlocks); });
}
/// Create intrinsic module array constant definitions.
void createIntrinsicModuleDefinitions(Fortran::lower::pft::Program &pft) {
// The intrinsic module scope, if present, is the first scope.
const Fortran::semantics::Scope *intrinsicModuleScope = nullptr;
for (Fortran::lower::pft::Program::Units &u : pft.getUnits()) {
Fortran::common::visit(
Fortran::common::visitors{
[&](Fortran::lower::pft::FunctionLikeUnit &f) {
intrinsicModuleScope = &f.getScope().parent();
},
[&](Fortran::lower::pft::ModuleLikeUnit &m) {
intrinsicModuleScope = &m.getScope().parent();
},
[&](Fortran::lower::pft::BlockDataUnit &b) {},
[&](Fortran::lower::pft::CompilerDirectiveUnit &d) {},
[&](Fortran::lower::pft::OpenACCDirectiveUnit &d) {},
},
u);
if (intrinsicModuleScope) {
while (!intrinsicModuleScope->IsGlobal())
intrinsicModuleScope = &intrinsicModuleScope->parent();
intrinsicModuleScope = &intrinsicModuleScope->children().front();
break;
}
}
if (!intrinsicModuleScope || !intrinsicModuleScope->IsIntrinsicModules())
return;
for (const auto &scope : intrinsicModuleScope->children()) {
llvm::StringRef modName = toStringRef(scope.symbol()->name());
if (modName != "__fortran_ieee_exceptions" &&
modName != "iso_fortran_env")
continue;
for (auto &var : Fortran::lower::pft::getScopeVariableList(scope)) {
const Fortran::semantics::Symbol &sym = var.getSymbol();
if (sym.test(Fortran::semantics::Symbol::Flag::CompilerCreated))
continue;
const auto *object =
sym.detailsIf<Fortran::semantics::ObjectEntityDetails>();
if (object && object->IsArray() && object->init())
Fortran::lower::createIntrinsicModuleGlobal(*this, var);
}
}
}
/// Collect entities used in visible Cray pointer associations.
void collectVisibleCrayPointerTargets(
Fortran::lower::pft::EvaluationList &evaluationList) {
for (Fortran::lower::pft::Evaluation &eval : evaluationList) {
eval.visit(Fortran::common::visitors{
[&](const Fortran::parser::AssignmentStmt &stmt) {
if (!stmt.typedAssignment || !stmt.typedAssignment->v)
return;
const Fortran::evaluate::Assignment &assignment =
*stmt.typedAssignment->v;
const Fortran::semantics::Symbol *pointer =
Fortran::evaluate::GetLastSymbol(assignment.lhs);
if (!pointer || !pointer->GetUltimate().test(
Fortran::semantics::Symbol::Flag::CrayPointer))
return;
const Fortran::evaluate::ProcedureRef *procedure =
Fortran::evaluate::UnwrapProcedureRef(assignment.rhs);
const Fortran::evaluate::SpecificIntrinsic *intrinsic =
procedure ? procedure->proc().GetSpecificIntrinsic() : nullptr;
if (!intrinsic || intrinsic->name != "loc" ||
procedure->arguments().size() != 1 ||
!procedure->arguments()[0])
return;
const Fortran::lower::SomeExpr *targetExpr =
procedure->arguments()[0]->UnwrapExpr();
const Fortran::semantics::Symbol *target =
targetExpr ? Fortran::evaluate::GetFirstSymbol(*targetExpr)
: nullptr;
if (!target)
return;
visibleCrayPointerTargets.insert(&target->GetUltimate());
},
[](const auto &) {}});
if (eval.hasNestedEvaluations())
collectVisibleCrayPointerTargets(eval.getNestedEvaluations());
}
}
/// Return whether \p scope declares or imports a Cray pointer.
bool hasCrayPointer(const Fortran::semantics::Scope &scope) {
if (!scope.crayPointers().empty())
return true;
for (Fortran::semantics::SymbolRef symbol : scope.GetSymbols())
if (symbol->GetUltimate().test(
Fortran::semantics::Symbol::Flag::CrayPointer))
return true;
return false;
}
/// Lower a procedure (nest).
void lowerFunc(Fortran::lower::pft::FunctionLikeUnit &funit) {
setCurrentPosition(funit.getStartingSourceLoc());
setCurrentFunctionUnit(&funit);
assert(visibleCrayPointerTargets.empty() &&
"Cray pointer targets must not outlive a procedure");
if (hasCrayPointer(funit.getScope()))
collectVisibleCrayPointerTargets(funit.evaluationList);
for (int entryIndex = 0, last = funit.entryPointList.size();
entryIndex < last; ++entryIndex) {
funit.setActiveEntry(entryIndex);
startNewFunction(funit); // the entry point for lowering this procedure
wrapUnstructuredCount = 0;
for (Fortran::lower::pft::Evaluation &eval : funit.evaluationList)
genFIR(eval);
if (wrapUnstructuredCount > 0) {
LLVM_DEBUG({
llvm::dbgs()
<< "[wrap-unstructured] summary: " << wrapUnstructuredCount
<< " execute_region(s) wrapping unstructured constructs at ";
toLocation().print(llvm::dbgs());
llvm::dbgs() << "\n";
});
}
endNewFunction(funit);
}
funit.setActiveEntry(0);
setCurrentFunctionUnit(nullptr);
visibleCrayPointerTargets.clear();
for (Fortran::lower::pft::ContainedUnit &unit : funit.containedUnitList)
if (auto *f = std::get_if<Fortran::lower::pft::FunctionLikeUnit>(&unit))
lowerFunc(*f); // internal procedure
}
/// Lower module variable definitions to fir::globalOp and OpenMP/OpenACC
/// declarative construct.
void lowerModuleDeclScope(Fortran::lower::pft::ModuleLikeUnit &mod) {
setCurrentPosition(mod.getStartingSourceLoc());
emitModuleDebugImports(*this, *builder, toLocation(), mod);
auto &scopeVariableListMap =
Fortran::lower::pft::getScopeVariableListMap(mod);
for (const auto &var : Fortran::lower::pft::getScopeVariableList(
mod.getScope(), scopeVariableListMap)) {
// Only define the variables owned by this module.
const Fortran::semantics::Scope *owningScope = var.getOwningScope();
if (owningScope && mod.getScope() != *owningScope)
continue;
// Very special case: The value of numeric_storage_size depends on
// compilation options and therefore its value is not yet known when
// building the builtins runtime. Instead, the parameter is folding a
// __numeric_storage_size() expression which is loaded into the user
// program. For the iso_fortran_env object file, omit the symbol as it
// is never used.
if (var.hasSymbol()) {
const Fortran::semantics::Symbol &sym = var.getSymbol();
const Fortran::semantics::Scope &owner = sym.owner();
if (sym.name() == "numeric_storage_size" && owner.IsModule() &&
DEREF(owner.symbol()).name() == "iso_fortran_env")
continue;
}
Fortran::lower::defineModuleVariable(*this, var);
}
for (auto &eval : mod.evaluationList)
genFIR(eval);
}
/// Lower functions contained in a module.
void lowerMod(Fortran::lower::pft::ModuleLikeUnit &mod) {
for (Fortran::lower::pft::ContainedUnit &unit : mod.containedUnitList)
if (auto *f = std::get_if<Fortran::lower::pft::FunctionLikeUnit>(&unit))
lowerFunc(*f);
}
void setCurrentPosition(const Fortran::parser::CharBlock &position) {
if (position != Fortran::parser::CharBlock{})
currentPosition = position;
}
/// Set current position at the location of \p parseTreeNode. Note that the
/// position is updated automatically when visiting statements, but not when
/// entering higher level nodes like constructs or procedures. This helper is
/// intended to cover the latter cases.
template <typename A>
void setCurrentPositionAt(const A &parseTreeNode) {
setCurrentPosition(Fortran::parser::FindSourceLocation(parseTreeNode));
}
//===--------------------------------------------------------------------===//
// Utility methods
//===--------------------------------------------------------------------===//
/// Convert a parser CharBlock to a Location
mlir::Location toLocation(const Fortran::parser::CharBlock &cb) {
return genLocation(cb);
}
mlir::Location toLocation() { return toLocation(currentPosition); }
void setCurrentEval(Fortran::lower::pft::Evaluation &eval) {
evalPtr = &eval;
}
Fortran::lower::pft::Evaluation &getEval() {
assert(evalPtr);
return *evalPtr;
}
std::optional<Fortran::evaluate::Shape>
getShape(const Fortran::lower::SomeExpr &expr) {
return Fortran::evaluate::GetShape(foldingContext, expr);
}
void createRuntimeTypeInfoGlobals() {}
// Returns the mangling prefix for the given constant expression.
std::string getConstantExprManglePrefix(mlir::Location loc,
const Fortran::lower::SomeExpr &expr,
mlir::Type eleTy) {
return Fortran::common::visit(
[&](const auto &x) -> std::string {
using T = std::decay_t<decltype(x)>;
if constexpr (Fortran::common::HasMember<
T, Fortran::lower::CategoryExpression>) {
if constexpr (T::Result::category ==
Fortran::common::TypeCategory::Derived) {
if (const auto *constant =
std::get_if<Fortran::evaluate::Constant<
Fortran::evaluate::SomeDerived>>(&x.u))
return Fortran::lower::mangle::mangleArrayLiteral(eleTy,
*constant);
fir::emitFatalError(loc,
"non a constant derived type expression");
} else {
return Fortran::common::visit(
[&](const auto &someKind) -> std::string {
using T = std::decay_t<decltype(someKind)>;
using TK = Fortran::evaluate::Type<T::Result::category,
T::Result::kind>;
if (const auto *constant =
std::get_if<Fortran::evaluate::Constant<TK>>(
&someKind.u)) {
return Fortran::lower::mangle::mangleArrayLiteral(
nullptr, *constant);
}
fir::emitFatalError(
loc, "not a Fortran::evaluate::Constant<T> expression");
return {};
},
x.u);
}
} else {
fir::emitFatalError(loc, "unexpected expression");
}
},
expr.u);
}
/// Performing OpenMP lowering actions that were deferred to the end of
/// lowering.
void finalizeOpenMPLowering(
llvm::SmallVectorImpl<const Fortran::semantics::Symbol *>
&globalOmpRequiresSymbol) {
if (!ompDeferredDeclareTarget.empty()) {
bool deferredDeviceFuncFound =
Fortran::lower::markOpenMPDeferredDeclareTargetFunctions(
getModuleOp().getOperation(), ompDeferredDeclareTarget, *this);
ompDeviceCodeFound = ompDeviceCodeFound || deferredDeviceFuncFound;
}
// Set the module attribute related to OpenMP requires directives
if (ompDeviceCodeFound) {
for (const Fortran::semantics::Symbol *sym : globalOmpRequiresSymbol)
Fortran::lower::genOpenMPRequires(getModuleOp().getOperation(), sym);
}
}
/// Record fir.dummy_scope operation for this function.
/// It will be used to set dummy_scope operand of the hlfir.declare
/// operations.
void setDummyArgsScope(mlir::Value val) {
assert(!dummyArgsScope && val);
dummyArgsScope = val;
}
/// Record the given symbol as a dummy argument of this function.
/// \param symRef The symbol representing the dummy argument
/// \param argNo The 1-based position of this argument in the source (0 =
/// unknown)
void registerDummySymbol(Fortran::semantics::SymbolRef symRef,
unsigned argNo = 0) {
auto *sym = &*symRef;
registeredDummySymbols.insert(sym);
if (argNo > 0)
dummyArgPositions[sym] = argNo;
}
/// Reset all registered dummy symbols.
void resetRegisteredDummySymbols() {
registeredDummySymbols.clear();
dummyArgPositions.clear();
}
void setCurrentFunctionUnit(Fortran::lower::pft::FunctionLikeUnit *unit) {
currentFunctionUnit = unit;
}
//===--------------------------------------------------------------------===//
Fortran::lower::LoweringBridge &bridge;
Fortran::evaluate::FoldingContext foldingContext;
fir::FirOpBuilder *builder = nullptr;
Fortran::lower::pft::Evaluation *evalPtr = nullptr;
Fortran::lower::pft::FunctionLikeUnit *currentFunctionUnit = nullptr;
Fortran::lower::SymMap localSymbols;
Fortran::parser::CharBlock currentPosition;
TypeInfoConverter typeInfoConverter;
/// Symbols associated with Cray pointers in the current procedure.
llvm::SmallPtrSet<const Fortran::semantics::Symbol *, 4>
visibleCrayPointerTargets;
/// Counter of `scf.execute_region` ops created when
/// `--wrap-unstructured-constructs-in-execute-region` is enabled for the
/// currently-lowered function.
unsigned wrapUnstructuredCount = 0;
// Stack to manage object deallocation and finalization at construct exits.
llvm::SmallVector<ConstructContext> activeConstructStack;
/// Track GOTO exits from ACC regions for jump table generation.
struct AccRegionExitInfo {
mlir::Value selector{}; // alloca i32 for exit selector
llvm::SmallVector<std::pair<int, mlir::Block *>> exits; // {id, target}
int nextId = 1;
};
llvm::SmallVector<AccRegionExitInfo> accRegionExitStack;
/// BLOCK name mangling component map
int blockId = 0;
Fortran::lower::mangle::ScopeBlockIdMap scopeBlockIdMap;
/// Tuple of host associated variables
mlir::Value hostAssocTuple;
/// Value of fir.dummy_scope operation for this function.
mlir::Value dummyArgsScope;
/// A set of dummy argument symbols for this function.
/// The set is only preserved during the instatiation
/// of variables for this function.
llvm::SmallPtrSet<const Fortran::semantics::Symbol *, 16>
registeredDummySymbols;
/// Map from dummy symbols to their 1-based argument positions.
/// Used to generate debug info with correct argument numbers.
llvm::DenseMap<const Fortran::semantics::Symbol *, unsigned>
dummyArgPositions;
/// A map of unique names for constant expressions.
/// The names are used for representing the constant expressions
/// with global constant initialized objects.
/// The names are usually prefixed by a mangling string based
/// on the element type of the constant expression, but the element
/// type is not used as a key into the map (so the assumption is that
/// the equivalent constant expressions are prefixed using the same
/// element type).
llvm::DenseMap<const Fortran::lower::SomeExpr *, std::string> literalNamesMap;
/// Storage for Constant expressions used as keys for literalNamesMap.
llvm::SmallVector<std::unique_ptr<Fortran::lower::SomeExpr>>
literalExprsStorage;
/// A counter for uniquing names in `literalNamesMap`.
std::uint64_t uniqueLitId = 0;
/// Whether an OpenMP target region or declare target function/subroutine
/// intended for device offloading has been detected
bool ompDeviceCodeFound = false;
/// Keeps track of symbols defined as declare target that could not be
/// processed at the time of lowering the declare target construct, such
/// as certain cases where interfaces are declared but not defined within
/// a module.
llvm::SmallVector<Fortran::lower::OMPDeferredDeclareTargetInfo>
ompDeferredDeclareTarget;
const Fortran::lower::ExprToValueMap *exprValueOverrides{nullptr};
/// Stack of derived type under construction to avoid infinite loops when
/// dealing with recursive derived types. This is held in the bridge because
/// the state needs to be maintained between data and function type lowering
/// utilities to deal with procedure pointer components whose arguments have
/// the type of the containing derived type.
Fortran::lower::TypeConstructionStack typeConstructionStack;
/// MLIR symbol table of the fir.global/func.func operations. Note that it is
/// not guaranteed to contain all operations of the ModuleOp with Symbol
/// attribute since mlirSymbolTable must pro-actively be maintained when
/// new Symbol operations are created.
mlir::SymbolTable mlirSymbolTable;
/// Used to store context while recursing into regions during lowering.
mlir::StateStack stateStack;
};
} // namespace
Fortran::evaluate::FoldingContext
Fortran::lower::LoweringBridge::createFoldingContext() {
return {getDefaultKinds(), getIntrinsicTable(), getTargetCharacteristics(),
getLanguageFeatures(), tempNames};
}
void Fortran::lower::LoweringBridge::lower(
const Fortran::parser::Program &prg,
const Fortran::semantics::SemanticsContext &semanticsContext) {
std::unique_ptr<Fortran::lower::pft::Program> pft =
Fortran::lower::createPFT(prg, semanticsContext, getLoweringOptions());
FirConverter converter{*this};
converter.run(*pft);
}
void Fortran::lower::LoweringBridge::parseSourceFile(llvm::SourceMgr &srcMgr) {
module = mlir::parseSourceFile<mlir::ModuleOp>(srcMgr, &context);
}
Fortran::lower::LoweringBridge::LoweringBridge(
mlir::MLIRContext &context,
Fortran::semantics::SemanticsContext &semanticsContext,
const Fortran::common::IntrinsicTypeDefaultKinds &defaultKinds,
const Fortran::evaluate::IntrinsicProcTable &intrinsics,
const Fortran::evaluate::TargetCharacteristics &targetCharacteristics,
const Fortran::parser::AllCookedSources &cooked, llvm::StringRef triple,
fir::KindMapping &kindMap,
const Fortran::lower::LoweringOptions &loweringOptions,
const std::vector<Fortran::lower::EnvironmentDefault> &envDefaults,
const Fortran::common::LanguageFeatureControl &languageFeatures,
const llvm::TargetMachine &targetMachine,
const Fortran::frontend::TargetOptions &targetOpts,
const Fortran::frontend::CodeGenOptions &cgOpts)
: semanticsContext{semanticsContext}, defaultKinds{defaultKinds},
intrinsics{intrinsics}, targetCharacteristics{targetCharacteristics},
cooked{&cooked}, context{context}, kindMap{kindMap},
loweringOptions{loweringOptions}, envDefaults{envDefaults},
languageFeatures{languageFeatures} {
// Register the diagnostic handler.
if (loweringOptions.getRegisterMLIRDiagnosticsHandler()) {
diagHandlerID =
context.getDiagEngine().registerHandler([](mlir::Diagnostic &diag) {
llvm::raw_ostream &os = llvm::errs();
switch (diag.getSeverity()) {
case mlir::DiagnosticSeverity::Error:
os << "error: ";
break;
case mlir::DiagnosticSeverity::Remark:
os << "info: ";
break;
case mlir::DiagnosticSeverity::Warning:
os << "warning: ";
break;
default:
break;
}
if (!mlir::isa<mlir::UnknownLoc>(diag.getLocation()))
os << diag.getLocation() << ": ";
os << diag << '\n';
os.flush();
return mlir::success();
});
}
auto getPathLocation = [&semanticsContext, &context]() -> mlir::Location {
std::optional<std::string> path;
const auto &allSources{semanticsContext.allCookedSources().allSources()};
if (auto initial{allSources.GetFirstFileProvenance()};
initial && !initial->empty()) {
if (const auto *sourceFile{allSources.GetSourceFile(initial->start())}) {
path = sourceFile->path();
}
}
if (path.has_value()) {
llvm::SmallString<256> curPath(*path);
llvm::sys::fs::make_absolute(curPath);
llvm::sys::path::remove_dots(curPath);
return mlir::FileLineColLoc::get(&context, curPath.str(), /*line=*/0,
/*col=*/0);
} else {
return mlir::UnknownLoc::get(&context);
}
};
// Create the module and attach the attributes.
module = mlir::OwningOpRef<mlir::ModuleOp>(
mlir::ModuleOp::create(getPathLocation()));
assert(*module && "module was not created");
fir::setTargetTriple(*module, triple);
fir::setKindMapping(*module, kindMap);
fir::setTargetCPU(*module, targetMachine.getTargetCPU());
fir::setTuneCPU(*module, targetOpts.cpuToTuneFor);
fir::setAtomicIgnoreDenormalMode(*module,
targetOpts.atomicIgnoreDenormalMode);
fir::setAtomicFineGrainedMemory(*module, targetOpts.atomicFineGrainedMemory);
fir::setAtomicRemoteMemory(*module, targetOpts.atomicRemoteMemory);
fir::setTargetFeatures(*module, targetMachine.getTargetFeatureString());
fir::setTargetABI(*module, targetOpts.abi);
fir::support::setMLIRDataLayout(
*module,
llvm::DataLayout(
targetMachine.getTargetTriple().computeDataLayout(targetOpts.abi)));
fir::setIdent(*module, Fortran::common::getFlangFullVersion());
fir::setRelocationModel(*module, cgOpts.getRelocationModel());
fir::setIsPIE(*module, cgOpts.IsPIE);
fir::setAllocationPolicy(
*module, fir::getCommandLineAllocationPolicy(cgOpts.StackArrays));
if (cgOpts.RecordCommandLine)
fir::setCommandline(*module, *cgOpts.RecordCommandLine);
// Under -gpu=mem:unified|managed, host heap allocations use the matching
// indirect runtime allocators (malloc_unified / malloc_managed).
if (languageFeatures.IsEnabled(Fortran::common::LanguageFeature::CudaUnified))
fir::setCudaHeapAllocMode(*module, fir::CudaHeapAllocMode::Unified);
else if (languageFeatures.IsEnabled(
Fortran::common::LanguageFeature::CudaManaged))
fir::setCudaHeapAllocMode(*module, fir::CudaHeapAllocMode::Managed);
if (cgOpts.UniqueInternalLinkageNames) {
if (auto fileLoc = mlir::dyn_cast<mlir::FileLineColLoc>(module->getLoc())) {
moduleNameHash =
llvm::getUniqueInternalLinkagePostfix(fileLoc.getFilename());
}
}
}
Fortran::lower::LoweringBridge::~LoweringBridge() {
if (diagHandlerID)
context.getDiagEngine().eraseHandler(*diagHandlerID);
}
void Fortran::lower::genCleanUpInRegionIfAny(
mlir::Location loc, fir::FirOpBuilder &builder, mlir::Region &region,
Fortran::lower::StatementContext &context) {
if (!context.hasCode())
return;
mlir::OpBuilder::InsertPoint insertPt = builder.saveInsertionPoint();
if (region.empty())
builder.createBlock(&region);
else
builder.setInsertionPointToEnd(&region.front());
context.finalizeAndPop();
hlfir::YieldOp::ensureTerminator(region, builder, loc);
builder.restoreInsertionPoint(insertPt);
}