diff --git a/flang/include/flang/Lower/AbstractConverter.h b/flang/include/flang/Lower/AbstractConverter.h --- a/flang/include/flang/Lower/AbstractConverter.h +++ b/flang/include/flang/Lower/AbstractConverter.h @@ -76,6 +76,9 @@ /// Get the mlir instance of a symbol. virtual mlir::Value getSymbolAddress(SymbolRef sym) = 0; + /// Get the binding of an implied do variable by name. + virtual mlir::Value impliedDoBinding(llvm::StringRef name) = 0; + /// Get the label set associated with a symbol. virtual bool lookupLabelSet(SymbolRef sym, pft::LabelSet &labelSet) = 0; diff --git a/flang/include/flang/Lower/ConvertExpr.h b/flang/include/flang/Lower/ConvertExpr.h --- a/flang/include/flang/Lower/ConvertExpr.h +++ b/flang/include/flang/Lower/ConvertExpr.h @@ -140,6 +140,13 @@ SymMap &symMap, StatementContext &stmtCtx); +/// Lower an array expression with "parallel" semantics. Such a rhs expression +/// is fully evaluated prior to being assigned back to a temporary array. +fir::ExtendedValue createSomeArrayTempValue(AbstractConverter &converter, + const SomeExpr &expr, + SymMap &symMap, + StatementContext &stmtCtx); + // Attribute for an alloca that is a trivial adaptor for converting a value to // pass-by-ref semantics for a VALUE parameter. The optimizer may be able to // eliminate these. diff --git a/flang/include/flang/Lower/CustomIntrinsicCall.h b/flang/include/flang/Lower/CustomIntrinsicCall.h new file mode 100644 --- /dev/null +++ b/flang/include/flang/Lower/CustomIntrinsicCall.h @@ -0,0 +1,99 @@ +//===-- Lower/CustomIntrinsicCall.h -----------------------------*- C++ -*-===// +// +// 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/ +// +//===----------------------------------------------------------------------===// +/// +/// Custom intrinsic lowering for the few intrinsic that have optional +/// arguments that prevents them to be handled in a more generic way in +/// IntrinsicCall.cpp. +/// The core principle is that this interface provides the intrinsic arguments +/// via callbacks to generate fir::ExtendedValue (instead of a list of +/// precomputed fir::ExtendedValue as done in the default intrinsic call +/// lowering). This gives more flexibility to only generate references to +/// dynamically optional arguments (pointers, allocatables, OPTIONAL dummies) in +/// a safe way. +//===----------------------------------------------------------------------===// + +#ifndef FORTRAN_LOWER_CUSTOMINTRINSICCALL_H +#define FORTRAN_LOWER_CUSTOMINTRINSICCALL_H + +#include "flang/Lower/AbstractConverter.h" +#include "llvm/ADT/Optional.h" +#include + +namespace Fortran { + +namespace evaluate { +class ProcedureRef; +struct SpecificIntrinsic; +} // namespace evaluate + +namespace lower { + +/// Does the call \p procRef to \p intrinsic need to be handle via this custom +/// framework due to optional arguments. Otherwise, the tools from +/// IntrinsicCall.cpp should be used directly. +bool intrinsicRequiresCustomOptionalHandling( + const Fortran::evaluate::ProcedureRef &procRef, + const Fortran::evaluate::SpecificIntrinsic &intrinsic, + AbstractConverter &converter); + +/// Type of callback to be provided to prepare the arguments fetching from an +/// actual argument expression. +using OperandPrepare = std::function; + +/// Type of the callback to inquire about an argument presence, once the call +/// preparation was done. An absent optional means the argument is statically +/// present. An mlir::Value means the presence must be checked at runtime, and +/// that the value contains the "is present" boolean value. +using OperandPresent = std::function(std::size_t)>; + +/// Type of the callback to generate an argument reference after the call +/// preparation was done. For optional arguments, the utility guarantees +/// these callbacks will only be called in regions where the presence was +/// verified. This means the getter callback can dereference the argument +/// without any special care. +/// For elemental intrinsics, the getter must provide the current iteration +/// element value. +using OperandGetter = std::function; + +/// Given a callback \p prepareOptionalArgument to prepare optional +/// arguments and a callback \p prepareOtherArgument to prepare non-optional +/// arguments prepare the intrinsic arguments calls. +/// It is up to the caller to decide what argument preparation means, +/// the only contract is that it should later allow the caller to provide +/// callbacks to generate argument reference given an argument index without +/// any further knowledge of the argument. The function simply visits +/// the actual arguments, deciding which ones are dynamically optional, +/// and calling the callbacks accordingly in argument order. +void prepareCustomIntrinsicArgument( + const Fortran::evaluate::ProcedureRef &procRef, + const Fortran::evaluate::SpecificIntrinsic &intrinsic, + llvm::Optional retTy, + const OperandPrepare &prepareOptionalArgument, + const OperandPrepare &prepareOtherArgument, AbstractConverter &converter); + +/// Given a callback \p getOperand to generate a reference to the i-th argument, +/// and a callback \p isPresentCheck to test if an argument is present, this +/// function lowers the intrinsic calls to \p name whose argument were +/// previously prepared with prepareCustomIntrinsicArgument. The elemental +/// aspects must be taken into account by the caller (i.e, the function should +/// be called during the loop nest generation for elemental intrinsics. It will +/// not generate any implicit loop nest on its own). +fir::ExtendedValue +lowerCustomIntrinsic(fir::FirOpBuilder &builder, mlir::Location loc, + llvm::StringRef name, llvm::Optional retTy, + const OperandPresent &isPresentCheck, + const OperandGetter &getOperand, std::size_t numOperands, + Fortran::lower::StatementContext &stmtCtx); +} // namespace lower +} // namespace Fortran + +#endif // FORTRAN_LOWER_CUSTOMINTRINSICCALL_H diff --git a/flang/include/flang/Lower/IntrinsicCall.h b/flang/include/flang/Lower/IntrinsicCall.h --- a/flang/include/flang/Lower/IntrinsicCall.h +++ b/flang/include/flang/Lower/IntrinsicCall.h @@ -18,6 +18,8 @@ namespace Fortran::lower { +class StatementContext; + // TODO: Error handling interface ? // TODO: Implementation is incomplete. Many intrinsics to tbd. @@ -27,7 +29,8 @@ fir::ExtendedValue genIntrinsicCall(fir::FirOpBuilder &, mlir::Location, llvm::StringRef name, llvm::Optional resultType, - llvm::ArrayRef args); + llvm::ArrayRef args, + StatementContext &); /// Enum specifying how intrinsic argument evaluate::Expr should be /// lowered to fir::ExtendedValue to be passed to genIntrinsicCall. diff --git a/flang/include/flang/Optimizer/Builder/FIRBuilder.h b/flang/include/flang/Optimizer/Builder/FIRBuilder.h --- a/flang/include/flang/Optimizer/Builder/FIRBuilder.h +++ b/flang/include/flang/Optimizer/Builder/FIRBuilder.h @@ -420,6 +420,18 @@ fir::ExtendedValue readBoxValue(fir::FirOpBuilder &builder, mlir::Location loc, const fir::BoxValue &box); +/// Get non default (not all ones) lower bounds of \p exv. Returns empty +/// vector if the lower bounds are all ones. +llvm::SmallVector +getNonDefaultLowerBounds(fir::FirOpBuilder &builder, mlir::Location loc, + const fir::ExtendedValue &exv); + +/// Return length parameters associated to \p exv that are not deferred (that +/// are available without having to read any fir.box values). +/// Empty if \p exv has no length parameters or if they are all deferred. +llvm::SmallVector +getNonDeferredLengthParams(const fir::ExtendedValue &exv); + //===----------------------------------------------------------------------===// // String literal helper helpers //===----------------------------------------------------------------------===// diff --git a/flang/include/flang/Optimizer/Dialect/FIRType.h b/flang/include/flang/Optimizer/Dialect/FIRType.h --- a/flang/include/flang/Optimizer/Dialect/FIRType.h +++ b/flang/include/flang/Optimizer/Dialect/FIRType.h @@ -127,6 +127,13 @@ /// Is `t` a CHARACTER type? Does not check the length. inline bool isa_char(mlir::Type t) { return t.isa(); } +/// Is `t` a trivial intrinsic type? CHARACTER is excluded because it +/// is a dependent type. +inline bool isa_trivial(mlir::Type t) { + return isa_integer(t) || isa_real(t) || isa_complex(t) || + t.isa(); +} + /// Is `t` a CHARACTER type with a LEN other than 1? inline bool isa_char_string(mlir::Type t) { if (auto ct = t.dyn_cast_or_null()) @@ -184,6 +191,12 @@ } #endif +/// Return true iff `ty` is the type of an ALLOCATABLE entity or value. +bool isAllocatableType(mlir::Type ty); + +/// Return true iff `ty` is a RecordType with members that are allocatable. +bool isRecordWithAllocatableMember(mlir::Type ty); + /// Return true iff `ty` is a RecordType with type parameters. inline bool isRecordWithTypeParameters(mlir::Type ty) { if (auto recTy = ty.dyn_cast_or_null()) diff --git a/flang/lib/Lower/Bridge.cpp b/flang/lib/Lower/Bridge.cpp --- a/flang/lib/Lower/Bridge.cpp +++ b/flang/lib/Lower/Bridge.cpp @@ -177,6 +177,13 @@ return lookupSymbol(sym).getAddr(); } + mlir::Value impliedDoBinding(llvm::StringRef name) override final { + mlir::Value val = localSymbols.lookupImpliedDo(name); + if (!val) + fir::emitFatalError(toLocation(), "ac-do-variable has no binding"); + return val; + } + bool lookupLabelSet(Fortran::lower::SymbolRef sym, Fortran::lower::pft::LabelSet &labelSet) override final { Fortran::lower::pft::FunctionLikeUnit &owningProc = @@ -818,6 +825,13 @@ return cond; } + static bool + isArraySectionWithoutVectorSubscript(const Fortran::lower::SomeExpr &expr) { + return expr.Rank() > 0 && Fortran::evaluate::IsVariable(expr) && + !Fortran::evaluate::UnwrapWholeSymbolDataRef(expr) && + !Fortran::evaluate::HasVectorSubscript(expr); + } + [[maybe_unused]] static bool isFuncResultDesignator(const Fortran::lower::SomeExpr &expr) { const Fortran::semantics::Symbol *sym = @@ -1086,6 +1100,15 @@ TODO(toLocation(), "SelectCaseStmt lowering"); } + fir::ExtendedValue + genAssociateSelector(const Fortran::lower::SomeExpr &selector, + Fortran::lower::StatementContext &stmtCtx) { + return isArraySectionWithoutVectorSubscript(selector) + ? Fortran::lower::createSomeArrayBox(*this, selector, + localSymbols, stmtCtx) + : genExprAddr(selector, stmtCtx); + } + void genFIR(const Fortran::parser::AssociateConstruct &) { TODO(toLocation(), "AssociateConstruct lowering"); } @@ -1457,10 +1480,6 @@ TODO(toLocation(), "EndDoStmt lowering"); } - void genFIR(const Fortran::parser::EndIfStmt &) { - TODO(toLocation(), "EndIfStmt lowering"); - } - void genFIR(const Fortran::parser::EndMpSubprogramStmt &) { TODO(toLocation(), "EndMpSubprogramStmt lowering"); } @@ -1472,6 +1491,7 @@ // Nop statements - No code, or code is generated at the construct level. void genFIR(const Fortran::parser::ContinueStmt &) {} // nop void genFIR(const Fortran::parser::EndFunctionStmt &) {} // nop + void genFIR(const Fortran::parser::EndIfStmt &) {} // nop void genFIR(const Fortran::parser::EndSubroutineStmt &) {} // nop void genFIR(const Fortran::parser::EntryStmt &) { diff --git a/flang/lib/Lower/CMakeLists.txt b/flang/lib/Lower/CMakeLists.txt --- a/flang/lib/Lower/CMakeLists.txt +++ b/flang/lib/Lower/CMakeLists.txt @@ -9,6 +9,7 @@ ConvertType.cpp ConvertVariable.cpp ComponentPath.cpp + CustomIntrinsicCall.cpp DumpEvaluateExpr.cpp HostAssociations.cpp IntrinsicCall.cpp diff --git a/flang/lib/Lower/ConvertExpr.cpp b/flang/lib/Lower/ConvertExpr.cpp --- a/flang/lib/Lower/ConvertExpr.cpp +++ b/flang/lib/Lower/ConvertExpr.cpp @@ -18,6 +18,7 @@ #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/StatementContext.h" @@ -28,12 +29,14 @@ #include "flang/Optimizer/Builder/Factory.h" #include "flang/Optimizer/Builder/LowLevelIntrinsics.h" #include "flang/Optimizer/Builder/MutableBox.h" +#include "flang/Optimizer/Builder/Runtime/RTBuilder.h" #include "flang/Optimizer/Dialect/FIROpsSupport.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/Support/CommandLine.h" #include "llvm/Support/Debug.h" #define DEBUG_TYPE "flang-lower-expr" @@ -49,6 +52,16 @@ // to the correct FIR representation in SSA form. //===----------------------------------------------------------------------===// +// 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. /// @@ -159,6 +172,19 @@ 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)); +} + /// 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 @@ -186,6 +212,21 @@ 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::isDerivedWithLengthParameters(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; +} + /// Is this a variable wrapped in parentheses? template static bool isParenthesizedVariable(const A &) { @@ -231,6 +272,76 @@ }); } +/// 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) { @@ -290,8 +401,8 @@ Fortran::lower::StatementContext &stmtCtx, InitializerData *initializer = nullptr) : location{loc}, converter{converter}, - builder{converter.getFirOpBuilder()}, stmtCtx{stmtCtx}, symMap{symMap} { - } + builder{converter.getFirOpBuilder()}, stmtCtx{stmtCtx}, symMap{symMap}, + inInitializer{initializer} {} ExtValue genExtAddr(const Fortran::lower::SomeExpr &expr) { return gen(expr); @@ -474,11 +585,36 @@ /// Lowering of an ac-do-variable, which is not a Symbol. ExtValue genval(const Fortran::evaluate::ImpliedDoIndex &var) { - TODO(getLoc(), "genval ImpliedDoIndex"); + return converter.impliedDoBinding(toStringRef(var.name)); } ExtValue genval(const Fortran::evaluate::DescriptorInquiry &desc) { - TODO(getLoc(), "genval DescriptorInquiry"); + ExtValue exv = desc.base().IsSymbol() ? gen(desc.base().GetLastSymbol()) + : 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 &) { @@ -1031,7 +1167,13 @@ /// value. This is required for lowering expressions such as `f1(f2(v))`. template ExtValue gen(const Fortran::evaluate::FunctionRef &funcRef) { - TODO(getLoc(), "gen FunctionRef"); + ExtValue retVal = genFunctionRef(funcRef); + mlir::Value retValBase = fir::getBase(retVal); + if (fir::conformsWithPassByRef(retValBase.getType())) + return retVal; + auto mem = builder.create(getLoc(), retValBase.getType()); + builder.create(getLoc(), retValBase, mem); + return fir::substBase(retVal, mem.getResult()); } /// helper to detect statement functions @@ -1088,6 +1230,43 @@ 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(builder, loc, 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, @@ -1420,6 +1599,48 @@ 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) { + if (!restrictCopyAtRuntime) { + ExtValue temp = genArrayTempFromMold(actualArg, ".copyinout"); + if (arg.mayBeReadByCall()) + genArrayCopy(temp, actualArg); + copyOutPairs.emplace_back(CopyOutPair{ + actualArg, temp, arg.mayBeModifiedByCall(), 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, ".copyinout"); + 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, arg.mayBeModifiedByCall(), restrictCopyAtRuntime}); + return temp; + } + /// Lower a non-elemental procedure reference. ExtValue genRawProcedureRef(const Fortran::evaluate::ProcedureRef &procRef, llvm::Optional resultType) { @@ -1498,6 +1719,9 @@ } const bool actualArgIsVariable = Fortran::evaluate::IsVariable(*expr); if (arg.passBy == PassBy::BaseAddress || arg.passBy == PassBy::BoxChar) { + const bool actualIsSimplyContiguous = + !actualArgIsVariable || Fortran::evaluate::IsSimplyContiguous( + *expr, converter.getFoldingContext()); auto argAddr = [&]() -> ExtValue { ExtValue baseAddr; if (actualArgIsVariable && arg.isOptional()) { @@ -1515,7 +1739,13 @@ // copied-in/copied-out without any care if needed. } if (actualArgIsVariable && expr->Rank() > 0) { - TODO(loc, "procedureref arrays"); + ExtValue box = genBoxArg(*expr); + if (!actualIsSimplyContiguous) + return genCopyIn(box, arg, copyOutPairs, + /*restrictCopyAtRuntime=*/llvm::None); + // 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. @@ -1615,6 +1845,27 @@ return genProcedureRef(procRef, resTy); } + /// 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); + 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 an intrinsic function. ExtValue genIntrinsicRef(const Fortran::evaluate::ProcedureRef &procRef, @@ -1645,32 +1896,57 @@ Fortran::lower::ArgLoweringRule argRules = Fortran::lower::lowerIntrinsicArgumentAs(loc, *argLowering, dummy.name); + 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: - TODO(getLoc(), "argument lowering for Addr"); + operands.emplace_back(gen(*expr)); continue; case Fortran::lower::LowerIntrinsicArgAs::Box: - TODO(getLoc(), "argument lowering for Box"); + operands.emplace_back(lowerIntrinsicArgumentAsBox(*expr)); continue; case Fortran::lower::LowerIntrinsicArgAs::Inquired: - TODO(getLoc(), "argument lowering for 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); + operands, stmtCtx); } template ExtValue genval(const Fortran::evaluate::Expr &x) { - if (isScalar(x)) + if (isScalar(x) || Fortran::evaluate::UnwrapWholeSymbolDataRef(x) || + inInitializer) return std::visit([&](const auto &e) { return genval(e); }, x.u); - TODO(getLoc(), "genval Expr arrays"); + return asArray(x); } /// Helper to detect Transformational function reference. @@ -1705,6 +1981,12 @@ return x.Rank() == 0; } + template + ExtValue asArray(const A &x) { + return Fortran::lower::createSomeArrayTempValue(converter, toEvExpr(x), + symMap, stmtCtx); + } + template ExtValue genval(const Fortran::evaluate::Expr> &exp) { @@ -1746,6 +2028,7 @@ fir::FirOpBuilder &builder; Fortran::lower::StatementContext &stmtCtx; Fortran::lower::SymMap &symMap; + InitializerData *inInitializer = nullptr; bool useBoxArg = false; // expression lowered as argument }; } // namespace @@ -2251,12 +2534,33 @@ 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); + } + // An expression with non-zero rank is an array expression. template bool isArray(const A &x) const { return x.Rank() != 0; } + /// 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. @@ -2267,6 +2571,207 @@ } } + /// 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 procedure reference to a Fortran elemental intrinsic procedure. + CC genElementalIntrinsicProcRef( + const Fortran::evaluate::ProcedureRef &procRef, + llvm::Optional retTy, + const Fortran::evaluate::SpecificIntrinsic &intrinsic) { + llvm::SmallVector operands; + llvm::StringRef name = intrinsic.name; + const Fortran::lower::IntrinsicArgumentLoweringRules *argLowering = + Fortran::lower::getIntrinsicArgumentLowering(name); + mlir::Location loc = getLoc(); + if (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(); + llvm::StringRef name = intrinsic.name; + 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, dummy] : + llvm::zip(procRef.arguments(), + intrinsic.characteristics.value().dummyArguments)) { + const auto *expr = + Fortran::evaluate::UnwrapExpr(arg); + 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(getLoc(), *argLowering, + dummy.name); + 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()); + }; + } + + /// 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 (ScalarExprLowering::isStatementFunctionCall(procRef)) + fir::emitFatalError(loc, "statement function cannot be elemental"); + + TODO(loc, "elemental user defined proc ref"); + } + + // 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, *intrinsic, retTy); + }; + } + return genarr( + ScalarExprLowering{loc, converter, symMap, stmtCtx}.genIntrinsicRef( + procRef, *intrinsic, retTy)); + } + + 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)); + } + template CC genScalarAndForwardValue(const A &x) { ExtValue result = asScalar(x); @@ -2322,12 +2827,28 @@ TODO(getLoc(), ""); } + //===--------------------------------------------------------------------===// + // 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) { \ - TODO(getLoc(), "genarr Binary"); \ + return createBinaryOp(x); \ } GENBIN(Add, Integer, mlir::arith::AddIOp) @@ -2393,9 +2914,410 @@ return genarr(extMemref, dummy); } + //===--------------------------------------------------------------------===// + // 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).getType(); + } + + /// Create a call to the LLVM memcpy intrinsic. + void createCallMemcpy(llvm::ArrayRef args) { + mlir::Location loc = getLoc(); + mlir::FuncOp memcpyFunc = fir::factory::getLlvmMemcpy(builder); + mlir::SymbolRefAttr funcSymAttr = + builder.getSymbolRefAttr(memcpyFunc.getName()); + mlir::FunctionType funcTy = memcpyFunc.getType(); + 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::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.getType(); + 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.hasValue()) { + charLen = builder.createTemporary(loc, builder.getI64Type()); + mlir::Value castLen = + builder.createConvert(loc, builder.getI64Type(), fir::getLen(exv)); + builder.create(loc, castLen, charLen.getValue()); + } + } + 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.getValue()); + 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) { - TODO(getLoc(), "genarr ArrayConstructor"); + 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.hasValue()) { + charLen = builder.createTemporary(loc, builder.getI64Type()); + mlir::Value castLen = + builder.createConvert(loc, builder.getI64Type(), fir::getLen(exv)); + builder.create(loc, castLen, charLen.getValue()); + } + } + 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 &) { @@ -2458,7 +3380,10 @@ template CC genarr(const Fortran::evaluate::FunctionRef &funRef) { - TODO(getLoc(), "genarr FunctionRef"); + // 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)))); } template @@ -2566,6 +3491,127 @@ return components.reversePath.empty(); } + /// 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; + }; + } + CC genarr(const Fortran::evaluate::ComplexPart &x, ComponentPath &components) { TODO(getLoc(), "genarr ComplexPart"); @@ -3123,6 +4169,15 @@ converter, symMap, stmtCtx, lhs, rhs, explicitSpace, implicitSpace); } +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); +} + mlir::Value Fortran::lower::genMaxWithZero(fir::FirOpBuilder &builder, mlir::Location loc, mlir::Value value) { diff --git a/flang/lib/Lower/CustomIntrinsicCall.cpp b/flang/lib/Lower/CustomIntrinsicCall.cpp new file mode 100644 --- /dev/null +++ b/flang/lib/Lower/CustomIntrinsicCall.cpp @@ -0,0 +1,255 @@ +//===-- CustomIntrinsicCall.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/CustomIntrinsicCall.h" +#include "flang/Evaluate/expression.h" +#include "flang/Evaluate/fold.h" +#include "flang/Evaluate/tools.h" +#include "flang/Lower/IntrinsicCall.h" +#include "flang/Lower/Todo.h" + +/// Is this a call to MIN or MAX intrinsic with arguments that may be absent at +/// runtime? This is a special case because MIN and MAX can have any number of +/// arguments. +static bool isMinOrMaxWithDynamicallyOptionalArg( + llvm::StringRef name, const Fortran::evaluate::ProcedureRef &procRef, + Fortran::evaluate::FoldingContext &foldingContex) { + if (name != "min" && name != "max") + return false; + const auto &args = procRef.arguments(); + std::size_t argSize = args.size(); + if (argSize <= 2) + return false; + for (std::size_t i = 2; i < argSize; ++i) { + if (auto *expr = + Fortran::evaluate::UnwrapExpr(args[i])) + if (Fortran::evaluate::MayBePassedAsAbsentOptional(*expr, foldingContex)) + return true; + } + return false; +} + +/// Is this a call to ISHFTC intrinsic with a SIZE argument that may be absent +/// at runtime? This is a special case because the SIZE value to be applied +/// when absent is not zero. +static bool isIshftcWithDynamicallyOptionalArg( + llvm::StringRef name, const Fortran::evaluate::ProcedureRef &procRef, + Fortran::evaluate::FoldingContext &foldingContex) { + if (name != "ishftc" || procRef.arguments().size() < 3) + return false; + auto *expr = Fortran::evaluate::UnwrapExpr( + procRef.arguments()[2]); + return expr && + Fortran::evaluate::MayBePassedAsAbsentOptional(*expr, foldingContex); +} + +/// Is this a call to SYSTEM_CLOCK or RANDOM_SEED intrinsic with arguments that +/// may be absent at runtime? This are special cases because that aspect cannot +/// be delegated to the runtime via a null fir.box or address given the current +/// runtime entry point. +static bool isSystemClockOrRandomSeedWithOptionalArg( + llvm::StringRef name, const Fortran::evaluate::ProcedureRef &procRef, + Fortran::evaluate::FoldingContext &foldingContex) { + if (name != "system_clock" && name != "random_seed") + return false; + for (const auto &arg : procRef.arguments()) { + auto *expr = Fortran::evaluate::UnwrapExpr(arg); + if (expr && + Fortran::evaluate::MayBePassedAsAbsentOptional(*expr, foldingContex)) + return true; + } + return false; +} + +bool Fortran::lower::intrinsicRequiresCustomOptionalHandling( + const Fortran::evaluate::ProcedureRef &procRef, + const Fortran::evaluate::SpecificIntrinsic &intrinsic, + AbstractConverter &converter) { + llvm::StringRef name = intrinsic.name; + Fortran::evaluate::FoldingContext &fldCtx = converter.getFoldingContext(); + return isMinOrMaxWithDynamicallyOptionalArg(name, procRef, fldCtx) || + isIshftcWithDynamicallyOptionalArg(name, procRef, fldCtx) || + isSystemClockOrRandomSeedWithOptionalArg(name, procRef, fldCtx); +} + +static void prepareMinOrMaxArguments( + const Fortran::evaluate::ProcedureRef &procRef, + const Fortran::evaluate::SpecificIntrinsic &intrinsic, + llvm::Optional retTy, + const Fortran::lower::OperandPrepare &prepareOptionalArgument, + const Fortran::lower::OperandPrepare &prepareOtherArgument, + Fortran::lower::AbstractConverter &converter) { + assert(retTy && "MIN and MAX must have a return type"); + mlir::Type resultType = retTy.getValue(); + mlir::Location loc = converter.getCurrentLocation(); + if (fir::isa_char(resultType)) + TODO(loc, + "CHARACTER MIN and MAX lowering with dynamically optional arguments"); + for (auto arg : llvm::enumerate(procRef.arguments())) { + const auto *expr = + Fortran::evaluate::UnwrapExpr(arg.value()); + if (!expr) + continue; + if (arg.index() <= 1 || !Fortran::evaluate::MayBePassedAsAbsentOptional( + *expr, converter.getFoldingContext())) { + // Non optional arguments. + prepareOtherArgument(*expr); + } else { + // Dynamically optional arguments. + // Subtle: even for scalar the if-then-else will be generated in the loop + // nest because the then part will require the current extremum value that + // may depend on previous array element argument and cannot be outlined. + prepareOptionalArgument(*expr); + } + } +} + +static fir::ExtendedValue +lowerMinOrMax(fir::FirOpBuilder &builder, mlir::Location loc, + llvm::StringRef name, llvm::Optional retTy, + const Fortran::lower::OperandPresent &isPresentCheck, + const Fortran::lower::OperandGetter &getOperand, + std::size_t numOperands, + Fortran::lower::StatementContext &stmtCtx) { + assert(numOperands >= 2 && !isPresentCheck(0) && !isPresentCheck(1) && + "min/max must have at least two non-optional args"); + assert(retTy && "MIN and MAX must have a return type"); + mlir::Type resultType = retTy.getValue(); + llvm::SmallVector args; + args.push_back(getOperand(0)); + args.push_back(getOperand(1)); + mlir::Value extremum = fir::getBase(Fortran::lower::genIntrinsicCall( + builder, loc, name, resultType, args, stmtCtx)); + + for (std::size_t opIndex = 2; opIndex < numOperands; ++opIndex) { + if (llvm::Optional isPresentRuntimeCheck = + isPresentCheck(opIndex)) { + // Argument is dynamically optional. + extremum = + builder + .genIfOp(loc, {resultType}, isPresentRuntimeCheck.getValue(), + /*withElseRegion=*/true) + .genThen([&]() { + llvm::SmallVector args; + args.emplace_back(extremum); + args.emplace_back(getOperand(opIndex)); + fir::ExtendedValue newExtremum = + Fortran::lower::genIntrinsicCall(builder, loc, name, + resultType, args, stmtCtx); + builder.create(loc, fir::getBase(newExtremum)); + }) + .genElse([&]() { builder.create(loc, extremum); }) + .getResults()[0]; + } else { + // Argument is know to be present at compile time. + llvm::SmallVector args; + args.emplace_back(extremum); + args.emplace_back(getOperand(opIndex)); + extremum = fir::getBase(Fortran::lower::genIntrinsicCall( + builder, loc, name, resultType, args, stmtCtx)); + } + } + return extremum; +} + +static void prepareIshftcArguments( + const Fortran::evaluate::ProcedureRef &procRef, + const Fortran::evaluate::SpecificIntrinsic &intrinsic, + llvm::Optional retTy, + const Fortran::lower::OperandPrepare &prepareOptionalArgument, + const Fortran::lower::OperandPrepare &prepareOtherArgument, + Fortran::lower::AbstractConverter &converter) { + for (auto arg : llvm::enumerate(procRef.arguments())) { + const auto *expr = + Fortran::evaluate::UnwrapExpr(arg.value()); + assert(expr && "expected all ISHFTC argument to be textually present here"); + if (arg.index() == 2) { + assert(Fortran::evaluate::MayBePassedAsAbsentOptional( + *expr, converter.getFoldingContext()) && + "expected ISHFTC SIZE arg to be dynamically optional"); + prepareOptionalArgument(*expr); + } else { + // Non optional arguments. + prepareOtherArgument(*expr); + } + } +} + +static fir::ExtendedValue +lowerIshftc(fir::FirOpBuilder &builder, mlir::Location loc, + llvm::StringRef name, llvm::Optional retTy, + const Fortran::lower::OperandPresent &isPresentCheck, + const Fortran::lower::OperandGetter &getOperand, + std::size_t numOperands, + Fortran::lower::StatementContext &stmtCtx) { + assert(numOperands == 3 && !isPresentCheck(0) && !isPresentCheck(1) && + isPresentCheck(2) && + "only ISHFTC SIZE arg is expected to be dynamically optional here"); + assert(retTy && "ISFHTC must have a return type"); + mlir::Type resultType = retTy.getValue(); + llvm::SmallVector args; + args.push_back(getOperand(0)); + args.push_back(getOperand(1)); + args.push_back(builder + .genIfOp(loc, {resultType}, isPresentCheck(2).getValue(), + /*withElseRegion=*/true) + .genThen([&]() { + fir::ExtendedValue sizeExv = getOperand(2); + mlir::Value size = builder.createConvert( + loc, resultType, fir::getBase(sizeExv)); + builder.create(loc, size); + }) + .genElse([&]() { + mlir::Value bitSize = builder.createIntegerConstant( + loc, resultType, + resultType.cast().getWidth()); + builder.create(loc, bitSize); + }) + .getResults()[0]); + return Fortran::lower::genIntrinsicCall(builder, loc, name, resultType, args, + stmtCtx); +} + +void Fortran::lower::prepareCustomIntrinsicArgument( + const Fortran::evaluate::ProcedureRef &procRef, + const Fortran::evaluate::SpecificIntrinsic &intrinsic, + llvm::Optional retTy, + const OperandPrepare &prepareOptionalArgument, + const OperandPrepare &prepareOtherArgument, AbstractConverter &converter) { + llvm::StringRef name = intrinsic.name; + if (name == "min" || name == "max") + return prepareMinOrMaxArguments(procRef, intrinsic, retTy, + prepareOptionalArgument, + prepareOtherArgument, converter); + if (name == "ishftc") + return prepareIshftcArguments(procRef, intrinsic, retTy, + prepareOptionalArgument, prepareOtherArgument, + converter); + TODO(converter.getCurrentLocation(), + "unhandled dynamically optional arguments in SYSTEM_CLOCK or " + "RANDOM_SEED"); +} + +fir::ExtendedValue Fortran::lower::lowerCustomIntrinsic( + fir::FirOpBuilder &builder, mlir::Location loc, llvm::StringRef name, + llvm::Optional retTy, const OperandPresent &isPresentCheck, + const OperandGetter &getOperand, std::size_t numOperands, + Fortran::lower::StatementContext &stmtCtx) { + if (name == "min" || name == "max") + return lowerMinOrMax(builder, loc, name, retTy, isPresentCheck, getOperand, + numOperands, stmtCtx); + if (name == "ishftc") + return lowerIshftc(builder, loc, name, retTy, isPresentCheck, getOperand, + numOperands, stmtCtx); + TODO(loc, "unhandled dynamically optional arguments in SYSTEM_CLOCK or " + "RANDOM_SEED"); +} diff --git a/flang/lib/Lower/IntrinsicCall.cpp b/flang/lib/Lower/IntrinsicCall.cpp --- a/flang/lib/Lower/IntrinsicCall.cpp +++ b/flang/lib/Lower/IntrinsicCall.cpp @@ -15,14 +15,18 @@ #include "flang/Lower/IntrinsicCall.h" #include "flang/Common/static-multimap-view.h" +#include "flang/Lower/Mangler.h" #include "flang/Lower/StatementContext.h" #include "flang/Lower/SymbolMap.h" #include "flang/Lower/Todo.h" +#include "flang/Optimizer/Builder/Character.h" #include "flang/Optimizer/Builder/Complex.h" #include "flang/Optimizer/Builder/FIRBuilder.h" #include "flang/Optimizer/Builder/MutableBox.h" #include "flang/Optimizer/Builder/Runtime/RTBuilder.h" +#include "flang/Optimizer/Builder/Runtime/Reduction.h" #include "flang/Optimizer/Support/FatalError.h" +#include "mlir/Dialect/LLVMIR/LLVMDialect.h" #include "llvm/Support/CommandLine.h" #define DEBUG_TYPE "flang-lower-intrinsic" @@ -90,12 +94,110 @@ return fir::UnboxedValue{}; } +/// Test if an ExtendedValue is absent. +static bool isAbsent(const fir::ExtendedValue &exv) { + return !fir::getBase(exv); +} + +/// Process calls to Maxval, Minval, Product, Sum intrinsic functions that +/// take a DIM argument. +template +static fir::ExtendedValue +genFuncDim(FD funcDim, mlir::Type resultType, fir::FirOpBuilder &builder, + mlir::Location loc, Fortran::lower::StatementContext *stmtCtx, + llvm::StringRef errMsg, mlir::Value array, fir::ExtendedValue dimArg, + mlir::Value mask, int rank) { + + // Create mutable fir.box to be passed to the runtime for the result. + mlir::Type resultArrayType = builder.getVarLenSeqTy(resultType, rank - 1); + fir::MutableBoxValue resultMutableBox = + fir::factory::createTempMutableBox(builder, loc, resultArrayType); + mlir::Value resultIrBox = + fir::factory::getMutableIRBox(builder, loc, resultMutableBox); + + mlir::Value dim = + isAbsent(dimArg) + ? builder.createIntegerConstant(loc, builder.getIndexType(), 0) + : fir::getBase(dimArg); + funcDim(builder, loc, resultIrBox, array, dim, mask); + + fir::ExtendedValue res = + fir::factory::genMutableBoxRead(builder, loc, resultMutableBox); + return res.match( + [&](const fir::ArrayBoxValue &box) -> fir::ExtendedValue { + // Add cleanup code + assert(stmtCtx); + fir::FirOpBuilder *bldr = &builder; + mlir::Value temp = box.getAddr(); + stmtCtx->attachCleanup( + [=]() { bldr->create(loc, temp); }); + return box; + }, + [&](const fir::CharArrayBoxValue &box) -> fir::ExtendedValue { + // Add cleanup code + assert(stmtCtx); + fir::FirOpBuilder *bldr = &builder; + mlir::Value temp = box.getAddr(); + stmtCtx->attachCleanup( + [=]() { bldr->create(loc, temp); }); + return box; + }, + [&](const auto &) -> fir::ExtendedValue { + fir::emitFatalError(loc, errMsg); + }); +} + +/// Process calls to Product, Sum intrinsic functions +template +static fir::ExtendedValue +genProdOrSum(FN func, FD funcDim, mlir::Type resultType, + fir::FirOpBuilder &builder, mlir::Location loc, + Fortran::lower::StatementContext *stmtCtx, llvm::StringRef errMsg, + llvm::ArrayRef args) { + + assert(args.size() == 3); + + // Handle required array argument + fir::BoxValue arryTmp = builder.createBox(loc, args[0]); + mlir::Value array = fir::getBase(arryTmp); + int rank = arryTmp.rank(); + assert(rank >= 1); + + // Handle optional mask argument + auto mask = isAbsent(args[2]) + ? builder.create( + loc, fir::BoxType::get(builder.getI1Type())) + : builder.createBox(loc, args[2]); + + bool absentDim = isAbsent(args[1]); + + // We call the type specific versions because the result is scalar + // in the case below. + if (absentDim || rank == 1) { + mlir::Type ty = array.getType(); + mlir::Type arrTy = fir::dyn_cast_ptrOrBoxEleTy(ty); + auto eleTy = arrTy.cast().getEleTy(); + if (fir::isa_complex(eleTy)) { + mlir::Value result = builder.createTemporary(loc, eleTy); + func(builder, loc, array, mask, result); + return builder.create(loc, result); + } + auto resultBox = builder.create( + loc, fir::BoxType::get(builder.getI1Type())); + return func(builder, loc, array, mask, resultBox); + } + // Handle Product/Sum cases that have an array result. + return genFuncDim(funcDim, resultType, builder, loc, stmtCtx, errMsg, array, + args[1], mask, rank); +} + // TODO error handling -> return a code or directly emit messages ? struct IntrinsicLibrary { // Constructors. - explicit IntrinsicLibrary(fir::FirOpBuilder &builder, mlir::Location loc) - : builder{builder}, loc{loc} {} + explicit IntrinsicLibrary(fir::FirOpBuilder &builder, mlir::Location loc, + Fortran::lower::StatementContext *stmtCtx = nullptr) + : builder{builder}, loc{loc}, stmtCtx{stmtCtx} {} IntrinsicLibrary() = delete; IntrinsicLibrary(const IntrinsicLibrary &) = delete; @@ -131,11 +233,23 @@ /// Lowering for the IAND intrinsic. The IAND intrinsic expects two arguments /// in the llvm::ArrayRef. mlir::Value genIand(mlir::Type, llvm::ArrayRef); + fir::ExtendedValue genSum(mlir::Type, llvm::ArrayRef); /// Define the different FIR generators that can be mapped to intrinsic to /// generate the related code. The intrinsic is lowered into an MLIR /// arith::AndIOp. using ElementalGenerator = decltype(&IntrinsicLibrary::genAbs); - using Generator = std::variant; + using ExtendedGenerator = decltype(&IntrinsicLibrary::genSum); + using Generator = std::variant; + + template + fir::ExtendedValue + outlineInExtendedWrapper(GeneratorType, llvm::StringRef name, + llvm::Optional resultType, + llvm::ArrayRef args); + + template + mlir::FuncOp getWrapper(GeneratorType, llvm::StringRef name, + mlir::FunctionType, bool loadRefArguments = false); /// Generate calls to ElementalGenerator, handling the elemental aspects template @@ -150,8 +264,13 @@ mlir::Value invokeGenerator(RuntimeCallGenerator generator, mlir::Type resultType, llvm::ArrayRef args); + mlir::Value invokeGenerator(ExtendedGenerator generator, + mlir::Type resultType, + llvm::ArrayRef args); + fir::FirOpBuilder &builder; mlir::Location loc; + Fortran::lower::StatementContext *stmtCtx; }; struct IntrinsicDummyArgument { @@ -171,11 +290,20 @@ struct IntrinsicHandler { const char *name; IntrinsicLibrary::Generator generator; + // The following may be omitted in the table below. Fortran::lower::IntrinsicArgumentLoweringRules argLoweringRules = {}; + bool isElemental = true; }; +constexpr auto asValue = Fortran::lower::LowerIntrinsicArgAs::Value; +constexpr auto asBox = Fortran::lower::LowerIntrinsicArgAs::Box; using I = IntrinsicLibrary; +/// Flag to indicate that an intrinsic argument has to be handled as +/// being dynamically optional (e.g. special handling when actual +/// argument is an optional variable in the current scope). +static constexpr bool handleDynamicOptional = true; + /// Table that drives the fir generation depending on the intrinsic. /// one to one mapping with Fortran arguments. If no mapping is /// defined here for a generic intrinsic, genRuntimeCall will be called @@ -186,6 +314,12 @@ static constexpr IntrinsicHandler handlers[]{ {"abs", &I::genAbs}, {"iand", &I::genIand}, + {"sum", + &I::genSum, + {{{"array", asBox}, + {"dim", asValue}, + {"mask", asBox, handleDynamicOptional}}}, + /*isElemental=*/false}, }; static const IntrinsicHandler *findIntrinsicHandler(llvm::StringRef name) { @@ -513,10 +647,71 @@ return mlir::FunctionType::get(builder.getModule().getContext(), argTypes, resTypes); } + +/// fir::ExtendedValue to mlir::Value translation layer + +fir::ExtendedValue toExtendedValue(mlir::Value val, fir::FirOpBuilder &builder, + mlir::Location loc) { + assert(val && "optional unhandled here"); + mlir::Type type = val.getType(); + mlir::Value base = val; + mlir::IndexType indexType = builder.getIndexType(); + llvm::SmallVector extents; + + fir::factory::CharacterExprHelper charHelper{builder, loc}; + // FIXME: we may want to allow non character scalar here. + if (charHelper.isCharacterScalar(type)) + return charHelper.toExtendedValue(val); + + if (auto refType = type.dyn_cast()) + type = refType.getEleTy(); + + if (auto arrayType = type.dyn_cast()) { + type = arrayType.getEleTy(); + for (fir::SequenceType::Extent extent : arrayType.getShape()) { + if (extent == fir::SequenceType::getUnknownExtent()) + break; + extents.emplace_back( + builder.createIntegerConstant(loc, indexType, extent)); + } + // Last extent might be missing in case of assumed-size. If more extents + // could not be deduced from type, that's an error (a fir.box should + // have been used in the interface). + if (extents.size() + 1 < arrayType.getShape().size()) + mlir::emitError(loc, "cannot retrieve array extents from type"); + } else if (type.isa() || type.isa()) { + fir::emitFatalError(loc, "not yet implemented: descriptor or derived type"); + } + + if (!extents.empty()) + return fir::ArrayBoxValue{base, extents}; + return base; +} + +mlir::Value toValue(const fir::ExtendedValue &val, fir::FirOpBuilder &builder, + mlir::Location loc) { + if (const fir::CharBoxValue *charBox = val.getCharBox()) { + mlir::Value buffer = charBox->getBuffer(); + if (buffer.getType().isa()) + return buffer; + return fir::factory::CharacterExprHelper{builder, loc}.createEmboxChar( + buffer, charBox->getLen()); + } + + // FIXME: need to access other ExtendedValue variants and handle them + // properly. + return fir::getBase(val); +} + //===----------------------------------------------------------------------===// // IntrinsicLibrary //===----------------------------------------------------------------------===// +/// Emit a TODO error message for as yet unimplemented intrinsics. +static void crashOnMissingIntrinsic(mlir::Location loc, llvm::StringRef name) { + TODO(loc, "missing intrinsic lowering: " + llvm::Twine(name)); +} + template fir::ExtendedValue IntrinsicLibrary::genElementalCall( GeneratorType generator, llvm::StringRef name, mlir::Type resultType, @@ -530,6 +725,19 @@ return invokeGenerator(generator, resultType, scalarArgs); } +template <> +fir::ExtendedValue +IntrinsicLibrary::genElementalCall( + ExtendedGenerator generator, llvm::StringRef name, mlir::Type resultType, + llvm::ArrayRef args, bool outline) { + for (const fir::ExtendedValue &arg : args) + if (!arg.getUnboxed() && !arg.getCharBox()) + fir::emitFatalError(loc, "nonscalar intrinsic argument"); + if (outline) + return outlineInExtendedWrapper(generator, name, resultType, args); + return std::invoke(generator, *this, resultType, args); +} + static fir::ExtendedValue invokeHandler(IntrinsicLibrary::ElementalGenerator generator, const IntrinsicHandler &handler, @@ -541,6 +749,22 @@ outline); } +static fir::ExtendedValue +invokeHandler(IntrinsicLibrary::ExtendedGenerator generator, + const IntrinsicHandler &handler, + llvm::Optional resultType, + llvm::ArrayRef args, bool outline, + IntrinsicLibrary &lib) { + assert(resultType && "expect intrinsic function"); + if (handler.isElemental) + return lib.genElementalCall(generator, handler.name, *resultType, args, + outline); + if (outline) + return lib.outlineInExtendedWrapper(generator, handler.name, *resultType, + args); + return std::invoke(generator, lib, *resultType, args); +} + fir::ExtendedValue IntrinsicLibrary::genIntrinsicCall(llvm::StringRef name, llvm::Optional resultType, @@ -555,8 +779,32 @@ handler->generator); } - TODO(loc, "genIntrinsicCall runtime"); - return {}; + if (!resultType) + // Subroutine should have a handler, they are likely missing for now. + crashOnMissingIntrinsic(loc, name); + + // Try the runtime if no special handler was defined for the + // intrinsic being called. Maths runtime only has numerical elemental. + // No optional arguments are expected at this point, the code will + // crash if it gets absent optional. + + // FIXME: using toValue to get the type won't work with array arguments. + llvm::SmallVector mlirArgs; + for (const fir::ExtendedValue &extendedVal : args) { + mlir::Value val = toValue(extendedVal, builder, loc); + if (!val) + // If an absent optional gets there, most likely its handler has just + // not yet been defined. + crashOnMissingIntrinsic(loc, name); + mlirArgs.emplace_back(val); + } + mlir::FunctionType soughtFuncType = + getFunctionType(*resultType, mlirArgs, builder); + + IntrinsicLibrary::RuntimeCallGenerator runtimeCallGenerator = + getRuntimeCallGenerator(name, soughtFuncType); + return genElementalCall(runtimeCallGenerator, name, *resultType, args, + /* outline */ true); } mlir::Value @@ -572,15 +820,108 @@ llvm::ArrayRef args) { return generator(builder, loc, args); } + +mlir::Value +IntrinsicLibrary::invokeGenerator(ExtendedGenerator generator, + mlir::Type resultType, + llvm::ArrayRef args) { + llvm::SmallVector extendedArgs; + for (mlir::Value arg : args) + extendedArgs.emplace_back(toExtendedValue(arg, builder, loc)); + auto extendedResult = std::invoke(generator, *this, resultType, extendedArgs); + return toValue(extendedResult, builder, loc); +} + +template +mlir::FuncOp IntrinsicLibrary::getWrapper(GeneratorType generator, + llvm::StringRef name, + mlir::FunctionType funcType, + bool loadRefArguments) { + std::string wrapperName = fir::mangleIntrinsicProcedure(name, funcType); + mlir::FuncOp function = builder.getNamedFunction(wrapperName); + if (!function) { + // First time this wrapper is needed, build it. + function = builder.createFunction(loc, wrapperName, funcType); + function->setAttr("fir.intrinsic", builder.getUnitAttr()); + auto internalLinkage = mlir::LLVM::linkage::Linkage::Internal; + auto linkage = + mlir::LLVM::LinkageAttr::get(builder.getContext(), internalLinkage); + function->setAttr("llvm.linkage", linkage); + function.addEntryBlock(); + + // Create local context to emit code into the newly created function + // This new function is not linked to a source file location, only + // its calls will be. + auto localBuilder = + std::make_unique(function, builder.getKindMap()); + localBuilder->setInsertionPointToStart(&function.front()); + // Location of code inside wrapper of the wrapper is independent from + // the location of the intrinsic call. + mlir::Location localLoc = localBuilder->getUnknownLoc(); + llvm::SmallVector localArguments; + for (mlir::BlockArgument bArg : function.front().getArguments()) { + auto refType = bArg.getType().dyn_cast(); + if (loadRefArguments && refType) { + auto loaded = localBuilder->create(localLoc, bArg); + localArguments.push_back(loaded); + } else { + localArguments.push_back(bArg); + } + } + + IntrinsicLibrary localLib{*localBuilder, localLoc}; + + assert(funcType.getNumResults() == 1 && + "expect one result for intrinsic function wrapper type"); + mlir::Type resultType = funcType.getResult(0); + auto result = + localLib.invokeGenerator(generator, resultType, localArguments); + localBuilder->create(localLoc, result); + } else { + // Wrapper was already built, ensure it has the sought type + assert(function.getType() == funcType && + "conflict between intrinsic wrapper types"); + } + return function; +} + +/// Helpers to detect absent optional (not yet supported in outlining). +bool static hasAbsentOptional(llvm::ArrayRef args) { + for (const fir::ExtendedValue &arg : args) + if (!fir::getBase(arg)) + return true; + return false; +} + +template +fir::ExtendedValue IntrinsicLibrary::outlineInExtendedWrapper( + GeneratorType generator, llvm::StringRef name, + llvm::Optional resultType, + llvm::ArrayRef args) { + if (hasAbsentOptional(args)) + TODO(loc, "cannot outline call to intrinsic " + llvm::Twine(name) + + " with absent optional argument"); + llvm::SmallVector mlirArgs; + for (const auto &extendedVal : args) + mlirArgs.emplace_back(toValue(extendedVal, builder, loc)); + mlir::FunctionType funcType = getFunctionType(resultType, mlirArgs, builder); + mlir::FuncOp wrapper = getWrapper(generator, name, funcType); + auto call = builder.create(loc, wrapper, mlirArgs); + if (resultType) + return toExtendedValue(call.getResult(0), builder, loc); + // Subroutine calls + return mlir::Value{}; +} + IntrinsicLibrary::RuntimeCallGenerator IntrinsicLibrary::getRuntimeCallGenerator(llvm::StringRef name, mlir::FunctionType soughtFuncType) { mlir::FuncOp funcOp = getRuntimeFunction(loc, builder, name, soughtFuncType); if (!funcOp) { - mlir::emitError(loc, - "TODO: missing intrinsic lowering: " + llvm::Twine(name)); - llvm::errs() << "requested type was: " << soughtFuncType << "\n"; - exit(1); + std::string buffer("not yet implemented: missing intrinsic lowering: "); + llvm::raw_string_ostream sstream(buffer); + sstream << name << "\nrequested type was: " << soughtFuncType << '\n'; + fir::emitFatalError(loc, buffer); } mlir::FunctionType actualFuncType = funcOp.getType(); @@ -722,6 +1063,14 @@ return result; } +// SUM +fir::ExtendedValue +IntrinsicLibrary::genSum(mlir::Type resultType, + llvm::ArrayRef args) { + return genProdOrSum(fir::runtime::genSum, fir::runtime::genSumDim, resultType, + builder, loc, stmtCtx, "unexpected result for Sum", args); +} + //===----------------------------------------------------------------------===// // Argument lowering rules interface //===----------------------------------------------------------------------===// @@ -756,9 +1105,10 @@ Fortran::lower::genIntrinsicCall(fir::FirOpBuilder &builder, mlir::Location loc, llvm::StringRef name, llvm::Optional resultType, - llvm::ArrayRef args) { - return IntrinsicLibrary{builder, loc}.genIntrinsicCall(name, resultType, - args); + llvm::ArrayRef args, + Fortran::lower::StatementContext &stmtCtx) { + return IntrinsicLibrary{builder, loc, &stmtCtx}.genIntrinsicCall( + name, resultType, args); } mlir::Value Fortran::lower::genMax(fir::FirOpBuilder &builder, diff --git a/flang/lib/Optimizer/Builder/FIRBuilder.cpp b/flang/lib/Optimizer/Builder/FIRBuilder.cpp --- a/flang/lib/Optimizer/Builder/FIRBuilder.cpp +++ b/flang/lib/Optimizer/Builder/FIRBuilder.cpp @@ -661,6 +661,46 @@ box.getLBounds()); } +llvm::SmallVector +fir::factory::getNonDefaultLowerBounds(fir::FirOpBuilder &builder, + mlir::Location loc, + const fir::ExtendedValue &exv) { + return exv.match( + [&](const fir::ArrayBoxValue &array) -> llvm::SmallVector { + return {array.getLBounds().begin(), array.getLBounds().end()}; + }, + [&](const fir::CharArrayBoxValue &array) + -> llvm::SmallVector { + return {array.getLBounds().begin(), array.getLBounds().end()}; + }, + [&](const fir::BoxValue &box) -> llvm::SmallVector { + return {box.getLBounds().begin(), box.getLBounds().end()}; + }, + [&](const fir::MutableBoxValue &box) -> llvm::SmallVector { + auto load = fir::factory::genMutableBoxRead(builder, loc, box); + return fir::factory::getNonDefaultLowerBounds(builder, loc, load); + }, + [&](const auto &) -> llvm::SmallVector { return {}; }); +} + +llvm::SmallVector +fir::factory::getNonDeferredLengthParams(const fir::ExtendedValue &exv) { + return exv.match( + [&](const fir::CharArrayBoxValue &character) + -> llvm::SmallVector { return {character.getLen()}; }, + [&](const fir::CharBoxValue &character) + -> llvm::SmallVector { return {character.getLen()}; }, + [&](const fir::MutableBoxValue &box) -> llvm::SmallVector { + return {box.nonDeferredLenParams().begin(), + box.nonDeferredLenParams().end()}; + }, + [&](const fir::BoxValue &box) -> llvm::SmallVector { + return {box.getExplicitParameters().begin(), + box.getExplicitParameters().end()}; + }, + [&](const auto &) -> llvm::SmallVector { return {}; }); +} + std::string fir::factory::uniqueCGIdent(llvm::StringRef prefix, llvm::StringRef name) { // For "long" identifiers use a hash value diff --git a/flang/lib/Optimizer/Dialect/FIRType.cpp b/flang/lib/Optimizer/Dialect/FIRType.cpp --- a/flang/lib/Optimizer/Dialect/FIRType.cpp +++ b/flang/lib/Optimizer/Dialect/FIRType.cpp @@ -246,6 +246,27 @@ return false; } +bool isAllocatableType(mlir::Type ty) { + if (auto refTy = fir::dyn_cast_ptrEleTy(ty)) + ty = refTy; + if (auto boxTy = ty.dyn_cast()) + return boxTy.getEleTy().isa(); + return false; +} + +bool isRecordWithAllocatableMember(mlir::Type ty) { + if (auto recTy = ty.dyn_cast()) + for (auto [field, memTy] : recTy.getTypeList()) { + if (fir::isAllocatableType(memTy)) + return true; + // A record type cannot recursively include itself as a direct member. + // There must be an intervening `ptr` type, so recursion is safe here. + if (memTy.isa() && isRecordWithAllocatableMember(memTy)) + return true; + } + return false; +} + } // namespace fir namespace { diff --git a/flang/test/Lower/Intrinsics/sum.f90 b/flang/test/Lower/Intrinsics/sum.f90 new file mode 100644 --- /dev/null +++ b/flang/test/Lower/Intrinsics/sum.f90 @@ -0,0 +1,134 @@ +! RUN: bbc -emit-fir %s -o - | FileCheck %s + +! CHECK-LABEL: func @_QPsum_test( +! CHECK-SAME: %[[arg0:.*]]: !fir.box>{{.*}}) -> i32 { +integer function sum_test(a) +integer :: a(:) +! CHECK-DAG: %[[c0:.*]] = arith.constant 0 : index +! CHECK-DAG: %[[a1:.*]] = fir.absent !fir.box +! CHECK-DAG: %[[a3:.*]] = fir.convert %[[arg0]] : (!fir.box>) -> !fir.box +! CHECK-DAG: %[[a5:.*]] = fir.convert %[[c0]] : (index) -> i32 +! CHECK-DAG: %[[a6:.*]] = fir.convert %[[a1]] : (!fir.box) -> !fir.box +sum_test = sum(a) +! CHECK: %{{.*}} = fir.call @_FortranASumInteger4(%[[a3]], %{{.*}}, %{{.*}}, %[[a5]], %[[a6]]) : (!fir.box, !fir.ref, i32, i32, !fir.box) -> i32 +end function + +! CHECK-LABEL: func @_QPsum_test2( +! CHECK-SAME: %[[arg0:.*]]: !fir.box>{{.*}}, %[[arg1:.*]]: !fir.box>{{.*}}) { +subroutine sum_test2(a,r) +integer :: a(:,:) +integer :: r(:) +! CHECK-DAG: %[[c2_i32:.*]] = arith.constant 2 : i32 +! CHECK-DAG: %[[a0:.*]] = fir.alloca !fir.box>> +! CHECK-DAG: %[[a1:.*]] = fir.absent !fir.box +! CHECK-DAG: %[[a6:.*]] = fir.convert %[[a0]] : (!fir.ref>>>) -> !fir.ref> +! CHECK-DAG: %[[a7:.*]] = fir.convert %[[arg0]] : (!fir.box>) -> !fir.box +! CHECK-DAG: %[[a9:.*]] = fir.convert %[[a1]] : (!fir.box) -> !fir.box +r = sum(a,dim=2) +! CHECK: %{{.*}} = fir.call @_FortranASumDim(%[[a6]], %[[a7]], %[[c2_i32]], %{{.*}}, %{{.*}}, %[[a9]]) : (!fir.ref>, !fir.box, i32, !fir.ref, i32, !fir.box) -> none +! CHECK-DAG: %[[a11:.*]] = fir.load %[[a0]] : !fir.ref>>> +! CHECK-DAG: %[[a13:.*]] = fir.box_addr %[[a11]] : (!fir.box>>) -> !fir.heap> +! CHECK-DAG: fir.freemem %[[a13]] +end subroutine + +! CHECK-LABEL: func @_QPsum_test3( +! CHECK-SAME: %[[arg0:.*]]: !fir.box>>{{.*}}) -> !fir.complex<4> { +complex function sum_test3(a) +complex :: a(:) +! CHECK-DAG: %[[c0:.*]] = arith.constant 0 : index +! CHECK-DAG: %[[a0:.*]] = fir.alloca !fir.complex<4> +! CHECK-DAG: %[[a3:.*]] = fir.absent !fir.box +! CHECK-DAG: %[[a5:.*]] = fir.convert %[[a0]] : (!fir.ref>) -> !fir.ref> +! CHECK-DAG: %[[a6:.*]] = fir.convert %[[arg0]] : (!fir.box>>) -> !fir.box +! CHECK-DAG: %[[a8:.*]] = fir.convert %[[c0]] : (index) -> i32 +! CHECK-DAG: %[[a9:.*]] = fir.convert %[[a3]] : (!fir.box) -> !fir.box +sum_test3 = sum(a) +! CHECK: %{{.*}} = fir.call @_FortranACppSumComplex4(%[[a5]], %[[a6]], %{{.*}}, %{{.*}}, %[[a8]], %[[a9]]) : (!fir.ref>, !fir.box, !fir.ref, i32, i32, !fir.box) -> none +end function + +! CHECK-LABEL: func @_QPsum_test4( +! CHECK-SAME: %[[arg0:.*]]: !fir.box>>{{.*}}) -> !fir.complex<10> { +complex(10) function sum_test4(x) +complex(10):: x(:) +! CHECK-DAG: %[[c0:.*]] = arith.constant 0 : index +! CHECK-DAG: %[[a0:.*]] = fir.alloca !fir.complex<10> +sum_test4 = sum(x) +! CHECK-DAG: %[[a2:.*]] = fir.absent !fir.box +! CHECK-DAG: %[[a4:.*]] = fir.convert %[[a0]] : (!fir.ref>) -> !fir.ref> +! CHECK-DAG: %[[a5:.*]] = fir.convert %[[arg0]] : (!fir.box>>) -> !fir.box +! CHECK-DAG: %[[a7:.*]] = fir.convert %[[c0]] : (index) -> i32 +! CHECK-DAG: %[[a8:.*]] = fir.convert %[[a2]] : (!fir.box) -> !fir.box +! CHECK: fir.call @_FortranACppSumComplex10(%[[a4]], %[[a5]], %{{.*}}, %{{.*}}, %[[a7]], %8) : (!fir.ref>, !fir.box, !fir.ref, i32, i32, !fir.box) -> () +end + +! CHECK-LABEL: func @_QPsum_test_optional( +! CHECK-SAME: %[[VAL_0:.*]]: !fir.box>> +integer function sum_test_optional(mask, x) +integer :: x(:) +logical, optional :: mask(:) +sum_test_optional = sum(x, mask=mask) +! CHECK: %[[VAL_9:.*]] = fir.convert %[[VAL_0]] : (!fir.box>>) -> !fir.box +! CHECK: fir.call @_FortranASumInteger4(%{{.*}}, %{{.*}}, %{{.*}}, %{{.*}}, %[[VAL_9]]) : (!fir.box, !fir.ref, i32, i32, !fir.box) -> i32 +end function + +! CHECK-LABEL: func @_QPsum_test_optional_2( +! CHECK-SAME: %[[VAL_0:.*]]: !fir.ref>>>> +integer function sum_test_optional_2(mask, x) +integer :: x(:) +logical, pointer :: mask(:) +sum_test_optional = sum(x, mask=mask) +! CHECK: %[[VAL_4:.*]] = fir.load %[[VAL_0]] : !fir.ref>>>> +! CHECK: %[[VAL_5:.*]] = fir.box_addr %[[VAL_4]] : (!fir.box>>>) -> !fir.ptr>> +! CHECK: %[[VAL_6:.*]] = fir.convert %[[VAL_5]] : (!fir.ptr>>) -> i64 +! CHECK: %[[VAL_7:.*]] = arith.constant 0 : i64 +! CHECK: %[[VAL_8:.*]] = arith.cmpi ne, %[[VAL_6]], %[[VAL_7]] : i64 +! CHECK: %[[VAL_9:.*]] = fir.load %[[VAL_0]] : !fir.ref>>>> +! CHECK: %[[VAL_10:.*]] = fir.absent !fir.box>>> +! CHECK: %[[VAL_11:.*]] = arith.select %[[VAL_8]], %[[VAL_9]], %[[VAL_10]] : !fir.box>>> +! CHECK: %[[VAL_18:.*]] = fir.convert %[[VAL_11]] : (!fir.box>>>) -> !fir.box +! CHECK: fir.call @_FortranASumInteger4(%{{.*}}, %{{.*}}, %{{.*}}, %{{.*}}, %[[VAL_18]]) : (!fir.box, !fir.ref, i32, i32, !fir.box) -> i32 +end function + +! CHECK-LABEL: func @_QPsum_test_optional_3( +! CHECK-SAME: %[[VAL_0:.*]]: !fir.ref>> +integer function sum_test_optional_3(mask, x) +integer :: x(:) +logical, optional :: mask(10) +sum_test_optional = sum(x, mask=mask) +! CHECK: %[[VAL_2:.*]] = arith.constant 10 : index +! CHECK: %[[VAL_5:.*]] = fir.is_present %[[VAL_0]] : (!fir.ref>>) -> i1 +! CHECK: %[[VAL_6:.*]] = fir.shape %[[VAL_2]] : (index) -> !fir.shape<1> +! CHECK: %[[VAL_7:.*]] = fir.embox %[[VAL_0]](%[[VAL_6]]) : (!fir.ref>>, !fir.shape<1>) -> !fir.box>> +! CHECK: %[[VAL_8:.*]] = fir.absent !fir.box>> +! CHECK: %[[VAL_9:.*]] = arith.select %[[VAL_5]], %[[VAL_7]], %[[VAL_8]] : !fir.box>> +! CHECK: %[[VAL_18:.*]] = fir.convert %[[VAL_9]] : (!fir.box>>) -> !fir.box +! CHECK: fir.call @_FortranASumInteger4(%{{.*}}, %{{.*}}, %{{.*}}, %{{.*}}, %[[VAL_18]]) : (!fir.box, !fir.ref, i32, i32, !fir.box) -> i32 +end function + +! CHECK-LABEL: func @_QPsum_test_optional_4( +integer function sum_test_optional_4(x, use_mask) +! Test that local allocatable tracked in local variables +! are dealt as optional argument correctly. +integer :: x(:) +logical :: use_mask +logical, allocatable :: mask(:) +if (use_mask) then + allocate(mask(size(x, 1))) + call set_mask(mask) + ! CHECK: fir.call @_QPset_mask +end if +sum_test_optional = sum(x, mask=mask) +! CHECK: %[[VAL_20:.*]] = fir.load %[[VAL_3:.*]] : !fir.ref>>> +! CHECK: %[[VAL_21:.*]] = fir.convert %[[VAL_20]] : (!fir.heap>>) -> i64 +! CHECK: %[[VAL_22:.*]] = arith.constant 0 : i64 +! CHECK: %[[VAL_23:.*]] = arith.cmpi ne, %[[VAL_21]], %[[VAL_22]] : i64 +! CHECK: %[[VAL_24:.*]] = fir.load %[[VAL_4:.*]] : !fir.ref +! CHECK: %[[VAL_25:.*]] = fir.load %[[VAL_5:.*]] : !fir.ref +! CHECK: %[[VAL_26:.*]] = fir.load %[[VAL_3]] : !fir.ref>>> +! CHECK: %[[VAL_27:.*]] = fir.shape_shift %[[VAL_24]], %[[VAL_25]] : (index, index) -> !fir.shapeshift<1> +! CHECK: %[[VAL_28:.*]] = fir.embox %[[VAL_26]](%[[VAL_27]]) : (!fir.heap>>, !fir.shapeshift<1>) -> !fir.box>> +! CHECK: %[[VAL_29:.*]] = fir.absent !fir.box>> +! CHECK: %[[VAL_30:.*]] = arith.select %[[VAL_23]], %[[VAL_28]], %[[VAL_29]] : !fir.box>> +! CHECK: %[[VAL_37:.*]] = fir.convert %[[VAL_30]] : (!fir.box>>) -> !fir.box +! CHECK: fir.call @_FortranASumInteger4(%{{.*}}, %{{.*}}, %{{.*}}, %{{.*}}, %[[VAL_37]]) : (!fir.box, !fir.ref, i32, i32, !fir.box) -> i32 +end function diff --git a/flang/unittests/Runtime/Time.cpp b/flang/unittests/Runtime/Time.cpp --- a/flang/unittests/Runtime/Time.cpp +++ b/flang/unittests/Runtime/Time.cpp @@ -166,3 +166,4 @@ EXPECT_LE(minutes, 59); } } +