//===-- 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/ConvertType.h" #include "flang/Lower/ConvertVariable.h" #include "flang/Lower/CustomIntrinsicCall.h" #include "flang/Lower/DumpEvaluateExpr.h" #include "flang/Lower/IntrinsicCall.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/Runtime/Character.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/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 #define DEBUG_TYPE "flang-lower-expr" //===----------------------------------------------------------------------===// // 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 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 clInitialBufferSize( "array-constructor-initial-buffer-size", llvm::cl::desc( "set the incremental array construction buffer size (default=32)"), llvm::cl::init(32u)); /// 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()) 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(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 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 (!ty.isa()) { 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 = ty.cast(); } auto arrayToExtendedValue = [&](const llvm::SmallVector &extents, const llvm::SmallVector &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(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(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{ Fortran::lower::getAdaptToByRefAttr(builder)}); builder.create(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 static bool isArray(const A &x) { return x.Rank() != 0; } /// Is this a variable wrapped in parentheses? template static bool isParenthesizedVariable(const A &) { return false; } template static bool isParenthesizedVariable(const Fortran::evaluate::Expr &expr) { using ExprVariant = decltype(Fortran::evaluate::Expr::u); using Parentheses = Fortran::evaluate::Parentheses; if constexpr (Fortran::common::HasMember) { if (const auto *parentheses = std::get_if(&expr.u)) return Fortran::evaluate::IsVariable(parentheses->left()); return false; } else { return std::visit([&](const auto &x) { return isParenthesizedVariable(x); }, expr.u); } } /// Does \p expr only refer to symbols that are mapped to IR values in \p symMap /// ? static bool allSymbolsInExprPresentInMap(const Fortran::lower::SomeExpr &expr, Fortran::lower::SymMap &symMap) { for (const auto &sym : Fortran::evaluate::CollectSymbols(expr)) if (!symMap.lookupSymbol(sym)) return false; return true; } /// 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::UnboxedValue &v) -> fir::ExtendedValue { if (fir::unwrapRefType(fir::getBase(v).getType()) .isa()) return v; return builder.create(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 { if (box.isUnlimitedPolymorphic()) fir::emitFatalError( loc, "lowering attempting to load an unlimited polymorphic entity"); 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(loc, val); }) .genElse([&]() { mlir::Value zero = fir::factory::createZeroValue(builder, loc, eleType); builder.create(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()) 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()) 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()) 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(loc, boxType); auto boxOrAbsent = builder.create( 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 &arg : procRef.arguments()) if (arg && arg->Rank() != 0) return true; return false; } template static bool isElementalProcWithArrayArgs(const Fortran::evaluate::Expr &) { return false; } template <> bool isElementalProcWithArrayArgs(const Fortran::lower::SomeExpr &x) { if (const auto *procRef = std::get_if(&x.u)) return isElementalProcWithArrayArgs(*procRef); return false; } /// Some auxiliary data for processing initialization in ScalarExprLowering /// below. This is currently used for generating dense attributed global /// arrays. struct InitializerData { explicit InitializerData(bool getRawVals = false) : genRawVals{getRawVals} {} llvm::SmallVector rawVals; // initialization raw values mlir::Type rawType; // Type of elements processed for rawVals vector. bool genRawVals; // generate the rawVals vector if set. }; /// If \p arg is the address of a function with a denoted host-association tuple /// argument, then return the host-associations tuple value of the current /// procedure. Otherwise, return nullptr. static mlir::Value argumentHostAssocs(Fortran::lower::AbstractConverter &converter, mlir::Value arg) { if (auto addr = mlir::dyn_cast_or_null(arg.getDefiningOp())) { auto &builder = converter.getFirOpBuilder(); if (auto funcOp = builder.getNamedFunction(addr.getSymbol())) if (fir::anyFuncArgsHaveAttr(funcOp, fir::getHostAssocAttrName())) return converter.hostAssocTupleValue(); } return {}; } /// \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 = argTy.cast().getType(0).cast(); mlir::Location loc = converter.getCurrentLocation(); auto &builder = converter.getFirOpBuilder(); auto boxProc = [&]() -> mlir::Value { if (auto host = argumentHostAssocs(converter, funcAddr)) return builder.create( loc, boxTy, llvm::ArrayRef{funcAddr, host}); return builder.create(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(boxType.isa() && "argument must be a fir.box"); mlir::Value emptyBox = fir::factory::createUnallocatedBox(builder, loc, boxType, llvm::None); auto safeToReadBox = builder.create(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 const Fortran::semantics::Symbol &getFirstSym(const A &obj) { return obj.GetFirstSymbol().GetUltimate(); } // Helper to get the ultimate last symbol. template const Fortran::semantics::Symbol &getLastSym(const A &obj) { return obj.GetLastSymbol().GetUltimate(); } static bool isIntrinsicModuleProcRef(const Fortran::evaluate::ProcedureRef &procRef) { const Fortran::semantics::Symbol *symbol = procRef.proc().GetSymbol(); if (!symbol) return false; const Fortran::semantics::Symbol *module = symbol->GetUltimate().owner().GetSymbol(); return module && module->attrs().test(Fortran::semantics::Attr::INTRINSIC); } namespace { /// Lowering of Fortran::evaluate::Expr 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, InitializerData *initializer = nullptr) : location{loc}, converter{converter}, builder{converter.getFirOpBuilder()}, stmtCtx{stmtCtx}, symMap{symMap}, inInitializer{initializer} {} 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 = std::visit( [&](const auto &x) { return genMutableBoxValueImpl(x); }, expr.u); const fir::MutableBoxValue *mutableBox = exv.getBoxOf(); if (!mutableBox) fir::emitFatalError(getLoc(), "expr was not lowered to MutableBoxValue"); return *mutableBox; } template 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. ExtValue genMutableBoxValueImpl(const Fortran::evaluate::NullPointer &) { mlir::Location loc = getLoc(); auto nullConst = builder.createNullConstant(loc); auto noneTy = mlir::NoneType::get(builder.getContext()); auto polyRefTy = fir::LLVMPointerType::get(noneTy); // MutableBoxValue will dereference the box, so create a bogus temporary for // the `nullptr`. The LLVM optimizer will garbage collect the temp. auto temp = builder.createTemporary(loc, polyRefTy, /*shape=*/mlir::ValueRange{}); auto nullPtr = builder.createConvert(loc, polyRefTy, nullConst); builder.create(loc, nullPtr, temp); auto nullBoxTy = builder.getRefType(fir::BoxType::get(noneTy)); return fir::MutableBoxValue(builder.createConvert(loc, nullBoxTy, temp), /*lenParameters=*/mlir::ValueRange{}, /*mutableProperties=*/{}); } template ExtValue genMutableBoxValueImpl(const Fortran::evaluate::FunctionRef &funRef) { return genRawProcedureRef(funRef, converter.genType(toEvExpr(funRef))); } template ExtValue genMutableBoxValueImpl(const Fortran::evaluate::Designator &designator) { return std::visit( Fortran::common::visitors{ [&](const Fortran::evaluate::SymbolRef &sym) -> ExtValue { return symMap.lookupSymbol(*sym).toExtendedValue(); }, [&](const Fortran::evaluate::Component &comp) -> ExtValue { return genComponent(comp); }, [&](const auto &) -> ExtValue { fir::emitFatalError(getLoc(), "not an allocatable or pointer designator"); }}, designator.u); } template ExtValue genMutableBoxValueImpl(const Fortran::evaluate::Expr &expr) { return std::visit([&](const auto &x) { return genMutableBoxValueImpl(x); }, expr.u); } mlir::Location getLoc() { return location; } template 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 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); } /// Generate a real constant with a value `value`. template mlir::Value genRealConstant(mlir::MLIRContext *context, const llvm::APFloat &value) { mlir::Type fltTy = Fortran::lower::convertReal(context, KIND); return builder.createRealConstant(getLoc(), fltTy, 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 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(getLoc(), pred, *lhs, *rhs); fir::emitFatalError(getLoc(), "array compare should be handled in genarr"); } template mlir::Value createCompareOp(const A &ex, mlir::arith::CmpIPredicate pred) { ExtValue left = genval(ex.left()); return createCompareOp(pred, left, genval(ex.right())); } template 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(getLoc(), pred, *lhs, *rhs); fir::emitFatalError(getLoc(), "array compare should be handled in genarr"); } template mlir::Value createFltCmpOp(const A &ex, mlir::arith::CmpFPredicate pred) { ExtValue left = genval(ex.left()); return createFltCmpOp(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 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) { if (Fortran::lower::SymbolBox val = symMap.lookupSymbol(sym)) return val.match( [&](const Fortran::lower::SymbolBox::PointerOrAllocatable &boxAddr) { return fir::factory::genMutableBoxRead(builder, getLoc(), boxAddr); }, [&val](auto &) { return val.toExtendedValue(); }); LLVM_DEBUG(llvm::dbgs() << "unknown symbol: " << sym << "\nmap: " << symMap << '\n'); fir::emitFatalError(getLoc(), "symbol is not mapped to any IR value"); } 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); } 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) { mlir::Location loc = getLoc(); if (const Fortran::evaluate::SpecificIntrinsic *intrinsic = proc.GetSpecificIntrinsic()) { mlir::FunctionType signature = Fortran::lower::translateSignature(proc, converter); // Intrinsic lowering is based on the generic name, so retrieve it here in // case it is different from the specific name. The type of the specific // intrinsic is retained in the signature. std::string genericName = converter.getFoldingContext().intrinsics().GetGenericIntrinsicName( intrinsic->name); mlir::SymbolRefAttr symbolRefAttr = Fortran::lower::getUnrestrictedIntrinsicSymbolRefAttr( builder, loc, genericName, signature); mlir::Value funcPtr = builder.create(loc, signature, symbolRefAttr); return funcPtr; } const Fortran::semantics::Symbol *symbol = proc.GetSymbol(); assert(symbol && "expected symbol in ProcedureDesignator"); mlir::Value funcPtr; mlir::Value funcPtrResultLength; if (Fortran::semantics::IsDummy(*symbol)) { Fortran::lower::SymbolBox val = symMap.lookupSymbol(*symbol); assert(val && "Dummy procedure not in symbol map"); funcPtr = val.getAddr(); if (fir::isCharacterProcedureTuple(funcPtr.getType(), /*acceptRawFunc=*/false)) std::tie(funcPtr, funcPtrResultLength) = fir::factory::extractCharacterProcedureTuple(builder, loc, funcPtr); } else { std::string name = converter.mangleName(*symbol); mlir::func::FuncOp func = Fortran::lower::getOrDeclareFunction(name, proc, converter); // Abstract results require later rewrite of the function type. // This currently does not happen inside GloalOps, causing LLVM // IR verification failure. This helper is only here to catch these // cases and emit a TODOs for now. if (inInitializer && fir::hasAbstractResult(func.getFunctionType())) TODO(converter.genLocation(symbol->name()), "static description of non trivial procedure bindings"); funcPtr = builder.create(loc, func.getFunctionType(), builder.getSymbolRefAttr(name)); } if (Fortran::lower::mustPassLengthWithDummyProcedure(proc, converter)) { // The result length, if available here, must be propagated along the // procedure address so that call sites where the result length is assumed // can retrieve the length. Fortran::evaluate::DynamicType resultType = proc.GetType().value(); if (const auto &lengthExpr = resultType.GetCharLength()) { // The length expression may refer to dummy argument symbols that are // meaningless without any actual arguments. Leave the length as // unknown in that case, it be resolved on the call site // with the actual arguments. if (allSymbolsInExprPresentInMap(toEvExpr(*lengthExpr), symMap)) { mlir::Value rawLen = fir::getBase(genval(*lengthExpr)); // F2018 7.4.4.2 point 5. funcPtrResultLength = fir::factory::genMaxWithZero(builder, getLoc(), rawLen); } } if (!funcPtrResultLength) funcPtrResultLength = builder.createIntegerConstant( loc, builder.getCharacterLengthType(), -1); return fir::CharBoxValue{funcPtr, funcPtrResultLength}; } return funcPtr; } ExtValue genval(const Fortran::evaluate::NullPointer &) { return builder.createNullConstant(getLoc()); } static bool isDerivedTypeWithLengthParameters(const Fortran::semantics::Symbol &sym) { if (const Fortran::semantics::DeclTypeSpec *declTy = sym.GetType()) if (const Fortran::semantics::DerivedTypeSpec *derived = declTy->AsDerived()) return Fortran::semantics::CountLenParameters(*derived) > 0; return false; } static bool isBuiltinCPtr(const Fortran::semantics::Symbol &sym) { if (const Fortran::semantics::DeclTypeSpec *declType = sym.GetType()) if (const Fortran::semantics::DerivedTypeSpec *derived = declType->AsDerived()) return Fortran::semantics::IsIsoCType(derived); return false; } /// Lower structure constructor without a temporary. This can be used in /// fir::GloablOp, and assumes that the structure component is a constant. ExtValue genStructComponentInInitializer( const Fortran::evaluate::StructureConstructor &ctor) { mlir::Location loc = getLoc(); mlir::Type ty = translateSomeExprToFIRType(converter, toEvExpr(ctor)); auto recTy = ty.cast(); auto fieldTy = fir::FieldType::get(ty.getContext()); mlir::Value res = builder.create(loc, recTy); for (const auto &[sym, expr] : ctor.values()) { // Parent components need more work because they do not appear in the // fir.rec type. if (sym->test(Fortran::semantics::Symbol::Flag::ParentComp)) TODO(loc, "parent component in structure constructor"); llvm::StringRef name = toStringRef(sym->name()); mlir::Type componentTy = recTy.getType(name); // FIXME: type parameters must come from the derived-type-spec auto field = builder.create( loc, fieldTy, name, ty, /*typeParams=*/mlir::ValueRange{} /*TODO*/); if (Fortran::semantics::IsAllocatable(sym)) TODO(loc, "allocatable component in structure constructor"); if (Fortran::semantics::IsPointer(sym)) { mlir::Value initialTarget = Fortran::lower::genInitialDataTarget( converter, loc, componentTy, expr.value()); res = builder.create( loc, recTy, res, initialTarget, builder.getArrayAttr(field.getAttributes())); continue; } if (isDerivedTypeWithLengthParameters(sym)) TODO(loc, "component with length parameters in structure constructor"); if (isBuiltinCPtr(sym)) { // Builtin c_ptr and c_funptr have special handling because initial // value are handled for them as an extension. mlir::Value addr = fir::getBase(Fortran::lower::genExtAddrInInitializer( converter, loc, expr.value())); if (addr.getType() == componentTy) { // Do nothing. The Ev::Expr was returned as a value that can be // inserted directly to the component without an intermediary. } else { // The Ev::Expr returned is an initializer that is a pointer (e.g., // null) that must be inserted into an intermediate cptr record // value's address field, which ought to be an intptr_t on the target. assert((fir::isa_ref_type(addr.getType()) || addr.getType().isa()) && "expect reference type for address field"); assert(fir::isa_derived(componentTy) && "expect C_PTR, C_FUNPTR to be a record"); auto cPtrRecTy = componentTy.cast(); llvm::StringRef addrFieldName = Fortran::lower::builtin::cptrFieldName; mlir::Type addrFieldTy = cPtrRecTy.getType(addrFieldName); auto addrField = builder.create( loc, fieldTy, addrFieldName, componentTy, /*typeParams=*/mlir::ValueRange{}); mlir::Value castAddr = builder.createConvert(loc, addrFieldTy, addr); auto undef = builder.create(loc, componentTy); addr = builder.create( loc, componentTy, undef, castAddr, builder.getArrayAttr(addrField.getAttributes())); } res = builder.create( loc, recTy, res, addr, builder.getArrayAttr(field.getAttributes())); continue; } mlir::Value val = fir::getBase(genval(expr.value())); assert(!fir::isa_ref_type(val.getType()) && "expecting a constant value"); mlir::Value castVal = builder.createConvert(loc, componentTy, val); res = builder.create( loc, recTy, res, castVal, builder.getArrayAttr(field.getAttributes())); } return res; } /// 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) { if (inInitializer) return genStructComponentInInitializer(ctor); mlir::Location loc = getLoc(); mlir::Type ty = translateSomeExprToFIRType(converter, toEvExpr(ctor)); auto recTy = ty.cast(); auto fieldTy = fir::FieldType::get(ty.getContext()); mlir::Value res = builder.createTemporary(loc, recTy); for (const auto &value : ctor.values()) { const Fortran::semantics::Symbol &sym = *value.first; const Fortran::lower::SomeExpr &expr = value.second.value(); // Parent components need more work because they do not appear in the // fir.rec type. if (sym.test(Fortran::semantics::Symbol::Flag::ParentComp)) TODO(loc, "parent component in structure constructor"); if (isDerivedTypeWithLengthParameters(sym)) TODO(loc, "component with length parameters in structure constructor"); llvm::StringRef name = toStringRef(sym.name()); // FIXME: type parameters must come from the derived-type-spec mlir::Value field = builder.create( loc, fieldTy, name, ty, /*typeParams=*/mlir::ValueRange{} /*TODO*/); mlir::Type coorTy = builder.getRefType(recTy.getType(name)); auto coor = builder.create(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::MutableBoxValue &toBox) { if (toBox.isPointer()) { Fortran::lower::associateMutableBox( converter, loc, toBox, expr, /*lbounds=*/llvm::None, 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 ac-do-variable, which is not a Symbol. ExtValue genval(const Fortran::evaluate::ImpliedDoIndex &var) { return converter.impliedDoBinding(toStringRef(var.name)); } 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 ExtValue genval(const Fortran::evaluate::ComplexComponent &part) { return extractComplexPart(genunbox(part.left()), part.isImaginaryPart); } template ExtValue genval(const Fortran::evaluate::Negate> &op) { mlir::Value input = genunbox(op.left()); // Like LLVM, integer negation is the binary op "0 - value" mlir::Value zero = genIntegerConstant(builder.getContext(), 0); return builder.create(getLoc(), zero, input); } template ExtValue genval(const Fortran::evaluate::Negate> &op) { return builder.create(getLoc(), genunbox(op.left())); } template ExtValue genval(const Fortran::evaluate::Negate> &op) { return builder.create(getLoc(), genunbox(op.left())); } template 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(getLoc(), lhs, rhs); } template mlir::Value createBinaryOp(const A &ex) { ExtValue left = genval(ex.left()); return createBinaryOp(left, genval(ex.right())); } #undef GENBIN #define GENBIN(GenBinEvOp, GenBinTyCat, GenBinFirOp) \ template \ ExtValue genval(const Fortran::evaluate::GenBinEvOp> &x) { \ return createBinaryOp(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) GENBIN(Divide, Complex, fir::DivcOp) template ExtValue genval( const Fortran::evaluate::Power> &op) { mlir::Type ty = converter.genType(TC, KIND); mlir::Value lhs = genunbox(op.left()); mlir::Value rhs = genunbox(op.right()); return Fortran::lower::genPow(builder, getLoc(), ty, lhs, rhs); } template ExtValue genval( const Fortran::evaluate::RealToIntPower> &op) { mlir::Type ty = converter.genType(TC, KIND); mlir::Value lhs = genunbox(op.left()); mlir::Value rhs = genunbox(op.right()); return Fortran::lower::genPow(builder, getLoc(), ty, lhs, rhs); } template ExtValue genval(const Fortran::evaluate::ComplexConstructor &op) { mlir::Value realPartValue = genunbox(op.left()); return fir::factory::Complex{builder, getLoc()}.createComplex( KIND, realPartValue, genunbox(op.right())); } template ExtValue genval(const Fortran::evaluate::Concat &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 ExtValue genval(const Fortran::evaluate::Extremum> &op) { mlir::Value lhs = genunbox(op.left()); mlir::Value rhs = genunbox(op.right()); switch (op.ordering) { case Fortran::evaluate::Ordering::Greater: return Fortran::lower::genMax(builder, getLoc(), llvm::ArrayRef{lhs, rhs}); case Fortran::evaluate::Ordering::Less: return Fortran::lower::genMin(builder, getLoc(), llvm::ArrayRef{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 = fir::unwrapPassByRefType(charAddr.getType()).cast(); 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 ExtValue genval(const Fortran::evaluate::SetLength &x) { mlir::Value newLenValue = genunbox(x.right()); fir::ExtendedValue lhs = gen(x.left()); return replaceScalarCharacterLength(lhs, newLenValue); } template ExtValue genval(const Fortran::evaluate::Relational> &op) { return createCompareOp(op, translateRelational(op.opr)); } template ExtValue genval(const Fortran::evaluate::Relational> &op) { return createFltCmpOp( op, translateFloatRelational(op.opr)); } template ExtValue genval(const Fortran::evaluate::Relational> &op) { return createFltCmpOp(op, translateFloatRelational(op.opr)); } template ExtValue genval(const Fortran::evaluate::Relational> &op) { return createCharCompare(op, translateRelational(op.opr)); } ExtValue genval(const Fortran::evaluate::Relational &op) { return std::visit([&](const auto &x) { return genval(x); }, op.u); } template ExtValue genval(const Fortran::evaluate::Convert, 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) { // Use char_convert. Each code point is translated from a // narrower/wider encoding to the target encoding. For example, 'A' // may be translated from 0x41 : i8 to 0x0041 : i16. The symbol // for euro (0x20AC : i16) may be translated from a wide character // to "0xE2 0x82 0xAC" : UTF-8. mlir::Value bufferSize = boxchar.getLen(); auto kindMap = builder.getKindMap(); mlir::Value boxCharAddr = boxchar.getAddr(); auto fromTy = boxCharAddr.getType(); if (auto charTy = fromTy.dyn_cast()) { // boxchar is a value, not a variable. Turn it into a temporary. // As a value, it ought to have a constant LEN value. assert(charTy.hasConstantLen() && "must have constant length"); mlir::Value tmp = builder.createTemporary(loc, charTy); builder.create(loc, boxCharAddr, tmp); boxCharAddr = tmp; } auto fromBits = kindMap.getCharacterBitsize(fir::unwrapRefType(fromTy) .cast() .getFKind()); auto toBits = kindMap.getCharacterBitsize( ty.cast().getFKind()); if (toBits < fromBits) { // Scale by relative ratio to give a buffer of the same length. auto ratio = builder.createIntegerConstant( loc, bufferSize.getType(), fromBits / toBits); bufferSize = builder.create(loc, bufferSize, ratio); } auto dest = builder.create( loc, ty, mlir::ValueRange{bufferSize}); builder.create(loc, boxCharAddr, boxchar.getLen(), dest); return fir::CharBoxValue{dest, boxchar.getLen()}; } 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 ExtValue genval(const Fortran::evaluate::Parentheses &op) { ExtValue input = genval(op.left()); mlir::Value base = fir::getBase(input); mlir::Value newBase = builder.create(getLoc(), base.getType(), base); return fir::substBase(input, newBase); } template ExtValue genval(const Fortran::evaluate::Not &op) { mlir::Value logical = genunbox(op.left()); mlir::Value one = genBoolConstant(true); mlir::Value val = builder.createConvert(getLoc(), builder.getI1Type(), logical); return builder.create(getLoc(), val, one); } template ExtValue genval(const Fortran::evaluate::LogicalOperation &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(lhs, rhs); case Fortran::evaluate::LogicalOperator::Or: return createBinaryOp(lhs, rhs); case Fortran::evaluate::LogicalOperator::Eqv: return createCompareOp( mlir::arith::CmpIPredicate::eq, lhs, rhs); case Fortran::evaluate::LogicalOperator::Neqv: return createCompareOp( mlir::arith::CmpIPredicate::ne, lhs, rhs); case Fortran::evaluate::LogicalOperator::Not: // lib/evaluate expression for .NOT. is Fortran::evaluate::Not. llvm_unreachable(".NOT. is not a binary operator"); } llvm_unreachable("unhandled logical operation"); } /// Convert a scalar literal constant to IR. template ExtValue genScalarLit( const Fortran::evaluate::Scalar> &value) { if constexpr (TC == Fortran::common::TypeCategory::Integer) { return genIntegerConstant(builder.getContext(), value.ToInt64()); } else if constexpr (TC == Fortran::common::TypeCategory::Logical) { return genBoolConstant(value.IsTrue()); } else if constexpr (TC == Fortran::common::TypeCategory::Real) { std::string str = value.DumpHexadecimal(); if constexpr (KIND == 2) { llvm::APFloat floatVal{llvm::APFloatBase::IEEEhalf(), str}; return genRealConstant(builder.getContext(), floatVal); } else if constexpr (KIND == 3) { llvm::APFloat floatVal{llvm::APFloatBase::BFloat(), str}; return genRealConstant(builder.getContext(), floatVal); } else if constexpr (KIND == 4) { llvm::APFloat floatVal{llvm::APFloatBase::IEEEsingle(), str}; return genRealConstant(builder.getContext(), floatVal); } else if constexpr (KIND == 10) { llvm::APFloat floatVal{llvm::APFloatBase::x87DoubleExtended(), str}; return genRealConstant(builder.getContext(), floatVal); } else if constexpr (KIND == 16) { llvm::APFloat floatVal{llvm::APFloatBase::IEEEquad(), str}; return genRealConstant(builder.getContext(), floatVal); } else { // convert everything else to double llvm::APFloat floatVal{llvm::APFloatBase::IEEEdouble(), str}; return genRealConstant(builder.getContext(), floatVal); } } else if constexpr (TC == Fortran::common::TypeCategory::Complex) { using TR = Fortran::evaluate::Type; Fortran::evaluate::ComplexConstructor ctor( Fortran::evaluate::Expr{ Fortran::evaluate::Constant{value.REAL()}}, Fortran::evaluate::Expr{ Fortran::evaluate::Constant{value.AIMAG()}}); return genunbox(ctor); } else /*constexpr*/ { llvm_unreachable("unhandled constant"); } } /// Generate a raw literal value and store it in the rawVals vector. template void genRawLit(const Fortran::evaluate::Scalar> &value) { mlir::Attribute val; assert(inInitializer != nullptr); if constexpr (TC == Fortran::common::TypeCategory::Integer) { inInitializer->rawType = converter.genType(TC, KIND); val = builder.getIntegerAttr(inInitializer->rawType, value.ToInt64()); } else if constexpr (TC == Fortran::common::TypeCategory::Logical) { inInitializer->rawType = converter.genType(Fortran::common::TypeCategory::Integer, KIND); val = builder.getIntegerAttr(inInitializer->rawType, value.IsTrue()); } else if constexpr (TC == Fortran::common::TypeCategory::Real) { std::string str = value.DumpHexadecimal(); inInitializer->rawType = converter.genType(TC, KIND); llvm::APFloat floatVal{builder.getKindMap().getFloatSemantics(KIND), str}; val = builder.getFloatAttr(inInitializer->rawType, floatVal); } else if constexpr (TC == Fortran::common::TypeCategory::Complex) { std::string strReal = value.REAL().DumpHexadecimal(); std::string strImg = value.AIMAG().DumpHexadecimal(); inInitializer->rawType = converter.genType(TC, KIND); llvm::APFloat realVal{builder.getKindMap().getFloatSemantics(KIND), strReal}; val = builder.getFloatAttr(inInitializer->rawType, realVal); inInitializer->rawVals.push_back(val); llvm::APFloat imgVal{builder.getKindMap().getFloatSemantics(KIND), strImg}; val = builder.getFloatAttr(inInitializer->rawType, imgVal); } inInitializer->rawVals.push_back(val); } /// Convert a scalar literal CHARACTER to IR. template ExtValue genScalarLit(const Fortran::evaluate::Scalar> &value, int64_t len) { using ET = typename std::decay_t::value_type; if constexpr (KIND == 1) { assert(value.size() == static_cast(len)); // Outline character constant in ro data if it is not in an initializer. if (!inInitializer) return fir::factory::createStringLiteral(builder, getLoc(), value); // When in an initializer context, construct the literal op itself and do // not construct another constant object in rodata. fir::StringLitOp stringLit = builder.createStringLitOp(getLoc(), value); mlir::Value lenp = builder.createIntegerConstant( getLoc(), builder.getCharacterLengthType(), len); return fir::CharBoxValue{stringLit.getResult(), lenp}; } fir::CharacterType type = fir::CharacterType::get(builder.getContext(), KIND, len); auto consLit = [&]() -> fir::StringLitOp { mlir::MLIRContext *context = builder.getContext(); std::int64_t size = static_cast(value.size()); mlir::ShapedType shape = mlir::RankedTensorType::get( llvm::ArrayRef{size}, mlir::IntegerType::get(builder.getContext(), sizeof(ET) * 8)); auto denseAttr = mlir::DenseElementsAttr::get( shape, llvm::ArrayRef{value.data(), value.size()}); auto denseTag = mlir::StringAttr::get(context, fir::StringLitOp::xlist()); mlir::NamedAttribute dataAttr(denseTag, denseAttr); auto sizeTag = mlir::StringAttr::get(context, fir::StringLitOp::size()); mlir::NamedAttribute sizeAttr(sizeTag, builder.getI64IntegerAttr(len)); llvm::SmallVector attrs = {dataAttr, sizeAttr}; return builder.create( getLoc(), llvm::ArrayRef{type}, llvm::None, attrs); }; mlir::Value lenp = builder.createIntegerConstant( getLoc(), builder.getCharacterLengthType(), len); // When in an initializer context, construct the literal op itself and do // not construct another constant object in rodata. if (inInitializer) return fir::CharBoxValue{consLit().getResult(), lenp}; // Otherwise, the string is in a plain old expression so "outline" the value // by hashconsing it to a constant literal object. std::string globalName = fir::factory::uniqueCGIdent("cl", (const char *)value.c_str()); fir::GlobalOp global = builder.getNamedGlobal(globalName); if (!global) global = builder.createGlobalConstant( getLoc(), type, globalName, [&](fir::FirOpBuilder &builder) { fir::StringLitOp str = consLit(); builder.create(getLoc(), str); }, builder.createLinkOnceLinkage()); auto addr = builder.create(getLoc(), global.resultType(), global.getSymbol()); return fir::CharBoxValue{addr, lenp}; } template ExtValue genArrayLit( const Fortran::evaluate::Constant> &con) { mlir::Location loc = getLoc(); mlir::IndexType idxTy = builder.getIndexType(); Fortran::evaluate::ConstantSubscript size = Fortran::evaluate::GetSize(con.shape()); fir::SequenceType::Shape shape(con.shape().begin(), con.shape().end()); mlir::Type eleTy; if constexpr (TC == Fortran::common::TypeCategory::Character) eleTy = converter.genType(TC, KIND, {con.LEN()}); else eleTy = converter.genType(TC, KIND); auto arrayTy = fir::SequenceType::get(shape, eleTy); mlir::Value array; llvm::SmallVector lbounds; llvm::SmallVector extents; if (!inInitializer || !inInitializer->genRawVals) { array = builder.create(loc, arrayTy); for (auto [lb, extent] : llvm::zip(con.lbounds(), shape)) { lbounds.push_back(builder.createIntegerConstant(loc, idxTy, lb - 1)); extents.push_back(builder.createIntegerConstant(loc, idxTy, extent)); } } if (size == 0) { if constexpr (TC == Fortran::common::TypeCategory::Character) { mlir::Value len = builder.createIntegerConstant(loc, idxTy, con.LEN()); return fir::CharArrayBoxValue{array, len, extents, lbounds}; } else { return fir::ArrayBoxValue{array, extents, lbounds}; } } Fortran::evaluate::ConstantSubscripts subscripts = con.lbounds(); auto createIdx = [&]() { llvm::SmallVector idx; for (size_t i = 0; i < subscripts.size(); ++i) idx.push_back( builder.getIntegerAttr(idxTy, subscripts[i] - con.lbounds()[i])); return idx; }; if constexpr (TC == Fortran::common::TypeCategory::Character) { assert(array && "array must not be nullptr"); do { mlir::Value elementVal = fir::getBase(genScalarLit(con.At(subscripts), con.LEN())); array = builder.create( loc, arrayTy, array, elementVal, builder.getArrayAttr(createIdx())); } while (con.IncrementSubscripts(subscripts)); mlir::Value len = builder.createIntegerConstant(loc, idxTy, con.LEN()); return fir::CharArrayBoxValue{array, len, extents, lbounds}; } else { llvm::SmallVector rangeStartIdx; uint64_t rangeSize = 0; do { if (inInitializer && inInitializer->genRawVals) { genRawLit(con.At(subscripts)); continue; } auto getElementVal = [&]() { return builder.createConvert( loc, eleTy, fir::getBase(genScalarLit(con.At(subscripts)))); }; Fortran::evaluate::ConstantSubscripts nextSubscripts = subscripts; bool nextIsSame = con.IncrementSubscripts(nextSubscripts) && con.At(subscripts) == con.At(nextSubscripts); if (!rangeSize && !nextIsSame) { // single (non-range) value array = builder.create( loc, arrayTy, array, getElementVal(), builder.getArrayAttr(createIdx())); } else if (!rangeSize) { // start a range rangeStartIdx = createIdx(); rangeSize = 1; } else if (nextIsSame) { // expand a range ++rangeSize; } else { // end a range llvm::SmallVector rangeBounds; llvm::SmallVector idx = createIdx(); for (size_t i = 0; i < idx.size(); ++i) { rangeBounds.push_back(rangeStartIdx[i] .cast() .getValue() .getSExtValue()); rangeBounds.push_back( idx[i].cast().getValue().getSExtValue()); } array = builder.create( loc, arrayTy, array, getElementVal(), builder.getIndexVectorAttr(rangeBounds)); rangeSize = 0; } } while (con.IncrementSubscripts(subscripts)); return fir::ArrayBoxValue{array, extents, lbounds}; } } fir::ExtendedValue genArrayLit( const Fortran::evaluate::Constant &con) { mlir::Location loc = getLoc(); mlir::IndexType idxTy = builder.getIndexType(); Fortran::evaluate::ConstantSubscript size = Fortran::evaluate::GetSize(con.shape()); fir::SequenceType::Shape shape(con.shape().begin(), con.shape().end()); mlir::Type eleTy = converter.genType(con.GetType().GetDerivedTypeSpec()); auto arrayTy = fir::SequenceType::get(shape, eleTy); mlir::Value array = builder.create(loc, arrayTy); llvm::SmallVector lbounds; llvm::SmallVector extents; for (auto [lb, extent] : llvm::zip(con.lbounds(), con.shape())) { lbounds.push_back(builder.createIntegerConstant(loc, idxTy, lb - 1)); extents.push_back(builder.createIntegerConstant(loc, idxTy, extent)); } if (size == 0) return fir::ArrayBoxValue{array, extents, lbounds}; Fortran::evaluate::ConstantSubscripts subscripts = con.lbounds(); do { mlir::Value derivedVal = fir::getBase(genval(con.At(subscripts))); llvm::SmallVector idx; for (auto [dim, lb] : llvm::zip(subscripts, con.lbounds())) idx.push_back(builder.getIntegerAttr(idxTy, dim - lb)); array = builder.create( loc, arrayTy, array, derivedVal, builder.getArrayAttr(idx)); } while (con.IncrementSubscripts(subscripts)); return fir::ArrayBoxValue{array, extents, lbounds}; } template ExtValue genval(const Fortran::evaluate::Constant> &con) { if (con.Rank() > 0) return genArrayLit(con); std::optional>> opt = con.GetScalarValue(); assert(opt.has_value() && "constant has no value"); if constexpr (TC == Fortran::common::TypeCategory::Character) { return genScalarLit(opt.value(), con.LEN()); } else { return genScalarLit(opt.value()); } } fir::ExtendedValue genval( const Fortran::evaluate::Constant &con) { if (con.Rank() > 0) return genArrayLit(con); if (auto ctor = con.GetScalarValue()) return genval(ctor.value()); fir::emitFatalError(getLoc(), "constant of derived type has no constructor"); } template ExtValue genval(const Fortran::evaluate::ArrayConstructor &) { fir::emitFatalError(getLoc(), "array constructor: lowering 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( 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 = std::visit( Fortran::common::visitors{ [&](const Fortran::evaluate::DataRef &x) { return gen(x); }, [&](const Fortran::evaluate::StaticDataObject::Pointer &p) -> ExtValue { if (std::optional str = p->AsString()) return fir::factory::createStringLiteral(builder, getLoc(), *str); // TODO: convert StaticDataObject to Constant 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 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( &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 std::visit([&](const auto &x) { return gen(x); }, dref.u); } ExtValue genval(const Fortran::evaluate::DataRef &dref) { return std::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 &list) { if (!getLastSym(cmpt).test(Fortran::semantics::Symbol::Flag::ParentComp)) list.push_front(&cmpt); return std::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 list; const Fortran::evaluate::DataRef *base = reverseComponents(cmpt, list); llvm::SmallVector 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 = ty.cast(); const Fortran::semantics::Symbol &sym = getLastSym(*field); llvm::StringRef name = toStringRef(sym.name()); coorArgs.push_back(builder.create( loc, fldTy, name, recTy, fir::getTypeParams(obj))); ty = recTy.getType(name); } ty = builder.getRefType(ty); return fir::factory::componentToExtendedValue( builder, loc, builder.create(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 = unwrapTy.cast(); llvm::ArrayRef 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 lowering"); } static bool isSlice(const Fortran::evaluate::ArrayRef &aref) { for (const Fortran::evaluate::Subscript &sub : aref.subscript()) if (std::holds_alternative(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()) return genOffsetAndCoordinateOp(array, aref); // Generate a fir.coordinate_of with zero based array indexes. llvm::SmallVector 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(loc, ty, val, lb)); } mlir::Value base = fir::getBase(array); auto seqTy = fir::dyn_cast_ptrOrBoxEleTy(base.getType()).cast(); assert(args.size() == seqTy.getDimension()); mlir::Type ty = builder.getRefType(seqTy.getEleTy()); auto addr = builder.create(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 = arrTy.cast().getEleTy(); 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(loc, val, lb); mlir::Value prod = builder.create(loc, delta, diff); total = builder.create(loc, prod, total); if (ext) delta = builder.create(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( loc, refTy, base, llvm::ArrayRef{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 lowering 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 = arrTy.cast().getEleTy(); mlir::Type refTy = builder.getRefType(eleTy); mlir::IndexType idxTy = builder.getIndexType(); llvm::SmallVector 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( 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 ExtValue gen(const Fortran::evaluate::Designator &des) { return std::visit([&](const auto &x) { return gen(x); }, des.u); } template ExtValue genval(const Fortran::evaluate::Designator &des) { return std::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()); return converter.genType(dt.GetDerivedTypeSpec()); } /// Lower a function reference template ExtValue genFunctionRef(const Fortran::evaluate::FunctionRef &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 ExtValue gen(const Fortran::evaluate::FunctionRef &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, converter.getFoldingContext())) 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); mlir::Value box = builder.createBox(loc, exv); return fir::BoxValue( box, fir::factory::getNonDefaultLowerBounds(builder, loc, exv), fir::factory::getNonDeferredLengthParams(exv)); } /// Generate a call to a Fortran intrinsic or intrinsic module procedure. ExtValue genIntrinsicRef( const Fortran::evaluate::ProcedureRef &procRef, llvm::Optional resultType, llvm::Optional intrinsic = llvm::None) { llvm::SmallVector 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>; llvm::SmallVector 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) { operands.emplace_back(genval(expr), llvm::None); }; Fortran::lower::prepareCustomIntrinsicArgument( procRef, *intrinsic, resultType, prepareOptionalArg, prepareOtherArg, converter); auto getArgument = [&](std::size_t i) -> ExtValue { if (fir::conformsWithPassByRef( fir::getBase(operands[i].first).getType())) return genLoad(operands[i].first); return operands[i].first; }; auto isPresent = [&](std::size_t i) -> llvm::Optional { return operands[i].second; }; return Fortran::lower::lowerCustomIntrinsic( builder, loc, name, resultType, isPresent, getArgument, operands.size(), stmtCtx); } const Fortran::lower::IntrinsicArgumentLoweringRules *argLowering = Fortran::lower::getIntrinsicArgumentLowering(name); for (const auto &arg : llvm::enumerate(procRef.arguments())) { auto *expr = Fortran::evaluate::UnwrapExpr(arg.value()); if (!expr) { // Absent optional. operands.emplace_back(Fortran::lower::getAbsentIntrinsicArgument()); continue; } if (!argLowering) { // No argument lowering instruction, lower by value. operands.emplace_back(genval(*expr)); continue; } // Ad-hoc argument lowering handling. Fortran::lower::ArgLoweringRule argRules = Fortran::lower::lowerIntrinsicArgumentAs(*argLowering, arg.index()); if (argRules.handleDynamicOptional && Fortran::evaluate::MayBePassedAsAbsentOptional( *expr, converter.getFoldingContext())) { ExtValue optional = lowerIntrinsicArgumentAsInquired(*expr); mlir::Value isPresent = genActualIsPresentTest(builder, loc, optional); switch (argRules.lowerAs) { case Fortran::lower::LowerIntrinsicArgAs::Value: operands.emplace_back( genOptionalValue(builder, loc, optional, isPresent)); continue; case Fortran::lower::LowerIntrinsicArgAs::Addr: operands.emplace_back( genOptionalAddr(builder, loc, optional, isPresent)); continue; case Fortran::lower::LowerIntrinsicArgAs::Box: operands.emplace_back( genOptionalBox(builder, loc, optional, isPresent)); continue; case Fortran::lower::LowerIntrinsicArgAs::Inquired: operands.emplace_back(optional); continue; } llvm_unreachable("bad switch"); } switch (argRules.lowerAs) { case Fortran::lower::LowerIntrinsicArgAs::Value: operands.emplace_back(genval(*expr)); continue; case Fortran::lower::LowerIntrinsicArgAs::Addr: operands.emplace_back(gen(*expr)); continue; case Fortran::lower::LowerIntrinsicArgAs::Box: operands.emplace_back(lowerIntrinsicArgumentAsBox(*expr)); continue; case Fortran::lower::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); } /// 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()) 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(); // 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()) 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; } /// Helper to package a Value and its properties into an ExtendedValue. static ExtValue toExtendedValue(mlir::Location loc, mlir::Value base, llvm::ArrayRef extents, llvm::ArrayRef lengths) { mlir::Type type = base.getType(); if (type.isa()) return fir::BoxValue(base, /*lbounds=*/{}, lengths, extents); type = fir::unwrapRefType(type); if (type.isa()) return fir::MutableBoxValue(base, lengths, /*mutableProperties*/ {}); if (auto seqTy = type.dyn_cast()) { if (seqTy.getDimension() != extents.size()) fir::emitFatalError(loc, "incorrect number of extents for array"); if (seqTy.getEleTy().isa()) { if (lengths.empty()) fir::emitFatalError(loc, "missing length for character"); assert(lengths.size() == 1); return fir::CharArrayBoxValue(base, lengths[0], extents); } return fir::ArrayBoxValue(base, extents); } if (type.isa()) { if (lengths.empty()) fir::emitFatalError(loc, "missing length for character"); assert(lengths.size() == 1); return fir::CharBoxValue(base, lengths[0]); } return base; } // Find the argument that corresponds to the host associations. // Verify some assumptions about how the signature was built here. [[maybe_unused]] static unsigned findHostAssocTuplePos(mlir::func::FuncOp fn) { // Scan the argument list from last to first as the host associations are // appended for now. for (unsigned i = fn.getNumArguments(); i > 0; --i) if (fn.getArgAttr(i - 1, fir::getHostAssocAttrName())) { // Host assoc tuple must be last argument (for now). assert(i == fn.getNumArguments() && "tuple must be last"); return i - 1; } llvm_unreachable("anyFuncArgsHaveAttr failed"); } /// 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 extents = fir::factory::getExtents(loc, builder, mold); llvm::SmallVector allocMemTypeParams = fir::getTypeParams(mold); mlir::Value charLen; mlir::Type elementType = fir::unwrapSequenceType(type); if (auto charType = elementType.dyn_cast()) { 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( loc, type, tempName, allocMemTypeParams, extents); if (fir::unwrapSequenceType(type).isa()) 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, llvm::Optional 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()) return fir::factory::genMutableBoxRead(builder, getLoc(), *box); return res; } /// Given a call site for which the arguments were already lowered, generate /// the call and return the result. This function deals with explicit result /// allocation and lowering if needed. It also deals with passing the host /// link to internal procedures. ExtValue genCallOpAndResult(Fortran::lower::CallerInterface &caller, mlir::FunctionType callSiteType, llvm::Optional resultType) { mlir::Location loc = getLoc(); using PassBy = Fortran::lower::CallerInterface::PassEntityBy; // Handle cases where caller must allocate the result or a fir.box for it. bool mustPopSymMap = false; if (caller.mustMapInterfaceSymbols()) { symMap.pushScope(); mustPopSymMap = true; Fortran::lower::mapCallInterfaceSymbols(converter, caller, symMap); } // If this is an indirect call, retrieve the function address. Also retrieve // the result length if this is a character function (note that this length // will be used only if there is no explicit length in the local interface). mlir::Value funcPointer; mlir::Value charFuncPointerLength; if (const Fortran::semantics::Symbol *sym = caller.getIfIndirectCallSymbol()) { funcPointer = symMap.lookupSymbol(*sym).getAddr(); if (!funcPointer) fir::emitFatalError(loc, "failed to find indirect call symbol address"); if (fir::isCharacterProcedureTuple(funcPointer.getType(), /*acceptRawFunc=*/false)) std::tie(funcPointer, charFuncPointerLength) = fir::factory::extractCharacterProcedureTuple(builder, loc, funcPointer); } mlir::IndexType idxTy = builder.getIndexType(); auto lowerSpecExpr = [&](const auto &expr) -> mlir::Value { return builder.createConvert( loc, idxTy, fir::getBase(converter.genExprValue(expr, stmtCtx))); }; llvm::SmallVector resultLengths; auto allocatedResult = [&]() -> llvm::Optional { llvm::SmallVector extents; llvm::SmallVector lengths; if (!caller.callerAllocateResult()) return {}; mlir::Type type = caller.getResultStorageType(); if (type.isa()) caller.walkResultExtents([&](const Fortran::lower::SomeExpr &e) { extents.emplace_back(lowerSpecExpr(e)); }); caller.walkResultLengths([&](const Fortran::lower::SomeExpr &e) { lengths.emplace_back(lowerSpecExpr(e)); }); // Result length parameters should not be provided to box storage // allocation and save_results, but they are still useful information to // keep in the ExtendedValue if non-deferred. if (!type.isa()) { if (fir::isa_char(fir::unwrapSequenceType(type)) && lengths.empty()) { // Calling an assumed length function. This is only possible if this // is a call to a character dummy procedure. if (!charFuncPointerLength) fir::emitFatalError(loc, "failed to retrieve character function " "length while calling it"); lengths.push_back(charFuncPointerLength); } resultLengths = lengths; } if (!extents.empty() || !lengths.empty()) { auto *bldr = &converter.getFirOpBuilder(); auto stackSaveFn = fir::factory::getLlvmStackSave(builder); auto stackSaveSymbol = bldr->getSymbolRefAttr(stackSaveFn.getName()); mlir::Value sp = bldr->create( loc, stackSaveFn.getFunctionType().getResults(), stackSaveSymbol, mlir::ValueRange{}) .getResult(0); stmtCtx.attachCleanup([bldr, loc, sp]() { auto stackRestoreFn = fir::factory::getLlvmStackRestore(*bldr); auto stackRestoreSymbol = bldr->getSymbolRefAttr(stackRestoreFn.getName()); bldr->create( loc, stackRestoreFn.getFunctionType().getResults(), stackRestoreSymbol, mlir::ValueRange{sp}); }); } mlir::Value temp = builder.createTemporary(loc, type, ".result", extents, resultLengths); return toExtendedValue(loc, temp, extents, lengths); }(); if (mustPopSymMap) symMap.popScope(); // Place allocated result or prepare the fir.save_result arguments. mlir::Value arrayResultShape; if (allocatedResult) { if (std::optional::PassedEntity> resultArg = caller.getPassedResult()) { if (resultArg->passBy == PassBy::AddressAndLength) caller.placeAddressAndLengthInput(*resultArg, fir::getBase(*allocatedResult), fir::getLen(*allocatedResult)); else if (resultArg->passBy == PassBy::BaseAddress) caller.placeInput(*resultArg, fir::getBase(*allocatedResult)); else fir::emitFatalError( loc, "only expect character scalar result to be passed by ref"); } else { assert(caller.mustSaveResult()); arrayResultShape = allocatedResult->match( [&](const fir::CharArrayBoxValue &) { return builder.createShape(loc, *allocatedResult); }, [&](const fir::ArrayBoxValue &) { return builder.createShape(loc, *allocatedResult); }, [&](const auto &) { return mlir::Value{}; }); } } // In older Fortran, procedure argument types are inferred. This may lead // different view of what the function signature is in different locations. // Casts are inserted as needed below to accommodate this. // The mlir::func::FuncOp type prevails, unless it has a different number of // arguments which can happen in legal program if it was passed as a dummy // procedure argument earlier with no further type information. mlir::SymbolRefAttr funcSymbolAttr; bool addHostAssociations = false; if (!funcPointer) { mlir::FunctionType funcOpType = caller.getFuncOp().getFunctionType(); mlir::SymbolRefAttr symbolAttr = builder.getSymbolRefAttr(caller.getMangledName()); if (callSiteType.getNumResults() == funcOpType.getNumResults() && callSiteType.getNumInputs() + 1 == funcOpType.getNumInputs() && fir::anyFuncArgsHaveAttr(caller.getFuncOp(), fir::getHostAssocAttrName())) { // The number of arguments is off by one, and we're lowering a function // with host associations. Modify call to include host associations // argument by appending the value at the end of the operands. assert(funcOpType.getInput(findHostAssocTuplePos(caller.getFuncOp())) == converter.hostAssocTupleValue().getType()); addHostAssociations = true; } if (!addHostAssociations && (callSiteType.getNumResults() != funcOpType.getNumResults() || callSiteType.getNumInputs() != funcOpType.getNumInputs())) { // Deal with argument number mismatch by making a function pointer so // that function type cast can be inserted. Do not emit a warning here // because this can happen in legal program if the function is not // defined here and it was first passed as an argument without any more // information. funcPointer = builder.create(loc, funcOpType, symbolAttr); } else if (callSiteType.getResults() != funcOpType.getResults()) { // Implicit interface result type mismatch are not standard Fortran, but // some compilers are not complaining about it. The front end is not // protecting lowering from this currently. Support this with a // discouraging warning. LLVM_DEBUG(mlir::emitWarning( loc, "a return type mismatch is not standard compliant and may " "lead to undefined behavior.")); // Cast the actual function to the current caller implicit type because // that is the behavior we would get if we could not see the definition. funcPointer = builder.create(loc, funcOpType, symbolAttr); } else { funcSymbolAttr = symbolAttr; } } mlir::FunctionType funcType = funcPointer ? callSiteType : caller.getFuncOp().getFunctionType(); llvm::SmallVector operands; // First operand of indirect call is the function pointer. Cast it to // required function type for the call to handle procedures that have a // compatible interface in Fortran, but that have different signatures in // FIR. if (funcPointer) { operands.push_back( funcPointer.getType().isa() ? builder.create(loc, funcType, funcPointer) : builder.createConvert(loc, funcType, funcPointer)); } // Deal with potential mismatches in arguments types. Passing an array to a // scalar argument should for instance be tolerated here. bool callingImplicitInterface = caller.canBeCalledViaImplicitInterface(); for (auto [fst, snd] : llvm::zip(caller.getInputs(), funcType.getInputs())) { // When passing arguments to a procedure that can be called an implicit // interface, allow character actual arguments to be passed to dummy // arguments of any type and vice versa mlir::Value cast; auto *context = builder.getContext(); if (snd.isa() && fst.getType().isa()) { auto funcTy = mlir::FunctionType::get(context, llvm::None, llvm::None); auto boxProcTy = builder.getBoxProcType(funcTy); if (mlir::Value host = argumentHostAssocs(converter, fst)) { cast = builder.create( loc, boxProcTy, llvm::ArrayRef{fst, host}); } else { cast = builder.create(loc, boxProcTy, fst); } } else { cast = builder.convertWithSemantics(loc, snd, fst, callingImplicitInterface); } operands.push_back(cast); } // Add host associations as necessary. if (addHostAssociations) operands.push_back(converter.hostAssocTupleValue()); auto call = builder.create(loc, funcType.getResults(), funcSymbolAttr, operands); if (caller.mustSaveResult()) builder.create( loc, call.getResult(0), fir::getBase(allocatedResult.getValue()), arrayResultShape, resultLengths); if (allocatedResult) { allocatedResult->match( [&](const fir::MutableBoxValue &box) { if (box.isAllocatable()) { // 9.7.3.2 point 4. Finalize allocatables. fir::FirOpBuilder *bldr = &converter.getFirOpBuilder(); stmtCtx.attachCleanup([bldr, loc, box]() { fir::factory::genFinalization(*bldr, loc, box); }); } }, [](const auto &) {}); return *allocatedResult; } if (!resultType) return mlir::Value{}; // subroutine call // For now, Fortran return values are implemented with a single MLIR // function return value. assert(call.getNumResults() == 1 && "Expected exactly one result in FUNCTION call"); return call.getResult(0); } /// 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(loc, value); mlir::Value temp = builder.createTemporary(loc, value.getType()); builder.create(loc, value, temp); return temp; }, [&](const fir::BoxValue &x) -> ExtValue { // Derived type scalar that may be polymorphic. 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(loc, var); mlir::Value temp = builder.createTemporary(loc, value.getType()); builder.create(loc, value, temp); return temp; }, [&](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. llvm::Optional restrictCopyAndFreeAtRuntime; }; using CopyOutPairs = llvm::SmallVector; /// 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()) 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 ©OutPairs, llvm::Optional restrictCopyAtRuntime, bool byValue) { const bool doCopyOut = !byValue && arg.mayBeModifiedByCall(); llvm::StringRef tempName = byValue ? ".copy" : ".copyinout"; if (!restrictCopyAtRuntime) { ExtValue temp = genArrayTempFromMold(actualArg, tempName); if (arg.mayBeReadByCall()) genArrayCopy(temp, actualArg); copyOutPairs.emplace_back( CopyOutPair{actualArg, temp, doCopyOut, restrictCopyAtRuntime}); return temp; } // Otherwise, need to be careful to only copy-in if allowed at runtime. mlir::Location loc = getLoc(); auto addrType = fir::HeapType::get( fir::unwrapPassByRefType(fir::getBase(actualArg).getType())); mlir::Value addr = builder .genIfOp(loc, {addrType}, *restrictCopyAtRuntime, /*withElseRegion=*/true) .genThen([&]() { auto temp = genArrayTempFromMold(actualArg, tempName); if (arg.mayBeReadByCall()) genArrayCopy(temp, actualArg); builder.create(loc, fir::getBase(temp)); }) .genElse([&]() { auto nullPtr = builder.createNullConstant(loc, addrType); builder.create(loc, nullPtr); }) .getResults()[0]; // Associate the temp address with actualArg lengths and extents. fir::ExtendedValue temp = fir::substBase(readIfBoxValue(actualArg), addr); 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 ©OutPair) { mlir::Location loc = getLoc(); if (!copyOutPair.restrictCopyAndFreeAtRuntime) { if (copyOutPair.argMayBeModifiedByCall) genArrayCopy(copyOutPair.var, copyOutPair.temp); builder.create(loc, fir::getBase(copyOutPair.temp)); return; } builder.genIfThen(loc, *copyOutPair.restrictCopyAndFreeAtRuntime) .genThen([&]() { if (copyOutPair.argMayBeModifiedByCall) genArrayCopy(copyOutPair.var, copyOutPair.temp); builder.create(loc, fir::getBase(copyOutPair.temp)); }) .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 prepareActualThatMayBeAbsent(const Fortran::lower::SomeExpr &expr) { mlir::Location loc = getLoc(); if (Fortran::evaluate::IsAllocatableOrPointerObject( expr, converter.getFoldingContext())) { // 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( loc, builder.getI1Type(), actualArgBase); if (!actualArgBase.getType().isa()) 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(loc, isPresent, len, zero); mlir::Value temp = builder.createTemporary( loc, type, /*name=*/{}, /*shape=*/{}, mlir::ValueRange{len}, llvm::ArrayRef{ Fortran::lower::getAdaptToByRefAttr(builder)}); return fir::CharBoxValue{temp, len}; } assert((fir::isa_trivial(type) || type.isa()) && "must be simple scalar"); return builder.createTemporary( loc, type, llvm::ArrayRef{ Fortran::lower::getAdaptToByRefAttr(builder)}); } template 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. ExtValue prepareActualToBaseAddressLike( const Fortran::lower::SomeExpr &expr, const Fortran::lower::CallerInterface::PassedEntity &arg, CopyOutPairs ©OutPairs, 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 = [&]() -> ExtValue { if (!actualArgIsVariable && !needsCopy) // Actual argument is not a variable. Make sure a variable address is // not passed. return genTempExtAddr(expr); ExtValue baseAddr; if (arg.isOptional() && Fortran::evaluate::MayBePassedAsAbsentOptional( expr, converter.getFoldingContext())) { auto [actualArgBind, isPresent] = prepareActualThatMayBeAbsent(expr); const ExtValue &actualArg = actualArgBind; if (!needsCopy) return actualArg; if (isArray) return genCopyIn(actualArg, arg, copyOutPairs, isPresent, byValue); // 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(loc, fir::getBase(temp)); }) .genElse([&]() { mlir::Value absent = builder.create(loc, tempAddrTy); builder.create(loc, absent); }) .getResults()[0]; return fir::substBase(temp, selectAddr); } // 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=*/llvm::None, byValue); // Contiguous: just use the box we created above! // This gets "unboxed" below, if needed. return box; } // Actual argument is a non-optional, non-pointer, non-allocatable // scalar. ExtValue actualArg = genExtAddr(expr); if (needsCopy) return createInMemoryScalarCopy(builder, loc, actualArg); return actualArg; }(); // 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); } /// Lower a non-elemental procedure reference. ExtValue genRawProcedureRef(const Fortran::evaluate::ProcedureRef &procRef, llvm::Optional resultType) { mlir::Location loc = getLoc(); if (isElementalProcWithArrayArgs(procRef)) fir::emitFatalError(loc, "trying to lower elemental procedure with array " "arguments as normal procedure"); if (const Fortran::evaluate::SpecificIntrinsic *intrinsic = procRef.proc().GetSpecificIntrinsic()) return genIntrinsicRef(procRef, resultType, *intrinsic); if (isIntrinsicModuleProcRef(procRef)) return genIntrinsicRef(procRef, resultType); if (isStatementFunctionCall(procRef)) return genStmtFunctionRef(procRef); Fortran::lower::CallerInterface caller(procRef, converter); using PassBy = Fortran::lower::CallerInterface::PassEntityBy; llvm::SmallVector mutableModifiedByCall; // List of where temp must be copied into var after the call. CopyOutPairs copyOutPairs; mlir::FunctionType callSiteType = caller.genFunctionType(); // Lower the actual arguments and map the lowered values to the dummy // arguments. for (const Fortran::lower::CallInterface< Fortran::lower::CallerInterface>::PassedEntity &arg : caller.getPassedArguments()) { const auto *actual = arg.entity; mlir::Type argTy = callSiteType.getInput(arg.firArgument); if (!actual) { // Optional dummy argument for which there is no actual argument. caller.placeInput(arg, builder.create(loc, argTy)); continue; } const auto *expr = actual->UnwrapExpr(); if (!expr) TODO(loc, "assumed type actual argument lowering"); if (arg.passBy == PassBy::Value) { ExtValue argVal = genval(*expr); if (!fir::isUnboxedValue(argVal)) fir::emitFatalError( loc, "internal error: passing non trivial value by value"); caller.placeInput(arg, fir::getBase(argVal)); continue; } if (arg.passBy == PassBy::MutableBox) { if (Fortran::evaluate::UnwrapExpr( *expr)) { // If expr is NULL(), the mutableBox created must be a deallocated // pointer with the dummy argument characteristics (see table 16.5 // in Fortran 2018 standard). // No length parameters are set for the created box because any non // deferred type parameters of the dummy will be evaluated on the // callee side, and it is illegal to use NULL without a MOLD if any // dummy length parameters are assumed. mlir::Type boxTy = fir::dyn_cast_ptrEleTy(argTy); assert(boxTy && boxTy.isa() && "must be a fir.box type"); mlir::Value boxStorage = builder.createTemporary(loc, boxTy); mlir::Value nullBox = fir::factory::createUnallocatedBox( builder, loc, boxTy, /*nonDeferredParams=*/{}); builder.create(loc, nullBox, boxStorage); caller.placeInput(arg, boxStorage); continue; } if (fir::isPointerType(argTy) && !Fortran::evaluate::IsObjectPointer( *expr, converter.getFoldingContext())) { // Passing a non POINTER actual argument to a POINTER dummy argument. // Create a pointer of the dummy argument type and assign the actual // argument to it. mlir::Value irBox = builder.createTemporary(loc, fir::unwrapRefType(argTy)); // Non deferred parameters will be evaluated on the callee side. fir::MutableBoxValue pointer(irBox, /*nonDeferredParams=*/mlir::ValueRange{}, /*mutableProperties=*/{}); Fortran::lower::associateMutableBox(converter, loc, pointer, *expr, /*lbounds=*/llvm::None, stmtCtx); caller.placeInput(arg, irBox); continue; } // Passing a POINTER to a POINTER, or an ALLOCATABLE to an ALLOCATABLE. fir::MutableBoxValue mutableBox = genMutableBoxValue(*expr); mlir::Value irBox = fir::factory::getMutableIRBox(builder, loc, mutableBox); caller.placeInput(arg, irBox); if (arg.mayBeModifiedByCall()) mutableModifiedByCall.emplace_back(std::move(mutableBox)); continue; } if (arg.passBy == PassBy::BaseAddress || arg.passBy == PassBy::BoxChar || arg.passBy == PassBy::BaseAddressValueAttribute || arg.passBy == PassBy::CharBoxValueAttribute) { const bool byValue = arg.passBy == PassBy::BaseAddressValueAttribute || arg.passBy == PassBy::CharBoxValueAttribute; ExtValue argAddr = prepareActualToBaseAddressLike(*expr, arg, copyOutPairs, byValue); if (arg.passBy == PassBy::BaseAddress || arg.passBy == PassBy::BaseAddressValueAttribute) { caller.placeInput(arg, fir::getBase(argAddr)); } else { assert(arg.passBy == PassBy::BoxChar || arg.passBy == PassBy::CharBoxValueAttribute); auto helper = fir::factory::CharacterExprHelper{builder, loc}; auto boxChar = argAddr.match( [&](const fir::CharBoxValue &x) { return helper.createEmbox(x); }, [&](const fir::CharArrayBoxValue &x) { return helper.createEmbox(x); }, [&](const auto &x) -> mlir::Value { // Fortran allows an actual argument of a completely different // type to be passed to a procedure expecting a CHARACTER in the // dummy argument position. When this happens, the data pointer // argument is simply assumed to point to CHARACTER data and the // LEN argument used is garbage. Simulate this behavior by // free-casting the base address to be a !fir.char reference and // setting the LEN argument to undefined. What could go wrong? auto dataPtr = fir::getBase(x); assert(!dataPtr.getType().template isa()); return builder.convertWithSemantics( loc, argTy, dataPtr, /*allowCharacterConversion=*/true); }); caller.placeInput(arg, boxChar); } } else if (arg.passBy == PassBy::Box) { // Before lowering to an address, handle the allocatable/pointer actual // argument to optional fir.box dummy. It is legal to pass // unallocated/disassociated entity to an optional. In this case, an // absent fir.box must be created instead of a fir.box with a null value // (Fortran 2018 15.5.2.12 point 1). if (arg.isOptional() && Fortran::evaluate::IsAllocatableOrPointerObject( *expr, converter.getFoldingContext())) { // Note that passing an absent allocatable to a non-allocatable // optional dummy argument is illegal (15.5.2.12 point 3 (8)). So // nothing has to be done to generate an absent argument in this case, // and it is OK to unconditionally read the mutable box here. fir::MutableBoxValue mutableBox = genMutableBoxValue(*expr); mlir::Value isAllocated = fir::factory::genIsAllocatedOrAssociatedTest(builder, loc, mutableBox); auto absent = builder.create(loc, argTy); /// For now, assume it is not OK to pass the allocatable/pointer /// descriptor to a non pointer/allocatable dummy. That is a strict /// interpretation of 18.3.6 point 4 that stipulates the descriptor /// has the dummy attributes in BIND(C) contexts. mlir::Value box = builder.createBox( loc, fir::factory::genMutableBoxRead(builder, loc, mutableBox)); // Need the box types to be exactly similar for the selectOp. mlir::Value convertedBox = builder.createConvert(loc, argTy, box); caller.placeInput(arg, builder.create( loc, isAllocated, convertedBox, absent)); } else { // Make sure a variable address is only passed if the expression is // actually a variable. mlir::Value box = Fortran::evaluate::IsVariable(*expr) ? builder.createBox(loc, genBoxArg(*expr)) : builder.createBox(getLoc(), genTempExtAddr(*expr)); caller.placeInput(arg, box); } } else if (arg.passBy == PassBy::AddressAndLength) { ExtValue argRef = genExtAddr(*expr); caller.placeAddressAndLengthInput(arg, fir::getBase(argRef), fir::getLen(argRef)); } else if (arg.passBy == PassBy::CharProcTuple) { ExtValue argRef = genExtAddr(*expr); mlir::Value tuple = createBoxProcCharTuple( converter, argTy, fir::getBase(argRef), fir::getLen(argRef)); caller.placeInput(arg, tuple); } else { TODO(loc, "pass by value in non elemental function call"); } } ExtValue result = genCallOpAndResult(caller, callSiteType, resultType); // Sync pointers and allocatables that may have been modified during the // call. for (const auto &mutableBox : mutableModifiedByCall) fir::factory::syncMutableBoxFromIRBox(builder, loc, mutableBox); // Handle case where result was passed as argument // Copy-out temps that were created for non contiguous variable arguments if // needed. for (const auto ©OutPair : copyOutPairs) genCopyOut(copyOutPair); return result; } template ExtValue genval(const Fortran::evaluate::FunctionRef &funcRef) { ExtValue result = genFunctionRef(funcRef); if (result.rank() == 0 && fir::isa_ref_type(fir::getBase(result).getType())) return genLoad(result); return result; } ExtValue genval(const Fortran::evaluate::ProcedureRef &procRef) { llvm::Optional resTy; if (procRef.hasAlternateReturns()) resTy = builder.getIndexType(); return genProcedureRef(procRef, resTy); } template bool isScalar(const A &x) { return x.Rank() == 0; } /// Helper to detect Transformational function reference. template bool isTransformationalRef(const T &) { return false; } template bool isTransformationalRef(const Fortran::evaluate::FunctionRef &funcRef) { return !funcRef.IsElemental() && funcRef.Rank(); } template bool isTransformationalRef(Fortran::evaluate::Expr expr) { return std::visit([&](const auto &e) { return isTransformationalRef(e); }, expr.u); } template ExtValue asArray(const A &x) { return Fortran::lower::createSomeArrayTempValue(converter, toEvExpr(x), symMap, stmtCtx); } /// Lower an array value as an argument. This argument can be passed as a box /// value, so it may be possible to avoid making a temporary. template ExtValue asArrayArg(const Fortran::evaluate::Expr &x) { return std::visit([&](const auto &e) { return asArrayArg(e, x); }, x.u); } template ExtValue asArrayArg(const Fortran::evaluate::Expr &x, const B &y) { return std::visit([&](const auto &e) { return asArrayArg(e, y); }, x.u); } template ExtValue asArrayArg(const Fortran::evaluate::Designator &, const B &x) { // Designator is being passed as an argument to a procedure. Lower the // expression to a boxed value. auto someExpr = toEvExpr(x); return Fortran::lower::createBoxValue(getLoc(), converter, someExpr, symMap, stmtCtx); } template ExtValue asArrayArg(const A &, const B &x) { // If the expression to pass as an argument is not a designator, then create // an array temp. return asArray(x); } template ExtValue gen(const Fortran::evaluate::Expr &x) { // Whole array symbols or components, and results of transformational // functions already have a storage and the scalar expression lowering path // is used to not create a new temporary storage. if (isScalar(x) || Fortran::evaluate::UnwrapWholeSymbolOrComponentDataRef(x) || isTransformationalRef(x)) return std::visit([&](const auto &e) { return genref(e); }, x.u); if (useBoxArg) return asArrayArg(x); return asArray(x); } template ExtValue genval(const Fortran::evaluate::Expr &x) { if (isScalar(x) || Fortran::evaluate::UnwrapWholeSymbolDataRef(x) || inInitializer) return std::visit([&](const auto &e) { return genval(e); }, x.u); return asArray(x); } template ExtValue genval(const Fortran::evaluate::Expr> &exp) { return std::visit([&](const auto &e) { return genval(e); }, exp.u); } using RefSet = std::tuple; template static constexpr bool inRefSet = Fortran::common::HasMember; template >> ExtValue genref(const A &a) { return gen(a); } template ExtValue genref(const A &a) { if (inInitializer) { // Initialization expressions can never allocate memory. return genval(a); } mlir::Type storageType = converter.genType(toEvExpr(a)); return placeScalarValueInMemory(builder, getLoc(), genval(a), storageType); } template typename T, typename B = std::decay_t>, std::enable_if_t< std::is_same_v> || std::is_same_v> || std::is_same_v>, bool> = true> ExtValue genref(const T &x) { return gen(x); } private: mlir::Location location; Fortran::lower::AbstractConverter &converter; fir::FirOpBuilder &builder; Fortran::lower::StatementContext &stmtCtx; Fortran::lower::SymMap &symMap; InitializerData *inInitializer = nullptr; bool useBoxArg = false; // expression lowered as argument }; } // namespace // Helper for changing the semantics in a given context. Preserves the current // semantics which is resumed when the "push" goes out of scope. #define PushSemantics(PushVal) \ [[maybe_unused]] auto pushSemanticsLocalVariable##__LINE__ = \ Fortran::common::ScopedSet(semant, PushVal); static bool isAdjustedArrayElementType(mlir::Type t) { return fir::isa_char(t) || fir::isa_derived(t) || t.isa(); } static bool elementTypeWasAdjusted(mlir::Type t) { if (auto ty = t.dyn_cast()) return isAdjustedArrayElementType(ty.getEleTy()); return false; } static mlir::Type adjustedArrayElementType(mlir::Type t) { return isAdjustedArrayElementType(t) ? fir::ReferenceType::get(t) : t; } /// Helper to generate calls to scalar user defined assignment procedures. static void genScalarUserDefinedAssignmentCall(fir::FirOpBuilder &builder, mlir::Location loc, mlir::func::FuncOp func, const fir::ExtendedValue &lhs, const fir::ExtendedValue &rhs) { auto prepareUserDefinedArg = [](fir::FirOpBuilder &builder, mlir::Location loc, const fir::ExtendedValue &value, mlir::Type argType) -> mlir::Value { if (argType.isa()) { const fir::CharBoxValue *charBox = value.getCharBox(); assert(charBox && "argument type mismatch in elemental user assignment"); return fir::factory::CharacterExprHelper{builder, loc}.createEmbox( *charBox); } if (argType.isa()) { mlir::Value box = builder.createBox(loc, value); return builder.createConvert(loc, argType, box); } // Simple pass by address. mlir::Type argBaseType = fir::unwrapRefType(argType); assert(!fir::hasDynamicSize(argBaseType)); mlir::Value from = fir::getBase(value); if (argBaseType != fir::unwrapRefType(from.getType())) { // With logicals, it is possible that from is i1 here. if (fir::isa_ref_type(from.getType())) from = builder.create(loc, from); from = builder.createConvert(loc, argBaseType, from); } if (!fir::isa_ref_type(from.getType())) { mlir::Value temp = builder.createTemporary(loc, argBaseType); builder.create(loc, from, temp); from = temp; } return builder.createConvert(loc, argType, from); }; assert(func.getNumArguments() == 2); mlir::Type lhsType = func.getFunctionType().getInput(0); mlir::Type rhsType = func.getFunctionType().getInput(1); mlir::Value lhsArg = prepareUserDefinedArg(builder, loc, lhs, lhsType); mlir::Value rhsArg = prepareUserDefinedArg(builder, loc, rhs, rhsType); builder.create(loc, func, mlir::ValueRange{lhsArg, rhsArg}); } /// Convert the result of a fir.array_modify to an ExtendedValue given the /// related fir.array_load. static fir::ExtendedValue arrayModifyToExv(fir::FirOpBuilder &builder, mlir::Location loc, fir::ArrayLoadOp load, mlir::Value elementAddr) { mlir::Type eleTy = fir::unwrapPassByRefType(elementAddr.getType()); if (fir::isa_char(eleTy)) { auto 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{elementAddr, len}; } return elementAddr; } //===----------------------------------------------------------------------===// // // Lowering of scalar expressions in an explicit iteration space context. // //===----------------------------------------------------------------------===// // Shared code for creating a copy of a derived type element. This function is // called from a continuation. inline static fir::ArrayAmendOp createDerivedArrayAmend(mlir::Location loc, fir::ArrayLoadOp destLoad, fir::FirOpBuilder &builder, fir::ArrayAccessOp destAcc, const fir::ExtendedValue &elementExv, mlir::Type eleTy, mlir::Value innerArg) { if (destLoad.getTypeparams().empty()) { fir::factory::genRecordAssignment(builder, loc, destAcc, elementExv); } else { auto boxTy = fir::BoxType::get(eleTy); auto toBox = builder.create(loc, boxTy, destAcc.getResult(), mlir::Value{}, mlir::Value{}, destLoad.getTypeparams()); auto fromBox = builder.create( loc, boxTy, fir::getBase(elementExv), mlir::Value{}, mlir::Value{}, destLoad.getTypeparams()); fir::factory::genRecordAssignment(builder, loc, fir::BoxValue(toBox), fir::BoxValue(fromBox)); } return builder.create(loc, innerArg.getType(), innerArg, destAcc); } inline static fir::ArrayAmendOp createCharArrayAmend(mlir::Location loc, fir::FirOpBuilder &builder, fir::ArrayAccessOp dstOp, mlir::Value &dstLen, const fir::ExtendedValue &srcExv, mlir::Value innerArg, llvm::ArrayRef bounds) { fir::CharBoxValue dstChar(dstOp, dstLen); fir::factory::CharacterExprHelper helper{builder, loc}; if (!bounds.empty()) { dstChar = helper.createSubstring(dstChar, bounds); fir::factory::genCharacterCopy(fir::getBase(srcExv), fir::getLen(srcExv), dstChar.getAddr(), dstChar.getLen(), builder, loc); // Update the LEN to the substring's LEN. dstLen = dstChar.getLen(); } // For a CHARACTER, we generate the element assignment loops inline. helper.createAssign(fir::ExtendedValue{dstChar}, srcExv); // Mark this array element as amended. mlir::Type ty = innerArg.getType(); auto amend = builder.create(loc, ty, innerArg, dstOp); return amend; } /// Build an ExtendedValue from a fir.array without actually setting /// the actual extents and lengths. This is only to allow their propagation as /// ExtendedValue without triggering verifier failures when propagating /// character/arrays as unboxed values. Only the base of the resulting /// ExtendedValue should be used, it is undefined to use the length or extents /// of the extended value returned, inline static fir::ExtendedValue convertToArrayBoxValue(mlir::Location loc, fir::FirOpBuilder &builder, mlir::Value val, mlir::Value len) { mlir::Type ty = fir::unwrapRefType(val.getType()); mlir::IndexType idxTy = builder.getIndexType(); auto seqTy = ty.cast(); auto undef = builder.create(loc, idxTy); llvm::SmallVector extents(seqTy.getDimension(), undef); if (fir::isa_char(seqTy.getEleTy())) return fir::CharArrayBoxValue(val, len ? len : undef, extents); return fir::ArrayBoxValue(val, extents); } //===----------------------------------------------------------------------===// // // Lowering of array expressions. // //===----------------------------------------------------------------------===// namespace { class ArrayExprLowering { using ExtValue = fir::ExtendedValue; /// Structure to keep track of lowered array operands in the /// array expression. Useful to later deduce the shape of the /// array expression. struct ArrayOperand { /// Array base (can be a fir.box). mlir::Value memref; /// ShapeOp, ShapeShiftOp or ShiftOp mlir::Value shape; /// SliceOp mlir::Value slice; /// Can this operand be absent ? bool mayBeAbsent = false; }; using ImplicitSubscripts = Fortran::lower::details::ImplicitSubscripts; using PathComponent = Fortran::lower::PathComponent; /// Active iteration space. using IterationSpace = Fortran::lower::IterationSpace; using IterSpace = const Fortran::lower::IterationSpace &; /// Current continuation. Function that will generate IR for a single /// iteration of the pending iterative loop structure. using CC = Fortran::lower::GenerateElementalArrayFunc; /// Projection continuation. Function that will project one iteration space /// into another. using PC = std::function; using ArrayBaseTy = std::variant; using ComponentPath = Fortran::lower::ComponentPath; public: //===--------------------------------------------------------------------===// // Regular array assignment //===--------------------------------------------------------------------===// /// Entry point for array assignments. Both the left-hand and right-hand sides /// can either be ExtendedValue or evaluate::Expr. template static void lowerArrayAssignment(Fortran::lower::AbstractConverter &converter, Fortran::lower::SymMap &symMap, Fortran::lower::StatementContext &stmtCtx, const TL &lhs, const TR &rhs) { ArrayExprLowering ael(converter, stmtCtx, symMap, ConstituentSemantics::CopyInCopyOut); ael.lowerArrayAssignment(lhs, rhs); } template void lowerArrayAssignment(const TL &lhs, const TR &rhs) { mlir::Location loc = getLoc(); /// Here the target subspace is not necessarily contiguous. The ArrayUpdate /// continuation is implicitly returned in `ccStoreToDest` and the ArrayLoad /// in `destination`. PushSemantics(ConstituentSemantics::ProjectedCopyInCopyOut); ccStoreToDest = genarr(lhs); determineShapeOfDest(lhs); semant = ConstituentSemantics::RefTransparent; ExtValue exv = lowerArrayExpression(rhs); if (explicitSpaceIsActive()) { explicitSpace->finalizeContext(); builder.create(loc, fir::getBase(exv)); } else { builder.create( loc, destination, fir::getBase(exv), destination.getMemref(), destination.getSlice(), destination.getTypeparams()); } } //===--------------------------------------------------------------------===// // WHERE array assignment, FORALL assignment, and FORALL+WHERE array // assignment //===--------------------------------------------------------------------===// /// Entry point for array assignment when the iteration space is explicitly /// defined (Fortran's FORALL) with or without masks, and/or the implied /// iteration space involves masks (Fortran's WHERE). Both contexts (explicit /// space and implicit space with masks) may be present. static void lowerAnyMaskedArrayAssignment( Fortran::lower::AbstractConverter &converter, Fortran::lower::SymMap &symMap, Fortran::lower::StatementContext &stmtCtx, const Fortran::lower::SomeExpr &lhs, const Fortran::lower::SomeExpr &rhs, Fortran::lower::ExplicitIterSpace &explicitSpace, Fortran::lower::ImplicitIterSpace &implicitSpace) { if (explicitSpace.isActive() && lhs.Rank() == 0) { // Scalar assignment expression in a FORALL context. ArrayExprLowering ael(converter, stmtCtx, symMap, ConstituentSemantics::RefTransparent, &explicitSpace, &implicitSpace); ael.lowerScalarAssignment(lhs, rhs); return; } // Array assignment expression in a FORALL and/or WHERE context. ArrayExprLowering ael(converter, stmtCtx, symMap, ConstituentSemantics::CopyInCopyOut, &explicitSpace, &implicitSpace); ael.lowerArrayAssignment(lhs, rhs); } //===--------------------------------------------------------------------===// // Array assignment to array of pointer box values. //===--------------------------------------------------------------------===// /// Entry point for assignment to pointer in an array of pointers. static void lowerArrayOfPointerAssignment( Fortran::lower::AbstractConverter &converter, Fortran::lower::SymMap &symMap, Fortran::lower::StatementContext &stmtCtx, const Fortran::lower::SomeExpr &lhs, const Fortran::lower::SomeExpr &rhs, Fortran::lower::ExplicitIterSpace &explicitSpace, Fortran::lower::ImplicitIterSpace &implicitSpace, const llvm::SmallVector &lbounds, llvm::Optional> ubounds) { ArrayExprLowering ael(converter, stmtCtx, symMap, ConstituentSemantics::CopyInCopyOut, &explicitSpace, &implicitSpace); ael.lowerArrayOfPointerAssignment(lhs, rhs, lbounds, ubounds); } /// Scalar pointer assignment in an explicit iteration space. /// /// Pointers may be bound to targets in a FORALL context. This is a scalar /// assignment in the sense there is never an implied iteration space, even if /// the pointer is to a target with non-zero rank. Since the pointer /// assignment must appear in a FORALL construct, correctness may require that /// the array of pointers follow copy-in/copy-out semantics. The pointer /// assignment may include a bounds-spec (lower bounds), a bounds-remapping /// (lower and upper bounds), or neither. void lowerArrayOfPointerAssignment( const Fortran::lower::SomeExpr &lhs, const Fortran::lower::SomeExpr &rhs, const llvm::SmallVector &lbounds, llvm::Optional> ubounds) { setPointerAssignmentBounds(lbounds, ubounds); if (rhs.Rank() == 0 || (Fortran::evaluate::UnwrapWholeSymbolOrComponentDataRef(rhs) && Fortran::evaluate::IsAllocatableOrPointerObject( rhs, converter.getFoldingContext()))) { lowerScalarAssignment(lhs, rhs); return; } TODO(getLoc(), "auto boxing of a ranked expression on RHS for pointer assignment"); } //===--------------------------------------------------------------------===// // Array assignment to allocatable array //===--------------------------------------------------------------------===// /// Entry point for assignment to allocatable array. static void lowerAllocatableArrayAssignment( Fortran::lower::AbstractConverter &converter, Fortran::lower::SymMap &symMap, Fortran::lower::StatementContext &stmtCtx, const Fortran::lower::SomeExpr &lhs, const Fortran::lower::SomeExpr &rhs, Fortran::lower::ExplicitIterSpace &explicitSpace, Fortran::lower::ImplicitIterSpace &implicitSpace) { ArrayExprLowering ael(converter, stmtCtx, symMap, ConstituentSemantics::CopyInCopyOut, &explicitSpace, &implicitSpace); ael.lowerAllocatableArrayAssignment(lhs, rhs); } /// Assignment to allocatable array. /// /// The semantics are reverse that of a "regular" array assignment. The rhs /// defines the iteration space of the computation and the lhs is /// resized/reallocated to fit if necessary. void lowerAllocatableArrayAssignment(const Fortran::lower::SomeExpr &lhs, const Fortran::lower::SomeExpr &rhs) { // With assignment to allocatable, we want to lower the rhs first and use // its shape to determine if we need to reallocate, etc. mlir::Location loc = getLoc(); // FIXME: If the lhs is in an explicit iteration space, the assignment may // be to an array of allocatable arrays rather than a single allocatable // array. fir::MutableBoxValue mutableBox = Fortran::lower::createMutableBox(loc, converter, lhs, symMap); mlir::Type resultTy = converter.genType(rhs); if (rhs.Rank() > 0) determineShapeOfDest(rhs); auto rhsCC = [&]() { PushSemantics(ConstituentSemantics::RefTransparent); return genarr(rhs); }(); llvm::SmallVector lengthParams; // Currently no safe way to gather length from rhs (at least for // character, it cannot be taken from array_loads since it may be // changed by concatenations). if ((mutableBox.isCharacter() && !mutableBox.hasNonDeferredLenParams()) || mutableBox.isDerivedWithLenParameters()) TODO(loc, "gather rhs length parameters in assignment to allocatable"); // The allocatable must take lower bounds from the expr if it is // reallocated and the right hand side is not a scalar. const bool takeLboundsIfRealloc = rhs.Rank() > 0; llvm::SmallVector lbounds; // When the reallocated LHS takes its lower bounds from the RHS, // they will be non default only if the RHS is a whole array // variable. Otherwise, lbounds is left empty and default lower bounds // will be used. if (takeLboundsIfRealloc && Fortran::evaluate::UnwrapWholeSymbolOrComponentDataRef(rhs)) { assert(arrayOperands.size() == 1 && "lbounds can only come from one array"); auto lbs = fir::factory::getOrigins(arrayOperands[0].shape); lbounds.append(lbs.begin(), lbs.end()); } fir::factory::MutableBoxReallocation realloc = fir::factory::genReallocIfNeeded(builder, loc, mutableBox, destShape, lengthParams); // Create ArrayLoad for the mutable box and save it into `destination`. PushSemantics(ConstituentSemantics::ProjectedCopyInCopyOut); ccStoreToDest = genarr(realloc.newValue); // If the rhs is scalar, get shape from the allocatable ArrayLoad. if (destShape.empty()) destShape = getShape(destination); // Finish lowering the loop nest. assert(destination && "destination must have been set"); ExtValue exv = lowerArrayExpression(rhsCC, resultTy); if (explicitSpaceIsActive()) { explicitSpace->finalizeContext(); builder.create(loc, fir::getBase(exv)); } else { builder.create( loc, destination, fir::getBase(exv), destination.getMemref(), destination.getSlice(), destination.getTypeparams()); } fir::factory::finalizeRealloc(builder, loc, mutableBox, lbounds, takeLboundsIfRealloc, realloc); } /// Entry point for when an array expression appears in a context where the /// result must be boxed. (BoxValue semantics.) static ExtValue lowerBoxedArrayExpression(Fortran::lower::AbstractConverter &converter, Fortran::lower::SymMap &symMap, Fortran::lower::StatementContext &stmtCtx, const Fortran::lower::SomeExpr &expr) { ArrayExprLowering ael{converter, stmtCtx, symMap, ConstituentSemantics::BoxValue}; return ael.lowerBoxedArrayExpr(expr); } ExtValue lowerBoxedArrayExpr(const Fortran::lower::SomeExpr &exp) { PushSemantics(ConstituentSemantics::BoxValue); return std::visit( [&](const auto &e) { auto f = genarr(e); ExtValue exv = f(IterationSpace{}); if (fir::getBase(exv).getType().template isa()) return exv; fir::emitFatalError(getLoc(), "array must be emboxed"); }, exp.u); } /// Entry point into lowering an expression with rank. This entry point is for /// lowering a rhs expression, for example. (RefTransparent semantics.) static ExtValue lowerNewArrayExpression(Fortran::lower::AbstractConverter &converter, Fortran::lower::SymMap &symMap, Fortran::lower::StatementContext &stmtCtx, const Fortran::lower::SomeExpr &expr) { ArrayExprLowering ael{converter, stmtCtx, symMap}; ael.determineShapeOfDest(expr); ExtValue loopRes = ael.lowerArrayExpression(expr); fir::ArrayLoadOp dest = ael.destination; mlir::Value tempRes = dest.getMemref(); fir::FirOpBuilder &builder = converter.getFirOpBuilder(); mlir::Location loc = converter.getCurrentLocation(); builder.create(loc, dest, fir::getBase(loopRes), tempRes, dest.getSlice(), dest.getTypeparams()); auto arrTy = fir::dyn_cast_ptrEleTy(tempRes.getType()).cast(); if (auto charTy = arrTy.getEleTy().template dyn_cast()) { if (fir::characterWithDynamicLen(charTy)) TODO(loc, "CHARACTER does not have constant LEN"); mlir::Value len = builder.createIntegerConstant( loc, builder.getCharacterLengthType(), charTy.getLen()); return fir::CharArrayBoxValue(tempRes, len, dest.getExtents()); } return fir::ArrayBoxValue(tempRes, dest.getExtents()); } static void lowerLazyArrayExpression( Fortran::lower::AbstractConverter &converter, Fortran::lower::SymMap &symMap, Fortran::lower::StatementContext &stmtCtx, const Fortran::lower::SomeExpr &expr, mlir::Value raggedHeader) { ArrayExprLowering ael(converter, stmtCtx, symMap); ael.lowerLazyArrayExpression(expr, raggedHeader); } /// Lower the expression \p expr into a buffer that is created on demand. The /// variable containing the pointer to the buffer is \p var and the variable /// containing the shape of the buffer is \p shapeBuffer. void lowerLazyArrayExpression(const Fortran::lower::SomeExpr &expr, mlir::Value header) { mlir::Location loc = getLoc(); mlir::TupleType hdrTy = fir::factory::getRaggedArrayHeaderType(builder); mlir::IntegerType i32Ty = builder.getIntegerType(32); // Once the loop extents have been computed, which may require being inside // some explicit loops, lazily allocate the expression on the heap. The // following continuation creates the buffer as needed. ccPrelude = [=](llvm::ArrayRef shape) { mlir::IntegerType i64Ty = builder.getIntegerType(64); mlir::Value byteSize = builder.createIntegerConstant(loc, i64Ty, 1); fir::runtime::genRaggedArrayAllocate( loc, builder, header, /*asHeaders=*/false, byteSize, shape); }; // Create a dummy array_load before the loop. We're storing to a lazy // temporary, so there will be no conflict and no copy-in. TODO: skip this // as there isn't any necessity for it. ccLoadDest = [=](llvm::ArrayRef shape) -> fir::ArrayLoadOp { mlir::Value one = builder.createIntegerConstant(loc, i32Ty, 1); auto var = builder.create( loc, builder.getRefType(hdrTy.getType(1)), header, one); auto load = builder.create(loc, var); mlir::Type eleTy = fir::unwrapSequenceType(fir::unwrapRefType(load.getType())); auto seqTy = fir::SequenceType::get(eleTy, shape.size()); mlir::Value castTo = builder.createConvert(loc, fir::HeapType::get(seqTy), load); mlir::Value shapeOp = builder.genShape(loc, shape); return builder.create( loc, seqTy, castTo, shapeOp, /*slice=*/mlir::Value{}, llvm::None); }; // Custom lowering of the element store to deal with the extra indirection // to the lazy allocated buffer. ccStoreToDest = [=](IterSpace iters) { mlir::Value one = builder.createIntegerConstant(loc, i32Ty, 1); auto var = builder.create( loc, builder.getRefType(hdrTy.getType(1)), header, one); auto load = builder.create(loc, var); mlir::Type eleTy = fir::unwrapSequenceType(fir::unwrapRefType(load.getType())); auto seqTy = fir::SequenceType::get(eleTy, iters.iterVec().size()); auto toTy = fir::HeapType::get(seqTy); mlir::Value castTo = builder.createConvert(loc, toTy, load); mlir::Value shape = builder.genShape(loc, genIterationShape()); llvm::SmallVector indices = fir::factory::originateIndices( loc, builder, castTo.getType(), shape, iters.iterVec()); auto eleAddr = builder.create( loc, builder.getRefType(eleTy), castTo, shape, /*slice=*/mlir::Value{}, indices, destination.getTypeparams()); mlir::Value eleVal = builder.createConvert(loc, eleTy, iters.getElement()); builder.create(loc, eleVal, eleAddr); return iters.innerArgument(); }; // Lower the array expression now. Clean-up any temps that may have // been generated when lowering `expr` right after the lowered value // was stored to the ragged array temporary. The local temps will not // be needed afterwards. stmtCtx.pushScope(); [[maybe_unused]] ExtValue loopRes = lowerArrayExpression(expr); stmtCtx.finalize(/*popScope=*/true); assert(fir::getBase(loopRes)); } static void lowerElementalUserAssignment(Fortran::lower::AbstractConverter &converter, Fortran::lower::SymMap &symMap, Fortran::lower::StatementContext &stmtCtx, Fortran::lower::ExplicitIterSpace &explicitSpace, Fortran::lower::ImplicitIterSpace &implicitSpace, const Fortran::evaluate::ProcedureRef &procRef) { ArrayExprLowering ael(converter, stmtCtx, symMap, ConstituentSemantics::CustomCopyInCopyOut, &explicitSpace, &implicitSpace); assert(procRef.arguments().size() == 2); const auto *lhs = procRef.arguments()[0].value().UnwrapExpr(); const auto *rhs = procRef.arguments()[1].value().UnwrapExpr(); assert(lhs && rhs && "user defined assignment arguments must be expressions"); mlir::func::FuncOp func = Fortran::lower::CallerInterface(procRef, converter).getFuncOp(); ael.lowerElementalUserAssignment(func, *lhs, *rhs); } void lowerElementalUserAssignment(mlir::func::FuncOp userAssignment, const Fortran::lower::SomeExpr &lhs, const Fortran::lower::SomeExpr &rhs) { mlir::Location loc = getLoc(); PushSemantics(ConstituentSemantics::CustomCopyInCopyOut); auto genArrayModify = genarr(lhs); ccStoreToDest = [=](IterSpace iters) -> ExtValue { auto modifiedArray = genArrayModify(iters); auto arrayModify = mlir::dyn_cast_or_null( fir::getBase(modifiedArray).getDefiningOp()); assert(arrayModify && "must be created by ArrayModifyOp"); fir::ExtendedValue lhs = arrayModifyToExv(builder, loc, destination, arrayModify.getResult(0)); genScalarUserDefinedAssignmentCall(builder, loc, userAssignment, lhs, iters.elementExv()); return modifiedArray; }; determineShapeOfDest(lhs); semant = ConstituentSemantics::RefTransparent; auto exv = lowerArrayExpression(rhs); if (explicitSpaceIsActive()) { explicitSpace->finalizeContext(); builder.create(loc, fir::getBase(exv)); } else { builder.create( loc, destination, fir::getBase(exv), destination.getMemref(), destination.getSlice(), destination.getTypeparams()); } } /// Lower an elemental subroutine call with at least one array argument. /// An elemental subroutine is an exception and does not have copy-in/copy-out /// semantics. See 15.8.3. /// Do NOT use this for user defined assignments. static void lowerElementalSubroutine(Fortran::lower::AbstractConverter &converter, Fortran::lower::SymMap &symMap, Fortran::lower::StatementContext &stmtCtx, const Fortran::lower::SomeExpr &call) { ArrayExprLowering ael(converter, stmtCtx, symMap, ConstituentSemantics::RefTransparent); ael.lowerElementalSubroutine(call); } // TODO: See the comment in genarr(const Fortran::lower::Parentheses&). // This is skipping generation of copy-in/copy-out code for analysis that is // required when arguments are in parentheses. void lowerElementalSubroutine(const Fortran::lower::SomeExpr &call) { auto f = genarr(call); llvm::SmallVector shape = genIterationShape(); auto [iterSpace, insPt] = genImplicitLoops(shape, /*innerArg=*/{}); f(iterSpace); finalizeElementCtx(); builder.restoreInsertionPoint(insPt); } ExtValue lowerScalarAssignment(const Fortran::lower::SomeExpr &lhs, const Fortran::lower::SomeExpr &rhs) { PushSemantics(ConstituentSemantics::RefTransparent); // 1) Lower the rhs expression with array_fetch op(s). IterationSpace iters; iters.setElement(genarr(rhs)(iters)); // 2) Lower the lhs expression to an array_update. semant = ConstituentSemantics::ProjectedCopyInCopyOut; auto lexv = genarr(lhs)(iters); // 3) Finalize the inner context. explicitSpace->finalizeContext(); // 4) Thread the array value updated forward. Note: the lhs might be // ill-formed (performing scalar assignment in an array context), // in which case there is no array to thread. auto createResult = [&](auto op) { mlir::Value oldInnerArg = op.getSequence(); std::size_t offset = explicitSpace->argPosition(oldInnerArg); explicitSpace->setInnerArg(offset, fir::getBase(lexv)); builder.create(getLoc(), fir::getBase(lexv)); }; llvm::TypeSwitch( fir::getBase(lexv).getDefiningOp()) .Case([&](fir::ArrayUpdateOp op) { createResult(op); }) .Case([&](fir::ArrayAmendOp op) { createResult(op); }) .Case([&](fir::ArrayModifyOp op) { createResult(op); }) .Default([&](mlir::Operation *) {}); return lexv; } static ExtValue lowerScalarUserAssignment( Fortran::lower::AbstractConverter &converter, Fortran::lower::SymMap &symMap, Fortran::lower::StatementContext &stmtCtx, Fortran::lower::ExplicitIterSpace &explicitIterSpace, mlir::func::FuncOp userAssignmentFunction, const Fortran::lower::SomeExpr &lhs, const Fortran::lower::SomeExpr &rhs) { Fortran::lower::ImplicitIterSpace implicit; ArrayExprLowering ael(converter, stmtCtx, symMap, ConstituentSemantics::RefTransparent, &explicitIterSpace, &implicit); return ael.lowerScalarUserAssignment(userAssignmentFunction, lhs, rhs); } ExtValue lowerScalarUserAssignment(mlir::func::FuncOp userAssignment, const Fortran::lower::SomeExpr &lhs, const Fortran::lower::SomeExpr &rhs) { mlir::Location loc = getLoc(); if (rhs.Rank() > 0) TODO(loc, "user-defined elemental assigment from expression with rank"); // 1) Lower the rhs expression with array_fetch op(s). IterationSpace iters; iters.setElement(genarr(rhs)(iters)); fir::ExtendedValue elementalExv = iters.elementExv(); // 2) Lower the lhs expression to an array_modify. semant = ConstituentSemantics::CustomCopyInCopyOut; auto lexv = genarr(lhs)(iters); bool isIllFormedLHS = false; // 3) Insert the call if (auto modifyOp = mlir::dyn_cast( fir::getBase(lexv).getDefiningOp())) { mlir::Value oldInnerArg = modifyOp.getSequence(); std::size_t offset = explicitSpace->argPosition(oldInnerArg); explicitSpace->setInnerArg(offset, fir::getBase(lexv)); fir::ExtendedValue exv = arrayModifyToExv(builder, loc, explicitSpace->getLhsLoad(0).value(), modifyOp.getResult(0)); genScalarUserDefinedAssignmentCall(builder, loc, userAssignment, exv, elementalExv); } else { // LHS is ill formed, it is a scalar with no references to FORALL // subscripts, so there is actually no array assignment here. The user // code is probably bad, but still insert user assignment call since it // was not rejected by semantics (a warning was emitted). isIllFormedLHS = true; genScalarUserDefinedAssignmentCall(builder, getLoc(), userAssignment, lexv, elementalExv); } // 4) Finalize the inner context. explicitSpace->finalizeContext(); // 5). Thread the array value updated forward. if (!isIllFormedLHS) builder.create(getLoc(), fir::getBase(lexv)); return lexv; } private: void determineShapeOfDest(const fir::ExtendedValue &lhs) { destShape = fir::factory::getExtents(getLoc(), builder, lhs); } void determineShapeOfDest(const Fortran::lower::SomeExpr &lhs) { if (!destShape.empty()) return; if (explicitSpaceIsActive() && determineShapeWithSlice(lhs)) return; mlir::Type idxTy = builder.getIndexType(); mlir::Location loc = getLoc(); if (std::optional constantShape = Fortran::evaluate::GetConstantExtents(converter.getFoldingContext(), lhs)) for (Fortran::common::ConstantSubscript extent : *constantShape) destShape.push_back(builder.createIntegerConstant(loc, idxTy, extent)); } bool genShapeFromDataRef(const Fortran::semantics::Symbol &x) { return false; } bool genShapeFromDataRef(const Fortran::evaluate::CoarrayRef &) { TODO(getLoc(), "coarray ref"); return false; } bool genShapeFromDataRef(const Fortran::evaluate::Component &x) { return x.base().Rank() > 0 ? genShapeFromDataRef(x.base()) : false; } bool genShapeFromDataRef(const Fortran::evaluate::ArrayRef &x) { if (x.Rank() == 0) return false; if (x.base().Rank() > 0) if (genShapeFromDataRef(x.base())) return true; // x has rank and x.base did not produce a shape. ExtValue exv = x.base().IsSymbol() ? asScalarRef(getFirstSym(x.base())) : asScalarRef(x.base().GetComponent()); mlir::Location loc = getLoc(); mlir::IndexType idxTy = builder.getIndexType(); llvm::SmallVector definedShape = fir::factory::getExtents(loc, builder, exv); mlir::Value one = builder.createIntegerConstant(loc, idxTy, 1); for (auto ss : llvm::enumerate(x.subscript())) { std::visit(Fortran::common::visitors{ [&](const Fortran::evaluate::Triplet &trip) { // For a subscript of triple notation, we compute the // range of this dimension of the iteration space. auto lo = [&]() { if (auto optLo = trip.lower()) return fir::getBase(asScalar(*optLo)); return getLBound(exv, ss.index(), one); }(); auto hi = [&]() { if (auto optHi = trip.upper()) return fir::getBase(asScalar(*optHi)); return getUBound(exv, ss.index(), one); }(); auto step = builder.createConvert( loc, idxTy, fir::getBase(asScalar(trip.stride()))); auto extent = builder.genExtentFromTriplet(loc, lo, hi, step, idxTy); destShape.push_back(extent); }, [&](auto) {}}, ss.value().u); } return true; } bool genShapeFromDataRef(const Fortran::evaluate::NamedEntity &x) { if (x.IsSymbol()) return genShapeFromDataRef(getFirstSym(x)); return genShapeFromDataRef(x.GetComponent()); } bool genShapeFromDataRef(const Fortran::evaluate::DataRef &x) { return std::visit([&](const auto &v) { return genShapeFromDataRef(v); }, x.u); } /// When in an explicit space, the ranked component must be evaluated to /// determine the actual number of iterations when slicing triples are /// present. Lower these expressions here. bool determineShapeWithSlice(const Fortran::lower::SomeExpr &lhs) { LLVM_DEBUG(Fortran::lower::DumpEvaluateExpr::dump( llvm::dbgs() << "determine shape of:\n", lhs)); // FIXME: We may not want to use ExtractDataRef here since it doesn't deal // with substrings, etc. std::optional dref = Fortran::evaluate::ExtractDataRef(lhs); return dref.has_value() ? genShapeFromDataRef(*dref) : false; } /// CHARACTER and derived type elements are treated as memory references. The /// numeric types are treated as values. static mlir::Type adjustedArraySubtype(mlir::Type ty, mlir::ValueRange indices) { mlir::Type pathTy = fir::applyPathToType(ty, indices); assert(pathTy && "indices failed to apply to type"); return adjustedArrayElementType(pathTy); } /// Lower rhs of an array expression. ExtValue lowerArrayExpression(const Fortran::lower::SomeExpr &exp) { mlir::Type resTy = converter.genType(exp); return std::visit( [&](const auto &e) { return lowerArrayExpression(genarr(e), resTy); }, exp.u); } ExtValue lowerArrayExpression(const ExtValue &exv) { assert(!explicitSpace); mlir::Type resTy = fir::unwrapPassByRefType(fir::getBase(exv).getType()); return lowerArrayExpression(genarr(exv), resTy); } void populateBounds(llvm::SmallVectorImpl &bounds, const Fortran::evaluate::Substring *substring) { if (!substring) return; bounds.push_back(fir::getBase(asScalar(substring->lower()))); if (auto upper = substring->upper()) bounds.push_back(fir::getBase(asScalar(*upper))); } /// Convert the original value, \p origVal, to type \p eleTy. When in a /// pointer assignment context, generate an appropriate `fir.rebox` for /// dealing with any bounds parameters on the pointer assignment. mlir::Value convertElementForUpdate(mlir::Location loc, mlir::Type eleTy, mlir::Value origVal) { mlir::Value val = builder.createConvert(loc, eleTy, origVal); if (isBoundsSpec()) { auto lbs = lbounds.value(); if (lbs.size() > 0) { // Rebox the value with user-specified shift. auto shiftTy = fir::ShiftType::get(eleTy.getContext(), lbs.size()); mlir::Value shiftOp = builder.create(loc, shiftTy, lbs); val = builder.create(loc, eleTy, val, shiftOp, mlir::Value{}); } } else if (isBoundsRemap()) { auto lbs = lbounds.getValue(); if (lbs.size() > 0) { // Rebox the value with user-specified shift and shape. auto shapeShiftArgs = flatZip(lbs, ubounds.getValue()); auto shapeTy = fir::ShapeShiftType::get(eleTy.getContext(), lbs.size()); mlir::Value shapeShift = builder.create(loc, shapeTy, shapeShiftArgs); val = builder.create(loc, eleTy, val, shapeShift, mlir::Value{}); } } return val; } /// Default store to destination implementation. /// This implements the default case, which is to assign the value in /// `iters.element` into the destination array, `iters.innerArgument`. Handles /// by value and by reference assignment. CC defaultStoreToDestination(const Fortran::evaluate::Substring *substring) { return [=](IterSpace iterSpace) -> ExtValue { mlir::Location loc = getLoc(); mlir::Value innerArg = iterSpace.innerArgument(); fir::ExtendedValue exv = iterSpace.elementExv(); mlir::Type arrTy = innerArg.getType(); mlir::Type eleTy = fir::applyPathToType(arrTy, iterSpace.iterVec()); if (isAdjustedArrayElementType(eleTy)) { // The elemental update is in the memref domain. Under this semantics, // we must always copy the computed new element from its location in // memory into the destination array. mlir::Type resRefTy = builder.getRefType(eleTy); // Get a reference to the array element to be amended. auto arrayOp = builder.create( loc, resRefTy, innerArg, iterSpace.iterVec(), destination.getTypeparams()); if (auto charTy = eleTy.dyn_cast()) { llvm::SmallVector substringBounds; populateBounds(substringBounds, substring); mlir::Value dstLen = fir::factory::genLenOfCharacter( builder, loc, destination, iterSpace.iterVec(), substringBounds); fir::ArrayAmendOp amend = createCharArrayAmend( loc, builder, arrayOp, dstLen, exv, innerArg, substringBounds); return abstractArrayExtValue(amend, dstLen); } if (fir::isa_derived(eleTy)) { fir::ArrayAmendOp amend = createDerivedArrayAmend( loc, destination, builder, arrayOp, exv, eleTy, innerArg); return abstractArrayExtValue(amend /*FIXME: typeparams?*/); } assert(eleTy.isa() && "must be an array"); TODO(loc, "array (as element) assignment"); } // By value semantics. The element is being assigned by value. auto ele = convertElementForUpdate(loc, eleTy, fir::getBase(exv)); auto update = builder.create( loc, arrTy, innerArg, ele, iterSpace.iterVec(), destination.getTypeparams()); return abstractArrayExtValue(update); }; } /// For an elemental array expression. /// 1. Lower the scalars and array loads. /// 2. Create the iteration space. /// 3. Create the element-by-element computation in the loop. /// 4. Return the resulting array value. /// If no destination was set in the array context, a temporary of /// \p resultTy will be created to hold the evaluated expression. /// Otherwise, \p resultTy is ignored and the expression is evaluated /// in the destination. \p f is a continuation built from an /// evaluate::Expr or an ExtendedValue. ExtValue lowerArrayExpression(CC f, mlir::Type resultTy) { mlir::Location loc = getLoc(); auto [iterSpace, insPt] = genIterSpace(resultTy); auto exv = f(iterSpace); iterSpace.setElement(std::move(exv)); auto lambda = ccStoreToDest.hasValue() ? ccStoreToDest.getValue() : defaultStoreToDestination(/*substring=*/nullptr); mlir::Value updVal = fir::getBase(lambda(iterSpace)); finalizeElementCtx(); builder.create(loc, updVal); builder.restoreInsertionPoint(insPt); return abstractArrayExtValue(iterSpace.outerResult()); } /// Compute the shape of a slice. llvm::SmallVector computeSliceShape(mlir::Value slice) { llvm::SmallVector slicedShape; auto slOp = mlir::cast(slice.getDefiningOp()); mlir::Operation::operand_range triples = slOp.getTriples(); mlir::IndexType idxTy = builder.getIndexType(); mlir::Location loc = getLoc(); for (unsigned i = 0, end = triples.size(); i < end; i += 3) { if (!mlir::isa_and_nonnull( triples[i + 1].getDefiningOp())) { // (..., lb:ub:step, ...) case: extent = max((ub-lb+step)/step, 0) // See Fortran 2018 9.5.3.3.2 section for more details. mlir::Value res = builder.genExtentFromTriplet( loc, triples[i], triples[i + 1], triples[i + 2], idxTy); slicedShape.emplace_back(res); } else { // do nothing. `..., i, ...` case, so dimension is dropped. } } return slicedShape; } /// Get the shape from an ArrayOperand. The shape of the array is adjusted if /// the array was sliced. llvm::SmallVector getShape(ArrayOperand array) { if (array.slice) return computeSliceShape(array.slice); if (array.memref.getType().isa()) return fir::factory::readExtents(builder, getLoc(), fir::BoxValue{array.memref}); return fir::factory::getExtents(array.shape); } /// Get the shape from an ArrayLoad. llvm::SmallVector getShape(fir::ArrayLoadOp arrayLoad) { return getShape(ArrayOperand{arrayLoad.getMemref(), arrayLoad.getShape(), arrayLoad.getSlice()}); } /// Returns the first array operand that may not be absent. If all /// array operands may be absent, return the first one. const ArrayOperand &getInducingShapeArrayOperand() const { assert(!arrayOperands.empty()); for (const ArrayOperand &op : arrayOperands) if (!op.mayBeAbsent) return op; // If all arrays operand appears in optional position, then none of them // is allowed to be absent as per 15.5.2.12 point 3. (6). Just pick the // first operands. // TODO: There is an opportunity to add a runtime check here that // this array is present as required. return arrayOperands[0]; } /// Generate the shape of the iteration space over the array expression. The /// iteration space may be implicit, explicit, or both. If it is implied it is /// based on the destination and operand array loads, or an optional /// Fortran::evaluate::Shape from the front end. If the shape is explicit, /// this returns any implicit shape component, if it exists. llvm::SmallVector genIterationShape() { // Use the precomputed destination shape. if (!destShape.empty()) return destShape; // Otherwise, use the destination's shape. if (destination) return getShape(destination); // Otherwise, use the first ArrayLoad operand shape. if (!arrayOperands.empty()) return getShape(getInducingShapeArrayOperand()); fir::emitFatalError(getLoc(), "failed to compute the array expression shape"); } bool explicitSpaceIsActive() const { return explicitSpace && explicitSpace->isActive(); } bool implicitSpaceHasMasks() const { return implicitSpace && !implicitSpace->empty(); } CC genMaskAccess(mlir::Value tmp, mlir::Value shape) { mlir::Location loc = getLoc(); return [=, builder = &converter.getFirOpBuilder()](IterSpace iters) { mlir::Type arrTy = fir::dyn_cast_ptrOrBoxEleTy(tmp.getType()); auto eleTy = arrTy.cast().getEleTy(); mlir::Type eleRefTy = builder->getRefType(eleTy); mlir::IntegerType i1Ty = builder->getI1Type(); // Adjust indices for any shift of the origin of the array. llvm::SmallVector indices = fir::factory::originateIndices( loc, *builder, tmp.getType(), shape, iters.iterVec()); auto addr = builder->create(loc, eleRefTy, tmp, shape, /*slice=*/mlir::Value{}, indices, /*typeParams=*/llvm::None); auto load = builder->create(loc, addr); return builder->createConvert(loc, i1Ty, load); }; } /// Construct the incremental instantiations of the ragged array structure. /// Rebind the lazy buffer variable, etc. as we go. template mlir::Value prepareRaggedArrays(Fortran::lower::FrontEndExpr expr) { assert(explicitSpaceIsActive()); mlir::Location loc = getLoc(); mlir::TupleType raggedTy = fir::factory::getRaggedArrayHeaderType(builder); llvm::SmallVector> loopStack = explicitSpace->getLoopStack(); const std::size_t depth = loopStack.size(); mlir::IntegerType i64Ty = builder.getIntegerType(64); [[maybe_unused]] mlir::Value byteSize = builder.createIntegerConstant(loc, i64Ty, 1); mlir::Value header = implicitSpace->lookupMaskHeader(expr); for (std::remove_const_t i = 0; i < depth; ++i) { auto insPt = builder.saveInsertionPoint(); if (i < depth - 1) builder.setInsertionPoint(loopStack[i + 1][0]); // Compute and gather the extents. llvm::SmallVector extents; for (auto doLoop : loopStack[i]) extents.push_back(builder.genExtentFromTriplet( loc, doLoop.getLowerBound(), doLoop.getUpperBound(), doLoop.getStep(), i64Ty)); if constexpr (withAllocation) { fir::runtime::genRaggedArrayAllocate( loc, builder, header, /*asHeader=*/true, byteSize, extents); } // Compute the dynamic position into the header. llvm::SmallVector offsets; for (auto doLoop : loopStack[i]) { auto m = builder.create( loc, doLoop.getInductionVar(), doLoop.getLowerBound()); auto n = builder.create(loc, m, doLoop.getStep()); mlir::Value one = builder.createIntegerConstant(loc, n.getType(), 1); offsets.push_back(builder.create(loc, n, one)); } mlir::IntegerType i32Ty = builder.getIntegerType(32); mlir::Value uno = builder.createIntegerConstant(loc, i32Ty, 1); mlir::Type coorTy = builder.getRefType(raggedTy.getType(1)); auto hdOff = builder.create(loc, coorTy, header, uno); auto toTy = fir::SequenceType::get(raggedTy, offsets.size()); mlir::Type toRefTy = builder.getRefType(toTy); auto ldHdr = builder.create(loc, hdOff); mlir::Value hdArr = builder.createConvert(loc, toRefTy, ldHdr); auto shapeOp = builder.genShape(loc, extents); header = builder.create( loc, builder.getRefType(raggedTy), hdArr, shapeOp, /*slice=*/mlir::Value{}, offsets, /*typeparams=*/mlir::ValueRange{}); auto hdrVar = builder.create(loc, coorTy, header, uno); auto inVar = builder.create(loc, hdrVar); mlir::Value two = builder.createIntegerConstant(loc, i32Ty, 2); mlir::Type coorTy2 = builder.getRefType(raggedTy.getType(2)); auto hdrSh = builder.create(loc, coorTy2, header, two); auto shapePtr = builder.create(loc, hdrSh); // Replace the binding. implicitSpace->rebind(expr, genMaskAccess(inVar, shapePtr)); if (i < depth - 1) builder.restoreInsertionPoint(insPt); } return header; } /// Lower mask expressions with implied iteration spaces from the variants of /// WHERE syntax. Since it is legal for mask expressions to have side-effects /// and modify values that will be used for the lhs, rhs, or both of /// subsequent assignments, the mask must be evaluated before the assignment /// is processed. /// Mask expressions are array expressions too. void genMasks() { // Lower the mask expressions, if any. if (implicitSpaceHasMasks()) { mlir::Location loc = getLoc(); // Mask expressions are array expressions too. for (const auto *e : implicitSpace->getExprs()) if (e && !implicitSpace->isLowered(e)) { if (mlir::Value var = implicitSpace->lookupMaskVariable(e)) { // Allocate the mask buffer lazily. assert(explicitSpaceIsActive()); mlir::Value header = prepareRaggedArrays(e); Fortran::lower::createLazyArrayTempValue(converter, *e, header, symMap, stmtCtx); // Close the explicit loops. builder.create(loc, explicitSpace->getInnerArgs()); builder.setInsertionPointAfter(explicitSpace->getOuterLoop()); // Open a new copy of the explicit loop nest. explicitSpace->genLoopNest(); continue; } fir::ExtendedValue tmp = Fortran::lower::createSomeArrayTempValue( converter, *e, symMap, stmtCtx); mlir::Value shape = builder.createShape(loc, tmp); implicitSpace->bind(e, genMaskAccess(fir::getBase(tmp), shape)); } // Set buffer from the header. for (const auto *e : implicitSpace->getExprs()) { if (!e) continue; if (implicitSpace->lookupMaskVariable(e)) { // Index into the ragged buffer to retrieve cached results. const int rank = e->Rank(); assert(destShape.empty() || static_cast(rank) == destShape.size()); mlir::Value header = prepareRaggedArrays(e); mlir::TupleType raggedTy = fir::factory::getRaggedArrayHeaderType(builder); mlir::IntegerType i32Ty = builder.getIntegerType(32); mlir::Value one = builder.createIntegerConstant(loc, i32Ty, 1); auto coor1 = builder.create( loc, builder.getRefType(raggedTy.getType(1)), header, one); auto db = builder.create(loc, coor1); mlir::Type eleTy = fir::unwrapSequenceType(fir::unwrapRefType(db.getType())); mlir::Type buffTy = builder.getRefType(fir::SequenceType::get(eleTy, rank)); // Address of ragged buffer data. mlir::Value buff = builder.createConvert(loc, buffTy, db); mlir::Value two = builder.createIntegerConstant(loc, i32Ty, 2); auto coor2 = builder.create( loc, builder.getRefType(raggedTy.getType(2)), header, two); auto shBuff = builder.create(loc, coor2); mlir::IntegerType i64Ty = builder.getIntegerType(64); mlir::IndexType idxTy = builder.getIndexType(); llvm::SmallVector extents; for (std::remove_const_t i = 0; i < rank; ++i) { mlir::Value off = builder.createIntegerConstant(loc, i32Ty, i); auto coor = builder.create( loc, builder.getRefType(i64Ty), shBuff, off); auto ldExt = builder.create(loc, coor); extents.push_back(builder.createConvert(loc, idxTy, ldExt)); } if (destShape.empty()) destShape = extents; // Construct shape of buffer. mlir::Value shapeOp = builder.genShape(loc, extents); // Replace binding with the local result. implicitSpace->rebind(e, genMaskAccess(buff, shapeOp)); } } } } // FIXME: should take multiple inner arguments. std::pair genImplicitLoops(mlir::ValueRange shape, mlir::Value innerArg) { mlir::Location loc = getLoc(); mlir::IndexType idxTy = builder.getIndexType(); mlir::Value one = builder.createIntegerConstant(loc, idxTy, 1); mlir::Value zero = builder.createIntegerConstant(loc, idxTy, 0); llvm::SmallVector loopUppers; // Convert any implied shape to closed interval form. The fir.do_loop will // run from 0 to `extent - 1` inclusive. for (auto extent : shape) loopUppers.push_back( builder.create(loc, extent, one)); // Iteration space is created with outermost columns, innermost rows llvm::SmallVector loops; const std::size_t loopDepth = loopUppers.size(); llvm::SmallVector ivars; for (auto i : llvm::enumerate(llvm::reverse(loopUppers))) { if (i.index() > 0) { assert(!loops.empty()); builder.setInsertionPointToStart(loops.back().getBody()); } fir::DoLoopOp loop; if (innerArg) { loop = builder.create( loc, zero, i.value(), one, isUnordered(), /*finalCount=*/false, mlir::ValueRange{innerArg}); innerArg = loop.getRegionIterArgs().front(); if (explicitSpaceIsActive()) explicitSpace->setInnerArg(0, innerArg); } else { loop = builder.create(loc, zero, i.value(), one, isUnordered(), /*finalCount=*/false); } ivars.push_back(loop.getInductionVar()); loops.push_back(loop); } if (innerArg) for (std::remove_const_t i = 0; i + 1 < loopDepth; ++i) { builder.setInsertionPointToEnd(loops[i].getBody()); builder.create(loc, loops[i + 1].getResult(0)); } // Move insertion point to the start of the innermost loop in the nest. builder.setInsertionPointToStart(loops.back().getBody()); // Set `afterLoopNest` to just after the entire loop nest. auto currPt = builder.saveInsertionPoint(); builder.setInsertionPointAfter(loops[0]); auto afterLoopNest = builder.saveInsertionPoint(); builder.restoreInsertionPoint(currPt); // Put the implicit loop variables in row to column order to match FIR's // Ops. (The loops were constructed from outermost column to innermost // row.) mlir::Value outerRes = loops[0].getResult(0); return {IterationSpace(innerArg, outerRes, llvm::reverse(ivars)), afterLoopNest}; } /// Build the iteration space into which the array expression will be lowered. /// The resultType is used to create a temporary, if needed. std::pair genIterSpace(mlir::Type resultType) { mlir::Location loc = getLoc(); llvm::SmallVector shape = genIterationShape(); if (!destination) { // Allocate storage for the result if it is not already provided. destination = createAndLoadSomeArrayTemp(resultType, shape); } // Generate the lazy mask allocation, if one was given. if (ccPrelude.hasValue()) ccPrelude.getValue()(shape); // Now handle the implicit loops. mlir::Value inner = explicitSpaceIsActive() ? explicitSpace->getInnerArgs().front() : destination.getResult(); auto [iters, afterLoopNest] = genImplicitLoops(shape, inner); mlir::Value innerArg = iters.innerArgument(); // Generate the mask conditional structure, if there are masks. Unlike the // explicit masks, which are interleaved, these mask expression appear in // the innermost loop. if (implicitSpaceHasMasks()) { // Recover the cached condition from the mask buffer. auto genCond = [&](Fortran::lower::FrontEndExpr e, IterSpace iters) { return implicitSpace->getBoundClosure(e)(iters); }; // Handle the negated conditions in topological order of the WHERE // clauses. See 10.2.3.2p4 as to why this control structure is produced. for (llvm::SmallVector maskExprs : implicitSpace->getMasks()) { const std::size_t size = maskExprs.size() - 1; auto genFalseBlock = [&](const auto *e, auto &&cond) { auto ifOp = builder.create( loc, mlir::TypeRange{innerArg.getType()}, fir::getBase(cond), /*withElseRegion=*/true); builder.create(loc, ifOp.getResult(0)); builder.setInsertionPointToStart(&ifOp.getThenRegion().front()); builder.create(loc, innerArg); builder.setInsertionPointToStart(&ifOp.getElseRegion().front()); }; auto genTrueBlock = [&](const auto *e, auto &&cond) { auto ifOp = builder.create( loc, mlir::TypeRange{innerArg.getType()}, fir::getBase(cond), /*withElseRegion=*/true); builder.create(loc, ifOp.getResult(0)); builder.setInsertionPointToStart(&ifOp.getElseRegion().front()); builder.create(loc, innerArg); builder.setInsertionPointToStart(&ifOp.getThenRegion().front()); }; for (std::remove_const_t i = 0; i < size; ++i) if (const auto *e = maskExprs[i]) genFalseBlock(e, genCond(e, iters)); // The last condition is either non-negated or unconditionally negated. if (const auto *e = maskExprs[size]) genTrueBlock(e, genCond(e, iters)); } } // We're ready to lower the body (an assignment statement) for this context // of loop nests at this point. return {iters, afterLoopNest}; } fir::ArrayLoadOp createAndLoadSomeArrayTemp(mlir::Type type, llvm::ArrayRef shape) { if (ccLoadDest.hasValue()) return ccLoadDest.getValue()(shape); auto seqTy = type.dyn_cast(); assert(seqTy && "must be an array"); mlir::Location loc = getLoc(); // TODO: Need to thread the length parameters here. For character, they may // differ from the operands length (e.g concatenation). So the array loads // type parameters are not enough. if (auto charTy = seqTy.getEleTy().dyn_cast()) if (charTy.hasDynamicLen()) TODO(loc, "character array expression temp with dynamic length"); if (auto recTy = seqTy.getEleTy().dyn_cast()) if (recTy.getNumLenParams() > 0) TODO(loc, "derived type array expression temp with length parameters"); mlir::Value temp = seqTy.hasConstantShape() ? builder.create(loc, type) : builder.create( loc, type, ".array.expr", llvm::None, shape); fir::FirOpBuilder *bldr = &converter.getFirOpBuilder(); stmtCtx.attachCleanup( [bldr, loc, temp]() { bldr->create(loc, temp); }); mlir::Value shapeOp = genShapeOp(shape); return builder.create(loc, seqTy, temp, shapeOp, /*slice=*/mlir::Value{}, llvm::None); } static fir::ShapeOp genShapeOp(mlir::Location loc, fir::FirOpBuilder &builder, llvm::ArrayRef shape) { mlir::IndexType idxTy = builder.getIndexType(); llvm::SmallVector idxShape; for (auto s : shape) idxShape.push_back(builder.createConvert(loc, idxTy, s)); auto shapeTy = fir::ShapeType::get(builder.getContext(), idxShape.size()); return builder.create(loc, shapeTy, idxShape); } fir::ShapeOp genShapeOp(llvm::ArrayRef shape) { return genShapeOp(getLoc(), builder, shape); } //===--------------------------------------------------------------------===// // Expression traversal and lowering. //===--------------------------------------------------------------------===// /// Lower the expression, \p x, in a scalar context. template ExtValue asScalar(const A &x) { return ScalarExprLowering{getLoc(), converter, symMap, stmtCtx}.genval(x); } /// Lower the expression, \p x, in a scalar context. If this is an explicit /// space, the expression may be scalar and refer to an array. We want to /// raise the array access to array operations in FIR to analyze potential /// conflicts even when the result is a scalar element. template ExtValue asScalarArray(const A &x) { return explicitSpaceIsActive() && !isPointerAssignment() ? genarr(x)(IterationSpace{}) : asScalar(x); } /// Lower the expression in a scalar context to a memory reference. template ExtValue asScalarRef(const A &x) { return ScalarExprLowering{getLoc(), converter, symMap, stmtCtx}.gen(x); } /// Lower an expression without dereferencing any indirection that may be /// a nullptr (because this is an absent optional or unallocated/disassociated /// descriptor). The returned expression cannot be addressed directly, it is /// meant to inquire about its status before addressing the related entity. template ExtValue asInquired(const A &x) { return ScalarExprLowering{getLoc(), converter, symMap, stmtCtx} .lowerIntrinsicArgumentAsInquired(x); } /// Some temporaries are allocated on an element-by-element basis during the /// array expression evaluation. Collect the cleanups here so the resources /// can be freed before the next loop iteration, avoiding memory leaks. etc. Fortran::lower::StatementContext &getElementCtx() { if (!elementCtx) { stmtCtx.pushScope(); elementCtx = true; } return stmtCtx; } /// If there were temporaries created for this element evaluation, finalize /// and deallocate the resources now. This should be done just prior the the /// fir::ResultOp at the end of the innermost loop. void finalizeElementCtx() { if (elementCtx) { stmtCtx.finalize(/*popScope=*/true); elementCtx = false; } } /// Lower an elemental function array argument. This ensures array /// sub-expressions that are not variables and must be passed by address /// are lowered by value and placed in memory. template CC genElementalArgument(const A &x) { // Ensure the returned element is in memory if this is what was requested. if ((semant == ConstituentSemantics::RefOpaque || semant == ConstituentSemantics::DataAddr || semant == ConstituentSemantics::ByValueArg)) { if (!Fortran::evaluate::IsVariable(x)) { PushSemantics(ConstituentSemantics::DataValue); CC cc = genarr(x); mlir::Location loc = getLoc(); if (isParenthesizedVariable(x)) { // Parenthesised variables are lowered to a reference to the variable // storage. When passing it as an argument, a copy must be passed. return [=](IterSpace iters) -> ExtValue { return createInMemoryScalarCopy(builder, loc, cc(iters)); }; } mlir::Type storageType = fir::unwrapSequenceType(converter.genType(toEvExpr(x))); return [=](IterSpace iters) -> ExtValue { return placeScalarValueInMemory(builder, loc, cc(iters), storageType); }; } } return genarr(x); } // A reference to a Fortran elemental intrinsic or intrinsic module procedure. CC genElementalIntrinsicProcRef( const Fortran::evaluate::ProcedureRef &procRef, llvm::Optional retTy, llvm::Optional intrinsic = llvm::None) { llvm::SmallVector operands; std::string name = intrinsic ? intrinsic->name : procRef.proc().GetSymbol()->GetUltimate().name().ToString(); const Fortran::lower::IntrinsicArgumentLoweringRules *argLowering = Fortran::lower::getIntrinsicArgumentLowering(name); mlir::Location loc = getLoc(); if (intrinsic && Fortran::lower::intrinsicRequiresCustomOptionalHandling( procRef, *intrinsic, converter)) { using CcPairT = std::pair>; llvm::SmallVector operands; auto prepareOptionalArg = [&](const Fortran::lower::SomeExpr &expr) { if (expr.Rank() == 0) { ExtValue optionalArg = this->asInquired(expr); mlir::Value isPresent = genActualIsPresentTest(builder, loc, optionalArg); operands.emplace_back( [=](IterSpace iters) -> ExtValue { return genLoad(builder, loc, optionalArg); }, isPresent); } else { auto [cc, isPresent, _] = this->genOptionalArrayFetch(expr); operands.emplace_back(cc, isPresent); } }; auto prepareOtherArg = [&](const Fortran::lower::SomeExpr &expr) { PushSemantics(ConstituentSemantics::RefTransparent); operands.emplace_back(genElementalArgument(expr), llvm::None); }; Fortran::lower::prepareCustomIntrinsicArgument( procRef, *intrinsic, retTy, prepareOptionalArg, prepareOtherArg, converter); fir::FirOpBuilder *bldr = &converter.getFirOpBuilder(); return [=](IterSpace iters) -> ExtValue { auto getArgument = [&](std::size_t i) -> ExtValue { return operands[i].first(iters); }; auto isPresent = [&](std::size_t i) -> llvm::Optional { return operands[i].second; }; return Fortran::lower::lowerCustomIntrinsic( *bldr, loc, name, retTy, isPresent, getArgument, operands.size(), getElementCtx()); }; } /// Otherwise, pre-lower arguments and use intrinsic lowering utility. for (const auto &arg : llvm::enumerate(procRef.arguments())) { const auto *expr = Fortran::evaluate::UnwrapExpr(arg.value()); if (!expr) { // Absent optional. operands.emplace_back([=](IterSpace) { return mlir::Value{}; }); } else if (!argLowering) { // No argument lowering instruction, lower by value. PushSemantics(ConstituentSemantics::RefTransparent); operands.emplace_back(genElementalArgument(*expr)); } else { // Ad-hoc argument lowering handling. Fortran::lower::ArgLoweringRule argRules = Fortran::lower::lowerIntrinsicArgumentAs(*argLowering, arg.index()); if (argRules.handleDynamicOptional && Fortran::evaluate::MayBePassedAsAbsentOptional( *expr, converter.getFoldingContext())) { // Currently, there is not elemental intrinsic that requires lowering // a potentially absent argument to something else than a value (apart // from character MAX/MIN that are handled elsewhere.) if (argRules.lowerAs != Fortran::lower::LowerIntrinsicArgAs::Value) TODO(loc, "lowering non trivial optional elemental intrinsic array " "argument"); PushSemantics(ConstituentSemantics::RefTransparent); operands.emplace_back(genarrForwardOptionalArgumentToCall(*expr)); continue; } switch (argRules.lowerAs) { case Fortran::lower::LowerIntrinsicArgAs::Value: { PushSemantics(ConstituentSemantics::RefTransparent); operands.emplace_back(genElementalArgument(*expr)); } break; case Fortran::lower::LowerIntrinsicArgAs::Addr: { // Note: assume does not have Fortran VALUE attribute semantics. PushSemantics(ConstituentSemantics::RefOpaque); operands.emplace_back(genElementalArgument(*expr)); } break; case Fortran::lower::LowerIntrinsicArgAs::Box: { PushSemantics(ConstituentSemantics::RefOpaque); auto lambda = genElementalArgument(*expr); operands.emplace_back([=](IterSpace iters) { return builder.createBox(loc, lambda(iters)); }); } break; case Fortran::lower::LowerIntrinsicArgAs::Inquired: TODO(loc, "intrinsic function with inquired argument"); break; } } } // Let the intrinsic library lower the intrinsic procedure call return [=](IterSpace iters) { llvm::SmallVector args; for (const auto &cc : operands) args.push_back(cc(iters)); return Fortran::lower::genIntrinsicCall(builder, loc, name, retTy, args, getElementCtx()); }; } /// Lower a procedure reference to a user-defined elemental procedure. CC genElementalUserDefinedProcRef( const Fortran::evaluate::ProcedureRef &procRef, llvm::Optional retTy) { using PassBy = Fortran::lower::CallerInterface::PassEntityBy; // 10.1.4 p5. Impure elemental procedures must be called in element order. if (const Fortran::semantics::Symbol *procSym = procRef.proc().GetSymbol()) if (!Fortran::semantics::IsPureProcedure(*procSym)) setUnordered(false); Fortran::lower::CallerInterface caller(procRef, converter); llvm::SmallVector operands; operands.reserve(caller.getPassedArguments().size()); mlir::Location loc = getLoc(); mlir::FunctionType callSiteType = caller.genFunctionType(); for (const Fortran::lower::CallInterface< Fortran::lower::CallerInterface>::PassedEntity &arg : caller.getPassedArguments()) { // 15.8.3 p1. Elemental procedure with intent(out)/intent(inout) // arguments must be called in element order. if (arg.mayBeModifiedByCall()) setUnordered(false); const auto *actual = arg.entity; mlir::Type argTy = callSiteType.getInput(arg.firArgument); if (!actual) { // Optional dummy argument for which there is no actual argument. auto absent = builder.create(loc, argTy); operands.emplace_back([=](IterSpace) { return absent; }); continue; } const auto *expr = actual->UnwrapExpr(); if (!expr) TODO(loc, "assumed type actual argument lowering"); LLVM_DEBUG(expr->AsFortran(llvm::dbgs() << "argument: " << arg.firArgument << " = [") << "]\n"); if (arg.isOptional() && Fortran::evaluate::MayBePassedAsAbsentOptional( *expr, converter.getFoldingContext())) TODO(loc, "passing dynamically optional argument to elemental procedures"); switch (arg.passBy) { case PassBy::Value: { // True pass-by-value semantics. PushSemantics(ConstituentSemantics::RefTransparent); operands.emplace_back(genElementalArgument(*expr)); } break; case PassBy::BaseAddressValueAttribute: { // VALUE attribute or pass-by-reference to a copy semantics. (byval*) if (isArray(*expr)) { PushSemantics(ConstituentSemantics::ByValueArg); operands.emplace_back(genElementalArgument(*expr)); } else { // Store scalar value in a temp to fulfill VALUE attribute. mlir::Value val = fir::getBase(asScalar(*expr)); mlir::Value temp = builder.createTemporary( loc, val.getType(), llvm::ArrayRef{ Fortran::lower::getAdaptToByRefAttr(builder)}); builder.create(loc, val, temp); operands.emplace_back( [=](IterSpace iters) -> ExtValue { return temp; }); } } break; case PassBy::BaseAddress: { if (isArray(*expr)) { PushSemantics(ConstituentSemantics::RefOpaque); operands.emplace_back(genElementalArgument(*expr)); } else { ExtValue exv = asScalarRef(*expr); operands.emplace_back([=](IterSpace iters) { return exv; }); } } break; case PassBy::CharBoxValueAttribute: { if (isArray(*expr)) { PushSemantics(ConstituentSemantics::DataValue); auto lambda = genElementalArgument(*expr); operands.emplace_back([=](IterSpace iters) { return fir::factory::CharacterExprHelper{builder, loc} .createTempFrom(lambda(iters)); }); } else { fir::factory::CharacterExprHelper helper(builder, loc); fir::CharBoxValue argVal = helper.createTempFrom(asScalarRef(*expr)); operands.emplace_back( [=](IterSpace iters) -> ExtValue { return argVal; }); } } break; case PassBy::BoxChar: { PushSemantics(ConstituentSemantics::RefOpaque); operands.emplace_back(genElementalArgument(*expr)); } break; case PassBy::AddressAndLength: // PassBy::AddressAndLength is only used for character results. Results // are not handled here. fir::emitFatalError( loc, "unexpected PassBy::AddressAndLength in elemental call"); break; case PassBy::CharProcTuple: { ExtValue argRef = asScalarRef(*expr); mlir::Value tuple = createBoxProcCharTuple( converter, argTy, fir::getBase(argRef), fir::getLen(argRef)); operands.emplace_back( [=](IterSpace iters) -> ExtValue { return tuple; }); } break; case PassBy::Box: case PassBy::MutableBox: // See C15100 and C15101 fir::emitFatalError(loc, "cannot be POINTER, ALLOCATABLE"); } } if (caller.getIfIndirectCallSymbol()) fir::emitFatalError(loc, "cannot be indirect call"); // The lambda is mutable so that `caller` copy can be modified inside it. return [=, caller = std::move(caller)](IterSpace iters) mutable -> ExtValue { for (const auto &[cc, argIface] : llvm::zip(operands, caller.getPassedArguments())) { auto exv = cc(iters); auto arg = exv.match( [&](const fir::CharBoxValue &cb) -> mlir::Value { return fir::factory::CharacterExprHelper{builder, loc} .createEmbox(cb); }, [&](const auto &) { return fir::getBase(exv); }); caller.placeInput(argIface, arg); } return ScalarExprLowering{loc, converter, symMap, getElementCtx()} .genCallOpAndResult(caller, callSiteType, retTy); }; } /// Generate a procedure reference. This code is shared for both functions and /// subroutines, the difference being reflected by `retTy`. CC genProcRef(const Fortran::evaluate::ProcedureRef &procRef, llvm::Optional retTy) { mlir::Location loc = getLoc(); if (procRef.IsElemental()) { if (const Fortran::evaluate::SpecificIntrinsic *intrin = procRef.proc().GetSpecificIntrinsic()) { // All elemental intrinsic functions are pure and cannot modify their // arguments. The only elemental subroutine, MVBITS has an Intent(inout) // argument. So for this last one, loops must be in element order // according to 15.8.3 p1. if (!retTy) setUnordered(false); // Elemental intrinsic call. // The intrinsic procedure is called once per element of the array. return genElementalIntrinsicProcRef(procRef, retTy, *intrin); } if (isIntrinsicModuleProcRef(procRef)) return genElementalIntrinsicProcRef(procRef, retTy); if (ScalarExprLowering::isStatementFunctionCall(procRef)) fir::emitFatalError(loc, "statement function cannot be elemental"); // Elemental call. // The procedure is called once per element of the array argument(s). return genElementalUserDefinedProcRef(procRef, retTy); } // Transformational call. // The procedure is called once and produces a value of rank > 0. if (const Fortran::evaluate::SpecificIntrinsic *intrinsic = procRef.proc().GetSpecificIntrinsic()) { if (explicitSpaceIsActive() && procRef.Rank() == 0) { // Elide any implicit loop iters. return [=, &procRef](IterSpace) { return ScalarExprLowering{loc, converter, symMap, stmtCtx} .genIntrinsicRef(procRef, retTy, *intrinsic); }; } return genarr( ScalarExprLowering{loc, converter, symMap, stmtCtx}.genIntrinsicRef( procRef, retTy, *intrinsic)); } if (explicitSpaceIsActive() && procRef.Rank() == 0) { // Elide any implicit loop iters. return [=, &procRef](IterSpace) { return ScalarExprLowering{loc, converter, symMap, stmtCtx} .genProcedureRef(procRef, retTy); }; } // In the default case, the call can be hoisted out of the loop nest. Apply // the iterations to the result, which may be an array value. return genarr( ScalarExprLowering{loc, converter, symMap, stmtCtx}.genProcedureRef( procRef, retTy)); } CC genarr(const Fortran::evaluate::ProcedureDesignator &) { TODO(getLoc(), "procedure designator"); } CC genarr(const Fortran::evaluate::ProcedureRef &x) { if (x.hasAlternateReturns()) fir::emitFatalError(getLoc(), "array procedure reference with alt-return"); return genProcRef(x, llvm::None); } template CC genScalarAndForwardValue(const A &x) { ExtValue result = asScalar(x); return [=](IterSpace) { return result; }; } template >> CC genarr(const A &x) { return genScalarAndForwardValue(x); } template CC genarr(const Fortran::evaluate::Expr &x) { LLVM_DEBUG(Fortran::lower::DumpEvaluateExpr::dump(llvm::dbgs(), x)); if (isArray(x) || (explicitSpaceIsActive() && isLeftHandSide()) || isElementalProcWithArrayArgs(x)) return std::visit([&](const auto &e) { return genarr(e); }, x.u); if (explicitSpaceIsActive()) { assert(!isArray(x) && !isLeftHandSide()); auto cc = std::visit([&](const auto &e) { return genarr(e); }, x.u); auto result = cc(IterationSpace{}); return [=](IterSpace) { return result; }; } return genScalarAndForwardValue(x); } // Converting a value of memory bound type requires creating a temp and // copying the value. static ExtValue convertAdjustedType(fir::FirOpBuilder &builder, mlir::Location loc, mlir::Type toType, const ExtValue &exv) { return exv.match( [&](const fir::CharBoxValue &cb) -> ExtValue { mlir::Value len = cb.getLen(); auto mem = builder.create(loc, toType, mlir::ValueRange{len}); fir::CharBoxValue result(mem, len); fir::factory::CharacterExprHelper{builder, loc}.createAssign( ExtValue{result}, exv); return result; }, [&](const auto &) -> ExtValue { fir::emitFatalError(loc, "convert on adjusted extended value"); }); } template CC genarr(const Fortran::evaluate::Convert, TC2> &x) { mlir::Location loc = getLoc(); auto lambda = genarr(x.left()); mlir::Type ty = converter.genType(TC1, KIND); return [=](IterSpace iters) -> ExtValue { auto exv = lambda(iters); mlir::Value val = fir::getBase(exv); auto valTy = val.getType(); if (elementTypeWasAdjusted(valTy) && !(fir::isa_ref_type(valTy) && fir::isa_integer(ty))) return convertAdjustedType(builder, loc, ty, exv); return builder.createConvert(loc, ty, val); }; } template CC genarr(const Fortran::evaluate::ComplexComponent &x) { mlir::Location loc = getLoc(); auto lambda = genarr(x.left()); bool isImagPart = x.isImaginaryPart; return [=](IterSpace iters) -> ExtValue { mlir::Value lhs = fir::getBase(lambda(iters)); return fir::factory::Complex{builder, loc}.extractComplexPart(lhs, isImagPart); }; } template CC genarr(const Fortran::evaluate::Parentheses &x) { mlir::Location loc = getLoc(); if (isReferentiallyOpaque()) { // Context is a call argument in, for example, an elemental procedure // call. TODO: all array arguments should use array_load, array_access, // array_amend, and INTENT(OUT), INTENT(INOUT) arguments should have // array_merge_store ops. TODO(loc, "parentheses on argument in elemental call"); } auto f = genarr(x.left()); return [=](IterSpace iters) -> ExtValue { auto val = f(iters); mlir::Value base = fir::getBase(val); auto newBase = builder.create(loc, base.getType(), base); return fir::substBase(val, newBase); }; } template CC genarr(const Fortran::evaluate::Negate> &x) { mlir::Location loc = getLoc(); auto f = genarr(x.left()); return [=](IterSpace iters) -> ExtValue { mlir::Value val = fir::getBase(f(iters)); mlir::Type ty = converter.genType(Fortran::common::TypeCategory::Integer, KIND); mlir::Value zero = builder.createIntegerConstant(loc, ty, 0); return builder.create(loc, zero, val); }; } template CC genarr(const Fortran::evaluate::Negate> &x) { mlir::Location loc = getLoc(); auto f = genarr(x.left()); return [=](IterSpace iters) -> ExtValue { return builder.create(loc, fir::getBase(f(iters))); }; } template CC genarr(const Fortran::evaluate::Negate> &x) { mlir::Location loc = getLoc(); auto f = genarr(x.left()); return [=](IterSpace iters) -> ExtValue { return builder.create(loc, fir::getBase(f(iters))); }; } //===--------------------------------------------------------------------===// // Binary elemental ops //===--------------------------------------------------------------------===// template CC createBinaryOp(const A &evEx) { mlir::Location loc = getLoc(); auto lambda = genarr(evEx.left()); auto rf = genarr(evEx.right()); return [=](IterSpace iters) -> ExtValue { mlir::Value left = fir::getBase(lambda(iters)); mlir::Value right = fir::getBase(rf(iters)); return builder.create(loc, left, right); }; } #undef GENBIN #define GENBIN(GenBinEvOp, GenBinTyCat, GenBinFirOp) \ template \ CC genarr(const Fortran::evaluate::GenBinEvOp> &x) { \ return createBinaryOp(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) GENBIN(Divide, Complex, fir::DivcOp) template CC genarr( const Fortran::evaluate::Power> &x) { mlir::Location loc = getLoc(); mlir::Type ty = converter.genType(TC, KIND); auto lf = genarr(x.left()); auto rf = genarr(x.right()); return [=](IterSpace iters) -> ExtValue { mlir::Value lhs = fir::getBase(lf(iters)); mlir::Value rhs = fir::getBase(rf(iters)); return Fortran::lower::genPow(builder, loc, ty, lhs, rhs); }; } template CC genarr( const Fortran::evaluate::Extremum> &x) { mlir::Location loc = getLoc(); auto lf = genarr(x.left()); auto rf = genarr(x.right()); switch (x.ordering) { case Fortran::evaluate::Ordering::Greater: return [=](IterSpace iters) -> ExtValue { mlir::Value lhs = fir::getBase(lf(iters)); mlir::Value rhs = fir::getBase(rf(iters)); return Fortran::lower::genMax(builder, loc, llvm::ArrayRef{lhs, rhs}); }; case Fortran::evaluate::Ordering::Less: return [=](IterSpace iters) -> ExtValue { mlir::Value lhs = fir::getBase(lf(iters)); mlir::Value rhs = fir::getBase(rf(iters)); return Fortran::lower::genMin(builder, loc, llvm::ArrayRef{lhs, rhs}); }; case Fortran::evaluate::Ordering::Equal: llvm_unreachable("Equal is not a valid ordering in this context"); } llvm_unreachable("unknown ordering"); } template CC genarr( const Fortran::evaluate::RealToIntPower> &x) { mlir::Location loc = getLoc(); auto ty = converter.genType(TC, KIND); auto lf = genarr(x.left()); auto rf = genarr(x.right()); return [=](IterSpace iters) { mlir::Value lhs = fir::getBase(lf(iters)); mlir::Value rhs = fir::getBase(rf(iters)); return Fortran::lower::genPow(builder, loc, ty, lhs, rhs); }; } template CC genarr(const Fortran::evaluate::ComplexConstructor &x) { mlir::Location loc = getLoc(); auto lf = genarr(x.left()); auto rf = genarr(x.right()); return [=](IterSpace iters) -> ExtValue { mlir::Value lhs = fir::getBase(lf(iters)); mlir::Value rhs = fir::getBase(rf(iters)); return fir::factory::Complex{builder, loc}.createComplex(KIND, lhs, rhs); }; } /// Fortran's concatenation operator `//`. template CC genarr(const Fortran::evaluate::Concat &x) { mlir::Location loc = getLoc(); auto lf = genarr(x.left()); auto rf = genarr(x.right()); return [=](IterSpace iters) -> ExtValue { auto lhs = lf(iters); auto rhs = rf(iters); const fir::CharBoxValue *lchr = lhs.getCharBox(); const fir::CharBoxValue *rchr = rhs.getCharBox(); if (lchr && rchr) { return fir::factory::CharacterExprHelper{builder, loc} .createConcatenate(*lchr, *rchr); } TODO(loc, "concat on unexpected extended values"); return mlir::Value{}; }; } template CC genarr(const Fortran::evaluate::SetLength &x) { auto lf = genarr(x.left()); mlir::Value rhs = fir::getBase(asScalar(x.right())); return [=](IterSpace iters) -> ExtValue { mlir::Value lhs = fir::getBase(lf(iters)); return fir::CharBoxValue{lhs, rhs}; }; } template CC genarr(const Fortran::evaluate::Constant &x) { if (x.Rank() == 0) return genScalarAndForwardValue(x); mlir::Location loc = getLoc(); mlir::IndexType idxTy = builder.getIndexType(); mlir::Type arrTy = converter.genType(toEvExpr(x)); std::string globalName = Fortran::lower::mangle::mangleArrayLiteral(x); fir::GlobalOp global = builder.getNamedGlobal(globalName); if (!global) { mlir::Type symTy = arrTy; mlir::Type eleTy = symTy.cast().getEleTy(); // If we have a rank-1 array of integer, real, or logical, then we can // create a global array with the dense attribute. // // The mlir tensor type can only handle integer, real, or logical. It // does not currently support nested structures which is required for // complex. // // Also, we currently handle just rank-1 since tensor type assumes // row major array ordering. We will need to reorder the dimensions // in the tensor type to support Fortran's column major array ordering. // How to create this tensor type is to be determined. if (x.Rank() == 1 && eleTy.isa()) global = Fortran::lower::createDenseGlobal( loc, arrTy, globalName, builder.createInternalLinkage(), true, toEvExpr(x), converter); // Note: If call to createDenseGlobal() returns 0, then call // createGlobalConstant() below. if (!global) global = builder.createGlobalConstant( loc, arrTy, globalName, [&](fir::FirOpBuilder &builder) { Fortran::lower::StatementContext stmtCtx( /*cleanupProhibited=*/true); fir::ExtendedValue result = Fortran::lower::createSomeInitializerExpression( loc, converter, toEvExpr(x), symMap, stmtCtx); mlir::Value castTo = builder.createConvert(loc, arrTy, fir::getBase(result)); builder.create(loc, castTo); }, builder.createInternalLinkage()); } auto addr = builder.create(getLoc(), global.resultType(), global.getSymbol()); auto seqTy = global.getType().cast(); llvm::SmallVector extents; for (auto extent : seqTy.getShape()) extents.push_back(builder.createIntegerConstant(loc, idxTy, extent)); if (auto charTy = seqTy.getEleTy().dyn_cast()) { mlir::Value len = builder.createIntegerConstant(loc, builder.getI64Type(), charTy.getLen()); return genarr(fir::CharArrayBoxValue{addr, len, extents}); } return genarr(fir::ArrayBoxValue{addr, extents}); } //===--------------------------------------------------------------------===// // A vector subscript expression may be wrapped with a cast to INTEGER*8. // Get rid of it here so the vector can be loaded. Add it back when // generating the elemental evaluation (inside the loop nest). static Fortran::lower::SomeExpr ignoreEvConvert(const Fortran::evaluate::Expr> &x) { return std::visit([&](const auto &v) { return ignoreEvConvert(v); }, x.u); } template static Fortran::lower::SomeExpr ignoreEvConvert( const Fortran::evaluate::Convert< Fortran::evaluate::Type, FROM> &x) { return toEvExpr(x.left()); } template static Fortran::lower::SomeExpr ignoreEvConvert(const A &x) { return toEvExpr(x); } //===--------------------------------------------------------------------===// // Get the `Se::Symbol*` for the subscript expression, `x`. This symbol can // be used to determine the lbound, ubound of the vector. template static const Fortran::semantics::Symbol * extractSubscriptSymbol(const Fortran::evaluate::Expr &x) { return std::visit([&](const auto &v) { return extractSubscriptSymbol(v); }, x.u); } template static const Fortran::semantics::Symbol * extractSubscriptSymbol(const Fortran::evaluate::Designator &x) { return Fortran::evaluate::UnwrapWholeSymbolDataRef(x); } template static const Fortran::semantics::Symbol *extractSubscriptSymbol(const A &x) { return nullptr; } //===--------------------------------------------------------------------===// /// Get the declared lower bound value of the array `x` in dimension `dim`. /// The argument `one` must be an ssa-value for the constant 1. mlir::Value getLBound(const ExtValue &x, unsigned dim, mlir::Value one) { return fir::factory::readLowerBound(builder, getLoc(), x, dim, one); } /// Get the declared upper bound value of the array `x` in dimension `dim`. /// The argument `one` must be an ssa-value for the constant 1. mlir::Value getUBound(const ExtValue &x, unsigned dim, mlir::Value one) { mlir::Location loc = getLoc(); mlir::Value lb = getLBound(x, dim, one); mlir::Value extent = fir::factory::readExtent(builder, loc, x, dim); auto add = builder.create(loc, lb, extent); return builder.create(loc, add, one); } /// Return the extent of the boxed array `x` in dimesion `dim`. mlir::Value getExtent(const ExtValue &x, unsigned dim) { return fir::factory::readExtent(builder, getLoc(), x, dim); } template ExtValue genArrayBase(const A &base) { ScalarExprLowering sel{getLoc(), converter, symMap, stmtCtx}; return base.IsSymbol() ? sel.gen(getFirstSym(base)) : sel.gen(base.GetComponent()); } template bool hasEvArrayRef(const A &x) { struct HasEvArrayRefHelper : public Fortran::evaluate::AnyTraverse { HasEvArrayRefHelper() : Fortran::evaluate::AnyTraverse(*this) {} using Fortran::evaluate::AnyTraverse::operator(); bool operator()(const Fortran::evaluate::ArrayRef &) const { return true; } } helper; return helper(x); } CC genVectorSubscriptArrayFetch(const Fortran::lower::SomeExpr &expr, std::size_t dim) { PushSemantics(ConstituentSemantics::RefTransparent); auto saved = Fortran::common::ScopedSet(explicitSpace, nullptr); llvm::SmallVector savedDestShape = destShape; destShape.clear(); auto result = genarr(expr); if (destShape.empty()) TODO(getLoc(), "expected vector to have an extent"); assert(destShape.size() == 1 && "vector has rank > 1"); if (destShape[0] != savedDestShape[dim]) { // Not the same, so choose the smaller value. mlir::Location loc = getLoc(); auto cmp = builder.create( loc, mlir::arith::CmpIPredicate::sgt, destShape[0], savedDestShape[dim]); auto sel = builder.create( loc, cmp, savedDestShape[dim], destShape[0]); savedDestShape[dim] = sel; destShape = savedDestShape; } return result; } /// Generate an access by vector subscript using the index in the iteration /// vector at `dim`. mlir::Value genAccessByVector(mlir::Location loc, CC genArrFetch, IterSpace iters, std::size_t dim) { IterationSpace vecIters(iters, llvm::ArrayRef{iters.iterValue(dim)}); fir::ExtendedValue fetch = genArrFetch(vecIters); mlir::IndexType idxTy = builder.getIndexType(); return builder.createConvert(loc, idxTy, fir::getBase(fetch)); } /// When we have an array reference, the expressions specified in each /// dimension may be slice operations (e.g. `i:j:k`), vectors, or simple /// (loop-invarianet) scalar expressions. This returns the base entity, the /// resulting type, and a continuation to adjust the default iteration space. void genSliceIndices(ComponentPath &cmptData, const ExtValue &arrayExv, const Fortran::evaluate::ArrayRef &x, bool atBase) { mlir::Location loc = getLoc(); mlir::IndexType idxTy = builder.getIndexType(); mlir::Value one = builder.createIntegerConstant(loc, idxTy, 1); llvm::SmallVector &trips = cmptData.trips; LLVM_DEBUG(llvm::dbgs() << "array: " << arrayExv << '\n'); auto &pc = cmptData.pc; const bool useTripsForSlice = !explicitSpaceIsActive(); const bool createDestShape = destShape.empty(); bool useSlice = false; std::size_t shapeIndex = 0; for (auto sub : llvm::enumerate(x.subscript())) { const std::size_t subsIndex = sub.index(); std::visit( Fortran::common::visitors{ [&](const Fortran::evaluate::Triplet &t) { mlir::Value lowerBound; if (auto optLo = t.lower()) lowerBound = fir::getBase(asScalar(*optLo)); else lowerBound = getLBound(arrayExv, subsIndex, one); lowerBound = builder.createConvert(loc, idxTy, lowerBound); mlir::Value stride = fir::getBase(asScalar(t.stride())); stride = builder.createConvert(loc, idxTy, stride); if (useTripsForSlice || createDestShape) { // Generate a slice operation for the triplet. The first and // second position of the triplet may be omitted, and the // declared lbound and/or ubound expression values, // respectively, should be used instead. trips.push_back(lowerBound); mlir::Value upperBound; if (auto optUp = t.upper()) upperBound = fir::getBase(asScalar(*optUp)); else upperBound = getUBound(arrayExv, subsIndex, one); upperBound = builder.createConvert(loc, idxTy, upperBound); trips.push_back(upperBound); trips.push_back(stride); if (createDestShape) { auto extent = builder.genExtentFromTriplet( loc, lowerBound, upperBound, stride, idxTy); destShape.push_back(extent); } useSlice = true; } if (!useTripsForSlice) { auto currentPC = pc; pc = [=](IterSpace iters) { IterationSpace newIters = currentPC(iters); mlir::Value impliedIter = newIters.iterValue(subsIndex); // FIXME: must use the lower bound of this component. auto arrLowerBound = atBase ? getLBound(arrayExv, subsIndex, one) : one; auto initial = builder.create( loc, lowerBound, arrLowerBound); auto prod = builder.create( loc, impliedIter, stride); auto result = builder.create(loc, initial, prod); newIters.setIndexValue(subsIndex, result); return newIters; }; } shapeIndex++; }, [&](const Fortran::evaluate::IndirectSubscriptIntegerExpr &ie) { const auto &e = ie.value(); // dereference if (isArray(e)) { // This is a vector subscript. Use the index values as read // from a vector to determine the temporary array value. // Note: 9.5.3.3.3(3) specifies undefined behavior for // multiple updates to any specific array element through a // vector subscript with replicated values. assert(!isBoxValue() && "fir.box cannot be created with vector subscripts"); auto arrExpr = ignoreEvConvert(e); if (createDestShape) destShape.push_back(fir::factory::getExtentAtDimension( loc, builder, arrayExv, subsIndex)); auto genArrFetch = genVectorSubscriptArrayFetch(arrExpr, shapeIndex); auto currentPC = pc; pc = [=](IterSpace iters) { IterationSpace newIters = currentPC(iters); auto val = genAccessByVector(loc, genArrFetch, newIters, subsIndex); // Value read from vector subscript array and normalized // using the base array's lower bound value. mlir::Value lb = fir::factory::readLowerBound( builder, loc, arrayExv, subsIndex, one); auto origin = builder.create( loc, idxTy, val, lb); newIters.setIndexValue(subsIndex, origin); return newIters; }; if (useTripsForSlice) { LLVM_ATTRIBUTE_UNUSED auto vectorSubscriptShape = getShape(arrayOperands.back()); auto undef = builder.create(loc, idxTy); trips.push_back(undef); trips.push_back(undef); trips.push_back(undef); } shapeIndex++; } else { // This is a regular scalar subscript. if (useTripsForSlice) { // A regular scalar index, which does not yield an array // section. Use a degenerate slice operation // `(e:undef:undef)` in this dimension as a placeholder. // This does not necessarily change the rank of the original // array, so the iteration space must also be extended to // include this expression in this dimension to adjust to // the array's declared rank. mlir::Value v = fir::getBase(asScalar(e)); trips.push_back(v); auto undef = builder.create(loc, idxTy); trips.push_back(undef); trips.push_back(undef); auto currentPC = pc; // Cast `e` to index type. mlir::Value iv = builder.createConvert(loc, idxTy, v); // Normalize `e` by subtracting the declared lbound. mlir::Value lb = fir::factory::readLowerBound( builder, loc, arrayExv, subsIndex, one); mlir::Value ivAdj = builder.create(loc, idxTy, iv, lb); // Add lbound adjusted value of `e` to the iteration vector // (except when creating a box because the iteration vector // is empty). if (!isBoxValue()) pc = [=](IterSpace iters) { IterationSpace newIters = currentPC(iters); newIters.insertIndexValue(subsIndex, ivAdj); return newIters; }; } else { auto currentPC = pc; mlir::Value newValue = fir::getBase(asScalarArray(e)); mlir::Value result = builder.createConvert(loc, idxTy, newValue); mlir::Value lb = fir::factory::readLowerBound( builder, loc, arrayExv, subsIndex, one); result = builder.create(loc, idxTy, result, lb); pc = [=](IterSpace iters) { IterationSpace newIters = currentPC(iters); newIters.insertIndexValue(subsIndex, result); return newIters; }; } } }}, sub.value().u); } if (!useSlice) trips.clear(); } static mlir::Type unwrapBoxEleTy(mlir::Type ty) { if (auto boxTy = ty.dyn_cast()) return fir::unwrapRefType(boxTy.getEleTy()); return ty; } llvm::SmallVector getShape(mlir::Type ty) { llvm::SmallVector result; ty = unwrapBoxEleTy(ty); mlir::Location loc = getLoc(); mlir::IndexType idxTy = builder.getIndexType(); for (auto extent : ty.cast().getShape()) { auto v = extent == fir::SequenceType::getUnknownExtent() ? builder.create(loc, idxTy).getResult() : builder.createIntegerConstant(loc, idxTy, extent); result.push_back(v); } return result; } CC genarr(const Fortran::semantics::SymbolRef &sym, ComponentPath &components) { return genarr(sym.get(), components); } ExtValue abstractArrayExtValue(mlir::Value val, mlir::Value len = {}) { return convertToArrayBoxValue(getLoc(), builder, val, len); } CC genarr(const ExtValue &extMemref) { ComponentPath dummy(/*isImplicit=*/true); return genarr(extMemref, dummy); } /// Base case of generating an array reference, CC genarr(const ExtValue &extMemref, ComponentPath &components) { mlir::Location loc = getLoc(); mlir::Value memref = fir::getBase(extMemref); mlir::Type arrTy = fir::dyn_cast_ptrOrBoxEleTy(memref.getType()); assert(arrTy.isa() && "memory ref must be an array"); mlir::Value shape = builder.createShape(loc, extMemref); mlir::Value slice; if (components.isSlice()) { if (isBoxValue() && components.substring) { // Append the substring operator to emboxing Op as it will become an // interior adjustment (add offset, adjust LEN) to the CHARACTER value // being referenced in the descriptor. llvm::SmallVector substringBounds; populateBounds(substringBounds, components.substring); // Convert to (offset, size) mlir::Type iTy = substringBounds[0].getType(); if (substringBounds.size() != 2) { fir::CharacterType charTy = fir::factory::CharacterExprHelper::getCharType(arrTy); if (charTy.hasConstantLen()) { mlir::IndexType idxTy = builder.getIndexType(); fir::CharacterType::LenType charLen = charTy.getLen(); mlir::Value lenValue = builder.createIntegerConstant(loc, idxTy, charLen); substringBounds.push_back(lenValue); } else { llvm::SmallVector typeparams = fir::getTypeParams(extMemref); substringBounds.push_back(typeparams.back()); } } // Convert the lower bound to 0-based substring. mlir::Value one = builder.createIntegerConstant(loc, substringBounds[0].getType(), 1); substringBounds[0] = builder.create(loc, substringBounds[0], one); // Convert the upper bound to a length. mlir::Value cast = builder.createConvert(loc, iTy, substringBounds[1]); mlir::Value zero = builder.createIntegerConstant(loc, iTy, 0); auto size = builder.create(loc, cast, substringBounds[0]); auto cmp = builder.create( loc, mlir::arith::CmpIPredicate::sgt, size, zero); // size = MAX(upper - (lower - 1), 0) substringBounds[1] = builder.create(loc, cmp, size, zero); slice = builder.create(loc, components.trips, components.suffixComponents, substringBounds); } else { slice = builder.createSlice(loc, extMemref, components.trips, components.suffixComponents); } if (components.hasComponents()) { auto seqTy = arrTy.cast(); mlir::Type eleTy = fir::applyPathToType(seqTy.getEleTy(), components.suffixComponents); if (!eleTy) fir::emitFatalError(loc, "slicing path is ill-formed"); if (auto realTy = eleTy.dyn_cast()) eleTy = Fortran::lower::convertReal(realTy.getContext(), realTy.getFKind()); // create the type of the projected array. arrTy = fir::SequenceType::get(seqTy.getShape(), eleTy); LLVM_DEBUG(llvm::dbgs() << "type of array projection from component slicing: " << eleTy << ", " << arrTy << '\n'); } } arrayOperands.push_back(ArrayOperand{memref, shape, slice}); if (destShape.empty()) destShape = getShape(arrayOperands.back()); if (isBoxValue()) { // Semantics are a reference to a boxed array. // This case just requires that an embox operation be created to box the // value. The value of the box is forwarded in the continuation. mlir::Type reduceTy = reduceRank(arrTy, slice); auto boxTy = fir::BoxType::get(reduceTy); if (components.substring) { // Adjust char length to substring size. fir::CharacterType charTy = fir::factory::CharacterExprHelper::getCharType(reduceTy); auto seqTy = reduceTy.cast(); // TODO: Use a constant for fir.char LEN if we can compute it. boxTy = fir::BoxType::get( fir::SequenceType::get(fir::CharacterType::getUnknownLen( builder.getContext(), charTy.getFKind()), seqTy.getDimension())); } mlir::Value embox = memref.getType().isa() ? builder.create(loc, boxTy, memref, shape, slice) .getResult() : builder .create(loc, boxTy, memref, shape, slice, fir::getTypeParams(extMemref)) .getResult(); return [=](IterSpace) -> ExtValue { return fir::BoxValue(embox); }; } auto eleTy = arrTy.cast().getEleTy(); if (isReferentiallyOpaque()) { // Semantics are an opaque reference to an array. // This case forwards a continuation that will generate the address // arithmetic to the array element. This does not have copy-in/copy-out // semantics. No attempt to copy the array value will be made during the // interpretation of the Fortran statement. mlir::Type refEleTy = builder.getRefType(eleTy); return [=](IterSpace iters) -> ExtValue { // ArrayCoorOp does not expect zero based indices. llvm::SmallVector indices = fir::factory::originateIndices( loc, builder, memref.getType(), shape, iters.iterVec()); mlir::Value coor = builder.create( loc, refEleTy, memref, shape, slice, indices, fir::getTypeParams(extMemref)); if (auto charTy = eleTy.dyn_cast()) { llvm::SmallVector substringBounds; populateBounds(substringBounds, components.substring); if (!substringBounds.empty()) { mlir::Value dstLen = fir::factory::genLenOfCharacter( builder, loc, arrTy.cast(), memref, fir::getTypeParams(extMemref), iters.iterVec(), substringBounds); fir::CharBoxValue dstChar(coor, dstLen); return fir::factory::CharacterExprHelper{builder, loc} .createSubstring(dstChar, substringBounds); } } return fir::factory::arraySectionElementToExtendedValue( builder, loc, extMemref, coor, slice); }; } auto arrLoad = builder.create( loc, arrTy, memref, shape, slice, fir::getTypeParams(extMemref)); mlir::Value arrLd = arrLoad.getResult(); if (isProjectedCopyInCopyOut()) { // Semantics are projected copy-in copy-out. // The backing store of the destination of an array expression may be // partially modified. These updates are recorded in FIR by forwarding a // continuation that generates an `array_update` Op. The destination is // always loaded at the beginning of the statement and merged at the // end. destination = arrLoad; auto lambda = ccStoreToDest.hasValue() ? ccStoreToDest.getValue() : defaultStoreToDestination(components.substring); return [=](IterSpace iters) -> ExtValue { return lambda(iters); }; } if (isCustomCopyInCopyOut()) { // Create an array_modify to get the LHS element address and indicate // the assignment, the actual assignment must be implemented in // ccStoreToDest. destination = arrLoad; return [=](IterSpace iters) -> ExtValue { mlir::Value innerArg = iters.innerArgument(); mlir::Type resTy = innerArg.getType(); mlir::Type eleTy = fir::applyPathToType(resTy, iters.iterVec()); mlir::Type refEleTy = fir::isa_ref_type(eleTy) ? eleTy : builder.getRefType(eleTy); auto arrModify = builder.create( loc, mlir::TypeRange{refEleTy, resTy}, innerArg, iters.iterVec(), destination.getTypeparams()); return abstractArrayExtValue(arrModify.getResult(1)); }; } if (isCopyInCopyOut()) { // Semantics are copy-in copy-out. // The continuation simply forwards the result of the `array_load` Op, // which is the value of the array as it was when loaded. All data // references with rank > 0 in an array expression typically have // copy-in copy-out semantics. return [=](IterSpace) -> ExtValue { return arrLd; }; } mlir::Operation::operand_range arrLdTypeParams = arrLoad.getTypeparams(); if (isValueAttribute()) { // Semantics are value attribute. // Here the continuation will `array_fetch` a value from an array and // then store that value in a temporary. One can thus imitate pass by // value even when the call is pass by reference. return [=](IterSpace iters) -> ExtValue { mlir::Value base; mlir::Type eleTy = fir::applyPathToType(arrTy, iters.iterVec()); if (isAdjustedArrayElementType(eleTy)) { mlir::Type eleRefTy = builder.getRefType(eleTy); base = builder.create( loc, eleRefTy, arrLd, iters.iterVec(), arrLdTypeParams); } else { base = builder.create( loc, eleTy, arrLd, iters.iterVec(), arrLdTypeParams); } mlir::Value temp = builder.createTemporary( loc, base.getType(), llvm::ArrayRef{ Fortran::lower::getAdaptToByRefAttr(builder)}); builder.create(loc, base, temp); return fir::factory::arraySectionElementToExtendedValue( builder, loc, extMemref, temp, slice); }; } // In the default case, the array reference forwards an `array_fetch` or // `array_access` Op in the continuation. return [=](IterSpace iters) -> ExtValue { mlir::Type eleTy = fir::applyPathToType(arrTy, iters.iterVec()); if (isAdjustedArrayElementType(eleTy)) { mlir::Type eleRefTy = builder.getRefType(eleTy); mlir::Value arrayOp = builder.create( loc, eleRefTy, arrLd, iters.iterVec(), arrLdTypeParams); if (auto charTy = eleTy.dyn_cast()) { llvm::SmallVector substringBounds; populateBounds(substringBounds, components.substring); if (!substringBounds.empty()) { mlir::Value dstLen = fir::factory::genLenOfCharacter( builder, loc, arrLoad, iters.iterVec(), substringBounds); fir::CharBoxValue dstChar(arrayOp, dstLen); return fir::factory::CharacterExprHelper{builder, loc} .createSubstring(dstChar, substringBounds); } } return fir::factory::arraySectionElementToExtendedValue( builder, loc, extMemref, arrayOp, slice); } auto arrFetch = builder.create( loc, eleTy, arrLd, iters.iterVec(), arrLdTypeParams); return fir::factory::arraySectionElementToExtendedValue( builder, loc, extMemref, arrFetch, slice); }; } /// 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 absentBoxToUnalllocatedBox(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(boxType.isa() && "argument must be a fir.box"); mlir::Value emptyBox = fir::factory::createUnallocatedBox(builder, loc, boxType, llvm::None); auto safeToReadBox = builder.create(loc, isPresent, box, emptyBox); return fir::substBase(exv, safeToReadBox); } std::tuple genOptionalArrayFetch(const Fortran::lower::SomeExpr &expr) { assert(expr.Rank() > 0 && "expr must be an array"); mlir::Location loc = getLoc(); ExtValue optionalArg = asInquired(expr); mlir::Value isPresent = genActualIsPresentTest(builder, loc, optionalArg); // Generate an array load and access to an array that may be an absent // optional or an unallocated optional. mlir::Value base = getBase(optionalArg); const bool hasOptionalAttr = fir::valueHasFirAttribute(base, fir::getOptionalAttrName()); mlir::Type baseType = fir::unwrapRefType(base.getType()); const bool isBox = baseType.isa(); const bool isAllocOrPtr = Fortran::evaluate::IsAllocatableOrPointerObject( expr, converter.getFoldingContext()); mlir::Type arrType = fir::unwrapPassByRefType(baseType); mlir::Type eleType = fir::unwrapSequenceType(arrType); ExtValue exv = optionalArg; if (hasOptionalAttr && isBox && !isAllocOrPtr) { // Elemental argument cannot be allocatable or pointers (C15100). // Hence, per 15.5.2.12 3 (8) and (9), the provided Allocatable and // Pointer optional arrays cannot be absent. The only kind of entities // that can get here are optional assumed shape and polymorphic entities. exv = absentBoxToUnalllocatedBox(builder, loc, exv, isPresent); } // All the properties can be read from any fir.box but the read values may // be undefined and should only be used inside a fir.if (canBeRead) region. if (const auto *mutableBox = exv.getBoxOf()) exv = fir::factory::genMutableBoxRead(builder, loc, *mutableBox); mlir::Value memref = fir::getBase(exv); mlir::Value shape = builder.createShape(loc, exv); mlir::Value noSlice; auto arrLoad = builder.create( loc, arrType, memref, shape, noSlice, fir::getTypeParams(exv)); mlir::Operation::operand_range arrLdTypeParams = arrLoad.getTypeparams(); mlir::Value arrLd = arrLoad.getResult(); // Mark the load to tell later passes it is unsafe to use this array_load // shape unconditionally. arrLoad->setAttr(fir::getOptionalAttrName(), builder.getUnitAttr()); // Place the array as optional on the arrayOperands stack so that its // shape will only be used as a fallback to induce the implicit loop nest // (that is if there is no non optional array arguments). arrayOperands.push_back( ArrayOperand{memref, shape, noSlice, /*mayBeAbsent=*/true}); // By value semantics. auto cc = [=](IterSpace iters) -> ExtValue { auto arrFetch = builder.create( loc, eleType, arrLd, iters.iterVec(), arrLdTypeParams); return fir::factory::arraySectionElementToExtendedValue( builder, loc, exv, arrFetch, noSlice); }; return {cc, isPresent, eleType}; } /// Generate a continuation to pass \p expr to an OPTIONAL argument of an /// elemental procedure. This is meant to handle the cases where \p expr might /// be dynamically absent (i.e. when it is a POINTER, an ALLOCATABLE or an /// OPTIONAL variable). If p\ expr is guaranteed to be present genarr() can /// directly be called instead. CC genarrForwardOptionalArgumentToCall(const Fortran::lower::SomeExpr &expr) { mlir::Location loc = getLoc(); // Only by-value numerical and logical so far. if (semant != ConstituentSemantics::RefTransparent) TODO(loc, "optional arguments in user defined elemental procedures"); // Handle scalar argument case (the if-then-else is generated outside of the // implicit loop nest). if (expr.Rank() == 0) { ExtValue optionalArg = asInquired(expr); mlir::Value isPresent = genActualIsPresentTest(builder, loc, optionalArg); mlir::Value elementValue = fir::getBase(genOptionalValue(builder, loc, optionalArg, isPresent)); return [=](IterSpace iters) -> ExtValue { return elementValue; }; } CC cc; mlir::Value isPresent; mlir::Type eleType; std::tie(cc, isPresent, eleType) = genOptionalArrayFetch(expr); return [=](IterSpace iters) -> ExtValue { mlir::Value elementValue = builder .genIfOp(loc, {eleType}, isPresent, /*withElseRegion=*/true) .genThen([&]() { builder.create(loc, fir::getBase(cc(iters))); }) .genElse([&]() { mlir::Value zero = fir::factory::createZeroValue(builder, loc, eleType); builder.create(loc, zero); }) .getResults()[0]; return elementValue; }; } /// Reduce the rank of a array to be boxed based on the slice's operands. static mlir::Type reduceRank(mlir::Type arrTy, mlir::Value slice) { if (slice) { auto slOp = mlir::dyn_cast(slice.getDefiningOp()); assert(slOp && "expected slice op"); auto seqTy = arrTy.dyn_cast(); assert(seqTy && "expected array type"); mlir::Operation::operand_range triples = slOp.getTriples(); fir::SequenceType::Shape shape; // reduce the rank for each invariant dimension for (unsigned i = 1, end = triples.size(); i < end; i += 3) if (!mlir::isa_and_nonnull(triples[i].getDefiningOp())) shape.push_back(fir::SequenceType::getUnknownExtent()); return fir::SequenceType::get(shape, seqTy.getEleTy()); } // not sliced, so no change in rank return arrTy; } /// Example: array%RE CC genarr(const Fortran::evaluate::ComplexPart &x, ComponentPath &components) { components.reversePath.push_back(&x); return genarr(x.complex(), components); } template CC genSlicePath(const A &x, ComponentPath &components) { return genarr(x, components); } CC genarr(const Fortran::evaluate::StaticDataObject::Pointer &, ComponentPath &components) { fir::emitFatalError(getLoc(), "substring of static array object"); } /// Substrings (see 9.4.1) CC genarr(const Fortran::evaluate::Substring &x, ComponentPath &components) { components.substring = &x; return std::visit([&](const auto &v) { return genarr(v, components); }, x.parent()); } template CC genarr(const Fortran::evaluate::FunctionRef &funRef) { // Note that it's possible that the function being called returns either an // array or a scalar. In the first case, use the element type of the array. return genProcRef( funRef, fir::unwrapSequenceType(converter.genType(toEvExpr(funRef)))); } //===--------------------------------------------------------------------===// // Array construction //===--------------------------------------------------------------------===// /// Target agnostic computation of the size of an element in the array. /// Returns the size in bytes with type `index` or a null Value if the element /// size is not constant. mlir::Value computeElementSize(const ExtValue &exv, mlir::Type eleTy, mlir::Type resTy) { mlir::Location loc = getLoc(); mlir::IndexType idxTy = builder.getIndexType(); mlir::Value multiplier = builder.createIntegerConstant(loc, idxTy, 1); if (fir::hasDynamicSize(eleTy)) { if (auto charTy = eleTy.dyn_cast()) { // Array of char with dynamic length parameter. Downcast to an array // of singleton char, and scale by the len type parameter from // `exv`. exv.match( [&](const fir::CharBoxValue &cb) { multiplier = cb.getLen(); }, [&](const fir::CharArrayBoxValue &cb) { multiplier = cb.getLen(); }, [&](const fir::BoxValue &box) { multiplier = fir::factory::CharacterExprHelper(builder, loc) .readLengthFromBox(box.getAddr()); }, [&](const fir::MutableBoxValue &box) { multiplier = fir::factory::CharacterExprHelper(builder, loc) .readLengthFromBox(box.getAddr()); }, [&](const auto &) { fir::emitFatalError(loc, "array constructor element has unknown size"); }); fir::CharacterType newEleTy = fir::CharacterType::getSingleton( eleTy.getContext(), charTy.getFKind()); if (auto seqTy = resTy.dyn_cast()) { assert(eleTy == seqTy.getEleTy()); resTy = fir::SequenceType::get(seqTy.getShape(), newEleTy); } eleTy = newEleTy; } else { TODO(loc, "dynamic sized type"); } } mlir::Type eleRefTy = builder.getRefType(eleTy); mlir::Type resRefTy = builder.getRefType(resTy); mlir::Value nullPtr = builder.createNullConstant(loc, resRefTy); auto offset = builder.create( loc, eleRefTy, nullPtr, mlir::ValueRange{multiplier}); return builder.createConvert(loc, idxTy, offset); } /// Get the function signature of the LLVM memcpy intrinsic. mlir::FunctionType memcpyType() { return fir::factory::getLlvmMemcpy(builder).getFunctionType(); } /// Create a call to the LLVM memcpy intrinsic. void createCallMemcpy(llvm::ArrayRef args) { mlir::Location loc = getLoc(); mlir::func::FuncOp memcpyFunc = fir::factory::getLlvmMemcpy(builder); mlir::SymbolRefAttr funcSymAttr = builder.getSymbolRefAttr(memcpyFunc.getName()); mlir::FunctionType funcTy = memcpyFunc.getFunctionType(); builder.create(loc, funcTy.getResults(), funcSymAttr, args); } // Construct code to check for a buffer overrun and realloc the buffer when // space is depleted. This is done between each item in the ac-value-list. mlir::Value growBuffer(mlir::Value mem, mlir::Value needed, mlir::Value bufferSize, mlir::Value buffSize, mlir::Value eleSz) { mlir::Location loc = getLoc(); mlir::func::FuncOp reallocFunc = fir::factory::getRealloc(builder); auto cond = builder.create( loc, mlir::arith::CmpIPredicate::sle, bufferSize, needed); auto ifOp = builder.create(loc, mem.getType(), cond, /*withElseRegion=*/true); auto insPt = builder.saveInsertionPoint(); builder.setInsertionPointToStart(&ifOp.getThenRegion().front()); // Not enough space, resize the buffer. mlir::IndexType idxTy = builder.getIndexType(); mlir::Value two = builder.createIntegerConstant(loc, idxTy, 2); auto newSz = builder.create(loc, needed, two); builder.create(loc, newSz, buffSize); mlir::Value byteSz = builder.create(loc, newSz, eleSz); mlir::SymbolRefAttr funcSymAttr = builder.getSymbolRefAttr(reallocFunc.getName()); mlir::FunctionType funcTy = reallocFunc.getFunctionType(); auto newMem = builder.create( loc, funcTy.getResults(), funcSymAttr, llvm::ArrayRef{ builder.createConvert(loc, funcTy.getInputs()[0], mem), builder.createConvert(loc, funcTy.getInputs()[1], byteSz)}); mlir::Value castNewMem = builder.createConvert(loc, mem.getType(), newMem.getResult(0)); builder.create(loc, castNewMem); builder.setInsertionPointToStart(&ifOp.getElseRegion().front()); // Otherwise, just forward the buffer. builder.create(loc, mem); builder.restoreInsertionPoint(insPt); return ifOp.getResult(0); } /// Copy the next value (or vector of values) into the array being /// constructed. mlir::Value copyNextArrayCtorSection(const ExtValue &exv, mlir::Value buffPos, mlir::Value buffSize, mlir::Value mem, mlir::Value eleSz, mlir::Type eleTy, mlir::Type eleRefTy, mlir::Type resTy) { mlir::Location loc = getLoc(); auto off = builder.create(loc, buffPos); auto limit = builder.create(loc, buffSize); mlir::IndexType idxTy = builder.getIndexType(); mlir::Value one = builder.createIntegerConstant(loc, idxTy, 1); if (fir::isRecordWithAllocatableMember(eleTy)) TODO(loc, "deep copy on allocatable members"); if (!eleSz) { // Compute the element size at runtime. assert(fir::hasDynamicSize(eleTy)); if (auto charTy = eleTy.dyn_cast()) { auto charBytes = builder.getKindMap().getCharacterBitsize(charTy.getFKind()) / 8; mlir::Value bytes = builder.createIntegerConstant(loc, idxTy, charBytes); mlir::Value length = fir::getLen(exv); if (!length) fir::emitFatalError(loc, "result is not boxed character"); eleSz = builder.create(loc, bytes, length); } else { TODO(loc, "PDT size"); // Will call the PDT's size function with the type parameters. } } // Compute the coordinate using `fir.coordinate_of`, or, if the type has // dynamic size, generating the pointer arithmetic. auto computeCoordinate = [&](mlir::Value buff, mlir::Value off) { mlir::Type refTy = eleRefTy; if (fir::hasDynamicSize(eleTy)) { if (auto charTy = eleTy.dyn_cast()) { // Scale a simple pointer using dynamic length and offset values. auto chTy = fir::CharacterType::getSingleton(charTy.getContext(), charTy.getFKind()); refTy = builder.getRefType(chTy); mlir::Type toTy = builder.getRefType(builder.getVarLenSeqTy(chTy)); buff = builder.createConvert(loc, toTy, buff); off = builder.create(loc, off, eleSz); } else { TODO(loc, "PDT offset"); } } auto coor = builder.create(loc, refTy, buff, mlir::ValueRange{off}); return builder.createConvert(loc, eleRefTy, coor); }; // Lambda to lower an abstract array box value. auto doAbstractArray = [&](const auto &v) { // Compute the array size. mlir::Value arrSz = one; for (auto ext : v.getExtents()) arrSz = builder.create(loc, arrSz, ext); // Grow the buffer as needed. auto endOff = builder.create(loc, off, arrSz); mem = growBuffer(mem, endOff, limit, buffSize, eleSz); // Copy the elements to the buffer. mlir::Value byteSz = builder.create(loc, arrSz, eleSz); auto buff = builder.createConvert(loc, fir::HeapType::get(resTy), mem); mlir::Value buffi = computeCoordinate(buff, off); llvm::SmallVector args = fir::runtime::createArguments( builder, loc, memcpyType(), buffi, v.getAddr(), byteSz, /*volatile=*/builder.createBool(loc, false)); createCallMemcpy(args); // Save the incremented buffer position. builder.create(loc, endOff, buffPos); }; // Copy a trivial scalar value into the buffer. auto doTrivialScalar = [&](const ExtValue &v, mlir::Value len = {}) { // Increment the buffer position. auto plusOne = builder.create(loc, off, one); // Grow the buffer as needed. mem = growBuffer(mem, plusOne, limit, buffSize, eleSz); // Store the element in the buffer. mlir::Value buff = builder.createConvert(loc, fir::HeapType::get(resTy), mem); auto buffi = builder.create(loc, eleRefTy, buff, mlir::ValueRange{off}); fir::factory::genScalarAssignment( builder, loc, [&]() -> ExtValue { if (len) return fir::CharBoxValue(buffi, len); return buffi; }(), v); builder.create(loc, plusOne, buffPos); }; // Copy the value. exv.match( [&](mlir::Value) { doTrivialScalar(exv); }, [&](const fir::CharBoxValue &v) { auto buffer = v.getBuffer(); if (fir::isa_char(buffer.getType())) { doTrivialScalar(exv, eleSz); } else { // Increment the buffer position. auto plusOne = builder.create(loc, off, one); // Grow the buffer as needed. mem = growBuffer(mem, plusOne, limit, buffSize, eleSz); // Store the element in the buffer. mlir::Value buff = builder.createConvert(loc, fir::HeapType::get(resTy), mem); mlir::Value buffi = computeCoordinate(buff, off); llvm::SmallVector args = fir::runtime::createArguments( builder, loc, memcpyType(), buffi, v.getAddr(), eleSz, /*volatile=*/builder.createBool(loc, false)); createCallMemcpy(args); builder.create(loc, plusOne, buffPos); } }, [&](const fir::ArrayBoxValue &v) { doAbstractArray(v); }, [&](const fir::CharArrayBoxValue &v) { doAbstractArray(v); }, [&](const auto &) { TODO(loc, "unhandled array constructor expression"); }); return mem; } // Lower the expr cases in an ac-value-list. template std::pair genArrayCtorInitializer(const Fortran::evaluate::Expr &x, mlir::Type, mlir::Value, mlir::Value, mlir::Value, Fortran::lower::StatementContext &stmtCtx) { if (isArray(x)) return {lowerNewArrayExpression(converter, symMap, stmtCtx, toEvExpr(x)), /*needCopy=*/true}; return {asScalar(x), /*needCopy=*/true}; } // Lower an ac-implied-do in an ac-value-list. template std::pair genArrayCtorInitializer(const Fortran::evaluate::ImpliedDo &x, mlir::Type resTy, mlir::Value mem, mlir::Value buffPos, mlir::Value buffSize, Fortran::lower::StatementContext &) { mlir::Location loc = getLoc(); mlir::IndexType idxTy = builder.getIndexType(); mlir::Value lo = builder.createConvert(loc, idxTy, fir::getBase(asScalar(x.lower()))); mlir::Value up = builder.createConvert(loc, idxTy, fir::getBase(asScalar(x.upper()))); mlir::Value step = builder.createConvert(loc, idxTy, fir::getBase(asScalar(x.stride()))); auto seqTy = resTy.template cast(); mlir::Type eleTy = fir::unwrapSequenceType(seqTy); auto loop = builder.create(loc, lo, up, step, /*unordered=*/false, /*finalCount=*/false, mem); // create a new binding for x.name(), to ac-do-variable, to the iteration // value. symMap.pushImpliedDoBinding(toStringRef(x.name()), loop.getInductionVar()); auto insPt = builder.saveInsertionPoint(); builder.setInsertionPointToStart(loop.getBody()); // Thread mem inside the loop via loop argument. mem = loop.getRegionIterArgs()[0]; mlir::Type eleRefTy = builder.getRefType(eleTy); // Any temps created in the loop body must be freed inside the loop body. stmtCtx.pushScope(); llvm::Optional charLen; for (const Fortran::evaluate::ArrayConstructorValue &acv : x.values()) { auto [exv, copyNeeded] = std::visit( [&](const auto &v) { return genArrayCtorInitializer(v, resTy, mem, buffPos, buffSize, stmtCtx); }, acv.u); mlir::Value eleSz = computeElementSize(exv, eleTy, resTy); mem = copyNeeded ? copyNextArrayCtorSection(exv, buffPos, buffSize, mem, eleSz, eleTy, eleRefTy, resTy) : fir::getBase(exv); if (fir::isa_char(seqTy.getEleTy()) && !charLen) { charLen = builder.createTemporary(loc, builder.getI64Type()); mlir::Value castLen = builder.createConvert(loc, builder.getI64Type(), fir::getLen(exv)); builder.create(loc, castLen, charLen.value()); } } stmtCtx.finalize(/*popScope=*/true); builder.create(loc, mem); builder.restoreInsertionPoint(insPt); mem = loop.getResult(0); symMap.popImpliedDoBinding(); llvm::SmallVector extents = { builder.create(loc, buffPos).getResult()}; // Convert to extended value. if (fir::isa_char(seqTy.getEleTy())) { auto len = builder.create(loc, charLen.value()); return {fir::CharArrayBoxValue{mem, len, extents}, /*needCopy=*/false}; } return {fir::ArrayBoxValue{mem, extents}, /*needCopy=*/false}; } // To simplify the handling and interaction between the various cases, array // constructors are always lowered to the incremental construction code // pattern, even if the extent of the array value is constant. After the // MemToReg pass and constant folding, the optimizer should be able to // determine that all the buffer overrun tests are false when the // incremental construction wasn't actually required. template CC genarr(const Fortran::evaluate::ArrayConstructor &x) { mlir::Location loc = getLoc(); auto evExpr = toEvExpr(x); mlir::Type resTy = translateSomeExprToFIRType(converter, evExpr); mlir::IndexType idxTy = builder.getIndexType(); auto seqTy = resTy.template cast(); mlir::Type eleTy = fir::unwrapSequenceType(resTy); mlir::Value buffSize = builder.createTemporary(loc, idxTy, ".buff.size"); mlir::Value zero = builder.createIntegerConstant(loc, idxTy, 0); mlir::Value buffPos = builder.createTemporary(loc, idxTy, ".buff.pos"); builder.create(loc, zero, buffPos); // Allocate space for the array to be constructed. mlir::Value mem; if (fir::hasDynamicSize(resTy)) { if (fir::hasDynamicSize(eleTy)) { // The size of each element may depend on a general expression. Defer // creating the buffer until after the expression is evaluated. mem = builder.createNullConstant(loc, builder.getRefType(eleTy)); builder.create(loc, zero, buffSize); } else { mlir::Value initBuffSz = builder.createIntegerConstant(loc, idxTy, clInitialBufferSize); mem = builder.create( loc, eleTy, /*typeparams=*/llvm::None, initBuffSz); builder.create(loc, initBuffSz, buffSize); } } else { mem = builder.create(loc, resTy); int64_t buffSz = 1; for (auto extent : seqTy.getShape()) buffSz *= extent; mlir::Value initBuffSz = builder.createIntegerConstant(loc, idxTy, buffSz); builder.create(loc, initBuffSz, buffSize); } // Compute size of element mlir::Type eleRefTy = builder.getRefType(eleTy); // Populate the buffer with the elements, growing as necessary. llvm::Optional charLen; for (const auto &expr : x) { auto [exv, copyNeeded] = std::visit( [&](const auto &e) { return genArrayCtorInitializer(e, resTy, mem, buffPos, buffSize, stmtCtx); }, expr.u); mlir::Value eleSz = computeElementSize(exv, eleTy, resTy); mem = copyNeeded ? copyNextArrayCtorSection(exv, buffPos, buffSize, mem, eleSz, eleTy, eleRefTy, resTy) : fir::getBase(exv); if (fir::isa_char(seqTy.getEleTy()) && !charLen) { charLen = builder.createTemporary(loc, builder.getI64Type()); mlir::Value castLen = builder.createConvert(loc, builder.getI64Type(), fir::getLen(exv)); builder.create(loc, castLen, charLen.value()); } } mem = builder.createConvert(loc, fir::HeapType::get(resTy), mem); llvm::SmallVector extents = { builder.create(loc, buffPos)}; // Cleanup the temporary. fir::FirOpBuilder *bldr = &converter.getFirOpBuilder(); stmtCtx.attachCleanup( [bldr, loc, mem]() { bldr->create(loc, mem); }); // Return the continuation. if (fir::isa_char(seqTy.getEleTy())) { if (charLen.hasValue()) { auto len = builder.create(loc, charLen.getValue()); return genarr(fir::CharArrayBoxValue{mem, len, extents}); } return genarr(fir::CharArrayBoxValue{mem, zero, extents}); } return genarr(fir::ArrayBoxValue{mem, extents}); } CC genarr(const Fortran::evaluate::ImpliedDoIndex &) { fir::emitFatalError(getLoc(), "implied do index cannot have rank > 0"); } CC genarr(const Fortran::evaluate::TypeParamInquiry &x) { TODO(getLoc(), "array expr type parameter inquiry"); return [](IterSpace iters) -> ExtValue { return mlir::Value{}; }; } CC genarr(const Fortran::evaluate::DescriptorInquiry &x) { TODO(getLoc(), "array expr descriptor inquiry"); return [](IterSpace iters) -> ExtValue { return mlir::Value{}; }; } CC genarr(const Fortran::evaluate::StructureConstructor &x) { TODO(getLoc(), "structure constructor"); return [](IterSpace iters) -> ExtValue { return mlir::Value{}; }; } //===--------------------------------------------------------------------===// // LOCICAL operators (.NOT., .AND., .EQV., etc.) //===--------------------------------------------------------------------===// template CC genarr(const Fortran::evaluate::Not &x) { mlir::Location loc = getLoc(); mlir::IntegerType i1Ty = builder.getI1Type(); auto lambda = genarr(x.left()); mlir::Value truth = builder.createBool(loc, true); return [=](IterSpace iters) -> ExtValue { mlir::Value logical = fir::getBase(lambda(iters)); mlir::Value val = builder.createConvert(loc, i1Ty, logical); return builder.create(loc, val, truth); }; } template CC createBinaryBoolOp(const A &x) { mlir::Location loc = getLoc(); mlir::IntegerType i1Ty = builder.getI1Type(); auto lf = genarr(x.left()); auto rf = genarr(x.right()); return [=](IterSpace iters) -> ExtValue { mlir::Value left = fir::getBase(lf(iters)); mlir::Value right = fir::getBase(rf(iters)); mlir::Value lhs = builder.createConvert(loc, i1Ty, left); mlir::Value rhs = builder.createConvert(loc, i1Ty, right); return builder.create(loc, lhs, rhs); }; } template CC createCompareBoolOp(mlir::arith::CmpIPredicate pred, const A &x) { mlir::Location loc = getLoc(); mlir::IntegerType i1Ty = builder.getI1Type(); auto lf = genarr(x.left()); auto rf = genarr(x.right()); return [=](IterSpace iters) -> ExtValue { mlir::Value left = fir::getBase(lf(iters)); mlir::Value right = fir::getBase(rf(iters)); mlir::Value lhs = builder.createConvert(loc, i1Ty, left); mlir::Value rhs = builder.createConvert(loc, i1Ty, right); return builder.create(loc, pred, lhs, rhs); }; } template CC genarr(const Fortran::evaluate::LogicalOperation &x) { switch (x.logicalOperator) { case Fortran::evaluate::LogicalOperator::And: return createBinaryBoolOp(x); case Fortran::evaluate::LogicalOperator::Or: return createBinaryBoolOp(x); case Fortran::evaluate::LogicalOperator::Eqv: return createCompareBoolOp( mlir::arith::CmpIPredicate::eq, x); case Fortran::evaluate::LogicalOperator::Neqv: return createCompareBoolOp( mlir::arith::CmpIPredicate::ne, x); case Fortran::evaluate::LogicalOperator::Not: llvm_unreachable(".NOT. handled elsewhere"); } llvm_unreachable("unhandled case"); } //===--------------------------------------------------------------------===// // Relational operators (<, <=, ==, etc.) //===--------------------------------------------------------------------===// template CC createCompareOp(PRED pred, const A &x) { mlir::Location loc = getLoc(); auto lf = genarr(x.left()); auto rf = genarr(x.right()); return [=](IterSpace iters) -> ExtValue { mlir::Value lhs = fir::getBase(lf(iters)); mlir::Value rhs = fir::getBase(rf(iters)); return builder.create(loc, pred, lhs, rhs); }; } template CC createCompareCharOp(mlir::arith::CmpIPredicate pred, const A &x) { mlir::Location loc = getLoc(); auto lf = genarr(x.left()); auto rf = genarr(x.right()); return [=](IterSpace iters) -> ExtValue { auto lhs = lf(iters); auto rhs = rf(iters); return fir::runtime::genCharCompare(builder, loc, pred, lhs, rhs); }; } template CC genarr(const Fortran::evaluate::Relational> &x) { return createCompareOp(translateRelational(x.opr), x); } template CC genarr(const Fortran::evaluate::Relational> &x) { return createCompareCharOp(translateRelational(x.opr), x); } template CC genarr(const Fortran::evaluate::Relational> &x) { return createCompareOp(translateFloatRelational(x.opr), x); } template CC genarr(const Fortran::evaluate::Relational> &x) { return createCompareOp(translateFloatRelational(x.opr), x); } CC genarr( const Fortran::evaluate::Relational &r) { return std::visit([&](const auto &x) { return genarr(x); }, r.u); } template CC genarr(const Fortran::evaluate::Designator &des) { ComponentPath components(des.Rank() > 0); return std::visit([&](const auto &x) { return genarr(x, components); }, des.u); } /// Is the path component rank > 0? static bool ranked(const PathComponent &x) { return std::visit(Fortran::common::visitors{ [](const ImplicitSubscripts &) { return false; }, [](const auto *v) { return v->Rank() > 0; }}, x); } void extendComponent(Fortran::lower::ComponentPath &component, mlir::Type coorTy, mlir::ValueRange vals) { auto *bldr = &converter.getFirOpBuilder(); llvm::SmallVector offsets(vals.begin(), vals.end()); auto currentFunc = component.getExtendCoorRef(); auto loc = getLoc(); auto newCoorRef = [bldr, coorTy, offsets, currentFunc, loc](mlir::Value val) -> mlir::Value { return bldr->create(loc, bldr->getRefType(coorTy), currentFunc(val), offsets); }; component.extendCoorRef = newCoorRef; } //===-------------------------------------------------------------------===// // Array data references in an explicit iteration space. // // Use the base array that was loaded before the loop nest. //===-------------------------------------------------------------------===// /// Lower the path (`revPath`, in reverse) to be appended to an array_fetch or /// array_update op. \p ty is the initial type of the array /// (reference). Returns the type of the element after application of the /// path in \p components. /// /// TODO: This needs to deal with array's with initial bounds other than 1. /// TODO: Thread type parameters correctly. mlir::Type lowerPath(const ExtValue &arrayExv, ComponentPath &components) { mlir::Location loc = getLoc(); mlir::Type ty = fir::getBase(arrayExv).getType(); auto &revPath = components.reversePath; ty = fir::unwrapPassByRefType(ty); bool prefix = true; bool deref = false; auto addComponentList = [&](mlir::Type ty, mlir::ValueRange vals) { if (deref) { extendComponent(components, ty, vals); } else if (prefix) { for (auto v : vals) components.prefixComponents.push_back(v); } else { for (auto v : vals) components.suffixComponents.push_back(v); } }; mlir::IndexType idxTy = builder.getIndexType(); mlir::Value one = builder.createIntegerConstant(loc, idxTy, 1); bool atBase = true; auto saveSemant = semant; if (isProjectedCopyInCopyOut()) semant = ConstituentSemantics::RefTransparent; unsigned index = 0; for (const auto &v : llvm::reverse(revPath)) { std::visit( Fortran::common::visitors{ [&](const ImplicitSubscripts &) { prefix = false; ty = fir::unwrapSequenceType(ty); }, [&](const Fortran::evaluate::ComplexPart *x) { assert(!prefix && "complex part must be at end"); mlir::Value offset = builder.createIntegerConstant( loc, builder.getI32Type(), x->part() == Fortran::evaluate::ComplexPart::Part::RE ? 0 : 1); components.suffixComponents.push_back(offset); ty = fir::applyPathToType(ty, mlir::ValueRange{offset}); }, [&](const Fortran::evaluate::ArrayRef *x) { if (Fortran::lower::isRankedArrayAccess(*x)) { genSliceIndices(components, arrayExv, *x, atBase); ty = fir::unwrapSeqOrBoxedSeqType(ty); } else { // Array access where the expressions are scalar and cannot // depend upon the implied iteration space. unsigned ssIndex = 0u; llvm::SmallVector componentsToAdd; for (const auto &ss : x->subscript()) { std::visit( Fortran::common::visitors{ [&](const Fortran::evaluate:: IndirectSubscriptIntegerExpr &ie) { const auto &e = ie.value(); if (isArray(e)) fir::emitFatalError( loc, "multiple components along single path " "generating array subexpressions"); // Lower scalar index expression, append it to // subs. mlir::Value subscriptVal = fir::getBase(asScalarArray(e)); // arrayExv is the base array. It needs to reflect // the current array component instead. // FIXME: must use lower bound of this component, // not just the constant 1. mlir::Value lb = atBase ? fir::factory::readLowerBound( builder, loc, arrayExv, ssIndex, one) : one; mlir::Value val = builder.createConvert( loc, idxTy, subscriptVal); mlir::Value ivAdj = builder.create( loc, idxTy, val, lb); componentsToAdd.push_back( builder.createConvert(loc, idxTy, ivAdj)); }, [&](const auto &) { fir::emitFatalError( loc, "multiple components along single path " "generating array subexpressions"); }}, ss.u); ssIndex++; } ty = fir::unwrapSeqOrBoxedSeqType(ty); addComponentList(ty, componentsToAdd); } }, [&](const Fortran::evaluate::Component *x) { auto fieldTy = fir::FieldType::get(builder.getContext()); llvm::StringRef name = toStringRef(getLastSym(*x).name()); if (auto recTy = ty.dyn_cast()) { ty = recTy.getType(name); auto fld = builder.create( loc, fieldTy, name, recTy, fir::getTypeParams(arrayExv)); addComponentList(ty, {fld}); if (index != revPath.size() - 1 || !isPointerAssignment()) { // Need an intermediate dereference if the boxed value // appears in the middle of the component path or if it is // on the right and this is not a pointer assignment. if (auto boxTy = ty.dyn_cast()) { auto currentFunc = components.getExtendCoorRef(); auto loc = getLoc(); auto *bldr = &converter.getFirOpBuilder(); auto newCoorRef = [=](mlir::Value val) -> mlir::Value { return bldr->create(loc, currentFunc(val)); }; components.extendCoorRef = newCoorRef; deref = true; } } } else if (auto boxTy = ty.dyn_cast()) { ty = fir::unwrapRefType(boxTy.getEleTy()); auto recTy = ty.cast(); ty = recTy.getType(name); auto fld = builder.create( loc, fieldTy, name, recTy, fir::getTypeParams(arrayExv)); extendComponent(components, ty, {fld}); } else { TODO(loc, "other component type"); } }}, v); atBase = false; ++index; } semant = saveSemant; ty = fir::unwrapSequenceType(ty); components.applied = true; return ty; } llvm::SmallVector genSubstringBounds(ComponentPath &components) { llvm::SmallVector result; if (components.substring) populateBounds(result, components.substring); return result; } CC applyPathToArrayLoad(fir::ArrayLoadOp load, ComponentPath &components) { mlir::Location loc = getLoc(); auto revPath = components.reversePath; fir::ExtendedValue arrayExv = arrayLoadExtValue(builder, loc, load, {}, load); mlir::Type eleTy = lowerPath(arrayExv, components); auto currentPC = components.pc; auto pc = [=, prefix = components.prefixComponents, suffix = components.suffixComponents](IterSpace iters) { // Add path prefix and suffix. return IterationSpace(currentPC(iters), prefix, suffix); }; components.resetPC(); llvm::SmallVector substringBounds = genSubstringBounds(components); if (isProjectedCopyInCopyOut()) { destination = load; auto lambda = [=, esp = this->explicitSpace](IterSpace iters) mutable { mlir::Value innerArg = esp->findArgumentOfLoad(load); if (isAdjustedArrayElementType(eleTy)) { mlir::Type eleRefTy = builder.getRefType(eleTy); auto arrayOp = builder.create( loc, eleRefTy, innerArg, iters.iterVec(), load.getTypeparams()); if (auto charTy = eleTy.dyn_cast()) { mlir::Value dstLen = fir::factory::genLenOfCharacter( builder, loc, load, iters.iterVec(), substringBounds); fir::ArrayAmendOp amend = createCharArrayAmend( loc, builder, arrayOp, dstLen, iters.elementExv(), innerArg, substringBounds); return arrayLoadExtValue(builder, loc, load, iters.iterVec(), amend, dstLen); } if (fir::isa_derived(eleTy)) { fir::ArrayAmendOp amend = createDerivedArrayAmend(loc, load, builder, arrayOp, iters.elementExv(), eleTy, innerArg); return arrayLoadExtValue(builder, loc, load, iters.iterVec(), amend); } assert(eleTy.isa()); TODO(loc, "array (as element) assignment"); } if (components.hasExtendCoorRef()) { auto eleBoxTy = fir::applyPathToType(innerArg.getType(), iters.iterVec()); assert(eleBoxTy && eleBoxTy.isa()); auto arrayOp = builder.create( loc, builder.getRefType(eleBoxTy), innerArg, iters.iterVec(), fir::factory::getTypeParams(loc, builder, load)); mlir::Value addr = components.getExtendCoorRef()(arrayOp); components.resetExtendCoorRef(); // When the lhs is a boxed value and the context is not a pointer // assignment, then insert the dereference of the box before any // conversion and store. if (!isPointerAssignment()) { if (auto boxTy = eleTy.dyn_cast()) { eleTy = boxTy.getEleTy(); if (!(eleTy.isa() || eleTy.isa())) eleTy = builder.getRefType(eleTy); addr = builder.create(loc, eleTy, addr); eleTy = fir::unwrapRefType(eleTy); } } auto ele = convertElementForUpdate(loc, eleTy, iters.getElement()); builder.create(loc, ele, addr); auto amend = builder.create( loc, innerArg.getType(), innerArg, arrayOp); return arrayLoadExtValue(builder, loc, load, iters.iterVec(), amend); } auto ele = convertElementForUpdate(loc, eleTy, iters.getElement()); auto update = builder.create( loc, innerArg.getType(), innerArg, ele, iters.iterVec(), fir::factory::getTypeParams(loc, builder, load)); return arrayLoadExtValue(builder, loc, load, iters.iterVec(), update); }; return [=](IterSpace iters) mutable { return lambda(pc(iters)); }; } if (isCustomCopyInCopyOut()) { // Create an array_modify to get the LHS element address and indicate // the assignment, and create the call to the user defined assignment. destination = load; auto lambda = [=](IterSpace iters) mutable { mlir::Value innerArg = explicitSpace->findArgumentOfLoad(load); mlir::Type refEleTy = fir::isa_ref_type(eleTy) ? eleTy : builder.getRefType(eleTy); auto arrModify = builder.create( loc, mlir::TypeRange{refEleTy, innerArg.getType()}, innerArg, iters.iterVec(), load.getTypeparams()); return arrayLoadExtValue(builder, loc, load, iters.iterVec(), arrModify.getResult(1)); }; return [=](IterSpace iters) mutable { return lambda(pc(iters)); }; } auto lambda = [=, semant = this->semant](IterSpace iters) mutable { if (semant == ConstituentSemantics::RefOpaque || isAdjustedArrayElementType(eleTy)) { mlir::Type resTy = builder.getRefType(eleTy); // Use array element reference semantics. auto access = builder.create( loc, resTy, load, iters.iterVec(), load.getTypeparams()); mlir::Value newBase = access; if (fir::isa_char(eleTy)) { mlir::Value dstLen = fir::factory::genLenOfCharacter( builder, loc, load, iters.iterVec(), substringBounds); if (!substringBounds.empty()) { fir::CharBoxValue charDst{access, dstLen}; fir::factory::CharacterExprHelper helper{builder, loc}; charDst = helper.createSubstring(charDst, substringBounds); newBase = charDst.getAddr(); } return arrayLoadExtValue(builder, loc, load, iters.iterVec(), newBase, dstLen); } return arrayLoadExtValue(builder, loc, load, iters.iterVec(), newBase); } if (components.hasExtendCoorRef()) { auto eleBoxTy = fir::applyPathToType(load.getType(), iters.iterVec()); assert(eleBoxTy && eleBoxTy.isa()); auto access = builder.create( loc, builder.getRefType(eleBoxTy), load, iters.iterVec(), fir::factory::getTypeParams(loc, builder, load)); mlir::Value addr = components.getExtendCoorRef()(access); components.resetExtendCoorRef(); return arrayLoadExtValue(builder, loc, load, iters.iterVec(), addr); } if (isPointerAssignment()) { auto eleTy = fir::applyPathToType(load.getType(), iters.iterVec()); if (!eleTy.isa()) { // Rhs is a regular expression that will need to be boxed before // assigning to the boxed variable. auto typeParams = fir::factory::getTypeParams(loc, builder, load); auto access = builder.create( loc, builder.getRefType(eleTy), load, iters.iterVec(), typeParams); auto addr = components.getExtendCoorRef()(access); components.resetExtendCoorRef(); auto ptrEleTy = fir::PointerType::get(eleTy); auto ptrAddr = builder.createConvert(loc, ptrEleTy, addr); auto boxTy = fir::BoxType::get(ptrEleTy); // FIXME: The typeparams to the load may be different than those of // the subobject. if (components.hasExtendCoorRef()) TODO(loc, "need to adjust typeparameter(s) to reflect the final " "component"); mlir::Value embox = builder.create(loc, boxTy, ptrAddr, /*shape=*/mlir::Value{}, /*slice=*/mlir::Value{}, typeParams); return arrayLoadExtValue(builder, loc, load, iters.iterVec(), embox); } } auto fetch = builder.create( loc, eleTy, load, iters.iterVec(), load.getTypeparams()); return arrayLoadExtValue(builder, loc, load, iters.iterVec(), fetch); }; return [=](IterSpace iters) mutable { return lambda(pc(iters)); }; } template CC genImplicitArrayAccess(const A &x, ComponentPath &components) { components.reversePath.push_back(ImplicitSubscripts{}); ExtValue exv = asScalarRef(x); lowerPath(exv, components); auto lambda = genarr(exv, components); return [=](IterSpace iters) { return lambda(components.pc(iters)); }; } CC genImplicitArrayAccess(const Fortran::evaluate::NamedEntity &x, ComponentPath &components) { if (x.IsSymbol()) return genImplicitArrayAccess(getFirstSym(x), components); return genImplicitArrayAccess(x.GetComponent(), components); } template CC genAsScalar(const A &x) { mlir::Location loc = getLoc(); if (isProjectedCopyInCopyOut()) { return [=, &x, builder = &converter.getFirOpBuilder()]( IterSpace iters) -> ExtValue { ExtValue exv = asScalarRef(x); mlir::Value val = fir::getBase(exv); mlir::Type eleTy = fir::unwrapRefType(val.getType()); if (isAdjustedArrayElementType(eleTy)) { if (fir::isa_char(eleTy)) { fir::factory::CharacterExprHelper{*builder, loc}.createAssign( exv, iters.elementExv()); } else if (fir::isa_derived(eleTy)) { TODO(loc, "assignment of derived type"); } else { fir::emitFatalError(loc, "array type not expected in scalar"); } } else { builder->create(loc, iters.getElement(), val); } return exv; }; } return [=, &x](IterSpace) { return asScalar(x); }; } bool tailIsPointerInPointerAssignment(const Fortran::semantics::Symbol &x, ComponentPath &components) { return isPointerAssignment() && Fortran::semantics::IsPointer(x) && !components.hasComponents(); } bool tailIsPointerInPointerAssignment(const Fortran::evaluate::Component &x, ComponentPath &components) { return tailIsPointerInPointerAssignment(getLastSym(x), components); } CC genarr(const Fortran::semantics::Symbol &x, ComponentPath &components) { if (explicitSpaceIsActive()) { if (x.Rank() > 0 && !tailIsPointerInPointerAssignment(x, components)) components.reversePath.push_back(ImplicitSubscripts{}); if (fir::ArrayLoadOp load = explicitSpace->findBinding(&x)) return applyPathToArrayLoad(load, components); } else { return genImplicitArrayAccess(x, components); } if (pathIsEmpty(components)) return components.substring ? genAsScalar(*components.substring) : genAsScalar(x); mlir::Location loc = getLoc(); return [=](IterSpace) -> ExtValue { fir::emitFatalError(loc, "reached symbol with path"); }; } /// Lower a component path with or without rank. /// Example: array%baz%qux%waldo CC genarr(const Fortran::evaluate::Component &x, ComponentPath &components) { if (explicitSpaceIsActive()) { if (x.base().Rank() == 0 && x.Rank() > 0 && !tailIsPointerInPointerAssignment(x, components)) components.reversePath.push_back(ImplicitSubscripts{}); if (fir::ArrayLoadOp load = explicitSpace->findBinding(&x)) return applyPathToArrayLoad(load, components); } else { if (x.base().Rank() == 0) return genImplicitArrayAccess(x, components); } bool atEnd = pathIsEmpty(components); if (!getLastSym(x).test(Fortran::semantics::Symbol::Flag::ParentComp)) // Skip parent components; their components are placed directly in the // object. components.reversePath.push_back(&x); auto result = genarr(x.base(), components); if (components.applied) return result; if (atEnd) return genAsScalar(x); mlir::Location loc = getLoc(); return [=](IterSpace) -> ExtValue { fir::emitFatalError(loc, "reached component with path"); }; } /// Array reference with subscripts. If this has rank > 0, this is a form /// of an array section (slice). /// /// There are two "slicing" primitives that may be applied on a dimension by /// dimension basis: (1) triple notation and (2) vector addressing. Since /// dimensions can be selectively sliced, some dimensions may contain /// regular scalar expressions and those dimensions do not participate in /// the array expression evaluation. CC genarr(const Fortran::evaluate::ArrayRef &x, ComponentPath &components) { if (explicitSpaceIsActive()) { if (Fortran::lower::isRankedArrayAccess(x)) components.reversePath.push_back(ImplicitSubscripts{}); if (fir::ArrayLoadOp load = explicitSpace->findBinding(&x)) { components.reversePath.push_back(&x); return applyPathToArrayLoad(load, components); } } else { if (Fortran::lower::isRankedArrayAccess(x)) { components.reversePath.push_back(&x); return genImplicitArrayAccess(x.base(), components); } } bool atEnd = pathIsEmpty(components); components.reversePath.push_back(&x); auto result = genarr(x.base(), components); if (components.applied) return result; mlir::Location loc = getLoc(); if (atEnd) { if (x.Rank() == 0) return genAsScalar(x); fir::emitFatalError(loc, "expected scalar"); } return [=](IterSpace) -> ExtValue { fir::emitFatalError(loc, "reached arrayref with path"); }; } CC genarr(const Fortran::evaluate::CoarrayRef &x, ComponentPath &components) { TODO(getLoc(), "coarray reference"); } CC genarr(const Fortran::evaluate::NamedEntity &x, ComponentPath &components) { return x.IsSymbol() ? genarr(getFirstSym(x), components) : genarr(x.GetComponent(), components); } CC genarr(const Fortran::evaluate::DataRef &x, ComponentPath &components) { return std::visit([&](const auto &v) { return genarr(v, components); }, x.u); } bool pathIsEmpty(const ComponentPath &components) { return components.reversePath.empty(); } explicit ArrayExprLowering(Fortran::lower::AbstractConverter &converter, Fortran::lower::StatementContext &stmtCtx, Fortran::lower::SymMap &symMap) : converter{converter}, builder{converter.getFirOpBuilder()}, stmtCtx{stmtCtx}, symMap{symMap} {} explicit ArrayExprLowering(Fortran::lower::AbstractConverter &converter, Fortran::lower::StatementContext &stmtCtx, Fortran::lower::SymMap &symMap, ConstituentSemantics sem) : converter{converter}, builder{converter.getFirOpBuilder()}, stmtCtx{stmtCtx}, symMap{symMap}, semant{sem} {} explicit ArrayExprLowering(Fortran::lower::AbstractConverter &converter, Fortran::lower::StatementContext &stmtCtx, Fortran::lower::SymMap &symMap, ConstituentSemantics sem, Fortran::lower::ExplicitIterSpace *expSpace, Fortran::lower::ImplicitIterSpace *impSpace) : converter{converter}, builder{converter.getFirOpBuilder()}, stmtCtx{stmtCtx}, symMap{symMap}, explicitSpace(expSpace->isActive() ? expSpace : nullptr), implicitSpace(impSpace->empty() ? nullptr : impSpace), semant{sem} { // Generate any mask expressions, as necessary. This is the compute step // that creates the effective masks. See 10.2.3.2 in particular. genMasks(); } mlir::Location getLoc() { return converter.getCurrentLocation(); } /// Array appears in a lhs context such that it is assigned after the rhs is /// fully evaluated. inline bool isCopyInCopyOut() { return semant == ConstituentSemantics::CopyInCopyOut; } /// Array appears in a lhs (or temp) context such that a projected, /// discontiguous subspace of the array is assigned after the rhs is fully /// evaluated. That is, the rhs array value is merged into a section of the /// lhs array. inline bool isProjectedCopyInCopyOut() { return semant == ConstituentSemantics::ProjectedCopyInCopyOut; } // ???: Do we still need this? inline bool isCustomCopyInCopyOut() { return semant == ConstituentSemantics::CustomCopyInCopyOut; } /// Are we lowering in a left-hand side context? inline bool isLeftHandSide() { return isCopyInCopyOut() || isProjectedCopyInCopyOut() || isCustomCopyInCopyOut(); } /// Array appears in a context where it must be boxed. inline bool isBoxValue() { return semant == ConstituentSemantics::BoxValue; } /// Array appears in a context where differences in the memory reference can /// be observable in the computational results. For example, an array /// element is passed to an impure procedure. inline bool isReferentiallyOpaque() { return semant == ConstituentSemantics::RefOpaque; } /// Array appears in a context where it is passed as a VALUE argument. inline bool isValueAttribute() { return semant == ConstituentSemantics::ByValueArg; } /// Can the loops over the expression be unordered? inline bool isUnordered() const { return unordered; } void setUnordered(bool b) { unordered = b; } inline bool isPointerAssignment() const { return lbounds.hasValue(); } inline bool isBoundsSpec() const { return isPointerAssignment() && !ubounds.hasValue(); } inline bool isBoundsRemap() const { return isPointerAssignment() && ubounds.hasValue(); } void setPointerAssignmentBounds( const llvm::SmallVector &lbs, llvm::Optional> ubs) { lbounds = lbs; ubounds = ubs; } Fortran::lower::AbstractConverter &converter; fir::FirOpBuilder &builder; Fortran::lower::StatementContext &stmtCtx; bool elementCtx = false; Fortran::lower::SymMap &symMap; /// The continuation to generate code to update the destination. llvm::Optional ccStoreToDest; llvm::Optional)>> ccPrelude; llvm::Optional)>> ccLoadDest; /// The destination is the loaded array into which the results will be /// merged. fir::ArrayLoadOp destination; /// The shape of the destination. llvm::SmallVector destShape; /// List of arrays in the expression that have been loaded. llvm::SmallVector arrayOperands; /// If there is a user-defined iteration space, explicitShape will hold the /// information from the front end. Fortran::lower::ExplicitIterSpace *explicitSpace = nullptr; Fortran::lower::ImplicitIterSpace *implicitSpace = nullptr; ConstituentSemantics semant = ConstituentSemantics::RefTransparent; /// `lbounds`, `ubounds` are used in POINTER value assignments, which may only /// occur in an explicit iteration space. llvm::Optional> lbounds; llvm::Optional> ubounds; // Can the array expression be evaluated in any order? // Will be set to false if any of the expression parts prevent this. bool unordered = true; }; } // namespace fir::ExtendedValue Fortran::lower::createSomeExtendedExpression( mlir::Location loc, Fortran::lower::AbstractConverter &converter, const Fortran::lower::SomeExpr &expr, Fortran::lower::SymMap &symMap, Fortran::lower::StatementContext &stmtCtx) { LLVM_DEBUG(expr.AsFortran(llvm::dbgs() << "expr: ") << '\n'); return ScalarExprLowering{loc, converter, symMap, stmtCtx}.genval(expr); } fir::GlobalOp Fortran::lower::createDenseGlobal( mlir::Location loc, mlir::Type symTy, llvm::StringRef globalName, mlir::StringAttr linkage, bool isConst, const Fortran::lower::SomeExpr &expr, Fortran::lower::AbstractConverter &converter) { Fortran::lower::StatementContext stmtCtx(/*prohibited=*/true); Fortran::lower::SymMap emptyMap; InitializerData initData(/*genRawVals=*/true); ScalarExprLowering sel(loc, converter, emptyMap, stmtCtx, /*initializer=*/&initData); sel.genval(expr); size_t sz = initData.rawVals.size(); llvm::ArrayRef ar = {initData.rawVals.data(), sz}; mlir::RankedTensorType tensorTy; auto &builder = converter.getFirOpBuilder(); mlir::Type iTy = initData.rawType; if (!iTy) return 0; // array extent is probably 0 in this case, so just return 0. tensorTy = mlir::RankedTensorType::get(sz, iTy); auto init = mlir::DenseElementsAttr::get(tensorTy, ar); return builder.createGlobal(loc, symTy, globalName, linkage, init, isConst); } fir::ExtendedValue Fortran::lower::createSomeInitializerExpression( mlir::Location loc, Fortran::lower::AbstractConverter &converter, const Fortran::lower::SomeExpr &expr, Fortran::lower::SymMap &symMap, Fortran::lower::StatementContext &stmtCtx) { LLVM_DEBUG(expr.AsFortran(llvm::dbgs() << "expr: ") << '\n'); InitializerData initData; // needed for initializations return ScalarExprLowering{loc, converter, symMap, stmtCtx, /*initializer=*/&initData} .genval(expr); } fir::ExtendedValue Fortran::lower::createSomeExtendedAddress( mlir::Location loc, Fortran::lower::AbstractConverter &converter, const Fortran::lower::SomeExpr &expr, Fortran::lower::SymMap &symMap, Fortran::lower::StatementContext &stmtCtx) { LLVM_DEBUG(expr.AsFortran(llvm::dbgs() << "address: ") << '\n'); return ScalarExprLowering(loc, converter, symMap, stmtCtx).gen(expr); } fir::ExtendedValue Fortran::lower::createInitializerAddress( mlir::Location loc, Fortran::lower::AbstractConverter &converter, const Fortran::lower::SomeExpr &expr, Fortran::lower::SymMap &symMap, Fortran::lower::StatementContext &stmtCtx) { LLVM_DEBUG(expr.AsFortran(llvm::dbgs() << "address: ") << '\n'); InitializerData init; return ScalarExprLowering(loc, converter, symMap, stmtCtx, &init).gen(expr); } void Fortran::lower::createSomeArrayAssignment( Fortran::lower::AbstractConverter &converter, const Fortran::lower::SomeExpr &lhs, const Fortran::lower::SomeExpr &rhs, Fortran::lower::SymMap &symMap, Fortran::lower::StatementContext &stmtCtx) { LLVM_DEBUG(lhs.AsFortran(llvm::dbgs() << "onto array: ") << '\n'; rhs.AsFortran(llvm::dbgs() << "assign expression: ") << '\n';); ArrayExprLowering::lowerArrayAssignment(converter, symMap, stmtCtx, lhs, rhs); } void Fortran::lower::createSomeArrayAssignment( Fortran::lower::AbstractConverter &converter, const fir::ExtendedValue &lhs, const Fortran::lower::SomeExpr &rhs, Fortran::lower::SymMap &symMap, Fortran::lower::StatementContext &stmtCtx) { LLVM_DEBUG(llvm::dbgs() << "onto array: " << lhs << '\n'; rhs.AsFortran(llvm::dbgs() << "assign expression: ") << '\n';); ArrayExprLowering::lowerArrayAssignment(converter, symMap, stmtCtx, lhs, rhs); } void Fortran::lower::createSomeArrayAssignment( Fortran::lower::AbstractConverter &converter, const fir::ExtendedValue &lhs, const fir::ExtendedValue &rhs, Fortran::lower::SymMap &symMap, Fortran::lower::StatementContext &stmtCtx) { LLVM_DEBUG(llvm::dbgs() << "onto array: " << lhs << '\n'; llvm::dbgs() << "assign expression: " << rhs << '\n';); ArrayExprLowering::lowerArrayAssignment(converter, symMap, stmtCtx, lhs, rhs); } void Fortran::lower::createAnyMaskedArrayAssignment( Fortran::lower::AbstractConverter &converter, const Fortran::lower::SomeExpr &lhs, const Fortran::lower::SomeExpr &rhs, Fortran::lower::ExplicitIterSpace &explicitSpace, Fortran::lower::ImplicitIterSpace &implicitSpace, Fortran::lower::SymMap &symMap, Fortran::lower::StatementContext &stmtCtx) { LLVM_DEBUG(lhs.AsFortran(llvm::dbgs() << "onto array: ") << '\n'; rhs.AsFortran(llvm::dbgs() << "assign expression: ") << " given the explicit iteration space:\n" << explicitSpace << "\n and implied mask conditions:\n" << implicitSpace << '\n';); ArrayExprLowering::lowerAnyMaskedArrayAssignment( converter, symMap, stmtCtx, lhs, rhs, explicitSpace, implicitSpace); } void Fortran::lower::createAllocatableArrayAssignment( Fortran::lower::AbstractConverter &converter, const Fortran::lower::SomeExpr &lhs, const Fortran::lower::SomeExpr &rhs, Fortran::lower::ExplicitIterSpace &explicitSpace, Fortran::lower::ImplicitIterSpace &implicitSpace, Fortran::lower::SymMap &symMap, Fortran::lower::StatementContext &stmtCtx) { LLVM_DEBUG(lhs.AsFortran(llvm::dbgs() << "defining array: ") << '\n'; rhs.AsFortran(llvm::dbgs() << "assign expression: ") << " given the explicit iteration space:\n" << explicitSpace << "\n and implied mask conditions:\n" << implicitSpace << '\n';); ArrayExprLowering::lowerAllocatableArrayAssignment( converter, symMap, stmtCtx, lhs, rhs, explicitSpace, implicitSpace); } void Fortran::lower::createArrayOfPointerAssignment( Fortran::lower::AbstractConverter &converter, const Fortran::lower::SomeExpr &lhs, const Fortran::lower::SomeExpr &rhs, Fortran::lower::ExplicitIterSpace &explicitSpace, Fortran::lower::ImplicitIterSpace &implicitSpace, const llvm::SmallVector &lbounds, llvm::Optional> ubounds, Fortran::lower::SymMap &symMap, Fortran::lower::StatementContext &stmtCtx) { LLVM_DEBUG(lhs.AsFortran(llvm::dbgs() << "defining pointer: ") << '\n'; rhs.AsFortran(llvm::dbgs() << "assign expression: ") << " given the explicit iteration space:\n" << explicitSpace << "\n and implied mask conditions:\n" << implicitSpace << '\n';); assert(explicitSpace.isActive() && "must be in FORALL construct"); ArrayExprLowering::lowerArrayOfPointerAssignment( converter, symMap, stmtCtx, lhs, rhs, explicitSpace, implicitSpace, lbounds, ubounds); } fir::ExtendedValue Fortran::lower::createSomeArrayTempValue( Fortran::lower::AbstractConverter &converter, const Fortran::lower::SomeExpr &expr, Fortran::lower::SymMap &symMap, Fortran::lower::StatementContext &stmtCtx) { LLVM_DEBUG(expr.AsFortran(llvm::dbgs() << "array value: ") << '\n'); return ArrayExprLowering::lowerNewArrayExpression(converter, symMap, stmtCtx, expr); } void Fortran::lower::createLazyArrayTempValue( Fortran::lower::AbstractConverter &converter, const Fortran::lower::SomeExpr &expr, mlir::Value raggedHeader, Fortran::lower::SymMap &symMap, Fortran::lower::StatementContext &stmtCtx) { LLVM_DEBUG(expr.AsFortran(llvm::dbgs() << "array value: ") << '\n'); ArrayExprLowering::lowerLazyArrayExpression(converter, symMap, stmtCtx, expr, raggedHeader); } fir::ExtendedValue Fortran::lower::createSomeArrayBox(Fortran::lower::AbstractConverter &converter, const Fortran::lower::SomeExpr &expr, Fortran::lower::SymMap &symMap, Fortran::lower::StatementContext &stmtCtx) { LLVM_DEBUG(expr.AsFortran(llvm::dbgs() << "box designator: ") << '\n'); return ArrayExprLowering::lowerBoxedArrayExpression(converter, symMap, stmtCtx, expr); } fir::MutableBoxValue Fortran::lower::createMutableBox( mlir::Location loc, Fortran::lower::AbstractConverter &converter, const Fortran::lower::SomeExpr &expr, Fortran::lower::SymMap &symMap) { // MutableBox lowering StatementContext does not need to be propagated // to the caller because the result value is a variable, not a temporary // expression. The StatementContext clean-up can occur before using the // resulting MutableBoxValue. Variables of all other types are handled in the // bridge. Fortran::lower::StatementContext dummyStmtCtx; return ScalarExprLowering{loc, converter, symMap, dummyStmtCtx} .genMutableBoxValue(expr); } fir::ExtendedValue Fortran::lower::createBoxValue( mlir::Location loc, Fortran::lower::AbstractConverter &converter, const Fortran::lower::SomeExpr &expr, Fortran::lower::SymMap &symMap, Fortran::lower::StatementContext &stmtCtx) { if (expr.Rank() > 0 && Fortran::evaluate::IsVariable(expr) && !Fortran::evaluate::HasVectorSubscript(expr)) return Fortran::lower::createSomeArrayBox(converter, expr, symMap, stmtCtx); fir::ExtendedValue addr = Fortran::lower::createSomeExtendedAddress( loc, converter, expr, symMap, stmtCtx); return fir::BoxValue(converter.getFirOpBuilder().createBox(loc, addr)); } mlir::Value Fortran::lower::createSubroutineCall( AbstractConverter &converter, const evaluate::ProcedureRef &call, ExplicitIterSpace &explicitIterSpace, ImplicitIterSpace &implicitIterSpace, SymMap &symMap, StatementContext &stmtCtx, bool isUserDefAssignment) { mlir::Location loc = converter.getCurrentLocation(); if (isUserDefAssignment) { assert(call.arguments().size() == 2); const auto *lhs = call.arguments()[0].value().UnwrapExpr(); const auto *rhs = call.arguments()[1].value().UnwrapExpr(); assert(lhs && rhs && "user defined assignment arguments must be expressions"); if (call.IsElemental() && lhs->Rank() > 0) { // Elemental user defined assignment has special requirements to deal with // LHS/RHS overlaps. See 10.2.1.5 p2. ArrayExprLowering::lowerElementalUserAssignment( converter, symMap, stmtCtx, explicitIterSpace, implicitIterSpace, call); } else if (explicitIterSpace.isActive() && lhs->Rank() == 0) { // Scalar defined assignment (elemental or not) in a FORALL context. mlir::func::FuncOp func = Fortran::lower::CallerInterface(call, converter).getFuncOp(); ArrayExprLowering::lowerScalarUserAssignment( converter, symMap, stmtCtx, explicitIterSpace, func, *lhs, *rhs); } else if (explicitIterSpace.isActive()) { // TODO: need to array fetch/modify sub-arrays? TODO(loc, "non elemental user defined array assignment inside FORALL"); } else { if (!implicitIterSpace.empty()) fir::emitFatalError( loc, "C1032: user defined assignment inside WHERE must be elemental"); // Non elemental user defined assignment outside of FORALL and WHERE. // FIXME: The non elemental user defined assignment case with array // arguments must be take into account potential overlap. So far the front // end does not add parentheses around the RHS argument in the call as it // should according to 15.4.3.4.3 p2. Fortran::lower::createSomeExtendedExpression( loc, converter, toEvExpr(call), symMap, stmtCtx); } return {}; } assert(implicitIterSpace.empty() && !explicitIterSpace.isActive() && "subroutine calls are not allowed inside WHERE and FORALL"); if (isElementalProcWithArrayArgs(call)) { ArrayExprLowering::lowerElementalSubroutine(converter, symMap, stmtCtx, toEvExpr(call)); return {}; } // Simple subroutine call, with potential alternate return. auto res = Fortran::lower::createSomeExtendedExpression( loc, converter, toEvExpr(call), symMap, stmtCtx); return fir::getBase(res); } template fir::ArrayLoadOp genArrayLoad(mlir::Location loc, Fortran::lower::AbstractConverter &converter, fir::FirOpBuilder &builder, const A *x, Fortran::lower::SymMap &symMap, Fortran::lower::StatementContext &stmtCtx) { auto exv = ScalarExprLowering{loc, converter, symMap, stmtCtx}.gen(*x); mlir::Value addr = fir::getBase(exv); mlir::Value shapeOp = builder.createShape(loc, exv); mlir::Type arrTy = fir::dyn_cast_ptrOrBoxEleTy(addr.getType()); return builder.create(loc, arrTy, addr, shapeOp, /*slice=*/mlir::Value{}, fir::getTypeParams(exv)); } template <> fir::ArrayLoadOp genArrayLoad(mlir::Location loc, Fortran::lower::AbstractConverter &converter, fir::FirOpBuilder &builder, const Fortran::evaluate::ArrayRef *x, Fortran::lower::SymMap &symMap, Fortran::lower::StatementContext &stmtCtx) { if (x->base().IsSymbol()) return genArrayLoad(loc, converter, builder, &getLastSym(x->base()), symMap, stmtCtx); return genArrayLoad(loc, converter, builder, &x->base().GetComponent(), symMap, stmtCtx); } void Fortran::lower::createArrayLoads( Fortran::lower::AbstractConverter &converter, Fortran::lower::ExplicitIterSpace &esp, Fortran::lower::SymMap &symMap) { std::size_t counter = esp.getCounter(); fir::FirOpBuilder &builder = converter.getFirOpBuilder(); mlir::Location loc = converter.getCurrentLocation(); Fortran::lower::StatementContext &stmtCtx = esp.stmtContext(); // Gen the fir.array_load ops. auto genLoad = [&](const auto *x) -> fir::ArrayLoadOp { return genArrayLoad(loc, converter, builder, x, symMap, stmtCtx); }; if (esp.lhsBases[counter].hasValue()) { auto &base = esp.lhsBases[counter].getValue(); auto load = std::visit(genLoad, base); esp.initialArgs.push_back(load); esp.resetInnerArgs(); esp.bindLoad(base, load); } for (const auto &base : esp.rhsBases[counter]) esp.bindLoad(base, std::visit(genLoad, base)); } void Fortran::lower::createArrayMergeStores( Fortran::lower::AbstractConverter &converter, Fortran::lower::ExplicitIterSpace &esp) { fir::FirOpBuilder &builder = converter.getFirOpBuilder(); mlir::Location loc = converter.getCurrentLocation(); builder.setInsertionPointAfter(esp.getOuterLoop()); // Gen the fir.array_merge_store ops for all LHS arrays. for (auto i : llvm::enumerate(esp.getOuterLoop().getResults())) if (llvm::Optional ldOpt = esp.getLhsLoad(i.index())) { fir::ArrayLoadOp load = ldOpt.getValue(); builder.create(loc, load, i.value(), load.getMemref(), load.getSlice(), load.getTypeparams()); } if (esp.loopCleanup.hasValue()) { esp.loopCleanup.getValue()(builder); esp.loopCleanup = llvm::None; } esp.initialArgs.clear(); esp.innerArgs.clear(); esp.outerLoop = llvm::None; esp.resetBindings(); esp.incrementCounter(); }