Google Git
Sign in
llvm / llvm-project / flang / refs/heads/main / . / lib / Lower / ConvertExpr.cpp
blob: 7698fac89c22313ebed76d06f72c92b711dea36c [file] [log] [blame]
//===-- ConvertExpr.cpp ---------------------------------------------------===//
//
// 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/ConvertExpr.h"
#include "flang/Common/default-kinds.h"
#include "flang/Common/unwrap.h"
#include "flang/Evaluate/fold.h"
#include "flang/Evaluate/real.h"
#include "flang/Evaluate/traverse.h"
#include "flang/Lower/Allocatable.h"
#include "flang/Lower/Bridge.h"
#include "flang/Lower/BuiltinModules.h"
#include "flang/Lower/CallInterface.h"
#include "flang/Lower/Coarray.h"
#include "flang/Lower/ComponentPath.h"
#include "flang/Lower/ConvertCall.h"
#include "flang/Lower/ConvertConstant.h"
#include "flang/Lower/ConvertProcedureDesignator.h"
#include "flang/Lower/ConvertType.h"
#include "flang/Lower/ConvertVariable.h"
#include "flang/Lower/CustomIntrinsicCall.h"
#include "flang/Lower/DumpEvaluateExpr.h"
#include "flang/Lower/Mangler.h"
#include "flang/Lower/Runtime.h"
#include "flang/Lower/Support/Utils.h"
#include "flang/Optimizer/Builder/Character.h"
#include "flang/Optimizer/Builder/Complex.h"
#include "flang/Optimizer/Builder/Factory.h"
#include "flang/Optimizer/Builder/IntrinsicCall.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/Inquiry.h"
#include "flang/Optimizer/Builder/Runtime/RTBuilder.h"
#include "flang/Optimizer/Builder/Runtime/Ragged.h"
#include "flang/Optimizer/Builder/Todo.h"
#include "flang/Optimizer/Dialect/FIRAttr.h"
#include "flang/Optimizer/Dialect/FIRDialect.h"
#include "flang/Optimizer/Dialect/FIROpsSupport.h"
#include "flang/Optimizer/Support/FatalError.h"
#include "flang/Runtime/support.h"
#include "flang/Semantics/expression.h"
#include "flang/Semantics/symbol.h"
#include "flang/Semantics/tools.h"
#include "flang/Semantics/type.h"
#include "mlir/Dialect/Func/IR/FuncOps.h"
#include "llvm/ADT/TypeSwitch.h"
#include "llvm/Support/CommandLine.h"
#include "llvm/Support/Debug.h"
#include "llvm/Support/ErrorHandling.h"
#include "llvm/Support/raw_ostream.h"
#include <algorithm>
#include <optional>
#define DEBUG_TYPE "flang-lower-expr"
using namespace Fortran::runtime;
//===----------------------------------------------------------------------===//
// The composition and structure of Fortran::evaluate::Expr is defined in
// the various header files in include/flang/Evaluate. You are referred
// there for more information on these data structures. Generally speaking,
// these data structures are a strongly typed family of abstract data types
// that, composed as trees, describe the syntax of Fortran expressions.
//
// This part of the bridge can traverse these tree structures and lower them
// to the correct FIR representation in SSA form.
//===----------------------------------------------------------------------===//
static llvm::cl::opt<bool> generateArrayCoordinate(
"gen-array-coor",
llvm::cl::desc("in lowering create ArrayCoorOp instead of CoordinateOp"),
llvm::cl::init(false));
// The default attempts to balance a modest allocation size with expected user
// input to minimize bounds checks and reallocations during dynamic array
// construction. Some user codes may have very large array constructors for
// which the default can be increased.
static llvm::cl::opt<unsigned> clInitialBufferSize(
"array-constructor-initial-buffer-size",
llvm::cl::desc(
"set the incremental array construction buffer size (default=32)"),
llvm::cl::init(32u));
// Lower TRANSPOSE as an "elemental" function that swaps the array
// expression's iteration space, so that no runtime call is needed.
// This lowering may help get rid of unnecessary creation of temporary
// arrays. Note that the runtime TRANSPOSE implementation may be different
// from the "inline" FIR, e.g. it may diagnose out-of-memory conditions
// during the temporary allocation whereas the inline implementation
// relies on AllocMemOp that will silently return null in case
// there is not enough memory.
//
// If it is set to false, then TRANSPOSE will be lowered using
// a runtime call. If it is set to true, then the lowering is controlled
// by LoweringOptions::optimizeTranspose bit (see isTransposeOptEnabled
// function in this file).
static llvm::cl::opt<bool> optimizeTranspose(
"opt-transpose",
llvm::cl::desc("lower transpose without using a runtime call"),
llvm::cl::init(true));
// When copy-in/copy-out is generated for a boxed object we may
// either produce loops to copy the data or call the Fortran runtime's
// Assign function. Since the data copy happens under a runtime check
// (for IsContiguous) the copy loops can hardly provide any value
// to optimizations, instead, the optimizer just wastes compilation
// time on these loops.
//
// This internal option will force the loops generation, when set
// to true. It is false by default.
//
// Note that for copy-in/copy-out of non-boxed objects (e.g. for passing
// arguments by value) we always generate loops. Since the memory for
// such objects is contiguous, it may be better to expose them
// to the optimizer.
static llvm::cl::opt<bool> inlineCopyInOutForBoxes(
"inline-copyinout-for-boxes",
llvm::cl::desc(
"generate loops for copy-in/copy-out of objects with descriptors"),
llvm::cl::init(false));
/// The various semantics of a program constituent (or a part thereof) as it may
/// appear in an expression.
///
/// Given the following Fortran declarations.
/// ```fortran
/// REAL :: v1, v2, v3
/// REAL, POINTER :: vp1
/// REAL :: a1(c), a2(c)
/// REAL ELEMENTAL FUNCTION f1(arg) ! array -> array
/// FUNCTION f2(arg) ! array -> array
/// vp1 => v3 ! 1
/// v1 = v2 * vp1 ! 2
/// a1 = a1 + a2 ! 3
/// a1 = f1(a2) ! 4
/// a1 = f2(a2) ! 5
/// ```
///
/// In line 1, `vp1` is a BoxAddr to copy a box value into. The box value is
/// constructed from the DataAddr of `v3`.
/// In line 2, `v1` is a DataAddr to copy a value into. The value is constructed
/// from the DataValue of `v2` and `vp1`. DataValue is implicitly a double
/// dereference in the `vp1` case.
/// In line 3, `a1` and `a2` on the rhs are RefTransparent. The `a1` on the lhs
/// is CopyInCopyOut as `a1` is replaced elementally by the additions.
/// In line 4, `a2` can be RefTransparent, ByValueArg, RefOpaque, or BoxAddr if
/// `arg` is declared as C-like pass-by-value, VALUE, INTENT(?), or ALLOCATABLE/
/// POINTER, respectively. `a1` on the lhs is CopyInCopyOut.
/// In line 5, `a2` may be DataAddr or BoxAddr assuming f2 is transformational.
/// `a1` on the lhs is again CopyInCopyOut.
enum class ConstituentSemantics {
// Scalar data reference semantics.
//
// For these let `v` be the location in memory of a variable with value `x`
DataValue, // refers to the value `x`
DataAddr, // refers to the address `v`
BoxValue, // refers to a box value containing `v`
BoxAddr, // refers to the address of a box value containing `v`
// Array data reference semantics.
//
// For these let `a` be the location in memory of a sequence of value `[xs]`.
// Let `x_i` be the `i`-th value in the sequence `[xs]`.
// Referentially transparent. Refers to the array's value, `[xs]`.
RefTransparent,
// Refers to an ephemeral address `tmp` containing value `x_i` (15.5.2.3.p7
// note 2). (Passing a copy by reference to simulate pass-by-value.)
ByValueArg,
// Refers to the merge of array value `[xs]` with another array value `[ys]`.
// This merged array value will be written into memory location `a`.
CopyInCopyOut,
// Similar to CopyInCopyOut but `a` may be a transient projection (rather than
// a whole array).
ProjectedCopyInCopyOut,
// Similar to ProjectedCopyInCopyOut, except the merge value is not assigned
// automatically by the framework. Instead, and address for `[xs]` is made
// accessible so that custom assignments to `[xs]` can be implemented.
CustomCopyInCopyOut,
// Referentially opaque. Refers to the address of `x_i`.
RefOpaque
};
/// Convert parser's INTEGER relational operators to MLIR. TODO: using
/// unordered, but we may want to cons ordered in certain situation.
static mlir::arith::CmpIPredicate
translateRelational(Fortran::common::RelationalOperator rop) {
switch (rop) {
case Fortran::common::RelationalOperator::LT:
return mlir::arith::CmpIPredicate::slt;
case Fortran::common::RelationalOperator::LE:
return mlir::arith::CmpIPredicate::sle;
case Fortran::common::RelationalOperator::EQ:
return mlir::arith::CmpIPredicate::eq;
case Fortran::common::RelationalOperator::NE:
return mlir::arith::CmpIPredicate::ne;
case Fortran::common::RelationalOperator::GT:
return mlir::arith::CmpIPredicate::sgt;
case Fortran::common::RelationalOperator::GE:
return mlir::arith::CmpIPredicate::sge;
}
llvm_unreachable("unhandled INTEGER relational operator");
}
/// Convert parser's REAL relational operators to MLIR.
/// The choice of order (O prefix) vs unorder (U prefix) follows Fortran 2018
/// requirements in the IEEE context (table 17.1 of F2018). This choice is
/// also applied in other contexts because it is easier and in line with
/// other Fortran compilers.
/// FIXME: The signaling/quiet aspect of the table 17.1 requirement is not
/// fully enforced. FIR and LLVM `fcmp` instructions do not give any guarantee
/// whether the comparison will signal or not in case of quiet NaN argument.
static mlir::arith::CmpFPredicate
translateFloatRelational(Fortran::common::RelationalOperator rop) {
switch (rop) {
case Fortran::common::RelationalOperator::LT:
return mlir::arith::CmpFPredicate::OLT;
case Fortran::common::RelationalOperator::LE:
return mlir::arith::CmpFPredicate::OLE;
case Fortran::common::RelationalOperator::EQ:
return mlir::arith::CmpFPredicate::OEQ;
case Fortran::common::RelationalOperator::NE:
return mlir::arith::CmpFPredicate::UNE;
case Fortran::common::RelationalOperator::GT:
return mlir::arith::CmpFPredicate::OGT;
case Fortran::common::RelationalOperator::GE:
return mlir::arith::CmpFPredicate::OGE;
}
llvm_unreachable("unhandled REAL relational operator");
}
static mlir::Value genActualIsPresentTest(fir::FirOpBuilder &builder,
mlir::Location loc,
fir::ExtendedValue actual) {
if (const auto *ptrOrAlloc = actual.getBoxOf<fir::MutableBoxValue>())
return fir::factory::genIsAllocatedOrAssociatedTest(builder, loc,
*ptrOrAlloc);
// Optional case (not that optional allocatable/pointer cannot be absent
// when passed to CMPLX as per 15.5.2.12 point 3 (7) and (8)). It is
// therefore possible to catch them in the `then` case above.
return builder.create<fir::IsPresentOp>(loc, builder.getI1Type(),
fir::getBase(actual));
}
/// Convert the array_load, `load`, to an extended value. If `path` is not
/// empty, then traverse through the components designated. The base value is
/// `newBase`. This does not accept an array_load with a slice operand.
static fir::ExtendedValue
arrayLoadExtValue(fir::FirOpBuilder &builder, mlir::Location loc,
fir::ArrayLoadOp load, llvm::ArrayRef<mlir::Value> path,
mlir::Value newBase, mlir::Value newLen = {}) {
// Recover the extended value from the load.
if (load.getSlice())
fir::emitFatalError(loc, "array_load with slice is not allowed");
mlir::Type arrTy = load.getType();
if (!path.empty()) {
mlir::Type ty = fir::applyPathToType(arrTy, path);
if (!ty)
fir::emitFatalError(loc, "path does not apply to type");
if (!mlir::isa<fir::SequenceType>(ty)) {
if (fir::isa_char(ty)) {
mlir::Value len = newLen;
if (!len)
len = fir::factory::CharacterExprHelper{builder, loc}.getLength(
load.getMemref());
if (!len) {
assert(load.getTypeparams().size() == 1 &&
"length must be in array_load");
len = load.getTypeparams()[0];
}
return fir::CharBoxValue{newBase, len};
}
return newBase;
}
arrTy = mlir::cast<fir::SequenceType>(ty);
}
auto arrayToExtendedValue =
[&](const llvm::SmallVector<mlir::Value> &extents,
const llvm::SmallVector<mlir::Value> &origins) -> fir::ExtendedValue {
mlir::Type eleTy = fir::unwrapSequenceType(arrTy);
if (fir::isa_char(eleTy)) {
mlir::Value len = newLen;
if (!len)
len = fir::factory::CharacterExprHelper{builder, loc}.getLength(
load.getMemref());
if (!len) {
assert(load.getTypeparams().size() == 1 &&
"length must be in array_load");
len = load.getTypeparams()[0];
}
return fir::CharArrayBoxValue(newBase, len, extents, origins);
}
return fir::ArrayBoxValue(newBase, extents, origins);
};
// Use the shape op, if there is one.
mlir::Value shapeVal = load.getShape();
if (shapeVal) {
if (!mlir::isa<fir::ShiftOp>(shapeVal.getDefiningOp())) {
auto extents = fir::factory::getExtents(shapeVal);
auto origins = fir::factory::getOrigins(shapeVal);
return arrayToExtendedValue(extents, origins);
}
if (!fir::isa_box_type(load.getMemref().getType()))
fir::emitFatalError(loc, "shift op is invalid in this context");
}
// If we're dealing with the array_load op (not a subobject) and the load does
// not have any type parameters, then read the extents from the original box.
// The origin may be either from the box or a shift operation. Create and
// return the array extended value.
if (path.empty() && load.getTypeparams().empty()) {
auto oldBox = load.getMemref();
fir::ExtendedValue exv = fir::factory::readBoxValue(builder, loc, oldBox);
auto extents = fir::factory::getExtents(loc, builder, exv);
auto origins = fir::factory::getNonDefaultLowerBounds(builder, loc, exv);
if (shapeVal) {
// shapeVal is a ShiftOp and load.memref() is a boxed value.
newBase = builder.create<fir::ReboxOp>(loc, oldBox.getType(), oldBox,
shapeVal, /*slice=*/mlir::Value{});
origins = fir::factory::getOrigins(shapeVal);
}
return fir::substBase(arrayToExtendedValue(extents, origins), newBase);
}
TODO(loc, "path to a POINTER, ALLOCATABLE, or other component that requires "
"dereferencing; generating the type parameters is a hard "
"requirement for correctness.");
}
/// Place \p exv in memory if it is not already a memory reference. If
/// \p forceValueType is provided, the value is first casted to the provided
/// type before being stored (this is mainly intended for logicals whose value
/// may be `i1` but needed to be stored as Fortran logicals).
static fir::ExtendedValue
placeScalarValueInMemory(fir::FirOpBuilder &builder, mlir::Location loc,
const fir::ExtendedValue &exv,
mlir::Type storageType) {
mlir::Value valBase = fir::getBase(exv);
if (fir::conformsWithPassByRef(valBase.getType()))
return exv;
assert(!fir::hasDynamicSize(storageType) &&
"only expect statically sized scalars to be by value");
// Since `a` is not itself a valid referent, determine its value and
// create a temporary location at the beginning of the function for
// referencing.
mlir::Value val = builder.createConvert(loc, storageType, valBase);
mlir::Value temp = builder.createTemporary(
loc, storageType,
llvm::ArrayRef<mlir::NamedAttribute>{fir::getAdaptToByRefAttr(builder)});
builder.create<fir::StoreOp>(loc, val, temp);
return fir::substBase(exv, temp);
}
// Copy a copy of scalar \p exv in a new temporary.
static fir::ExtendedValue
createInMemoryScalarCopy(fir::FirOpBuilder &builder, mlir::Location loc,
const fir::ExtendedValue &exv) {
assert(exv.rank() == 0 && "input to scalar memory copy must be a scalar");
if (exv.getCharBox() != nullptr)
return fir::factory::CharacterExprHelper{builder, loc}.createTempFrom(exv);
if (fir::isDerivedWithLenParameters(exv))
TODO(loc, "copy derived type with length parameters");
mlir::Type type = fir::unwrapPassByRefType(fir::getBase(exv).getType());
fir::ExtendedValue temp = builder.createTemporary(loc, type);
fir::factory::genScalarAssignment(builder, loc, temp, exv);
return temp;
}
// An expression with non-zero rank is an array expression.
template <typename A>
static bool isArray(const A &x) {
return x.Rank() != 0;
}
/// Is this a variable wrapped in parentheses?
template <typename A>
static bool isParenthesizedVariable(const A &) {
return false;
}
template <typename T>
static bool isParenthesizedVariable(const Fortran::evaluate::Expr<T> &expr) {
using ExprVariant = decltype(Fortran::evaluate::Expr<T>::u);
using Parentheses = Fortran::evaluate::Parentheses<T>;
if constexpr (Fortran::common::HasMember<Parentheses, ExprVariant>) {
if (const auto *parentheses = std::get_if<Parentheses>(&expr.u))
return Fortran::evaluate::IsVariable(parentheses->left());
return false;
} else {
return Fortran::common::visit(
[&](const auto &x) { return isParenthesizedVariable(x); }, expr.u);
}
}
/// Generate a load of a value from an address. Beware that this will lose
/// any dynamic type information for polymorphic entities (note that unlimited
/// polymorphic cannot be loaded and must not be provided here).
static fir::ExtendedValue genLoad(fir::FirOpBuilder &builder,
mlir::Location loc,
const fir::ExtendedValue &addr) {
return addr.match(
[](const fir::CharBoxValue &box) -> fir::ExtendedValue { return box; },
[&](const fir::PolymorphicValue &p) -> fir::ExtendedValue {
if (mlir::isa<fir::RecordType>(
fir::unwrapRefType(fir::getBase(p).getType())))
return p;
mlir::Value load = builder.create<fir::LoadOp>(loc, fir::getBase(p));
return fir::PolymorphicValue(load, p.getSourceBox());
},
[&](const fir::UnboxedValue &v) -> fir::ExtendedValue {
if (mlir::isa<fir::RecordType>(
fir::unwrapRefType(fir::getBase(v).getType())))
return v;
return builder.create<fir::LoadOp>(loc, fir::getBase(v));
},
[&](const fir::MutableBoxValue &box) -> fir::ExtendedValue {
return genLoad(builder, loc,
fir::factory::genMutableBoxRead(builder, loc, box));
},
[&](const fir::BoxValue &box) -> fir::ExtendedValue {
return genLoad(builder, loc,
fir::factory::readBoxValue(builder, loc, box));
},
[&](const auto &) -> fir::ExtendedValue {
fir::emitFatalError(
loc, "attempting to load whole array or procedure address");
});
}
/// Create an optional dummy argument value from entity \p exv that may be
/// absent. This can only be called with numerical or logical scalar \p exv.
/// If \p exv is considered absent according to 15.5.2.12 point 1., the returned
/// value is zero (or false), otherwise it is the value of \p exv.
static fir::ExtendedValue genOptionalValue(fir::FirOpBuilder &builder,
mlir::Location loc,
const fir::ExtendedValue &exv,
mlir::Value isPresent) {
mlir::Type eleType = fir::getBaseTypeOf(exv);
assert(exv.rank() == 0 && fir::isa_trivial(eleType) &&
"must be a numerical or logical scalar");
return builder
.genIfOp(loc, {eleType}, isPresent,
/*withElseRegion=*/true)
.genThen([&]() {
mlir::Value val = fir::getBase(genLoad(builder, loc, exv));
builder.create<fir::ResultOp>(loc, val);
})
.genElse([&]() {
mlir::Value zero = fir::factory::createZeroValue(builder, loc, eleType);
builder.create<fir::ResultOp>(loc, zero);
})
.getResults()[0];
}
/// Create an optional dummy argument address from entity \p exv that may be
/// absent. If \p exv is considered absent according to 15.5.2.12 point 1., the
/// returned value is a null pointer, otherwise it is the address of \p exv.
static fir::ExtendedValue genOptionalAddr(fir::FirOpBuilder &builder,
mlir::Location loc,
const fir::ExtendedValue &exv,
mlir::Value isPresent) {
// If it is an exv pointer/allocatable, then it cannot be absent
// because it is passed to a non-pointer/non-allocatable.
if (const auto *box = exv.getBoxOf<fir::MutableBoxValue>())
return fir::factory::genMutableBoxRead(builder, loc, *box);
// If this is not a POINTER or ALLOCATABLE, then it is already an OPTIONAL
// address and can be passed directly.
return exv;
}
/// Create an optional dummy argument address from entity \p exv that may be
/// absent. If \p exv is considered absent according to 15.5.2.12 point 1., the
/// returned value is an absent fir.box, otherwise it is a fir.box describing \p
/// exv.
static fir::ExtendedValue genOptionalBox(fir::FirOpBuilder &builder,
mlir::Location loc,
const fir::ExtendedValue &exv,
mlir::Value isPresent) {
// Non allocatable/pointer optional box -> simply forward
if (exv.getBoxOf<fir::BoxValue>())
return exv;
fir::ExtendedValue newExv = exv;
// Optional allocatable/pointer -> Cannot be absent, but need to translate
// unallocated/diassociated into absent fir.box.
if (const auto *box = exv.getBoxOf<fir::MutableBoxValue>())
newExv = fir::factory::genMutableBoxRead(builder, loc, *box);
// createBox will not do create any invalid memory dereferences if exv is
// absent. The created fir.box will not be usable, but the SelectOp below
// ensures it won't be.
mlir::Value box = builder.createBox(loc, newExv);
mlir::Type boxType = box.getType();
auto absent = builder.create<fir::AbsentOp>(loc, boxType);
auto boxOrAbsent = builder.create<mlir::arith::SelectOp>(
loc, boxType, isPresent, box, absent);
return fir::BoxValue(boxOrAbsent);
}
/// Is this a call to an elemental procedure with at least one array argument?
static bool
isElementalProcWithArrayArgs(const Fortran::evaluate::ProcedureRef &procRef) {
if (procRef.IsElemental())
for (const std::optional<Fortran::evaluate::ActualArgument> &arg :
procRef.arguments())
if (arg && arg->Rank() != 0)
return true;
return false;
}
template <typename T>
static bool isElementalProcWithArrayArgs(const Fortran::evaluate::Expr<T> &) {
return false;
}
template <>
bool isElementalProcWithArrayArgs(const Fortran::lower::SomeExpr &x) {
if (const auto *procRef = std::get_if<Fortran::evaluate::ProcedureRef>(&x.u))
return isElementalProcWithArrayArgs(*procRef);
return false;
}
/// \p argTy must be a tuple (pair) of boxproc and integral types. Convert the
/// \p funcAddr argument to a boxproc value, with the host-association as
/// required. Call the factory function to finish creating the tuple value.
static mlir::Value
createBoxProcCharTuple(Fortran::lower::AbstractConverter &converter,
mlir::Type argTy, mlir::Value funcAddr,
mlir::Value charLen) {
auto boxTy = mlir::cast<fir::BoxProcType>(
mlir::cast<mlir::TupleType>(argTy).getType(0));
mlir::Location loc = converter.getCurrentLocation();
auto &builder = converter.getFirOpBuilder();
// While character procedure arguments are expected here, Fortran allows
// actual arguments of other types to be passed instead.
// To support this, we cast any reference to the expected type or extract
// procedures from their boxes if needed.
mlir::Type fromTy = funcAddr.getType();
mlir::Type toTy = boxTy.getEleTy();
if (fir::isa_ref_type(fromTy))
funcAddr = builder.createConvert(loc, toTy, funcAddr);
else if (mlir::isa<fir::BoxProcType>(fromTy))
funcAddr = builder.create<fir::BoxAddrOp>(loc, toTy, funcAddr);
auto boxProc = [&]() -> mlir::Value {
if (auto host = Fortran::lower::argumentHostAssocs(converter, funcAddr))
return builder.create<fir::EmboxProcOp>(
loc, boxTy, llvm::ArrayRef<mlir::Value>{funcAddr, host});
return builder.create<fir::EmboxProcOp>(loc, boxTy, funcAddr);
}();
return fir::factory::createCharacterProcedureTuple(builder, loc, argTy,
boxProc, charLen);
}
/// Given an optional fir.box, returns an fir.box that is the original one if
/// it is present and it otherwise an unallocated box.
/// Absent fir.box are implemented as a null pointer descriptor. Generated
/// code may need to unconditionally read a fir.box that can be absent.
/// This helper allows creating a fir.box that can be read in all cases
/// outside of a fir.if (isPresent) region. However, the usages of the value
/// read from such box should still only be done in a fir.if(isPresent).
static fir::ExtendedValue
absentBoxToUnallocatedBox(fir::FirOpBuilder &builder, mlir::Location loc,
const fir::ExtendedValue &exv,
mlir::Value isPresent) {
mlir::Value box = fir::getBase(exv);
mlir::Type boxType = box.getType();
assert(mlir::isa<fir::BoxType>(boxType) && "argument must be a fir.box");
mlir::Value emptyBox =
fir::factory::createUnallocatedBox(builder, loc, boxType, std::nullopt);
auto safeToReadBox =
builder.create<mlir::arith::SelectOp>(loc, isPresent, box, emptyBox);
return fir::substBase(exv, safeToReadBox);
}
// Helper to get the ultimate first symbol. This works around the fact that
// symbol resolution in the front end doesn't always resolve a symbol to its
// ultimate symbol but may leave placeholder indirections for use and host
// associations.
template <typename A>
const Fortran::semantics::Symbol &getFirstSym(const A &obj) {
const Fortran::semantics::Symbol &sym = obj.GetFirstSymbol();
return sym.HasLocalLocality() ? sym : sym.GetUltimate();
}
// Helper to get the ultimate last symbol.
template <typename A>
const Fortran::semantics::Symbol &getLastSym(const A &obj) {
const Fortran::semantics::Symbol &sym = obj.GetLastSymbol();
return sym.HasLocalLocality() ? sym : sym.GetUltimate();
}
// Return true if TRANSPOSE should be lowered without a runtime call.
static bool
isTransposeOptEnabled(const Fortran::lower::AbstractConverter &converter) {
return optimizeTranspose &&
converter.getLoweringOptions().getOptimizeTranspose();
}
// A set of visitors to detect if the given expression
// is a TRANSPOSE call that should be lowered without using
// runtime TRANSPOSE implementation.
template <typename T>
static bool isOptimizableTranspose(const T &,
const Fortran::lower::AbstractConverter &) {
return false;
}
static bool
isOptimizableTranspose(const Fortran::evaluate::ProcedureRef &procRef,
const Fortran::lower::AbstractConverter &converter) {
const Fortran::evaluate::SpecificIntrinsic *intrin =
procRef.proc().GetSpecificIntrinsic();
if (isTransposeOptEnabled(converter) && intrin &&
intrin->name == "transpose") {
const std::optional<Fortran::evaluate::ActualArgument> matrix =
procRef.arguments().at(0);
return !(matrix && matrix->GetType() && matrix->GetType()->IsPolymorphic());
}
return false;
}
template <typename T>
static bool
isOptimizableTranspose(const Fortran::evaluate::FunctionRef<T> &funcRef,
const Fortran::lower::AbstractConverter &converter) {
return isOptimizableTranspose(
static_cast<const Fortran::evaluate::ProcedureRef &>(funcRef), converter);
}
template <typename T>
static bool
isOptimizableTranspose(Fortran::evaluate::Expr<T> expr,
const Fortran::lower::AbstractConverter &converter) {
// If optimizeTranspose is not enabled, return false right away.
if (!isTransposeOptEnabled(converter))
return false;
return Fortran::common::visit(
[&](const auto &e) { return isOptimizableTranspose(e, converter); },
expr.u);
}
namespace {
/// Lowering of Fortran::evaluate::Expr<T> expressions
class ScalarExprLowering {
public:
using ExtValue = fir::ExtendedValue;
explicit ScalarExprLowering(mlir::Location loc,
Fortran::lower::AbstractConverter &converter,
Fortran::lower::SymMap &symMap,
Fortran::lower::StatementContext &stmtCtx,
bool inInitializer = false)
: location{loc}, converter{converter},
builder{converter.getFirOpBuilder()}, stmtCtx{stmtCtx}, symMap{symMap},
inInitializer{inInitializer} {}
ExtValue genExtAddr(const Fortran::lower::SomeExpr &expr) {
return gen(expr);
}
/// Lower `expr` to be passed as a fir.box argument. Do not create a temp
/// for the expr if it is a variable that can be described as a fir.box.
ExtValue genBoxArg(const Fortran::lower::SomeExpr &expr) {
bool saveUseBoxArg = useBoxArg;
useBoxArg = true;
ExtValue result = gen(expr);
useBoxArg = saveUseBoxArg;
return result;
}
ExtValue genExtValue(const Fortran::lower::SomeExpr &expr) {
return genval(expr);
}
/// Lower an expression that is a pointer or an allocatable to a
/// MutableBoxValue.
fir::MutableBoxValue
genMutableBoxValue(const Fortran::lower::SomeExpr &expr) {
// Pointers and allocatables can only be:
// - a simple designator "x"
// - a component designator "a%b(i,j)%x"
// - a function reference "foo()"
// - result of NULL() or NULL(MOLD) intrinsic.
// NULL() requires some context to be lowered, so it is not handled
// here and must be lowered according to the context where it appears.
ExtValue exv = Fortran::common::visit(
[&](const auto &x) { return genMutableBoxValueImpl(x); }, expr.u);
const fir::MutableBoxValue *mutableBox =
exv.getBoxOf<fir::MutableBoxValue>();
if (!mutableBox)
fir::emitFatalError(getLoc(), "expr was not lowered to MutableBoxValue");
return *mutableBox;
}
template <typename T>
ExtValue genMutableBoxValueImpl(const T &) {
// NULL() case should not be handled here.
fir::emitFatalError(getLoc(), "NULL() must be lowered in its context");
}
/// A `NULL()` in a position where a mutable box is expected has the same
/// semantics as an absent optional box value. Note: this code should
/// be depreciated because the rank information is not known here. A
/// scalar fir.box is created: it should not be cast to an array box type
/// later, but there is no way to enforce that here.
ExtValue genMutableBoxValueImpl(const Fortran::evaluate::NullPointer &) {
mlir::Location loc = getLoc();
mlir::Type noneTy = mlir::NoneType::get(builder.getContext());
mlir::Type polyRefTy = fir::PointerType::get(noneTy);
mlir::Type boxType = fir::BoxType::get(polyRefTy);
mlir::Value tempBox =
fir::factory::genNullBoxStorage(builder, loc, boxType);
return fir::MutableBoxValue(tempBox,
/*lenParameters=*/mlir::ValueRange{},
/*mutableProperties=*/{});
}
template <typename T>
ExtValue
genMutableBoxValueImpl(const Fortran::evaluate::FunctionRef<T> &funRef) {
return genRawProcedureRef(funRef, converter.genType(toEvExpr(funRef)));
}
template <typename T>
ExtValue
genMutableBoxValueImpl(const Fortran::evaluate::Designator<T> &designator) {
return Fortran::common::visit(
Fortran::common::visitors{
[&](const Fortran::evaluate::SymbolRef &sym) -> ExtValue {
return converter.getSymbolExtendedValue(*sym, &symMap);
},
[&](const Fortran::evaluate::Component &comp) -> ExtValue {
return genComponent(comp);
},
[&](const auto &) -> ExtValue {
fir::emitFatalError(getLoc(),
"not an allocatable or pointer designator");
}},
designator.u);
}
template <typename T>
ExtValue genMutableBoxValueImpl(const Fortran::evaluate::Expr<T> &expr) {
return Fortran::common::visit(
[&](const auto &x) { return genMutableBoxValueImpl(x); }, expr.u);
}
mlir::Location getLoc() { return location; }
template <typename A>
mlir::Value genunbox(const A &expr) {
ExtValue e = genval(expr);
if (const fir::UnboxedValue *r = e.getUnboxed())
return *r;
fir::emitFatalError(getLoc(), "unboxed expression expected");
}
/// Generate an integral constant of `value`
template <int KIND>
mlir::Value genIntegerConstant(mlir::MLIRContext *context,
std::int64_t value) {
mlir::Type type =
converter.genType(Fortran::common::TypeCategory::Integer, KIND);
return builder.createIntegerConstant(getLoc(), type, value);
}
/// Generate a logical/boolean constant of `value`
mlir::Value genBoolConstant(bool value) {
return builder.createBool(getLoc(), value);
}
mlir::Type getSomeKindInteger() { return builder.getIndexType(); }
mlir::func::FuncOp getFunction(llvm::StringRef name,
mlir::FunctionType funTy) {
if (mlir::func::FuncOp func = builder.getNamedFunction(name))
return func;
return builder.createFunction(getLoc(), name, funTy);
}
template <typename OpTy>
mlir::Value createCompareOp(mlir::arith::CmpIPredicate pred,
const ExtValue &left, const ExtValue &right) {
if (const fir::UnboxedValue *lhs = left.getUnboxed())
if (const fir::UnboxedValue *rhs = right.getUnboxed())
return builder.create<OpTy>(getLoc(), pred, *lhs, *rhs);
fir::emitFatalError(getLoc(), "array compare should be handled in genarr");
}
template <typename OpTy, typename A>
mlir::Value createCompareOp(const A &ex, mlir::arith::CmpIPredicate pred) {
ExtValue left = genval(ex.left());
return createCompareOp<OpTy>(pred, left, genval(ex.right()));
}
template <typename OpTy>
mlir::Value createFltCmpOp(mlir::arith::CmpFPredicate pred,
const ExtValue &left, const ExtValue &right) {
if (const fir::UnboxedValue *lhs = left.getUnboxed())
if (const fir::UnboxedValue *rhs = right.getUnboxed())
return builder.create<OpTy>(getLoc(), pred, *lhs, *rhs);
fir::emitFatalError(getLoc(), "array compare should be handled in genarr");
}
template <typename OpTy, typename A>
mlir::Value createFltCmpOp(const A &ex, mlir::arith::CmpFPredicate pred) {
ExtValue left = genval(ex.left());
return createFltCmpOp<OpTy>(pred, left, genval(ex.right()));
}
/// Create a call to the runtime to compare two CHARACTER values.
/// Precondition: This assumes that the two values have `fir.boxchar` type.
mlir::Value createCharCompare(mlir::arith::CmpIPredicate pred,
const ExtValue &left, const ExtValue &right) {
return fir::runtime::genCharCompare(builder, getLoc(), pred, left, right);
}
template <typename A>
mlir::Value createCharCompare(const A &ex, mlir::arith::CmpIPredicate pred) {
ExtValue left = genval(ex.left());
return createCharCompare(pred, left, genval(ex.right()));
}
/// Returns a reference to a symbol or its box/boxChar descriptor if it has
/// one.
ExtValue gen(Fortran::semantics::SymbolRef sym) {
fir::ExtendedValue exv = converter.getSymbolExtendedValue(sym, &symMap);
if (const auto *box = exv.getBoxOf<fir::MutableBoxValue>())
return fir::factory::genMutableBoxRead(builder, getLoc(), *box);
return exv;
}
ExtValue genLoad(const ExtValue &exv) {
return ::genLoad(builder, getLoc(), exv);
}
ExtValue genval(Fortran::semantics::SymbolRef sym) {
mlir::Location loc = getLoc();
ExtValue var = gen(sym);
if (const fir::UnboxedValue *s = var.getUnboxed()) {
if (fir::isa_ref_type(s->getType())) {
// 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. A reference to a result variable
// of one of the other types requires conversion to the actual type.
fir::UnboxedValue addr = *s;
if (Fortran::semantics::IsFunctionResult(sym)) {
mlir::Type resultType = converter.genType(*sym);
if (addr.getType() != resultType)
addr = builder.createConvert(loc, builder.getRefType(resultType),
addr);
} else if (sym->test(Fortran::semantics::Symbol::Flag::CrayPointee)) {
// get the corresponding Cray pointer
Fortran::semantics::SymbolRef ptrSym{
Fortran::semantics::GetCrayPointer(sym)};
ExtValue ptr = gen(ptrSym);
mlir::Value ptrVal = fir::getBase(ptr);
mlir::Type ptrTy = converter.genType(*ptrSym);
ExtValue pte = gen(sym);
mlir::Value pteVal = fir::getBase(pte);
mlir::Value cnvrt = Fortran::lower::addCrayPointerInst(
loc, builder, ptrVal, ptrTy, pteVal.getType());
addr = builder.create<fir::LoadOp>(loc, cnvrt);
}
return genLoad(addr);
}
}
return var;
}
ExtValue genval(const Fortran::evaluate::BOZLiteralConstant &) {
TODO(getLoc(), "BOZ");
}
/// Return indirection to function designated in ProcedureDesignator.
/// The type of the function indirection is not guaranteed to match the one
/// of the ProcedureDesignator due to Fortran implicit typing rules.
ExtValue genval(const Fortran::evaluate::ProcedureDesignator &proc) {
return Fortran::lower::convertProcedureDesignator(getLoc(), converter, proc,
symMap, stmtCtx);
}
ExtValue genval(const Fortran::evaluate::NullPointer &) {
return builder.createNullConstant(getLoc());
}
static bool
isDerivedTypeWithLenParameters(const Fortran::semantics::Symbol &sym) {
if (const Fortran::semantics::DeclTypeSpec *declTy = sym.GetType())
if (const Fortran::semantics::DerivedTypeSpec *derived =
declTy->AsDerived())
return Fortran::semantics::CountLenParameters(*derived) > 0;
return false;
}
/// A structure constructor is lowered two ways. In an initializer context,
/// the entire structure must be constant, so the aggregate value is
/// constructed inline. This allows it to be the body of a GlobalOp.
/// Otherwise, the structure constructor is in an expression. In that case, a
/// temporary object is constructed in the stack frame of the procedure.
ExtValue genval(const Fortran::evaluate::StructureConstructor &ctor) {
mlir::Location loc = getLoc();
if (inInitializer)
return Fortran::lower::genInlinedStructureCtorLit(converter, loc, ctor);
mlir::Type ty = translateSomeExprToFIRType(converter, toEvExpr(ctor));
auto recTy = mlir::cast<fir::RecordType>(ty);
auto fieldTy = fir::FieldType::get(ty.getContext());
mlir::Value res = builder.createTemporary(loc, recTy);
mlir::Value box = builder.createBox(loc, fir::ExtendedValue{res});
fir::runtime::genDerivedTypeInitialize(builder, loc, box);
for (const auto &value : ctor.values()) {
const Fortran::semantics::Symbol &sym = *value.first;
const Fortran::lower::SomeExpr &expr = value.second.value();
if (sym.test(Fortran::semantics::Symbol::Flag::ParentComp)) {
ExtValue from = gen(expr);
mlir::Type fromTy = fir::unwrapPassByRefType(
fir::unwrapRefType(fir::getBase(from).getType()));
mlir::Value resCast =
builder.createConvert(loc, builder.getRefType(fromTy), res);
fir::factory::genRecordAssignment(builder, loc, resCast, from);
continue;
}
if (isDerivedTypeWithLenParameters(sym))
TODO(loc, "component with length parameters in structure constructor");
std::string name = converter.getRecordTypeFieldName(sym);
// FIXME: type parameters must come from the derived-type-spec
mlir::Value field = builder.create<fir::FieldIndexOp>(
loc, fieldTy, name, ty,
/*typeParams=*/mlir::ValueRange{} /*TODO*/);
mlir::Type coorTy = builder.getRefType(recTy.getType(name));
auto coor = builder.create<fir::CoordinateOp>(loc, coorTy,
fir::getBase(res), field);
ExtValue to = fir::factory::componentToExtendedValue(builder, loc, coor);
to.match(
[&](const fir::UnboxedValue &toPtr) {
ExtValue value = genval(expr);
fir::factory::genScalarAssignment(builder, loc, to, value);
},
[&](const fir::CharBoxValue &) {
ExtValue value = genval(expr);
fir::factory::genScalarAssignment(builder, loc, to, value);
},
[&](const fir::ArrayBoxValue &) {
Fortran::lower::createSomeArrayAssignment(converter, to, expr,
symMap, stmtCtx);
},
[&](const fir::CharArrayBoxValue &) {
Fortran::lower::createSomeArrayAssignment(converter, to, expr,
symMap, stmtCtx);
},
[&](const fir::BoxValue &toBox) {
fir::emitFatalError(loc, "derived type components must not be "
"represented by fir::BoxValue");
},
[&](const fir::PolymorphicValue &) {
TODO(loc, "polymorphic component in derived type assignment");
},
[&](const fir::MutableBoxValue &toBox) {
if (toBox.isPointer()) {
Fortran::lower::associateMutableBox(converter, loc, toBox, expr,
/*lbounds=*/std::nullopt,
stmtCtx);
return;
}
// For allocatable components, a deep copy is needed.
TODO(loc, "allocatable components in derived type assignment");
},
[&](const fir::ProcBoxValue &toBox) {
TODO(loc, "procedure pointer component in derived type assignment");
});
}
return res;
}
/// Lowering of an <i>ac-do-variable</i>, which is not a Symbol.
ExtValue genval(const Fortran::evaluate::ImpliedDoIndex &var) {
mlir::Value value = converter.impliedDoBinding(toStringRef(var.name));
// The index value generated by the implied-do has Index type,
// while computations based on it inside the loop body are using
// the original data type. So we need to cast it appropriately.
mlir::Type varTy = converter.genType(toEvExpr(var));
return builder.createConvert(getLoc(), varTy, value);
}
ExtValue genval(const Fortran::evaluate::DescriptorInquiry &desc) {
ExtValue exv = desc.base().IsSymbol() ? gen(getLastSym(desc.base()))
: gen(desc.base().GetComponent());
mlir::IndexType idxTy = builder.getIndexType();
mlir::Location loc = getLoc();
auto castResult = [&](mlir::Value v) {
using ResTy = Fortran::evaluate::DescriptorInquiry::Result;
return builder.createConvert(
loc, converter.genType(ResTy::category, ResTy::kind), v);
};
switch (desc.field()) {
case Fortran::evaluate::DescriptorInquiry::Field::Len:
return castResult(fir::factory::readCharLen(builder, loc, exv));
case Fortran::evaluate::DescriptorInquiry::Field::LowerBound:
return castResult(fir::factory::readLowerBound(
builder, loc, exv, desc.dimension(),
builder.createIntegerConstant(loc, idxTy, 1)));
case Fortran::evaluate::DescriptorInquiry::Field::Extent:
return castResult(
fir::factory::readExtent(builder, loc, exv, desc.dimension()));
case Fortran::evaluate::DescriptorInquiry::Field::Rank:
TODO(loc, "rank inquiry on assumed rank");
case Fortran::evaluate::DescriptorInquiry::Field::Stride:
// So far the front end does not generate this inquiry.
TODO(loc, "stride inquiry");
}
llvm_unreachable("unknown descriptor inquiry");
}
ExtValue genval(const Fortran::evaluate::TypeParamInquiry &) {
TODO(getLoc(), "type parameter inquiry");
}
mlir::Value extractComplexPart(mlir::Value cplx, bool isImagPart) {
return fir::factory::Complex{builder, getLoc()}.extractComplexPart(
cplx, isImagPart);
}
template <int KIND>
ExtValue genval(const Fortran::evaluate::ComplexComponent<KIND> &part) {
return extractComplexPart(genunbox(part.left()), part.isImaginaryPart);
}
template <int KIND>
ExtValue genval(const Fortran::evaluate::Negate<Fortran::evaluate::Type<
Fortran::common::TypeCategory::Integer, KIND>> &op) {
mlir::Value input = genunbox(op.left());
// Like LLVM, integer negation is the binary op "0 - value"
mlir::Value zero = genIntegerConstant<KIND>(builder.getContext(), 0);
return builder.create<mlir::arith::SubIOp>(getLoc(), zero, input);
}
template <int KIND>
ExtValue genval(const Fortran::evaluate::Negate<Fortran::evaluate::Type<
Fortran::common::TypeCategory::Real, KIND>> &op) {
return builder.create<mlir::arith::NegFOp>(getLoc(), genunbox(op.left()));
}
template <int KIND>
ExtValue genval(const Fortran::evaluate::Negate<Fortran::evaluate::Type<
Fortran::common::TypeCategory::Complex, KIND>> &op) {
return builder.create<fir::NegcOp>(getLoc(), genunbox(op.left()));
}
template <typename OpTy>
mlir::Value createBinaryOp(const ExtValue &left, const ExtValue &right) {
assert(fir::isUnboxedValue(left) && fir::isUnboxedValue(right));
mlir::Value lhs = fir::getBase(left);
mlir::Value rhs = fir::getBase(right);
assert(lhs.getType() == rhs.getType() && "types must be the same");
return builder.create<OpTy>(getLoc(), lhs, rhs);
}
template <typename OpTy, typename A>
mlir::Value createBinaryOp(const A &ex) {
ExtValue left = genval(ex.left());
return createBinaryOp<OpTy>(left, genval(ex.right()));
}
#undef GENBIN
#define GENBIN(GenBinEvOp, GenBinTyCat, GenBinFirOp) \
template <int KIND> \
ExtValue genval(const Fortran::evaluate::GenBinEvOp<Fortran::evaluate::Type< \
Fortran::common::TypeCategory::GenBinTyCat, KIND>> &x) { \
return createBinaryOp<GenBinFirOp>(x); \
}
GENBIN(Add, Integer, mlir::arith::AddIOp)
GENBIN(Add, Real, mlir::arith::AddFOp)
GENBIN(Add, Complex, fir::AddcOp)
GENBIN(Subtract, Integer, mlir::arith::SubIOp)
GENBIN(Subtract, Real, mlir::arith::SubFOp)
GENBIN(Subtract, Complex, fir::SubcOp)
GENBIN(Multiply, Integer, mlir::arith::MulIOp)
GENBIN(Multiply, Real, mlir::arith::MulFOp)
GENBIN(Multiply, Complex, fir::MulcOp)
GENBIN(Divide, Integer, mlir::arith::DivSIOp)
GENBIN(Divide, Real, mlir::arith::DivFOp)
template <int KIND>
ExtValue genval(const Fortran::evaluate::Divide<Fortran::evaluate::Type<
Fortran::common::TypeCategory::Complex, KIND>> &op) {
mlir::Type ty =
converter.genType(Fortran::common::TypeCategory::Complex, KIND);
mlir::Value lhs = genunbox(op.left());
mlir::Value rhs = genunbox(op.right());
return fir::genDivC(builder, getLoc(), ty, lhs, rhs);
}
template <Fortran::common::TypeCategory TC, int KIND>
ExtValue genval(
const Fortran::evaluate::Power<Fortran::evaluate::Type<TC, KIND>> &op) {
mlir::Type ty = converter.genType(TC, KIND);
mlir::Value lhs = genunbox(op.left());
mlir::Value rhs = genunbox(op.right());
return fir::genPow(builder, getLoc(), ty, lhs, rhs);
}
template <Fortran::common::TypeCategory TC, int KIND>
ExtValue genval(
const Fortran::evaluate::RealToIntPower<Fortran::evaluate::Type<TC, KIND>>
&op) {
mlir::Type ty = converter.genType(TC, KIND);
mlir::Value lhs = genunbox(op.left());
mlir::Value rhs = genunbox(op.right());
return fir::genPow(builder, getLoc(), ty, lhs, rhs);
}
template <int KIND>
ExtValue genval(const Fortran::evaluate::ComplexConstructor<KIND> &op) {
mlir::Value realPartValue = genunbox(op.left());
return fir::factory::Complex{builder, getLoc()}.createComplex(
realPartValue, genunbox(op.right()));
}
template <int KIND>
ExtValue genval(const Fortran::evaluate::Concat<KIND> &op) {
ExtValue lhs = genval(op.left());
ExtValue rhs = genval(op.right());
const fir::CharBoxValue *lhsChar = lhs.getCharBox();
const fir::CharBoxValue *rhsChar = rhs.getCharBox();
if (lhsChar && rhsChar)
return fir::factory::CharacterExprHelper{builder, getLoc()}
.createConcatenate(*lhsChar, *rhsChar);
TODO(getLoc(), "character array concatenate");
}
/// MIN and MAX operations
template <Fortran::common::TypeCategory TC, int KIND>
ExtValue
genval(const Fortran::evaluate::Extremum<Fortran::evaluate::Type<TC, KIND>>
&op) {
mlir::Value lhs = genunbox(op.left());
mlir::Value rhs = genunbox(op.right());
switch (op.ordering) {
case Fortran::evaluate::Ordering::Greater:
return fir::genMax(builder, getLoc(),
llvm::ArrayRef<mlir::Value>{lhs, rhs});
case Fortran::evaluate::Ordering::Less:
return fir::genMin(builder, getLoc(),
llvm::ArrayRef<mlir::Value>{lhs, rhs});
case Fortran::evaluate::Ordering::Equal:
llvm_unreachable("Equal is not a valid ordering in this context");
}
llvm_unreachable("unknown ordering");
}
// Change the dynamic length information without actually changing the
// underlying character storage.
fir::ExtendedValue
replaceScalarCharacterLength(const fir::ExtendedValue &scalarChar,
mlir::Value newLenValue) {
mlir::Location loc = getLoc();
const fir::CharBoxValue *charBox = scalarChar.getCharBox();
if (!charBox)
fir::emitFatalError(loc, "expected scalar character");
mlir::Value charAddr = charBox->getAddr();
auto charType = mlir::cast<fir::CharacterType>(
fir::unwrapPassByRefType(charAddr.getType()));
if (charType.hasConstantLen()) {
// Erase previous constant length from the base type.
fir::CharacterType::LenType newLen = fir::CharacterType::unknownLen();
mlir::Type newCharTy = fir::CharacterType::get(
builder.getContext(), charType.getFKind(), newLen);
mlir::Type newType = fir::ReferenceType::get(newCharTy);
charAddr = builder.createConvert(loc, newType, charAddr);
return fir::CharBoxValue{charAddr, newLenValue};
}
return fir::CharBoxValue{charAddr, newLenValue};
}
template <int KIND>
ExtValue genval(const Fortran::evaluate::SetLength<KIND> &x) {
mlir::Value newLenValue = genunbox(x.right());
fir::ExtendedValue lhs = gen(x.left());
fir::factory::CharacterExprHelper charHelper(builder, getLoc());
fir::CharBoxValue temp = charHelper.createCharacterTemp(
charHelper.getCharacterType(fir::getBase(lhs).getType()), newLenValue);
charHelper.createAssign(temp, lhs);
return fir::ExtendedValue{temp};
}
template <int KIND>
ExtValue genval(const Fortran::evaluate::Relational<Fortran::evaluate::Type<
Fortran::common::TypeCategory::Integer, KIND>> &op) {
return createCompareOp<mlir::arith::CmpIOp>(op,
translateRelational(op.opr));
}
template <int KIND>
ExtValue genval(const Fortran::evaluate::Relational<Fortran::evaluate::Type<
Fortran::common::TypeCategory::Real, KIND>> &op) {
return createFltCmpOp<mlir::arith::CmpFOp>(
op, translateFloatRelational(op.opr));
}
template <int KIND>
ExtValue genval(const Fortran::evaluate::Relational<Fortran::evaluate::Type<
Fortran::common::TypeCategory::Complex, KIND>> &op) {
return createFltCmpOp<fir::CmpcOp>(op, translateFloatRelational(op.opr));
}
template <int KIND>
ExtValue genval(const Fortran::evaluate::Relational<Fortran::evaluate::Type<
Fortran::common::TypeCategory::Character, KIND>> &op) {
return createCharCompare(op, translateRelational(op.opr));
}
ExtValue
genval(const Fortran::evaluate::Relational<Fortran::evaluate::SomeType> &op) {
return Fortran::common::visit([&](const auto &x) { return genval(x); },
op.u);
}
template <Fortran::common::TypeCategory TC1, int KIND,
Fortran::common::TypeCategory TC2>
ExtValue
genval(const Fortran::evaluate::Convert<Fortran::evaluate::Type<TC1, KIND>,
TC2> &convert) {
mlir::Type ty = converter.genType(TC1, KIND);
auto fromExpr = genval(convert.left());
auto loc = getLoc();
return fromExpr.match(
[&](const fir::CharBoxValue &boxchar) -> ExtValue {
if constexpr (TC1 == Fortran::common::TypeCategory::Character &&
TC2 == TC1) {
return fir::factory::convertCharacterKind(builder, loc, boxchar,
KIND);
} else {
fir::emitFatalError(
loc, "unsupported evaluate::Convert between CHARACTER type "
"category and non-CHARACTER category");
}
},
[&](const fir::UnboxedValue &value) -> ExtValue {
return builder.convertWithSemantics(loc, ty, value);
},
[&](auto &) -> ExtValue {
fir::emitFatalError(loc, "unsupported evaluate::Convert");
});
}
template <typename A>
ExtValue genval(const Fortran::evaluate::Parentheses<A> &op) {
ExtValue input = genval(op.left());
mlir::Value base = fir::getBase(input);
mlir::Value newBase =
builder.create<fir::NoReassocOp>(getLoc(), base.getType(), base);
return fir::substBase(input, newBase);
}
template <int KIND>
ExtValue genval(const Fortran::evaluate::Not<KIND> &op) {
mlir::Value logical = genunbox(op.left());
mlir::Value one = genBoolConstant(true);
mlir::Value val =
builder.createConvert(getLoc(), builder.getI1Type(), logical);
return builder.create<mlir::arith::XOrIOp>(getLoc(), val, one);
}
template <int KIND>
ExtValue genval(const Fortran::evaluate::LogicalOperation<KIND> &op) {
mlir::IntegerType i1Type = builder.getI1Type();
mlir::Value slhs = genunbox(op.left());
mlir::Value srhs = genunbox(op.right());
mlir::Value lhs = builder.createConvert(getLoc(), i1Type, slhs);
mlir::Value rhs = builder.createConvert(getLoc(), i1Type, srhs);
switch (op.logicalOperator) {
case Fortran::evaluate::LogicalOperator::And:
return createBinaryOp<mlir::arith::AndIOp>(lhs, rhs);
case Fortran::evaluate::LogicalOperator::Or:
return createBinaryOp<mlir::arith::OrIOp>(lhs, rhs);
case Fortran::evaluate::LogicalOperator::Eqv:
return createCompareOp<mlir::arith::CmpIOp>(
mlir::arith::CmpIPredicate::eq, lhs, rhs);
case Fortran::evaluate::LogicalOperator::Neqv:
return createCompareOp<mlir::arith::CmpIOp>(
mlir::arith::CmpIPredicate::ne, lhs, rhs);
case Fortran::evaluate::LogicalOperator::Not:
// lib/evaluate expression for .NOT. is Fortran::evaluate::Not<KIND>.
llvm_unreachable(".NOT. is not a binary operator");
}
llvm_unreachable("unhandled logical operation");
}
template <Fortran::common::TypeCategory TC, int KIND>
ExtValue
genval(const Fortran::evaluate::Constant<Fortran::evaluate::Type<TC, KIND>>
&con) {
return Fortran::lower::convertConstant(
converter, getLoc(), con,
/*outlineBigConstantsInReadOnlyMemory=*/!inInitializer);
}
fir::ExtendedValue genval(
const Fortran::evaluate::Constant<Fortran::evaluate::SomeDerived> &con) {
if (auto ctor = con.GetScalarValue())
return genval(*ctor);
return Fortran::lower::convertConstant(
converter, getLoc(), con,
/*outlineBigConstantsInReadOnlyMemory=*/false);
}
template <typename A>
ExtValue genval(const Fortran::evaluate::ArrayConstructor<A> &) {
fir::emitFatalError(getLoc(), "array constructor: should not reach here");
}
ExtValue gen(const Fortran::evaluate::ComplexPart &x) {
mlir::Location loc = getLoc();
auto idxTy = builder.getI32Type();
ExtValue exv = gen(x.complex());
mlir::Value base = fir::getBase(exv);
fir::factory::Complex helper{builder, loc};
mlir::Type eleTy =
helper.getComplexPartType(fir::dyn_cast_ptrEleTy(base.getType()));
mlir::Value offset = builder.createIntegerConstant(
loc, idxTy,
x.part() == Fortran::evaluate::ComplexPart::Part::RE ? 0 : 1);
mlir::Value result = builder.create<fir::CoordinateOp>(
loc, builder.getRefType(eleTy), base, mlir::ValueRange{offset});
return {result};
}
ExtValue genval(const Fortran::evaluate::ComplexPart &x) {
return genLoad(gen(x));
}
/// Reference to a substring.
ExtValue gen(const Fortran::evaluate::Substring &s) {
// Get base string
auto baseString = Fortran::common::visit(
Fortran::common::visitors{
[&](const Fortran::evaluate::DataRef &x) { return gen(x); },
[&](const Fortran::evaluate::StaticDataObject::Pointer &p)
-> ExtValue {
if (std::optional<std::string> str = p->AsString())
return fir::factory::createStringLiteral(builder, getLoc(),
*str);
// TODO: convert StaticDataObject to Constant<T> and use normal
// constant path. Beware that StaticDataObject data() takes into
// account build machine endianness.
TODO(getLoc(),
"StaticDataObject::Pointer substring with kind > 1");
},
},
s.parent());
llvm::SmallVector<mlir::Value> bounds;
mlir::Value lower = genunbox(s.lower());
bounds.push_back(lower);
if (Fortran::evaluate::MaybeExtentExpr upperBound = s.upper()) {
mlir::Value upper = genunbox(*upperBound);
bounds.push_back(upper);
}
fir::factory::CharacterExprHelper charHelper{builder, getLoc()};
return baseString.match(
[&](const fir::CharBoxValue &x) -> ExtValue {
return charHelper.createSubstring(x, bounds);
},
[&](const fir::CharArrayBoxValue &) -> ExtValue {
fir::emitFatalError(
getLoc(),
"array substring should be handled in array expression");
},
[&](const auto &) -> ExtValue {
fir::emitFatalError(getLoc(), "substring base is not a CharBox");
});
}
/// The value of a substring.
ExtValue genval(const Fortran::evaluate::Substring &ss) {
// FIXME: why is the value of a substring being lowered the same as the
// address of a substring?
return gen(ss);
}
ExtValue genval(const Fortran::evaluate::Subscript &subs) {
if (auto *s = std::get_if<Fortran::evaluate::IndirectSubscriptIntegerExpr>(
&subs.u)) {
if (s->value().Rank() > 0)
fir::emitFatalError(getLoc(), "vector subscript is not scalar");
return {genval(s->value())};
}
fir::emitFatalError(getLoc(), "subscript triple notation is not scalar");
}
ExtValue genSubscript(const Fortran::evaluate::Subscript &subs) {
return genval(subs);
}
ExtValue gen(const Fortran::evaluate::DataRef &dref) {
return Fortran::common::visit([&](const auto &x) { return gen(x); },
dref.u);
}
ExtValue genval(const Fortran::evaluate::DataRef &dref) {
return Fortran::common::visit([&](const auto &x) { return genval(x); },
dref.u);
}
// Helper function to turn the Component structure into a list of nested
// components, ordered from largest/leftmost to smallest/rightmost:
// - where only the smallest/rightmost item may be allocatable or a pointer
// (nested allocatable/pointer components require nested coordinate_of ops)
// - that does not contain any parent components
// (the front end places parent components directly in the object)
// Return the object used as the base coordinate for the component chain.
static Fortran::evaluate::DataRef const *
reverseComponents(const Fortran::evaluate::Component &cmpt,
std::list<const Fortran::evaluate::Component *> &list) {
if (!getLastSym(cmpt).test(Fortran::semantics::Symbol::Flag::ParentComp))
list.push_front(&cmpt);
return Fortran::common::visit(
Fortran::common::visitors{
[&](const Fortran::evaluate::Component &x) {
if (Fortran::semantics::IsAllocatableOrPointer(getLastSym(x)))
return &cmpt.base();
return reverseComponents(x, list);
},
[&](auto &) { return &cmpt.base(); },
},
cmpt.base().u);
}
// Return the coordinate of the component reference
ExtValue genComponent(const Fortran::evaluate::Component &cmpt) {
std::list<const Fortran::evaluate::Component *> list;
const Fortran::evaluate::DataRef *base = reverseComponents(cmpt, list);
llvm::SmallVector<mlir::Value> coorArgs;
ExtValue obj = gen(*base);
mlir::Type ty = fir::dyn_cast_ptrOrBoxEleTy(fir::getBase(obj).getType());
mlir::Location loc = getLoc();
auto fldTy = fir::FieldType::get(&converter.getMLIRContext());
// FIXME: need to thread the LEN type parameters here.
for (const Fortran::evaluate::Component *field : list) {
auto recTy = mlir::cast<fir::RecordType>(ty);
const Fortran::semantics::Symbol &sym = getLastSym(*field);
std::string name = converter.getRecordTypeFieldName(sym);
coorArgs.push_back(builder.create<fir::FieldIndexOp>(
loc, fldTy, name, recTy, fir::getTypeParams(obj)));
ty = recTy.getType(name);
}
// If parent component is referred then it has no coordinate argument.
if (coorArgs.size() == 0)
return obj;
ty = builder.getRefType(ty);
return fir::factory::componentToExtendedValue(
builder, loc,
builder.create<fir::CoordinateOp>(loc, ty, fir::getBase(obj),
coorArgs));
}
ExtValue gen(const Fortran::evaluate::Component &cmpt) {
// Components may be pointer or allocatable. In the gen() path, the mutable
// aspect is lost to simplify handling on the client side. To retain the
// mutable aspect, genMutableBoxValue should be used.
return genComponent(cmpt).match(
[&](const fir::MutableBoxValue &mutableBox) {
return fir::factory::genMutableBoxRead(builder, getLoc(), mutableBox);
},
[](auto &box) -> ExtValue { return box; });
}
ExtValue genval(const Fortran::evaluate::Component &cmpt) {
return genLoad(gen(cmpt));
}
// Determine the result type after removing `dims` dimensions from the array
// type `arrTy`
mlir::Type genSubType(mlir::Type arrTy, unsigned dims) {
mlir::Type unwrapTy = fir::dyn_cast_ptrOrBoxEleTy(arrTy);
assert(unwrapTy && "must be a pointer or box type");
auto seqTy = mlir::cast<fir::SequenceType>(unwrapTy);
llvm::ArrayRef<int64_t> shape = seqTy.getShape();
assert(shape.size() > 0 && "removing columns for sequence sans shape");
assert(dims <= shape.size() && "removing more columns than exist");
fir::SequenceType::Shape newBnds;
// follow Fortran semantics and remove columns (from right)
std::size_t e = shape.size() - dims;
for (decltype(e) i = 0; i < e; ++i)
newBnds.push_back(shape[i]);
if (!newBnds.empty())
return fir::SequenceType::get(newBnds, seqTy.getEleTy());
return seqTy.getEleTy();
}
// Generate the code for a Bound value.
ExtValue genval(const Fortran::semantics::Bound &bound) {
if (bound.isExplicit()) {
Fortran::semantics::MaybeSubscriptIntExpr sub = bound.GetExplicit();
if (sub.has_value())
return genval(*sub);
return genIntegerConstant<8>(builder.getContext(), 1);
}
TODO(getLoc(), "non explicit semantics::Bound implementation");
}
static bool isSlice(const Fortran::evaluate::ArrayRef &aref) {
for (const Fortran::evaluate::Subscript &sub : aref.subscript())
if (std::holds_alternative<Fortran::evaluate::Triplet>(sub.u))
return true;
return false;
}
/// Lower an ArrayRef to a fir.coordinate_of given its lowered base.
ExtValue genCoordinateOp(const ExtValue &array,
const Fortran::evaluate::ArrayRef &aref) {
mlir::Location loc = getLoc();
// References to array of rank > 1 with non constant shape that are not
// fir.box must be collapsed into an offset computation in lowering already.
// The same is needed with dynamic length character arrays of all ranks.
mlir::Type baseType =
fir::dyn_cast_ptrOrBoxEleTy(fir::getBase(array).getType());
if ((array.rank() > 1 && fir::hasDynamicSize(baseType)) ||
fir::characterWithDynamicLen(fir::unwrapSequenceType(baseType)))
if (!array.getBoxOf<fir::BoxValue>())
return genOffsetAndCoordinateOp(array, aref);
// Generate a fir.coordinate_of with zero based array indexes.
llvm::SmallVector<mlir::Value> args;
for (const auto &subsc : llvm::enumerate(aref.subscript())) {
ExtValue subVal = genSubscript(subsc.value());
assert(fir::isUnboxedValue(subVal) && "subscript must be simple scalar");
mlir::Value val = fir::getBase(subVal);
mlir::Type ty = val.getType();
mlir::Value lb = getLBound(array, subsc.index(), ty);
args.push_back(builder.create<mlir::arith::SubIOp>(loc, ty, val, lb));
}
mlir::Value base = fir::getBase(array);
auto baseSym = getFirstSym(aref);
if (baseSym.test(Fortran::semantics::Symbol::Flag::CrayPointee)) {
// get the corresponding Cray pointer
Fortran::semantics::SymbolRef ptrSym{
Fortran::semantics::GetCrayPointer(baseSym)};
fir::ExtendedValue ptr = gen(ptrSym);
mlir::Value ptrVal = fir::getBase(ptr);
mlir::Type ptrTy = ptrVal.getType();
mlir::Value cnvrt = Fortran::lower::addCrayPointerInst(
loc, builder, ptrVal, ptrTy, base.getType());
base = builder.create<fir::LoadOp>(loc, cnvrt);
}
mlir::Type eleTy = fir::dyn_cast_ptrOrBoxEleTy(base.getType());
if (auto classTy = mlir::dyn_cast<fir::ClassType>(eleTy))
eleTy = classTy.getEleTy();
auto seqTy = mlir::cast<fir::SequenceType>(eleTy);
assert(args.size() == seqTy.getDimension());
mlir::Type ty = builder.getRefType(seqTy.getEleTy());
auto addr = builder.create<fir::CoordinateOp>(loc, ty, base, args);
return fir::factory::arrayElementToExtendedValue(builder, loc, array, addr);
}
/// Lower an ArrayRef to a fir.coordinate_of using an element offset instead
/// of array indexes.
/// This generates offset computation from the indexes and length parameters,
/// and use the offset to access the element with a fir.coordinate_of. This
/// must only be used if it is not possible to generate a normal
/// fir.coordinate_of using array indexes (i.e. when the shape information is
/// unavailable in the IR).
ExtValue genOffsetAndCoordinateOp(const ExtValue &array,
const Fortran::evaluate::ArrayRef &aref) {
mlir::Location loc = getLoc();
mlir::Value addr = fir::getBase(array);
mlir::Type arrTy = fir::dyn_cast_ptrEleTy(addr.getType());
auto eleTy = mlir::cast<fir::SequenceType>(arrTy).getElementType();
mlir::Type seqTy = builder.getRefType(builder.getVarLenSeqTy(eleTy));
mlir::Type refTy = builder.getRefType(eleTy);
mlir::Value base = builder.createConvert(loc, seqTy, addr);
mlir::IndexType idxTy = builder.getIndexType();
mlir::Value one = builder.createIntegerConstant(loc, idxTy, 1);
mlir::Value zero = builder.createIntegerConstant(loc, idxTy, 0);
auto getLB = [&](const auto &arr, unsigned dim) -> mlir::Value {
return arr.getLBounds().empty() ? one : arr.getLBounds()[dim];
};
auto genFullDim = [&](const auto &arr, mlir::Value delta) -> mlir::Value {
mlir::Value total = zero;
assert(arr.getExtents().size() == aref.subscript().size());
delta = builder.createConvert(loc, idxTy, delta);
unsigned dim = 0;
for (auto [ext, sub] : llvm::zip(arr.getExtents(), aref.subscript())) {
ExtValue subVal = genSubscript(sub);
assert(fir::isUnboxedValue(subVal));
mlir::Value val =
builder.createConvert(loc, idxTy, fir::getBase(subVal));
mlir::Value lb = builder.createConvert(loc, idxTy, getLB(arr, dim));
mlir::Value diff = builder.create<mlir::arith::SubIOp>(loc, val, lb);
mlir::Value prod =
builder.create<mlir::arith::MulIOp>(loc, delta, diff);
total = builder.create<mlir::arith::AddIOp>(loc, prod, total);
if (ext)
delta = builder.create<mlir::arith::MulIOp>(loc, delta, ext);
++dim;
}
mlir::Type origRefTy = refTy;
if (fir::factory::CharacterExprHelper::isCharacterScalar(refTy)) {
fir::CharacterType chTy =
fir::factory::CharacterExprHelper::getCharacterType(refTy);
if (fir::characterWithDynamicLen(chTy)) {
mlir::MLIRContext *ctx = builder.getContext();
fir::KindTy kind =
fir::factory::CharacterExprHelper::getCharacterKind(chTy);
fir::CharacterType singleTy =
fir::CharacterType::getSingleton(ctx, kind);
refTy = builder.getRefType(singleTy);
mlir::Type seqRefTy =
builder.getRefType(builder.getVarLenSeqTy(singleTy));
base = builder.createConvert(loc, seqRefTy, base);
}
}
auto coor = builder.create<fir::CoordinateOp>(
loc, refTy, base, llvm::ArrayRef<mlir::Value>{total});
// Convert to expected, original type after address arithmetic.
return builder.createConvert(loc, origRefTy, coor);
};
return array.match(
[&](const fir::ArrayBoxValue &arr) -> ExtValue {
// FIXME: this check can be removed when slicing is implemented
if (isSlice(aref))
fir::emitFatalError(
getLoc(),
"slice should be handled in array expression context");
return genFullDim(arr, one);
},
[&](const fir::CharArrayBoxValue &arr) -> ExtValue {
mlir::Value delta = arr.getLen();
// If the length is known in the type, fir.coordinate_of will
// already take the length into account.
if (fir::factory::CharacterExprHelper::hasConstantLengthInType(arr))
delta = one;
return fir::CharBoxValue(genFullDim(arr, delta), arr.getLen());
},
[&](const fir::BoxValue &arr) -> ExtValue {
// CoordinateOp for BoxValue is not generated here. The dimensions
// must be kept in the fir.coordinate_op so that potential fir.box
// strides can be applied by codegen.
fir::emitFatalError(
loc, "internal: BoxValue in dim-collapsed fir.coordinate_of");
},
[&](const auto &) -> ExtValue {
fir::emitFatalError(loc, "internal: array processing failed");
});
}
/// Lower an ArrayRef to a fir.array_coor.
ExtValue genArrayCoorOp(const ExtValue &exv,
const Fortran::evaluate::ArrayRef &aref) {
mlir::Location loc = getLoc();
mlir::Value addr = fir::getBase(exv);
mlir::Type arrTy = fir::dyn_cast_ptrOrBoxEleTy(addr.getType());
mlir::Type eleTy = mlir::cast<fir::SequenceType>(arrTy).getElementType();
mlir::Type refTy = builder.getRefType(eleTy);
mlir::IndexType idxTy = builder.getIndexType();
llvm::SmallVector<mlir::Value> arrayCoorArgs;
// The ArrayRef is expected to be scalar here, arrays are handled in array
// expression lowering. So no vector subscript or triplet is expected here.
for (const auto &sub : aref.subscript()) {
ExtValue subVal = genSubscript(sub);
assert(fir::isUnboxedValue(subVal));
arrayCoorArgs.push_back(
builder.createConvert(loc, idxTy, fir::getBase(subVal)));
}
mlir::Value shape = builder.createShape(loc, exv);
mlir::Value elementAddr = builder.create<fir::ArrayCoorOp>(
loc, refTy, addr, shape, /*slice=*/mlir::Value{}, arrayCoorArgs,
fir::getTypeParams(exv));
return fir::factory::arrayElementToExtendedValue(builder, loc, exv,
elementAddr);
}
/// Return the coordinate of the array reference.
ExtValue gen(const Fortran::evaluate::ArrayRef &aref) {
ExtValue base = aref.base().IsSymbol() ? gen(getFirstSym(aref.base()))
: gen(aref.base().GetComponent());
// Check for command-line override to use array_coor op.
if (generateArrayCoordinate)
return genArrayCoorOp(base, aref);
// Otherwise, use coordinate_of op.
return genCoordinateOp(base, aref);
}
/// Return lower bounds of \p box in dimension \p dim. The returned value
/// has type \ty.
mlir::Value getLBound(const ExtValue &box, unsigned dim, mlir::Type ty) {
assert(box.rank() > 0 && "must be an array");
mlir::Location loc = getLoc();
mlir::Value one = builder.createIntegerConstant(loc, ty, 1);
mlir::Value lb = fir::factory::readLowerBound(builder, loc, box, dim, one);
return builder.createConvert(loc, ty, lb);
}
ExtValue genval(const Fortran::evaluate::ArrayRef &aref) {
return genLoad(gen(aref));
}
ExtValue gen(const Fortran::evaluate::CoarrayRef &coref) {
return Fortran::lower::CoarrayExprHelper{converter, getLoc(), symMap}
.genAddr(coref);
}
ExtValue genval(const Fortran::evaluate::CoarrayRef &coref) {
return Fortran::lower::CoarrayExprHelper{converter, getLoc(), symMap}
.genValue(coref);
}
template <typename A>
ExtValue gen(const Fortran::evaluate::Designator<A> &des) {
return Fortran::common::visit([&](const auto &x) { return gen(x); }, des.u);
}
template <typename A>
ExtValue genval(const Fortran::evaluate::Designator<A> &des) {
return Fortran::common::visit([&](const auto &x) { return genval(x); },
des.u);
}
mlir::Type genType(const Fortran::evaluate::DynamicType &dt) {
if (dt.category() != Fortran::common::TypeCategory::Derived)
return converter.genType(dt.category(), dt.kind());
if (dt.IsUnlimitedPolymorphic())
return mlir::NoneType::get(&converter.getMLIRContext());
return converter.genType(dt.GetDerivedTypeSpec());
}
/// Lower a function reference
template <typename A>
ExtValue genFunctionRef(const Fortran::evaluate::FunctionRef<A> &funcRef) {
if (!funcRef.GetType().has_value())
fir::emitFatalError(getLoc(), "a function must have a type");
mlir::Type resTy = genType(*funcRef.GetType());
return genProcedureRef(funcRef, {resTy});
}
/// Lower function call `funcRef` and return a reference to the resultant
/// value. This is required for lowering expressions such as `f1(f2(v))`.
template <typename A>
ExtValue gen(const Fortran::evaluate::FunctionRef<A> &funcRef) {
ExtValue retVal = genFunctionRef(funcRef);
mlir::Type resultType = converter.genType(toEvExpr(funcRef));
return placeScalarValueInMemory(builder, getLoc(), retVal, resultType);
}
/// Helper to lower intrinsic arguments for inquiry intrinsic.
ExtValue
lowerIntrinsicArgumentAsInquired(const Fortran::lower::SomeExpr &expr) {
if (Fortran::evaluate::IsAllocatableOrPointerObject(expr))
return genMutableBoxValue(expr);
/// Do not create temps for array sections whose properties only need to be
/// inquired: create a descriptor that will be inquired.
if (Fortran::evaluate::IsVariable(expr) && isArray(expr) &&
!Fortran::evaluate::UnwrapWholeSymbolOrComponentDataRef(expr))
return lowerIntrinsicArgumentAsBox(expr);
return gen(expr);
}
/// Helper to lower intrinsic arguments to a fir::BoxValue.
/// It preserves all the non default lower bounds/non deferred length
/// parameter information.
ExtValue lowerIntrinsicArgumentAsBox(const Fortran::lower::SomeExpr &expr) {
mlir::Location loc = getLoc();
ExtValue exv = genBoxArg(expr);
auto exvTy = fir::getBase(exv).getType();
if (mlir::isa<mlir::FunctionType>(exvTy)) {
auto boxProcTy =
builder.getBoxProcType(mlir::cast<mlir::FunctionType>(exvTy));
return builder.create<fir::EmboxProcOp>(loc, boxProcTy,
fir::getBase(exv));
}
mlir::Value box = builder.createBox(loc, exv, exv.isPolymorphic());
if (Fortran::lower::isParentComponent(expr)) {
fir::ExtendedValue newExv =
Fortran::lower::updateBoxForParentComponent(converter, box, expr);
box = fir::getBase(newExv);
}
return fir::BoxValue(
box, fir::factory::getNonDefaultLowerBounds(builder, loc, exv),
fir::factory::getNonDeferredLenParams(exv));
}
/// Generate a call to a Fortran intrinsic or intrinsic module procedure.
ExtValue genIntrinsicRef(
const Fortran::evaluate::ProcedureRef &procRef,
std::optional<mlir::Type> resultType,
std::optional<const Fortran::evaluate::SpecificIntrinsic> intrinsic =
std::nullopt) {
llvm::SmallVector<ExtValue> operands;
std::string name =
intrinsic ? intrinsic->name
: procRef.proc().GetSymbol()->GetUltimate().name().ToString();
mlir::Location loc = getLoc();
if (intrinsic && Fortran::lower::intrinsicRequiresCustomOptionalHandling(
procRef, *intrinsic, converter)) {
using ExvAndPresence = std::pair<ExtValue, std::optional<mlir::Value>>;
llvm::SmallVector<ExvAndPresence, 4> operands;
auto prepareOptionalArg = [&](const Fortran::lower::SomeExpr &expr) {
ExtValue optionalArg = lowerIntrinsicArgumentAsInquired(expr);
mlir::Value isPresent =
genActualIsPresentTest(builder, loc, optionalArg);
operands.emplace_back(optionalArg, isPresent);
};
auto prepareOtherArg = [&](const Fortran::lower::SomeExpr &expr,
fir::LowerIntrinsicArgAs lowerAs) {
switch (lowerAs) {
case fir::LowerIntrinsicArgAs::Value:
operands.emplace_back(genval(expr), std::nullopt);
return;
case fir::LowerIntrinsicArgAs::Addr:
operands.emplace_back(gen(expr), std::nullopt);
return;
case fir::LowerIntrinsicArgAs::Box:
operands.emplace_back(lowerIntrinsicArgumentAsBox(expr),
std::nullopt);
return;
case fir::LowerIntrinsicArgAs::Inquired:
operands.emplace_back(lowerIntrinsicArgumentAsInquired(expr),
std::nullopt);
return;
}
};
Fortran::lower::prepareCustomIntrinsicArgument(
procRef, *intrinsic, resultType, prepareOptionalArg, prepareOtherArg,
converter);
auto getArgument = [&](std::size_t i, bool loadArg) -> ExtValue {
if (loadArg && fir::conformsWithPassByRef(
fir::getBase(operands[i].first).getType()))
return genLoad(operands[i].first);
return operands[i].first;
};
auto isPresent = [&](std::size_t i) -> std::optional<mlir::Value> {
return operands[i].second;
};
return Fortran::lower::lowerCustomIntrinsic(
builder, loc, name, resultType, isPresent, getArgument,
operands.size(), stmtCtx);
}
const fir::IntrinsicArgumentLoweringRules *argLowering =
fir::getIntrinsicArgumentLowering(name);
for (const auto &arg : llvm::enumerate(procRef.arguments())) {
auto *expr =
Fortran::evaluate::UnwrapExpr<Fortran::lower::SomeExpr>(arg.value());
if (!expr && arg.value() && arg.value()->GetAssumedTypeDummy()) {
// Assumed type optional.
const Fortran::evaluate::Symbol *assumedTypeSym =
arg.value()->GetAssumedTypeDummy();
auto symBox = symMap.lookupSymbol(*assumedTypeSym);
ExtValue exv =
converter.getSymbolExtendedValue(*assumedTypeSym, &symMap);
if (argLowering) {
fir::ArgLoweringRule argRules =
fir::lowerIntrinsicArgumentAs(*argLowering, arg.index());
// Note: usages of TYPE(*) is limited by C710 but C_LOC and
// IS_CONTIGUOUS may require an assumed size TYPE(*) to be passed to
// the intrinsic library utility as a fir.box.
if (argRules.lowerAs == fir::LowerIntrinsicArgAs::Box &&
!mlir::isa<fir::BaseBoxType>(fir::getBase(exv).getType())) {
operands.emplace_back(
fir::factory::createBoxValue(builder, loc, exv));
continue;
}
}
operands.emplace_back(std::move(exv));
continue;
}
if (!expr) {
// Absent optional.
operands.emplace_back(fir::getAbsentIntrinsicArgument());
continue;
}
if (!argLowering) {
// No argument lowering instruction, lower by value.
operands.emplace_back(genval(*expr));
continue;
}
// Ad-hoc argument lowering handling.
fir::ArgLoweringRule argRules =
fir::lowerIntrinsicArgumentAs(*argLowering, arg.index());
if (argRules.handleDynamicOptional &&
Fortran::evaluate::MayBePassedAsAbsentOptional(*expr)) {
ExtValue optional = lowerIntrinsicArgumentAsInquired(*expr);
mlir::Value isPresent = genActualIsPresentTest(builder, loc, optional);
switch (argRules.lowerAs) {
case fir::LowerIntrinsicArgAs::Value:
operands.emplace_back(
genOptionalValue(builder, loc, optional, isPresent));
continue;
case fir::LowerIntrinsicArgAs::Addr:
operands.emplace_back(
genOptionalAddr(builder, loc, optional, isPresent));
continue;
case fir::LowerIntrinsicArgAs::Box:
operands.emplace_back(
genOptionalBox(builder, loc, optional, isPresent));
continue;
case fir::LowerIntrinsicArgAs::Inquired:
operands.emplace_back(optional);
continue;
}
llvm_unreachable("bad switch");
}
switch (argRules.lowerAs) {
case fir::LowerIntrinsicArgAs::Value:
operands.emplace_back(genval(*expr));
continue;
case fir::LowerIntrinsicArgAs::Addr:
operands.emplace_back(gen(*expr));
continue;
case fir::LowerIntrinsicArgAs::Box:
operands.emplace_back(lowerIntrinsicArgumentAsBox(*expr));
continue;
case fir::LowerIntrinsicArgAs::Inquired:
operands.emplace_back(lowerIntrinsicArgumentAsInquired(*expr));
continue;
}
llvm_unreachable("bad switch");
}
// Let the intrinsic library lower the intrinsic procedure call
return Fortran::lower::genIntrinsicCall(builder, getLoc(), name, resultType,
operands, stmtCtx, &converter);
}
/// helper to detect statement functions
static bool
isStatementFunctionCall(const Fortran::evaluate::ProcedureRef &procRef) {
if (const Fortran::semantics::Symbol *symbol = procRef.proc().GetSymbol())
if (const auto *details =
symbol->detailsIf<Fortran::semantics::SubprogramDetails>())
return details->stmtFunction().has_value();
return false;
}
/// Generate Statement function calls
ExtValue genStmtFunctionRef(const Fortran::evaluate::ProcedureRef &procRef) {
const Fortran::semantics::Symbol *symbol = procRef.proc().GetSymbol();
assert(symbol && "expected symbol in ProcedureRef of statement functions");
const auto &details = symbol->get<Fortran::semantics::SubprogramDetails>();
// Statement functions have their own scope, we just need to associate
// the dummy symbols to argument expressions. They are no
// optional/alternate return arguments. Statement functions cannot be
// recursive (directly or indirectly) so it is safe to add dummy symbols to
// the local map here.
symMap.pushScope();
for (auto [arg, bind] :
llvm::zip(details.dummyArgs(), procRef.arguments())) {
assert(arg && "alternate return in statement function");
assert(bind && "optional argument in statement function");
const auto *expr = bind->UnwrapExpr();
// TODO: assumed type in statement function, that surprisingly seems
// allowed, probably because nobody thought of restricting this usage.
// gfortran/ifort compiles this.
assert(expr && "assumed type used as statement function argument");
// As per Fortran 2018 C1580, statement function arguments can only be
// scalars, so just pass the box with the address. The only care is to
// to use the dummy character explicit length if any instead of the
// actual argument length (that can be bigger).
if (const Fortran::semantics::DeclTypeSpec *type = arg->GetType())
if (type->category() == Fortran::semantics::DeclTypeSpec::Character)
if (const Fortran::semantics::MaybeIntExpr &lenExpr =
type->characterTypeSpec().length().GetExplicit()) {
mlir::Value len = fir::getBase(genval(*lenExpr));
// F2018 7.4.4.2 point 5.
len = fir::factory::genMaxWithZero(builder, getLoc(), len);
symMap.addSymbol(*arg,
replaceScalarCharacterLength(gen(*expr), len));
continue;
}
symMap.addSymbol(*arg, gen(*expr));
}
// Explicitly map statement function host associated symbols to their
// parent scope lowered symbol box.
for (const Fortran::semantics::SymbolRef &sym :
Fortran::evaluate::CollectSymbols(*details.stmtFunction()))
if (const auto *details =
sym->detailsIf<Fortran::semantics::HostAssocDetails>())
if (!symMap.lookupSymbol(*sym))
symMap.addSymbol(*sym, gen(details->symbol()));
ExtValue result = genval(details.stmtFunction().value());
LLVM_DEBUG(llvm::dbgs() << "stmt-function: " << result << '\n');
symMap.popScope();
return result;
}
/// Create a contiguous temporary array with the same shape,
/// length parameters and type as mold. It is up to the caller to deallocate
/// the temporary.
ExtValue genArrayTempFromMold(const ExtValue &mold,
llvm::StringRef tempName) {
mlir::Type type = fir::dyn_cast_ptrOrBoxEleTy(fir::getBase(mold).getType());
assert(type && "expected descriptor or memory type");
mlir::Location loc = getLoc();
llvm::SmallVector<mlir::Value> extents =
fir::factory::getExtents(loc, builder, mold);
llvm::SmallVector<mlir::Value> allocMemTypeParams =
fir::getTypeParams(mold);
mlir::Value charLen;
mlir::Type elementType = fir::unwrapSequenceType(type);
if (auto charType = mlir::dyn_cast<fir::CharacterType>(elementType)) {
charLen = allocMemTypeParams.empty()
? fir::factory::readCharLen(builder, loc, mold)
: allocMemTypeParams[0];
if (charType.hasDynamicLen() && allocMemTypeParams.empty())
allocMemTypeParams.push_back(charLen);
} else if (fir::hasDynamicSize(elementType)) {
TODO(loc, "creating temporary for derived type with length parameters");
}
mlir::Value temp = builder.create<fir::AllocMemOp>(
loc, type, tempName, allocMemTypeParams, extents);
if (mlir::isa<fir::CharacterType>(fir::unwrapSequenceType(type)))
return fir::CharArrayBoxValue{temp, charLen, extents};
return fir::ArrayBoxValue{temp, extents};
}
/// Copy \p source array into \p dest array. Both arrays must be
/// conforming, but neither array must be contiguous.
void genArrayCopy(ExtValue dest, ExtValue source) {
return createSomeArrayAssignment(converter, dest, source, symMap, stmtCtx);
}
/// Lower a non-elemental procedure reference and read allocatable and pointer
/// results into normal values.
ExtValue genProcedureRef(const Fortran::evaluate::ProcedureRef &procRef,
std::optional<mlir::Type> resultType) {
ExtValue res = genRawProcedureRef(procRef, resultType);
// In most contexts, pointers and allocatable do not appear as allocatable
// or pointer variable on the caller side (see 8.5.3 note 1 for
// allocatables). The few context where this can happen must call
// genRawProcedureRef directly.
if (const auto *box = res.getBoxOf<fir::MutableBoxValue>())
return fir::factory::genMutableBoxRead(builder, getLoc(), *box);
return res;
}
/// Like genExtAddr, but ensure the address returned is a temporary even if \p
/// expr is variable inside parentheses.
ExtValue genTempExtAddr(const Fortran::lower::SomeExpr &expr) {
// In general, genExtAddr might not create a temp for variable inside
// parentheses to avoid creating array temporary in sub-expressions. It only
// ensures the sub-expression is not re-associated with other parts of the
// expression. In the call semantics, there is a difference between expr and
// variable (see R1524). For expressions, a variable storage must not be
// argument associated since it could be modified inside the call, or the
// variable could also be modified by other means during the call.
if (!isParenthesizedVariable(expr))
return genExtAddr(expr);
if (expr.Rank() > 0)
return asArray(expr);
mlir::Location loc = getLoc();
return genExtValue(expr).match(
[&](const fir::CharBoxValue &boxChar) -> ExtValue {
return fir::factory::CharacterExprHelper{builder, loc}.createTempFrom(
boxChar);
},
[&](const fir::UnboxedValue &v) -> ExtValue {
mlir::Type type = v.getType();
mlir::Value value = v;
if (fir::isa_ref_type(type))
value = builder.create<fir::LoadOp>(loc, value);
mlir::Value temp = builder.createTemporary(loc, value.getType());
builder.create<fir::StoreOp>(loc, value, temp);
return temp;
},
[&](const fir::BoxValue &x) -> ExtValue {
// Derived type scalar that may be polymorphic.
if (fir::isPolymorphicType(fir::getBase(x).getType()))
TODO(loc, "polymorphic array temporary");
assert(!x.hasRank() && x.isDerived());
if (x.isDerivedWithLenParameters())
fir::emitFatalError(
loc, "making temps for derived type with length parameters");
// TODO: polymorphic aspects should be kept but for now the temp
// created always has the declared type.
mlir::Value var =
fir::getBase(fir::factory::readBoxValue(builder, loc, x));
auto value = builder.create<fir::LoadOp>(loc, var);
mlir::Value temp = builder.createTemporary(loc, value.getType());
builder.create<fir::StoreOp>(loc, value, temp);
return temp;
},
[&](const fir::PolymorphicValue &p) -> ExtValue {
TODO(loc, "creating polymorphic temporary");
},
[&](const auto &) -> ExtValue {
fir::emitFatalError(loc, "expr is not a scalar value");
});
}
/// Helper structure to track potential copy-in of non contiguous variable
/// argument into a contiguous temp. It is used to deallocate the temp that
/// may have been created as well as to the copy-out from the temp to the
/// variable after the call.
struct CopyOutPair {
ExtValue var;
ExtValue temp;
// Flag to indicate if the argument may have been modified by the
// callee, in which case it must be copied-out to the variable.
bool argMayBeModifiedByCall;
// Optional boolean value that, if present and false, prevents
// the copy-out and temp deallocation.
std::optional<mlir::Value> restrictCopyAndFreeAtRuntime;
};
using CopyOutPairs = llvm::SmallVector<CopyOutPair, 4>;
/// Helper to read any fir::BoxValue into other fir::ExtendedValue categories
/// not based on fir.box.
/// This will lose any non contiguous stride information and dynamic type and
/// should only be called if \p exv is known to be contiguous or if its base
/// address will be replaced by a contiguous one. If \p exv is not a
/// fir::BoxValue, this is a no-op.
ExtValue readIfBoxValue(const ExtValue &exv) {
if (const auto *box = exv.getBoxOf<fir::BoxValue>())
return fir::factory::readBoxValue(builder, getLoc(), *box);
return exv;
}
/// Generate a contiguous temp to pass \p actualArg as argument \p arg. The
/// creation of the temp and copy-in can be made conditional at runtime by
/// providing a runtime boolean flag \p restrictCopyAtRuntime (in which case
/// the temp and copy will only be made if the value is true at runtime).
ExtValue genCopyIn(const ExtValue &actualArg,
const Fortran::lower::CallerInterface::PassedEntity &arg,
CopyOutPairs &copyOutPairs,
std::optional<mlir::Value> restrictCopyAtRuntime,
bool byValue) {
const bool doCopyOut = !byValue && arg.mayBeModifiedByCall();
llvm::StringRef tempName = byValue ? ".copy" : ".copyinout";
mlir::Location loc = getLoc();
bool isActualArgBox = fir::isa_box_type(fir::getBase(actualArg).getType());
mlir::Value isContiguousResult;
mlir::Type addrType = fir::HeapType::get(
fir::unwrapPassByRefType(fir::getBase(actualArg).getType()));
if (isActualArgBox) {
// Check at runtime if the argument is contiguous so no copy is needed.
isContiguousResult =
fir::runtime::genIsContiguous(builder, loc, fir::getBase(actualArg));
}
auto doCopyIn = [&]() -> ExtValue {
ExtValue temp = genArrayTempFromMold(actualArg, tempName);
if (!arg.mayBeReadByCall() &&
// INTENT(OUT) dummy argument finalization, automatically
// done when the procedure is invoked, may imply reading
// the argument value in the finalization routine.
// So we need to make a copy, if finalization may occur.
// TODO: do we have to avoid the copying for an actual
// argument of type that does not require finalization?
!arg.mayRequireIntentoutFinalization() &&
// ALLOCATABLE dummy argument may require finalization.
// If it has to be automatically deallocated at the end
// of the procedure invocation (9.7.3.2 p. 2),
// then the finalization may happen if the actual argument
// is allocated (7.5.6.3 p. 2).
!arg.hasAllocatableAttribute()) {
// We have to initialize the temp if it may have components
// that need initialization. If there are no components
// requiring initialization, then the call is a no-op.
if (mlir::isa<fir::RecordType>(getElementTypeOf(temp))) {
mlir::Value tempBox = fir::getBase(builder.createBox(loc, temp));
fir::runtime::genDerivedTypeInitialize(builder, loc, tempBox);
}
return temp;
}
if (!isActualArgBox || inlineCopyInOutForBoxes) {
genArrayCopy(temp, actualArg);
return temp;
}
// Generate AssignTemporary() call to copy data from the actualArg
// to a temporary. AssignTemporary() will initialize the temporary,
// if needed, before doing the assignment, which is required
// since the temporary's components (if any) are uninitialized
// at this point.
mlir::Value destBox = fir::getBase(builder.createBox(loc, temp));
mlir::Value boxRef = builder.createTemporary(loc, destBox.getType());
builder.create<fir::StoreOp>(loc, destBox, boxRef);
fir::runtime::genAssignTemporary(builder, loc, boxRef,
fir::getBase(actualArg));
return temp;
};
auto noCopy = [&]() {
mlir::Value box = fir::getBase(actualArg);
mlir::Value boxAddr = builder.create<fir::BoxAddrOp>(loc, addrType, box);
builder.create<fir::ResultOp>(loc, boxAddr);
};
auto combinedCondition = [&]() {
if (isActualArgBox) {
mlir::Value zero =
builder.createIntegerConstant(loc, builder.getI1Type(), 0);
mlir::Value notContiguous = builder.create<mlir::arith::CmpIOp>(
loc, mlir::arith::CmpIPredicate::eq, isContiguousResult, zero);
if (!restrictCopyAtRuntime) {
restrictCopyAtRuntime = notContiguous;
} else {
mlir::Value cond = builder.create<mlir::arith::AndIOp>(
loc, *restrictCopyAtRuntime, notContiguous);
restrictCopyAtRuntime = cond;
}
}
};
if (!restrictCopyAtRuntime) {
if (isActualArgBox) {
// isContiguousResult = genIsContiguousCall();
mlir::Value addr =
builder
.genIfOp(loc, {addrType}, isContiguousResult,
/*withElseRegion=*/true)
.genThen([&]() { noCopy(); })
.genElse([&] {
ExtValue temp = doCopyIn();
builder.create<fir::ResultOp>(loc, fir::getBase(temp));
})
.getResults()[0];
fir::ExtendedValue temp =
fir::substBase(readIfBoxValue(actualArg), addr);
combinedCondition();
copyOutPairs.emplace_back(
CopyOutPair{actualArg, temp, doCopyOut, restrictCopyAtRuntime});
return temp;
}
ExtValue temp = doCopyIn();
copyOutPairs.emplace_back(CopyOutPair{actualArg, temp, doCopyOut, {}});
return temp;
}
// Otherwise, need to be careful to only copy-in if allowed at runtime.
mlir::Value addr =
builder
.genIfOp(loc, {addrType}, *restrictCopyAtRuntime,
/*withElseRegion=*/true)
.genThen([&]() {
if (isActualArgBox) {
// isContiguousResult = genIsContiguousCall();
// Avoid copyin if the argument is contiguous at runtime.
mlir::Value addr1 =
builder
.genIfOp(loc, {addrType}, isContiguousResult,
/*withElseRegion=*/true)
.genThen([&]() { noCopy(); })
.genElse([&]() {
ExtValue temp = doCopyIn();
builder.create<fir::ResultOp>(loc,
fir::getBase(temp));
})
.getResults()[0];
builder.create<fir::ResultOp>(loc, addr1);
} else {
ExtValue temp = doCopyIn();
builder.create<fir::ResultOp>(loc, fir::getBase(temp));
}
})
.genElse([&]() {
mlir::Value nullPtr = builder.createNullConstant(loc, addrType);
builder.create<fir::ResultOp>(loc, nullPtr);
})
.getResults()[0];
// Associate the temp address with actualArg lengths and extents if a
// temporary is generated. Otherwise the same address is associated.
fir::ExtendedValue temp = fir::substBase(readIfBoxValue(actualArg), addr);
combinedCondition();
copyOutPairs.emplace_back(
CopyOutPair{actualArg, temp, doCopyOut, restrictCopyAtRuntime});
return temp;
}
/// Generate copy-out if needed and free the temporary for an argument that
/// has been copied-in into a contiguous temp.
void genCopyOut(const CopyOutPair &copyOutPair) {
mlir::Location loc = getLoc();
bool isActualArgBox =
fir::isa_box_type(fir::getBase(copyOutPair.var).getType());
auto doCopyOut = [&]() {
if (!isActualArgBox || inlineCopyInOutForBoxes) {
if (copyOutPair.argMayBeModifiedByCall)
genArrayCopy(copyOutPair.var, copyOutPair.temp);
if (mlir::isa<fir::RecordType>(
fir::getElementTypeOf(copyOutPair.temp))) {
// Destroy components of the temporary (if any).
// If there are no components requiring destruction, then the call
// is a no-op.
mlir::Value tempBox =
fir::getBase(builder.createBox(loc, copyOutPair.temp));
fir::runtime::genDerivedTypeDestroyWithoutFinalization(builder, loc,
tempBox);
}
// Deallocate the top-level entity of the temporary.
builder.create<fir::FreeMemOp>(loc, fir::getBase(copyOutPair.temp));
return;
}
// Generate CopyOutAssign() call to copy data from the temporary
// to the actualArg. Note that in case the actual argument
// is ALLOCATABLE/POINTER the CopyOutAssign() implementation
// should not engage its reallocation, because the temporary
// is rank, shape and type compatible with it.
// Moreover, CopyOutAssign() guarantees that there will be no
// finalization for the LHS even if it is of a derived type
// with finalization.
// Create allocatable descriptor for the temp so that the runtime may
// deallocate it.
mlir::Value srcBox =
fir::getBase(builder.createBox(loc, copyOutPair.temp));
mlir::Type allocBoxTy =
mlir::cast<fir::BaseBoxType>(srcBox.getType())
.getBoxTypeWithNewAttr(fir::BaseBoxType::Attribute::Allocatable);
srcBox = builder.create<fir::ReboxOp>(loc, allocBoxTy, srcBox,
/*shift=*/mlir::Value{},
/*slice=*/mlir::Value{});
mlir::Value srcBoxRef = builder.createTemporary(loc, srcBox.getType());
builder.create<fir::StoreOp>(loc, srcBox, srcBoxRef);
// Create descriptor pointer to variable descriptor if copy out is needed,
// and nullptr otherwise.
mlir::Value destBoxRef;
if (copyOutPair.argMayBeModifiedByCall) {
mlir::Value destBox =
fir::getBase(builder.createBox(loc, copyOutPair.var));
destBoxRef = builder.createTemporary(loc, destBox.getType());
builder.create<fir::StoreOp>(loc, destBox, destBoxRef);
} else {
destBoxRef = builder.create<fir::ZeroOp>(loc, srcBoxRef.getType());
}
fir::runtime::genCopyOutAssign(builder, loc, destBoxRef, srcBoxRef);
};
if (!copyOutPair.restrictCopyAndFreeAtRuntime)
doCopyOut();
else
builder.genIfThen(loc, *copyOutPair.restrictCopyAndFreeAtRuntime)
.genThen([&]() { doCopyOut(); })
.end();
}
/// Lower a designator to a variable that may be absent at runtime into an
/// ExtendedValue where all the properties (base address, shape and length
/// parameters) can be safely read (set to zero if not present). It also
/// returns a boolean mlir::Value telling if the variable is present at
/// runtime.
/// This is useful to later be able to do conditional copy-in/copy-out
/// or to retrieve the base address without having to deal with the case
/// where the actual may be an absent fir.box.
std::pair<ExtValue, mlir::Value>
prepareActualThatMayBeAbsent(const Fortran::lower::SomeExpr &expr) {
mlir::Location loc = getLoc();
if (Fortran::evaluate::IsAllocatableOrPointerObject(expr)) {
// Fortran 2018 15.5.2.12 point 1: If unallocated/disassociated,
// it is as if the argument was absent. The main care here is to
// not do a copy-in/copy-out because the temp address, even though
// pointing to a null size storage, would not be a nullptr and
// therefore the argument would not be considered absent on the
// callee side. Note: if wholeSymbol is optional, it cannot be
// absent as per 15.5.2.12 point 7. and 8. We rely on this to
// un-conditionally read the allocatable/pointer descriptor here.
fir::MutableBoxValue mutableBox = genMutableBoxValue(expr);
mlir::Value isPresent = fir::factory::genIsAllocatedOrAssociatedTest(
builder, loc, mutableBox);
fir::ExtendedValue actualArg =
fir::factory::genMutableBoxRead(builder, loc, mutableBox);
return {actualArg, isPresent};
}
// Absent descriptor cannot be read. To avoid any issue in
// copy-in/copy-out, and when retrieving the address/length
// create an descriptor pointing to a null address here if the
// fir.box is absent.
ExtValue actualArg = gen(expr);
mlir::Value actualArgBase = fir::getBase(actualArg);
mlir::Value isPresent = builder.create<fir::IsPresentOp>(
loc, builder.getI1Type(), actualArgBase);
if (!mlir::isa<fir::BoxType>(actualArgBase.getType()))
return {actualArg, isPresent};
ExtValue safeToReadBox =
absentBoxToUnallocatedBox(builder, loc, actualArg, isPresent);
return {safeToReadBox, isPresent};
}
/// Create a temp on the stack for scalar actual arguments that may be absent
/// at runtime, but must be passed via a temp if they are presents.
fir::ExtendedValue
createScalarTempForArgThatMayBeAbsent(ExtValue actualArg,
mlir::Value isPresent) {
mlir::Location loc = getLoc();
mlir::Type type = fir::unwrapRefType(fir::getBase(actualArg).getType());
if (fir::isDerivedWithLenParameters(actualArg))
TODO(loc, "parametrized derived type optional scalar argument copy-in");
if (const fir::CharBoxValue *charBox = actualArg.getCharBox()) {
mlir::Value len = charBox->getLen();
mlir::Value zero = builder.createIntegerConstant(loc, len.getType(), 0);
len = builder.create<mlir::arith::SelectOp>(loc, isPresent, len, zero);
mlir::Value temp =
builder.createTemporary(loc, type, /*name=*/{},
/*shape=*/{}, mlir::ValueRange{len},
llvm::ArrayRef<mlir::NamedAttribute>{
fir::getAdaptToByRefAttr(builder)});
return fir::CharBoxValue{temp, len};
}
assert((fir::isa_trivial(type) || mlir::isa<fir::RecordType>(type)) &&
"must be simple scalar");
return builder.createTemporary(loc, type,
llvm::ArrayRef<mlir::NamedAttribute>{
fir::getAdaptToByRefAttr(builder)});
}
template <typename A>
bool isCharacterType(const A &exp) {
if (auto type = exp.GetType())
return type->category() == Fortran::common::TypeCategory::Character;
return false;
}
/// Lower an actual argument that must be passed via an address.
/// This generates of the copy-in/copy-out if the actual is not contiguous, or
/// the creation of the temp if the actual is a variable and \p byValue is
/// true. It handles the cases where the actual may be absent, and all of the
/// copying has to be conditional at runtime.
/// If the actual argument may be dynamically absent, return an additional
/// boolean mlir::Value that if true means that the actual argument is
/// present.
std::pair<ExtValue, std::optional<mlir::Value>>
prepareActualToBaseAddressLike(
const Fortran::lower::SomeExpr &expr,
const Fortran::lower::CallerInterface::PassedEntity &arg,
CopyOutPairs &copyOutPairs, bool byValue) {
mlir::Location loc = getLoc();
const bool isArray = expr.Rank() > 0;
const bool actualArgIsVariable = Fortran::evaluate::IsVariable(expr);
// It must be possible to modify VALUE arguments on the callee side, even
// if the actual argument is a literal or named constant. Hence, the
// address of static storage must not be passed in that case, and a copy
// must be made even if this is not a variable.
// Note: isArray should be used here, but genBoxArg already creates copies
// for it, so do not duplicate the copy until genBoxArg behavior is changed.
const bool isStaticConstantByValue =
byValue && Fortran::evaluate::IsActuallyConstant(expr) &&
(isCharacterType(expr));
const bool variableNeedsCopy =
actualArgIsVariable &&
(byValue || (isArray && !Fortran::evaluate::IsSimplyContiguous(
expr, converter.getFoldingContext())));
const bool needsCopy = isStaticConstantByValue || variableNeedsCopy;
auto [argAddr, isPresent] =
[&]() -> std::pair<ExtValue, std::optional<mlir::Value>> {
if (!actualArgIsVariable && !needsCopy)
// Actual argument is not a variable. Make sure a variable address is
// not passed.
return {genTempExtAddr(expr), std::nullopt};
ExtValue baseAddr;
if (arg.isOptional() &&
Fortran::evaluate::MayBePassedAsAbsentOptional(expr)) {
auto [actualArgBind, isPresent] = prepareActualThatMayBeAbsent(expr);
const ExtValue &actualArg = actualArgBind;
if (!needsCopy)
return {actualArg, isPresent};
if (isArray)
return {genCopyIn(actualArg, arg, copyOutPairs, isPresent, byValue),
isPresent};
// Scalars, create a temp, and use it conditionally at runtime if
// the argument is present.
ExtValue temp =
createScalarTempForArgThatMayBeAbsent(actualArg, isPresent);
mlir::Type tempAddrTy = fir::getBase(temp).getType();
mlir::Value selectAddr =
builder
.genIfOp(loc, {tempAddrTy}, isPresent,
/*withElseRegion=*/true)
.genThen([&]() {
fir::factory::genScalarAssignment(builder, loc, temp,
actualArg);
builder.create<fir::ResultOp>(loc, fir::getBase(temp));
})
.genElse([&]() {
mlir::Value absent =
builder.create<fir::AbsentOp>(loc, tempAddrTy);
builder.create<fir::ResultOp>(loc, absent);
})
.getResults()[0];
return {fir::substBase(temp, selectAddr), isPresent};
}
// Actual cannot be absent, the actual argument can safely be
// copied-in/copied-out without any care if needed.
if (isArray) {
ExtValue box = genBoxArg(expr);
if (needsCopy)
return {genCopyIn(box, arg, copyOutPairs,
/*restrictCopyAtRuntime=*/std::nullopt, byValue),
std::nullopt};
// Contiguous: just use the box we created above!
// This gets "unboxed" below, if needed.
return {box, std::nullopt};
}
// Actual argument is a non-optional, non-pointer, non-allocatable
// scalar.
ExtValue actualArg = genExtAddr(expr);
if (needsCopy)
return {createInMemoryScalarCopy(builder, loc, actualArg),
std::nullopt};
return {actualArg, std::nullopt};
}();
// Scalar and contiguous expressions may be lowered to a fir.box,
// either to account for potential polymorphism, or because lowering
// did not account for some contiguity hints.
// Here, polymorphism does not matter (an entity of the declared type
// is passed, not one of the dynamic type), and the expr is known to
// be simply contiguous, so it is safe to unbox it and pass the
// address without making a copy.
return {readIfBoxValue(argAddr), isPresent};
}