Google Git
Sign in
llvm / llvm-project / flang / ec119e1f87fd47ce30c535d713e82dc8e96dd990 / . / lib / Lower / Bridge.cpp
blob: 0e3011e73902da0716111a9a327445d98a35f3c1 [file] [log] [blame]
//===-- 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 "DirectivesCommon.h"
#include "flang/Common/Version.h"
#include "flang/Lower/Allocatable.h"
#include "flang/Lower/CallInterface.h"
#include "flang/Lower/Coarray.h"
#include "flang/Lower/ConvertCall.h"
#include "flang/Lower/ConvertExpr.h"
#include "flang/Lower/ConvertExprToHLFIR.h"
#include "flang/Lower/ConvertType.h"
#include "flang/Lower/ConvertVariable.h"
#include "flang/Lower/Cuda.h"
#include "flang/Lower/HostAssociations.h"
#include "flang/Lower/IO.h"
#include "flang/Lower/IterationSpace.h"
#include "flang/Lower/Mangler.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/Utils.h"
#include "flang/Optimizer/Builder/BoxValue.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/Character.h"
#include "flang/Optimizer/Builder/Runtime/Derived.h"
#include "flang/Optimizer/Builder/Runtime/EnvironmentDefaults.h"
#include "flang/Optimizer/Builder/Runtime/Main.h"
#include "flang/Optimizer/Builder/Runtime/Ragged.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/FIRDialect.h"
#include "flang/Optimizer/Dialect/FIROps.h"
#include "flang/Optimizer/Dialect/Support/FIRContext.h"
#include "flang/Optimizer/HLFIR/HLFIROps.h"
#include "flang/Optimizer/Support/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/Runtime/iostat.h"
#include "flang/Semantics/runtime-type-info.h"
#include "flang/Semantics/symbol.h"
#include "flang/Semantics/tools.h"
#include "mlir/Dialect/ControlFlow/IR/ControlFlowOps.h"
#include "mlir/IR/Matchers.h"
#include "mlir/IR/PatternMatch.h"
#include "mlir/Parser/Parser.h"
#include "mlir/Transforms/RegionUtils.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> dumpBeforeFir(
"fdebug-dump-pre-fir", llvm::cl::init(false),
llvm::cl::desc("dump the Pre-FIR tree prior to FIR generation"));
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 isUnordered = false)
: loopVariableSym{&sym}, lowerExpr{Fortran::semantics::GetExpr(lower)},
upperExpr{Fortran::semantics::GetExpr(upper)},
stepExpr{Fortran::semantics::GetExpr(step)}, isUnordered{isUnordered} {}
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 isUnordered; // do concurrent, forall
llvm::SmallVector<const Fortran::semantics::Symbol *> localSymList;
llvm::SmallVector<const Fortran::semantics::Symbol *> localInitSymList;
llvm::SmallVector<
std::pair<fir::ReduceOperationEnum, const Fortran::semantics::Symbol *>>
reduceSymList;
llvm::SmallVector<const Fortran::semantics::Symbol *> sharedSymList;
mlir::Value loopVariable = nullptr;
// Data members for structured loops.
fir::DoLoopOp doLoop = 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);
}
/// 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) {
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) {
Fortran::lower::createRuntimeTypeInfoGlobal(converter, info.symbol.get());
createTypeInfoOp(converter, info);
}
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 init, destroy, and nofinal attributes.
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());
builder.create<fir::DTEntryOp>(
info.loc, mlir::StringAttr::get(builder.getContext(), tbpName),
mlir::SymbolRefAttr::get(builder.getContext(), bindingName));
}
builder.create<fir::FirEndOp>(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()));
builder.create<fir::DTComponentOp>(info.loc, compName, lbs, init_val);
}
}
if (componentInfo)
builder.create<fir::FirEndOp>(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.
// - Define module variables and OpenMP/OpenACC declarative constructs so
// they are available before lowering any function that may use them.
bool hasMainProgram = false;
const Fortran::semantics::Symbol *globalOmpRequiresSymbol = nullptr;
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;
declareFunction(f);
if (!globalOmpRequiresSymbol)
globalOmpRequiresSymbol = f.getScope().symbol();
},
[&](Fortran::lower::pft::ModuleLikeUnit &m) {
lowerModuleDeclScope(m);
for (Fortran::lower::pft::ContainedUnit &unit :
m.containedUnitList)
if (auto *f =
std::get_if<Fortran::lower::pft::FunctionLikeUnit>(
&unit))
declareFunction(*f);
},
[&](Fortran::lower::pft::BlockDataUnit &b) {
if (!globalOmpRequiresSymbol)
globalOmpRequiresSymbol = b.symTab.symbol();
},
[&](Fortran::lower::pft::CompilerDirectiveUnit &d) {},
[&](Fortran::lower::pft::OpenACCDirectiveUnit &d) {},
},
u);
}
// Create definitions of intrinsic module constants.
createGlobalOutsideOfFunctionLowering(
[&]() { 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) {
builder = new fir::FirOpBuilder(
bridge.getModule(), bridge.getKindMap(), &mlirSymbolTable);
Fortran::lower::genOpenACCRoutineConstruct(
*this, bridge.getSemanticsContext(), bridge.getModule(),
d.routine, accRoutineInfos);
builder = nullptr;
},
},
u);
}
// 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.
createGlobalOutsideOfFunctionLowering(
[&]() { typeInfoConverter.createTypeInfo(*this); });
// Generate the `main` entry point if necessary
if (hasMainProgram)
createGlobalOutsideOfFunctionLowering([&]() {
fir::runtime::genMain(*builder, toLocation(),
bridge.getEnvironmentDefaults());
});
finalizeOpenACCLowering();
finalizeOpenMPLowering(globalOmpRequiresSymbol);
}
/// Declare a function.
void declareFunction(Fortran::lower::pft::FunctionLikeUnit &funit) {
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) {
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
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();
if (lowerToHighLevelFIR())
return Fortran::lower::convertExprToAddress(loc, *this, expr,
localSymbols, context);
return Fortran::lower::createSomeExtendedAddress(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();
if (lowerToHighLevelFIR())
return Fortran::lower::convertExprToValue(loc, *this, expr, localSymbols,
context);
return Fortran::lower::createSomeExtendedExpression(loc, *this, expr,
localSymbols, context);
}
fir::ExtendedValue
genExprBox(mlir::Location loc, const Fortran::lower::SomeExpr &expr,
Fortran::lower::StatementContext &stmtCtx) override final {
if (lowerToHighLevelFIR())
return Fortran::lower::convertExprToBox(loc, *this, expr, localSymbols,
stmtCtx);
return Fortran::lower::createBoxValue(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),
std::nullopt);
}
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) 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 {
// Do not process pointers
if (Fortran::semantics::IsPointer(sym.GetUltimate())) {
return;
}
// Allocate storage for a pointer/allocatble descriptor.
// No shape/lengths to be passed to the alloca.
const auto new_box = exv.getBoxOf<fir::MutableBoxValue>();
// 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=*/std::nullopt, 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=*/std::nullopt,
/*extents=*/std::nullopt,
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(), {});
builder->create<fir::StoreOp>(loc, empty, new_box->getAddr());
});
if_builder.end();
},
[&](const auto &) -> void {
// Do nothing
});
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) 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::InsertPoint insPt = builder->saveInsertionPoint();
if (copyAssignIP && copyAssignIP->isSet())
builder->restoreInsertionPoint(*copyAssignIP);
else
builder->setInsertionPointAfter(sb.getAddr().getDefiningOp());
Fortran::lower::SymbolBox *lhs_sb, *rhs_sb;
if (copyAssignIP && copyAssignIP->isSet() &&
sym.test(Fortran::semantics::Symbol::Flag::OmpLastPrivate)) {
// lastprivate case
lhs_sb = &hsb;
rhs_sb = &sb;
} else {
lhs_sb = &sb;
rhs_sb = &hsb;
}
copyVar(sym, *lhs_sb, *rhs_sb, sym.flags());
if (copyAssignIP && copyAssignIP->isSet() &&
sym.test(Fortran::semantics::Symbol::Flag::OmpLastPrivate)) {
builder->restoreInsertionPoint(insPt);
}
}
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 (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);
llvm::sys::fs::make_absolute(path);
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.
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 = nullptr;
}
}
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 { 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 {
return Fortran::lower::mangle::mangleName(
symbol, scopeBlockIdMap, /*keepExternalInScope=*/false,
getLoweringOptions().getUnderscoring());
}
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 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();
}
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);
}
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;
}
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 (lowerToHighLevelFIR()) {
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 {};
}
if (Fortran::lower::SymbolBox v = symMap->lookupSymbol(sym))
return v;
return {};
}
/// Find the symbol in the inner-most level of the local map or return null.
Fortran::lower::SymbolBox
shallowLookupSymbol(const Fortran::semantics::Symbol &sym) {
if (Fortran::lower::SymbolBox v = localSymbols.shallowLookupSymbol(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; }
/// 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;
if (lowerToHighLevelFIR()) {
Fortran::lower::genDeclareSymbol(*this, localSymbols, sym, val,
fir::FortranVariableFlagsEnum::None,
forced);
} else {
localSymbols.addSymbol(sym, val, 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());
if (lowerToHighLevelFIR())
copyVarHLFIR(loc, lhs_sb, rhs_sb, flags);
else
copyVarFIR(loc, sym, lhs_sb, rhs_sb);
}
void copyVarHLFIR(mlir::Location loc, Fortran::lower::SymbolBox dst,
Fortran::lower::SymbolBox src,
Fortran::semantics::Symbol::Flags flags) {
assert(lowerToHighLevelFIR());
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 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) {
assert(lowerToHighLevelFIR());
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);
builder->create<hlfir::AssignOp>(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 = builder->create<fir::LoadOp>(loc, rhs);
builder->create<fir::StoreOp>(loc, loadVal, lhs);
} else if (isAllocatable &&
(flags.test(Fortran::semantics::Symbol::Flag::OmpFirstPrivate) ||
flags.test(Fortran::semantics::Symbol::Flag::OmpCopyIn))) {
// For firstprivate and copyin 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 {
copyData(lhs, rhs);
}
}
void copyVarFIR(mlir::Location loc, const Fortran::semantics::Symbol &sym,
const Fortran::lower::SymbolBox &lhs_sb,
const Fortran::lower::SymbolBox &rhs_sb) {
assert(!lowerToHighLevelFIR());
fir::ExtendedValue lhs = symBoxToExtendedValue(lhs_sb);
fir::ExtendedValue rhs = symBoxToExtendedValue(rhs_sb);
mlir::Type symType = genType(sym);
if (auto seqTy = mlir::dyn_cast<fir::SequenceType>(symType)) {
Fortran::lower::StatementContext stmtCtx;
Fortran::lower::createSomeArrayAssignment(*this, lhs, rhs, localSymbols,
stmtCtx);
stmtCtx.finalizeAndReset();
} else if (lhs.getBoxOf<fir::CharBoxValue>()) {
fir::factory::CharacterExprHelper{*builder, loc}.createAssign(lhs, rhs);
} else {
auto loadVal = builder->create<fir::LoadOp>(loc, fir::getBase(rhs));
builder->create<fir::StoreOp>(loc, loadVal, fir::getBase(lhs));
}
}
/// 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.
bool mapBlockArgToDummyOrResult(const Fortran::semantics::SymbolRef sym,
mlir::Value val, bool isResult) {
localSymbols.addSymbol(sym, val);
if (!isResult)
registerDummySymbol(sym);
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 (isUnordered || sym.has<Fortran::semantics::HostAssocDetails>() ||
sym.has<Fortran::semantics::UseDetails>()) {
if (!shallowLookupSymbol(sym) &&
!sym.test(Fortran::semantics::Symbol::Flag::OmpShared)) {
// 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");
builder->create<mlir::cf::BranchOp>(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);
builder->create<mlir::cf::CondBranchOp>(loc, bcc, trueTarget, std::nullopt,
falseTarget, std::nullopt);
}
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);
}
/// 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]);
builder->create<fir::SelectOp>(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
? builder->create<mlir::arith::ConstantOp>(
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 = builder->create<mlir::arith::CmpFOp>(
loc,
label.index() == 0 ? mlir::arith::CmpFPredicate::OLT
: mlir::arith::CmpFPredicate::OGT,
selector, zero);
else if (inArithmeticIfContext) // INTEGER selector
cond = builder->create<mlir::arith::CmpIOp>(
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 = builder->create<mlir::arith::CmpIOp>(
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
//===--------------------------------------------------------------------===//
/// END of program
///
/// Generate the cleanup block before the program exits
void genExitRoutine() {
if (blockIsUnterminated())
builder->create<mlir::func::ReturnOp>(toLocation());
}
/// 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) {
mlir::emitError(loc, "internal error when processing function return");
return;
}
mlir::Value resultVal = resultSymBox.match(
[&](const fir::CharBoxValue &x) -> mlir::Value {
if (Fortran::semantics::IsBindCProcedure(functionSymbol))
return builder->create<fir::LoadOp>(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 = builder->create<fir::LoadOp>(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 =
builder->create<fir::ShiftOp>(loc, shiftTy, lbounds);
load = builder->create<fir::ReboxOp>(
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->createConvert(loc, resultRefType, resultRef);
return builder->create<fir::LoadOp>(loc, resultRef);
});
bridge.openAccCtx().finalizeAndPop();
bridge.fctCtx().finalizeAndPop();
builder->create<mlir::func::ReturnOp>(loc, 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())
builder->create<mlir::cf::BranchOp>(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 = builder->create<fir::LoadOp>(
toLocation(), getAltReturnResult(symbol));
bridge.openAccCtx().finalizeAndPop();
bridge.fctCtx().finalizeAndPop();
builder->create<mlir::func::ReturnOp>(toLocation(), retval);
} else {
bridge.openAccCtx().finalizeAndPop();
bridge.fctCtx().finalizeAndPop();
genExitRoutine();
}
}
//
// 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 = builder->create<mlir::arith::XOrIOp>(
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{};
if (lowerToHighLevelFIR()) {
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;
} else {
// Call statement lowering shares code with function call lowering.
res = Fortran::lower::createSubroutineCall(
*this, *stmt.typedCall, explicitIterSpace, implicitIterSpace,
localSymbols, stmtCtx, /*isUserDefAssignment=*/false);
}
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;
for (const Fortran::parser::ActualArgSpec &arg :
std::get<std::list<Fortran::parser::ActualArgSpec>>(stmt.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 = builder->create<mlir::arith::AddFOp>(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.
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()) {
auto selectExpr =
builder->create<fir::LoadOp>(loc, 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");
builder->create<fir::UnreachableOp>(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::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::EIOR;
}
llvm_unreachable("illegal reduction operator");
}
/// Collect DO CONCURRENT or FORALL 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(
std::make_pair(reduce_operation, x.symbol));
}
}
}
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();
for (const Fortran::semantics::Symbol *sym : info.localSymList)
createHostAssociateVarClone(*sym);
for (const Fortran::semantics::Symbol *sym : info.localInitSymList) {
createHostAssociateVarClone(*sym);
const auto *hostDetails =
sym->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{*sym}).value(),
ea.Designate(Fortran::evaluate::DataRef{*hostSym}).value()};
if (Fortran::semantics::IsPointer(*sym))
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);
}
}
/// 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);
// Collect loop nest information.
// Generate begin loop code directly for infinite and while loops.
Fortran::lower::pft::Evaluation &eval = getEval();
bool unstructuredContext = eval.lowerAsUnstructured();
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());
};
mlir::Block *headerBlock =
unstructuredContext ? createNextBeginBlock() : nullptr;
mlir::Block *bodyBlock = doStmtEval.lexicalSuccessor->block;
mlir::Block *exitBlock = doStmtEval.parentConstruct->constructExit->block;
IncrementLoopNestInfo incrementLoopNestInfo;
const Fortran::parser::ScalarLogicalExpr *whileCondition = nullptr;
bool infiniteLoop = !loopControl.has_value();
if (infiniteLoop) {
assert(unstructuredContext && "infinite loop must be unstructured");
startBlock(headerBlock);
} else if ((whileCondition =
std::get_if<Fortran::parser::ScalarLogicalExpr>(
&loopControl->u))) {
assert(unstructuredContext && "while loop must be unstructured");
maybeStartBlock(preheaderBlock); // no block or empty block
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);
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);
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();
}
}
}
// 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);
}
/// 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() ? 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) {
mlir::BoolAttr f = mlir::BoolAttr::get(builder->getContext(), false);
mlir::LLVM::LoopVectorizeAttr va = mlir::LLVM::LoopVectorizeAttr::get(
builder->getContext(), /*disable=*/f, {}, {}, {}, {}, {}, {});
mlir::LLVM::LoopAnnotationAttr la = mlir::LLVM::LoopAnnotationAttr::get(
builder->getContext(), {}, /*vectorize=*/va, {}, {}, {}, {}, {}, {}, {},
{}, {}, {}, {}, {}, {});
info.doLoop.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::Operation *boundsAndStepIP = nullptr;
for (IncrementLoopInfo &info : incrementLoopNestInfo) {
mlir::Value lowerValue;
mlir::Value upperValue;
mlir::Value stepValue;
{
mlir::OpBuilder::InsertionGuard guard(*builder);
// Set the IP before the first loop in the nest so that all nest bounds
// and step values are created outside the nest.
if (boundsAndStepIP)
builder->setInsertionPointAfter(boundsAndStepIP);
info.loopVariable = genLoopVariableAddress(loc, *info.loopVariableSym,
info.isUnordered);
lowerValue = genControlValue(info.lowerExpr, info);
upperValue = genControlValue(info.upperExpr, info);
bool isConst = true;
stepValue = genControlValue(info.stepExpr, info,
info.isStructured() ? nullptr : &isConst);
boundsAndStepIP = stepValue.getDefiningOp();
// Use a temp variable for unstructured loops with non-const step.
if (!isConst) {
info.stepVariable =
builder->createTemporary(loc, stepValue.getType());
boundsAndStepIP =
builder->create<fir::StoreOp>(loc, stepValue, info.stepVariable);
}
}
// Structured loop - generate fir.do_loop.
if (info.isStructured()) {
mlir::Type loopVarType = info.getLoopVariableType();
mlir::Value loopValue;
if (info.isUnordered) {
llvm::SmallVector<mlir::Value> reduceOperands;
llvm::SmallVector<mlir::Attribute> reduceAttrs;
// Create DO CONCURRENT reduce operands and attributes
for (const auto &reduceSym : info.reduceSymList) {
const fir::ReduceOperationEnum reduce_operation = reduceSym.first;
const Fortran::semantics::Symbol *sym = reduceSym.second;
fir::ExtendedValue exv = getSymbolExtendedValue(*sym, nullptr);
reduceOperands.push_back(fir::getBase(exv));
auto reduce_attr =
fir::ReduceAttr::get(builder->getContext(), reduce_operation);
reduceAttrs.push_back(reduce_attr);
}
// The loop variable value is explicitly updated.
info.doLoop = builder->create<fir::DoLoopOp>(
loc, lowerValue, upperValue, stepValue, /*unordered=*/true,
/*finalCountValue=*/false, /*iterArgs=*/std::nullopt,
llvm::ArrayRef<mlir::Value>(reduceOperands), reduceAttrs);
builder->setInsertionPointToStart(info.doLoop.getBody());
loopValue = builder->createConvert(loc, loopVarType,
info.doLoop.getInductionVar());
} else {
// The loop variable is a doLoop op argument.
info.doLoop = builder->create<fir::DoLoopOp>(
loc, lowerValue, upperValue, stepValue, /*unordered=*/false,
/*finalCountValue=*/true,
builder->createConvert(loc, loopVarType, lowerValue));
builder->setInsertionPointToStart(info.doLoop.getBody());
loopValue = info.doLoop.getRegionIterArgs()[0];
}
// Update the loop variable value in case it has non-index references.
builder->create<fir::StoreOp>(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 = builder->create<fir::IfOp>(loc, maskCondCast,
/*withElseRegion=*/false);
builder->setInsertionPointToStart(&ifOp.getThenRegion().front());
}
if (info.hasLocalitySpecs())
handleLocalitySpecs(info);
for (const auto *dir : dirs) {
Fortran::common::visit(
Fortran::common::visitors{
[&](const Fortran::parser::CompilerDirective::VectorAlways
&d) { addLoopAnnotationAttr(info); },
[&](const auto &) {}},
dir->u);
}
continue;
}
// Unstructured loop preheader - initialize tripVariable and loopVariable.
mlir::Value tripCount;
if (info.hasRealControl) {
auto diff1 =
builder->create<mlir::arith::SubFOp>(loc, upperValue, lowerValue);
auto diff2 =
builder->create<mlir::arith::AddFOp>(loc, diff1, stepValue);
tripCount = builder->create<mlir::arith::DivFOp>(loc, diff2, stepValue);
tripCount =
builder->createConvert(loc, builder->getIndexType(), tripCount);
} else {
auto diff1 =
builder->create<mlir::arith::SubIOp>(loc, upperValue, lowerValue);
auto diff2 =
builder->create<mlir::arith::AddIOp>(loc, diff1, stepValue);
tripCount =
builder->create<mlir::arith::DivSIOp>(loc, diff2, stepValue);
}
if (forceLoopToExecuteOnce) { // minimum tripCount is 1
mlir::Value one =
builder->createIntegerConstant(loc, tripCount.getType(), 1);
auto cond = builder->create<mlir::arith::CmpIOp>(
loc, mlir::arith::CmpIPredicate::slt, tripCount, one);
tripCount =
builder->create<mlir::arith::SelectOp>(loc, cond, one, tripCount);
}
info.tripVariable = builder->createTemporary(loc, tripCount.getType());
builder->create<fir::StoreOp>(loc, tripCount, info.tripVariable);
builder->create<fir::StoreOp>(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 = builder->create<fir::LoadOp>(loc, info.tripVariable);
mlir::Value zero =
builder->createIntegerConstant(loc, tripCount.getType(), 0);
auto cond = builder->create<mlir::arith::CmpIOp>(
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);
}
}
}
/// 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().getNSWOnLoopVarInc())
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_loop.
if (info.isUnordered) {
builder->setInsertionPointAfter(info.doLoop);
continue;
}
// Decrement tripVariable.
builder->setInsertionPointToEnd(info.doLoop.getBody());
llvm::SmallVector<mlir::Value, 2> results;
results.push_back(builder->create<mlir::arith::AddIOp>(
loc, info.doLoop.getInductionVar(), info.doLoop.getStep(),
iofAttr));
// Step loopVariable to help optimizations such as vectorization.
// Induction variable elimination will clean up as necessary.
mlir::Value step = builder->createConvert(
loc, info.getLoopVariableType(), info.doLoop.getStep());
mlir::Value loopVar =
builder->create<fir::LoadOp>(loc, info.loopVariable);
results.push_back(
builder->create<mlir::arith::AddIOp>(loc, loopVar, step, iofAttr));
builder->create<fir::ResultOp>(loc, results);
builder->setInsertionPointAfter(info.doLoop);
// The loop control variable may be used after the loop.
builder->create<fir::StoreOp>(loc, info.doLoop.getResult(1),
info.loopVariable);
continue;
}
// Unstructured loop - decrement tripVariable and step loopVariable.
mlir::Value tripCount =
builder->create<fir::LoadOp>(loc, info.tripVariable);
mlir::Value one =
builder->createIntegerConstant(loc, tripCount.getType(), 1);
tripCount = builder->create<mlir::arith::SubIOp>(loc, tripCount, one);
builder->create<fir::StoreOp>(loc, tripCount, info.tripVariable);
mlir::Value value = builder->create<fir::LoadOp>(loc, info.loopVariable);
mlir::Value step;
if (info.stepVariable)
step = builder->create<fir::LoadOp>(loc, info.stepVariable);
else
step = genControlValue(info.stepExpr, info);
if (info.hasRealControl)
value = builder->create<mlir::arith::AddFOp>(loc, value, step);
else
value = builder->create<mlir::arith::AddIOp>(loc, value, step, iofAttr);
builder->create<fir::StoreOp>(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 = builder->create<fir::IfOp>(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;
}
// Unstructured branch sequence.
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);
}
}
}
}
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);
}
/// Force the binding of an explicit symbol. This is used to bind and re-bind
/// a concurrent control symbol to its value.
void forceControlVariableBinding(const Fortran::semantics::Symbol *sym,
mlir::Value inducVar) {
mlir::Location loc = toLocation();
assert(sym && "There must be a symbol to bind");
mlir::Type toTy = genType(*sym);
// FIXME: this should be a "per iteration" temporary.
mlir::Value tmp =
builder->createTemporary(loc, toTy, toStringRef(sym->name()),
llvm::ArrayRef<mlir::NamedAttribute>{
fir::getAdaptToByRefAttr(*builder)});
mlir::Value cast = builder->createConvert(loc, toTy, inducVar);
builder->create<fir::StoreOp>(loc, cast, tmp);
addSymbol(*sym, tmp, /*force=*/true);
}
/// Process a concurrent header for a FORALL. (Concurrent headers for DO
/// CONCURRENT loops are lowered elsewhere.)
void genFIR(const Fortran::parser::ConcurrentHeader &header) {
llvm::SmallVector<mlir::Value> lows;
llvm::SmallVector<mlir::Value> highs;
llvm::SmallVector<mlir::Value> steps;
if (explicitIterSpace.isOutermostForall()) {
// For the outermost forall, we evaluate the bounds expressions once.
// Contrastingly, if this forall is nested, the bounds expressions are
// assumed to be pure, possibly dependent on outer concurrent control
// variables, possibly variant with respect to arguments, and will be
// re-evaluated.
mlir::Location loc = toLocation();
mlir::Type idxTy = builder->getIndexType();
Fortran::lower::StatementContext &stmtCtx =
explicitIterSpace.stmtContext();
auto lowerExpr = [&](auto &e) {
return fir::getBase(genExprValue(e, stmtCtx));
};
for (const Fortran::parser::ConcurrentControl &ctrl :
std::get<std::list<Fortran::parser::ConcurrentControl>>(header.t)) {
const Fortran::lower::SomeExpr *lo =
Fortran::semantics::GetExpr(std::get<1>(ctrl.t));
const Fortran::lower::SomeExpr *hi =
Fortran::semantics::GetExpr(std::get<2>(ctrl.t));
auto &optStep =
std::get<std::optional<Fortran::parser::ScalarIntExpr>>(ctrl.t);
lows.push_back(builder->createConvert(loc, idxTy, lowerExpr(*lo)));
highs.push_back(builder->createConvert(loc