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 @@ -57,6 +57,7 @@ using SomeExpr = Fortran::evaluate::Expr; using SymbolRef = Fortran::common::Reference; +class StatementContext; //===----------------------------------------------------------------------===// // AbstractConverter interface @@ -87,12 +88,13 @@ } /// Generate the computations of the expression to produce a value - virtual fir::ExtendedValue genExprValue(const SomeExpr &, + virtual fir::ExtendedValue genExprValue(const SomeExpr &, StatementContext &, mlir::Location *loc = nullptr) = 0; /// Generate the computations of the expression, someExpr, to produce a value fir::ExtendedValue genExprValue(const SomeExpr *someExpr, + StatementContext &stmtCtx, mlir::Location loc) { - return genExprValue(*someExpr, &loc); + return genExprValue(*someExpr, stmtCtx, &loc); } /// Get FoldingContext that is required for some expression @@ -103,16 +105,18 @@ // Types //===--------------------------------------------------------------------===// - /// Generate the type of a DataRef - virtual mlir::Type genType(const Fortran::evaluate::DataRef &) = 0; /// Generate the type of an Expr virtual mlir::Type genType(const SomeExpr &) = 0; /// Generate the type of a Symbol virtual mlir::Type genType(SymbolRef) = 0; /// Generate the type from a category virtual mlir::Type genType(Fortran::common::TypeCategory tc) = 0; - /// Generate the type from a category and kind - virtual mlir::Type genType(Fortran::common::TypeCategory tc, int kind) = 0; + /// Generate the type from a category and kind and length parameters. + virtual mlir::Type + genType(Fortran::common::TypeCategory tc, int kind, + llvm::ArrayRef lenParameters = llvm::None) = 0; + /// Generate the type from a DerivedTypeSpec. + virtual mlir::Type genType(const Fortran::semantics::DerivedTypeSpec &) = 0; /// Generate the type from a Variable virtual mlir::Type genType(const pft::Variable &) = 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 @@ -34,6 +34,7 @@ namespace Fortran::lower { class AbstractConverter; +class StatementContext; class SymMap; using SomeExpr = Fortran::evaluate::Expr; @@ -41,7 +42,29 @@ fir::ExtendedValue createSomeExtendedExpression(mlir::Location loc, AbstractConverter &converter, const SomeExpr &expr, - SymMap &symMap); + 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); + +/// Lower an array expression to a value of type box. The expression must be a +/// variable. +fir::ExtendedValue createSomeArrayBox(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. +inline mlir::NamedAttribute getAdaptToByRefAttr(fir::FirOpBuilder &builder) { + return {mlir::StringAttr::get(builder.getContext(), fir::getAdaptToByRefAttrName()), + builder.getUnitAttr()}; +} + } // namespace Fortran::lower diff --git a/flang/include/flang/Lower/ConvertType.h b/flang/include/flang/Lower/ConvertType.h --- a/flang/include/flang/Lower/ConvertType.h +++ b/flang/include/flang/Lower/ConvertType.h @@ -61,13 +61,12 @@ using SomeExpr = evaluate::Expr; using SymbolRef = common::Reference; +// Type for compile time constant length type parameters. +using LenParameterTy = std::int64_t; + /// Get a FIR type based on a category and kind. mlir::Type getFIRType(mlir::MLIRContext *ctxt, common::TypeCategory tc, - int kind); - -/// Get a FIR type based on a category. -mlir::Type getFIRType(Fortran::lower::AbstractConverter &, - common::TypeCategory tc); + int kind, llvm::ArrayRef); /// Translate a Fortran::evaluate::DataRef to an mlir::Type. mlir::Type translateDataRefToFIRType(Fortran::lower::AbstractConverter &, diff --git a/flang/include/flang/Lower/IntrinsicCall.h b/flang/include/flang/Lower/IntrinsicCall.h new file mode 100644 --- /dev/null +++ b/flang/include/flang/Lower/IntrinsicCall.h @@ -0,0 +1,116 @@ +//===-- Lower/IntrinsicCall.h -- lowering of intrinsics ---------*- 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 +// +//===----------------------------------------------------------------------===// + +#ifndef FORTRAN_LOWER_INTRINSICCALL_H +#define FORTRAN_LOWER_INTRINSICCALL_H + +#include "flang/Optimizer/Builder/FIRBuilder.h" +#include "llvm/ADT/Optional.h" + +namespace fir { +class ExtendedValue; +} + +namespace Fortran::lower { + +class StatementContext; + +// TODO: Error handling interface ? +// TODO: Implementation is incomplete. Many intrinsics to tbd. + +/// Generate the FIR+MLIR operations for the generic intrinsic \p name +/// with arguments \p args and expected result type \p resultType. +/// Returned mlir::Value is the returned Fortran intrinsic value. +/// If the result is an allocated temporary, its clean-up is added to the +/// StatementContext. +fir::ExtendedValue genIntrinsicCall(fir::FirOpBuilder &, mlir::Location, + llvm::StringRef name, + llvm::Optional resultType, + llvm::ArrayRef args, + StatementContext &); + +/// Enum specifying how intrinsic argument evaluate::Expr should be +/// lowered to fir::ExtendedValue to be passed to genIntrinsicCall. +enum class LowerIntrinsicArgAs { + /// Lower argument to a value. Mainly intended for scalar arguments. + Value, + /// Lower argument to an address. Only valid when the argument properties are + /// fully defined (e.g. allocatable is allocated...). + Addr, + /// Lower argument to a box. + Box, + /// Lower argument without assuming that the argument is fully defined. + /// It can be used on unallocated allocatable, disassociated pointer, + /// or absent optional. This is meant for inquiry intrinsic arguments. + Inquired +}; + +/// Define how a given intrinsic argument must be lowered. +struct ArgLoweringRule { + LowerIntrinsicArgAs lowerAs; + /// Value: + // - Numerical: 0 + // - Logical : false + // - Derived/character: not possible. Need custom intrinsic lowering. + // Addr: + // - nullptr + // Box: + // - absent box + // AsInquired: + // - no-op + bool handleDynamicOptional; +}; + +/// Opaque class defining the argument lowering rules for all the argument of +/// an intrinsic. +struct IntrinsicArgumentLoweringRules; + +/// Return argument lowering rules for an intrinsic. +/// Returns a nullptr if all the intrinsic arguments should be lowered by value. +const IntrinsicArgumentLoweringRules * +getIntrinsicArgumentLowering(llvm::StringRef intrinsicName); + +/// Return how argument \p argName should be lowered given the rules for the +/// intrinsic function. The argument names are the one defined by the standard. +ArgLoweringRule lowerIntrinsicArgumentAs(mlir::Location, + const IntrinsicArgumentLoweringRules &, + llvm::StringRef argName); + +/// Return place-holder for absent intrinsic arguments. +fir::ExtendedValue getAbsentIntrinsicArgument(); + +/// Get SymbolRefAttr of runtime (or wrapper function containing inlined +// implementation) of an unrestricted intrinsic (defined by its signature +// and generic name) +mlir::SymbolRefAttr +getUnrestrictedIntrinsicSymbolRefAttr(fir::FirOpBuilder &, mlir::Location, + llvm::StringRef name, + mlir::FunctionType signature); + +//===--------------------------------------------------------------------===// +// Direct access to intrinsics that may be used by lowering outside +// of intrinsic call lowering. +//===--------------------------------------------------------------------===// + +/// Generate maximum. There must be at least one argument and all arguments +/// must have the same type. +mlir::Value genMax(fir::FirOpBuilder &, mlir::Location, + llvm::ArrayRef args); + +/// Generate minimum. Same constraints as genMax. +mlir::Value genMin(fir::FirOpBuilder &, mlir::Location, + llvm::ArrayRef args); + +/// Generate power function x**y with given the expected +/// result type. +mlir::Value genPow(fir::FirOpBuilder &, mlir::Location, mlir::Type resultType, + mlir::Value x, mlir::Value y); + +} // namespace Fortran::lower + +#endif // FORTRAN_LOWER_INTRINSICCALL_H diff --git a/flang/include/flang/Lower/StatementContext.h b/flang/include/flang/Lower/StatementContext.h new file mode 100644 --- /dev/null +++ b/flang/include/flang/Lower/StatementContext.h @@ -0,0 +1,85 @@ +//===-- StatementContext.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/ +// +//===----------------------------------------------------------------------===// + +#ifndef FORTRAN_LOWER_STATEMENTCONTEXT_H +#define FORTRAN_LOWER_STATEMENTCONTEXT_H + +#include + +namespace Fortran::lower { + +/// When lowering a statement, temporaries for intermediate results may be +/// allocated on the heap. A StatementContext enables their deallocation +/// either explicitly with finalize() calls, or implicitly at the end of +/// the context. A context may prohibit temporary allocation. Otherwise, +/// an initial "outer" context scope may have nested context scopes, which +/// must make explicit subscope finalize() calls. +class StatementContext { +public: + explicit StatementContext(bool cleanupProhibited = false) { + if (cleanupProhibited) + return; + cufs.push_back({}); + } + + ~StatementContext() { + if (!cufs.empty()) + finalize(/*popScope=*/true); + assert(cufs.empty() && "invalid StatementContext destructor call"); + } + + using CleanupFunction = std::function; + + /// Push a context subscope. + void pushScope() { + assert(!cufs.empty() && "invalid pushScope statement context"); + cufs.push_back({}); + } + + /// Append a cleanup function to the "list" of cleanup functions. + void attachCleanup(CleanupFunction cuf) { + assert(!cufs.empty() && "invalid attachCleanup statement context"); + if (cufs.back()) { + CleanupFunction oldCleanup = *cufs.back(); + cufs.back() = [=]() { + cuf(); + oldCleanup(); + }; + } else { + cufs.back() = cuf; + } + } + + /// Make cleanup calls. Pop or reset the stack top list. + void finalize(bool popScope = false) { + assert(!cufs.empty() && "invalid finalize statement context"); + if (cufs.back()) + (*cufs.back())(); + if (popScope) + cufs.pop_back(); + else + cufs.back().reset(); + } + +private: + // A statement context should never be copied or moved. + StatementContext(const StatementContext &) = delete; + StatementContext &operator=(const StatementContext &) = delete; + StatementContext(StatementContext &&) = delete; + + // Stack of cleanup function "lists" (nested cleanup function calls). + llvm::SmallVector> cufs; +}; + +} // namespace Fortran::lower + +#endif // FORTRAN_LOWER_STATEMENTCONTEXT_H diff --git a/flang/include/flang/Lower/Support/Utils.h b/flang/include/flang/Lower/Support/Utils.h --- a/flang/include/flang/Lower/Support/Utils.h +++ b/flang/include/flang/Lower/Support/Utils.h @@ -15,10 +15,14 @@ #include "flang/Common/indirection.h" #include "flang/Parser/char-block.h" +#include "flang/Semantics/tools.h" #include "mlir/Dialect/StandardOps/IR/Ops.h" #include "mlir/IR/BuiltinAttributes.h" #include "llvm/ADT/StringRef.h" -#include + +namespace Fortran::lower { +using SomeExpr = Fortran::evaluate::Expr; +} //===----------------------------------------------------------------------===// // Small inline helper functions to deal with repetitive, clumsy conversions. @@ -46,4 +50,9 @@ return a.value(); } +/// Clone subexpression and wrap it as a generic `Fortran::evaluate::Expr`. +template +static Fortran::lower::SomeExpr toEvExpr(const A &x) { + return Fortran::evaluate::AsGenericExpr(Fortran::common::Clone(x)); +} #endif // FORTRAN_LOWER_SUPPORT_UTILS_H diff --git a/flang/include/flang/Optimizer/Builder/Runtime/Inquiry.h b/flang/include/flang/Optimizer/Builder/Runtime/Inquiry.h new file mode 100644 --- /dev/null +++ b/flang/include/flang/Optimizer/Builder/Runtime/Inquiry.h @@ -0,0 +1,46 @@ +//===-- Inquiry.h - generate inquiry runtime API calls ----------*- 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 +// +//===----------------------------------------------------------------------===// + +#ifndef FORTRAN_OPTIMIZER_BUILDER_RUNTIME_INQUIRY_H +#define FORTRAN_OPTIMIZER_BUILDER_RUNTIME_INQUIRY_H + +namespace mlir { +class Value; +class Location; +} // namespace mlir + +namespace fir { +class FirOpBuilder; +} + +namespace fir::runtime { + +/// Generate call to general `LboundDim` runtime routine. Calls to LBOUND +/// without a DIM argument get transformed into descriptor inquiries so they're +/// not handled in the runtime. +mlir::Value genLboundDim(fir::FirOpBuilder &builder, mlir::Location loc, + mlir::Value array, mlir::Value dim); + +/// Generate call to general `Ubound` runtime routine. Calls to UBOUND +/// with a DIM argument get transformed into an expression equivalent to +/// SIZE() + LBOUND() - 1, so they don't have an intrinsic in the runtime. +void genUbound(fir::FirOpBuilder &builder, mlir::Location loc, + mlir::Value resultBox, mlir::Value array, mlir::Value kind); + +/// Generate call to `Size` runtime routine. This routine is a specialized +/// version when the DIM argument is not specified by the user. +mlir::Value genSize(fir::FirOpBuilder &builder, mlir::Location loc, + mlir::Value array); + +/// Generate call to general `SizeDim` runtime routine. This version is for +/// when the user specifies a DIM argument. +mlir::Value genSizeDim(fir::FirOpBuilder &builder, mlir::Location loc, + mlir::Value array, mlir::Value dim); + +} // namespace fir::runtime +#endif // FORTRAN_OPTIMIZER_BUILDER_RUNTIME_INQUIRY_H diff --git a/flang/include/flang/Optimizer/Dialect/FIROps.h b/flang/include/flang/Optimizer/Dialect/FIROps.h --- a/flang/include/flang/Optimizer/Dialect/FIROps.h +++ b/flang/include/flang/Optimizer/Dialect/FIROps.h @@ -38,6 +38,10 @@ mlir::OpAsmParser::OperandType &selector, mlir::Type &type); +static constexpr llvm::StringRef getAdaptToByRefAttrName() { + return "adapt.valuebyref"; +} + } // namespace fir #define GET_OP_CLASSES 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 @@ -82,38 +82,42 @@ } fir::ExtendedValue genExprValue(const Fortran::lower::SomeExpr &expr, + Fortran::lower::StatementContext &context, mlir::Location *loc = nullptr) override final { return createSomeExtendedExpression(loc ? *loc : toLocation(), *this, expr, - localSymbols); + localSymbols, context); } Fortran::evaluate::FoldingContext &getFoldingContext() override final { return foldingContext; } - mlir::Type genType(const Fortran::evaluate::DataRef &) override final { - TODO_NOLOC("Not implemented genType DataRef. Needed for more complex " - "expression lowering"); - } mlir::Type genType(const Fortran::lower::SomeExpr &) override final { TODO_NOLOC("Not implemented genType SomeExpr. Needed for more complex " "expression lowering"); } + mlir::Type genType(const Fortran::lower::pft::Variable &var) override final { + return Fortran::lower::translateVariableToFIRType(*this, var); + } mlir::Type genType(Fortran::lower::SymbolRef) override final { TODO_NOLOC("Not implemented genType SymbolRef. Needed for more complex " "expression lowering"); } + mlir::Type + genType(Fortran::common::TypeCategory tc, int kind, + llvm::ArrayRef lenParameters) override final { + return Fortran::lower::getFIRType(&getMLIRContext(), tc, kind, + lenParameters); + } + mlir::Type + genType(const Fortran::semantics::DerivedTypeSpec &) override final { + TODO_NOLOC("Not implemented genType DerivedTypeSpec. Needed for more complex " + "expression lowering"); + } mlir::Type genType(Fortran::common::TypeCategory tc) override final { TODO_NOLOC("Not implemented genType TypeCategory. Needed for more complex " "expression lowering"); } - mlir::Type genType(Fortran::common::TypeCategory tc, - int kind) override final { - return Fortran::lower::getFIRType(&getMLIRContext(), tc, kind); - } - mlir::Type genType(const Fortran::lower::pft::Variable &var) override final { - return Fortran::lower::translateVariableToFIRType(*this, var); - } void setCurrentPosition(const Fortran::parser::CharBlock &position) { if (position != Fortran::parser::CharBlock{}) 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 @@ -7,6 +7,7 @@ ConvertExpr.cpp ConvertType.cpp ConvertVariable.cpp + IntrinsicCall.cpp Mangler.cpp OpenACC.cpp OpenMP.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 @@ -16,6 +16,7 @@ #include "flang/Evaluate/traverse.h" #include "flang/Lower/AbstractConverter.h" #include "flang/Lower/SymbolMap.h" +#include "flang/Lower/IntrinsicCall.h" #include "flang/Lower/Todo.h" #include "flang/Semantics/expression.h" #include "flang/Semantics/symbol.h" @@ -37,6 +38,33 @@ // to the correct FIR representation in SSA form. //===----------------------------------------------------------------------===// + +/// Place \p exv in memory if it is not already a memory reference. If +/// \p forceValueType is provided, the value is first casted to the provided +/// type before being stored (this is mainly intended for logicals whose value +/// may be `i1` but needed to be stored as Fortran logicals). +static fir::ExtendedValue +placeScalarValueInMemory(fir::FirOpBuilder &builder, mlir::Location loc, + const fir::ExtendedValue &exv, + mlir::Type storageType) { + mlir::Value valBase = fir::getBase(exv); + if (fir::conformsWithPassByRef(valBase.getType())) + return exv; + + assert(!fir::hasDynamicSize(storageType) && + "only expect statically sized scalars to be by value"); + + // Since `a` is not itself a valid referent, determine its value and + // create a temporary location at the beginning of the function for + // referencing. + mlir::Value val = builder.createConvert(loc, storageType, valBase); + mlir::Value temp = builder.createTemporary( + loc, storageType, + llvm::ArrayRef{ + Fortran::lower::getAdaptToByRefAttr(builder)}); + builder.create(loc, val, temp); + return fir::substBase(exv, temp); +} /// Generate a load of a value from an address. Beware that this will lose /// any dynamic type information for polymorphic entities (note that unlimited /// polymorphic cannot be loaded and must not be provided here). @@ -63,6 +91,17 @@ }); } + +/// Is this a call to an elemental procedure with at least one array argument? +static bool +isElementalProcWithArrayArgs(const Fortran::evaluate::ProcedureRef &procRef) { + if (procRef.IsElemental()) + for (const std::optional &arg : + procRef.arguments()) + if (arg && arg->Rank() != 0) + return true; + return false; +} namespace { /// Lowering of Fortran::evaluate::Expr expressions @@ -72,9 +111,10 @@ explicit ScalarExprLowering(mlir::Location loc, Fortran::lower::AbstractConverter &converter, - Fortran::lower::SymMap &symMap) + Fortran::lower::SymMap &symMap, + Fortran::lower::StatementContext &stmtCtx) : location{loc}, converter{converter}, - builder{converter.getFirOpBuilder()}, symMap{symMap} {} + builder{converter.getFirOpBuilder()}, stmtCtx{stmtCtx}, symMap{symMap} {} mlir::Location getLoc() { return location; } @@ -330,10 +370,17 @@ TODO(getLoc(), "genval ArrayConstructor"); } + ExtValue gen(const Fortran::evaluate::ComplexPart &x) { + TODO(getLoc(), "gen ComplexPart"); + } ExtValue genval(const Fortran::evaluate::ComplexPart &x) { TODO(getLoc(), "genval ComplexPart"); } + ExtValue gen(const Fortran::evaluate::Substring &ss) { + TODO(getLoc(), "gen Substring"); + } + ExtValue genval(const Fortran::evaluate::Substring &ss) { TODO(getLoc(), "genval Substring"); } @@ -346,6 +393,10 @@ TODO(getLoc(), "genval DataRef"); } + ExtValue gen(const Fortran::evaluate::Component &cmpt) { + TODO(getLoc(), "gen Component"); + } + ExtValue genval(const Fortran::evaluate::Component &cmpt) { TODO(getLoc(), "genval Component"); } @@ -354,31 +405,179 @@ TODO(getLoc(), "genval Bound"); } + /// Return the coordinate of the array reference. + ExtValue gen(const Fortran::evaluate::ArrayRef &aref) { + TODO(getLoc(), "gen ArrayRef"); + } + ExtValue genval(const Fortran::evaluate::ArrayRef &aref) { TODO(getLoc(), "genval ArrayRef"); } + ExtValue gen(const Fortran::evaluate::CoarrayRef &coref) { + TODO(getLoc(), "genval CoarrayRef"); + } + ExtValue genval(const Fortran::evaluate::CoarrayRef &coref) { TODO(getLoc(), "genval CoarrayRef"); } + template + ExtValue gen(const Fortran::evaluate::Designator &des) { + return std::visit([&](const auto &x) { return gen(x); }, des.u); + } template ExtValue genval(const Fortran::evaluate::Designator &des) { return std::visit([&](const auto &x) { return genval(x); }, des.u); } + mlir::Type genType(const Fortran::evaluate::DynamicType &dt) { + if (dt.category() != Fortran::common::TypeCategory::Derived) + return converter.genType(dt.category(), dt.kind()); + return converter.genType(dt.GetDerivedTypeSpec()); + } + + /// Lower a function reference + template + ExtValue genFunctionRef(const Fortran::evaluate::FunctionRef &funcRef) { + if (!funcRef.GetType().has_value()) + fir::emitFatalError(getLoc(), "internal: a function must have a type"); + mlir::Type resTy = genType(*funcRef.GetType()); + return genProcedureRef(funcRef, {resTy}); + } + + /// Lower function call `funcRef` and return a reference to the resultant + /// value. This is required for lowering expressions such as `f1(f2(v))`. + template + ExtValue gen(const Fortran::evaluate::FunctionRef &funcRef) { + ExtValue retVal = genFunctionRef(funcRef); + mlir::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()); + } template ExtValue genval(const Fortran::evaluate::FunctionRef &funcRef) { - TODO(getLoc(), "genval FunctionRef"); + ExtValue result = genFunctionRef(funcRef); + if (result.rank() == 0 && fir::isa_ref_type(fir::getBase(result).getType())) + return genLoad(result); + return result; } + ExtValue genval(const Fortran::evaluate::ProcedureRef &procRef) { TODO(getLoc(), "genval ProcedureRef"); } - template - bool isScalar(const A &x) { - return x.Rank() == 0; + /// Generate a call to an intrinsic function. + ExtValue + genIntrinsicRef(const Fortran::evaluate::ProcedureRef &procRef, + const Fortran::evaluate::SpecificIntrinsic &intrinsic, + llvm::Optional resultType) { + llvm::SmallVector operands; + + llvm::StringRef name = intrinsic.name; + mlir::Location loc = getLoc(); + /* + if (Fortran::lower::intrinsicRequiresCustomOptionalHandling( + procRef, intrinsic, converter)) { + using ExvAndPresence = std::pair>; + llvm::SmallVector operands; + auto prepareOptionalArg = [&](const Fortran::lower::SomeExpr &expr) { + ExtValue optionalArg = lowerIntrinsicArgumentAsInquired(expr); + mlir::Value isPresent = + genActualIsPresentTest(builder, loc, optionalArg); + operands.emplace_back(optionalArg, isPresent); + }; + auto prepareOtherArg = [&](const Fortran::lower::SomeExpr &expr) { + operands.emplace_back(genval(expr), llvm::None); + }; + Fortran::lower::prepareCustomIntrinsicArgument( + procRef, intrinsic, resultType, prepareOptionalArg, prepareOtherArg, + converter); + + auto getArgument = [&](std::size_t i) -> ExtValue { + if (fir::conformsWithPassByRef( + fir::getBase(operands[i].first).getType())) + return genLoad(operands[i].first); + return operands[i].first; + }; + auto isPresent = [&](std::size_t i) -> llvm::Optional { + return operands[i].second; + }; + return Fortran::lower::lowerCustomIntrinsic( + builder, loc, name, resultType, isPresent, getArgument, + operands.size(), stmtCtx); + } + */ + + const Fortran::lower::IntrinsicArgumentLoweringRules *argLowering = + Fortran::lower::getIntrinsicArgumentLowering(name); + for (const auto &[arg, dummy] : + llvm::zip(procRef.arguments(), + intrinsic.characteristics.value().dummyArguments)) { + auto *expr = Fortran::evaluate::UnwrapExpr(arg); + if (!expr) { + // Absent optional. + operands.emplace_back(Fortran::lower::getAbsentIntrinsicArgument()); + continue; + } + if (!argLowering) { + // No argument lowering instruction, lower by value. + operands.emplace_back(genval(*expr)); + continue; + } + // Ad-hoc argument lowering handling. + Fortran::lower::ArgLoweringRule argRules = + Fortran::lower::lowerIntrinsicArgumentAs(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: + operands.emplace_back(gen(*expr)); + continue; + //case Fortran::lower::LowerIntrinsicArgAs::Box: + // operands.emplace_back(lowerIntrinsicArgumentAsBox(*expr)); + // continue; + //case Fortran::lower::LowerIntrinsicArgAs::Inquired: + // operands.emplace_back(lowerIntrinsicArgumentAsInquired(*expr)); + // continue; + } + llvm_unreachable("bad switch"); + } + // Let the intrinsic library lower the intrinsic procedure call + return Fortran::lower::genIntrinsicCall(builder, getLoc(), name, resultType, + operands, stmtCtx); } template @@ -393,18 +592,149 @@ Fortran::common::TypeCategory::Logical, KIND>> &exp) { return std::visit([&](const auto &e) { return genval(e); }, exp.u); } + /// Lower a non-elemental procedure reference and read allocatable and pointer + /// results into normal values. + ExtValue genProcedureRef(const Fortran::evaluate::ProcedureRef &procRef, + llvm::Optional resultType) { + ExtValue res = genRawProcedureRef(procRef, resultType); + // In most contexts, pointers and allocatable do not appear as allocatable + // or pointer variable on the caller side (see 8.5.3 note 1 for + // allocatables). The few context where this can happen must call + // genRawProcedureRef directly. + // if (const auto *box = res.getBoxOf()) + // return fir::factory::genMutableBoxRead(builder, getLoc(), *box); + return res; + } + + + /// Lower a non-elemental procedure reference. + ExtValue genRawProcedureRef(const Fortran::evaluate::ProcedureRef &procRef, + llvm::Optional resultType) { + mlir::Location loc = getLoc(); + if (isElementalProcWithArrayArgs(procRef)) + fir::emitFatalError(loc, "trying to lower elemental procedure with array " + "arguments as normal procedure"); + if (const Fortran::evaluate::SpecificIntrinsic *intrinsic = + procRef.proc().GetSpecificIntrinsic()) + return genIntrinsicRef(procRef, *intrinsic, resultType); + } + + template + bool isScalar(const A &x) { + return x.Rank() == 0; + } + + /// Helper to detect Transformational function reference. + template + bool isTransformationalRef(const T &) { + return false; + } + template + bool isTransformationalRef(const Fortran::evaluate::FunctionRef &funcRef) { + return !funcRef.IsElemental() && funcRef.Rank(); + } + template + bool isTransformationalRef(Fortran::evaluate::Expr expr) { + return std::visit([&](const auto &e) { return isTransformationalRef(e); }, + expr.u); + } + + template + ExtValue asArray(const A &x) { + return Fortran::lower::createSomeArrayTempValue(converter, toEvExpr(x), + symMap, stmtCtx); + } + + /// Lower an array value as an argument. This argument can be passed as a box + /// value, so it may be possible to avoid making a temporary. + template + ExtValue asArrayArg(const Fortran::evaluate::Expr &x) { + return std::visit([&](const auto &e) { return asArrayArg(e, x); }, x.u); + } + template + ExtValue asArrayArg(const Fortran::evaluate::Expr &x, const B &y) { + return std::visit([&](const auto &e) { return asArrayArg(e, y); }, x.u); + } + template + ExtValue asArrayArg(const Fortran::evaluate::Designator &, const B &x) { + TODO(getLoc(), "ArrayArg lowering"); + return {}; + } + template + ExtValue asArrayArg(const A &, const B &x) { + // If the expression to pass as an argument is not a designator, then create + // an array temp. + return asArray(x); + } + + template + ExtValue gen(const Fortran::evaluate::Expr &x) { + // Whole array symbols or components, and results of transformational + // functions already have a storage and the scalar expression lowering path + // is used to not create a new temporary storage. + if (isScalar(x) || + Fortran::evaluate::UnwrapWholeSymbolOrComponentDataRef(x) || + isTransformationalRef(x)) + return std::visit([&](const auto &e) { return genref(e); }, x.u); + if (useBoxArg) + return asArrayArg(x); + return asArray(x); + } + + + using RefSet = + std::tuple; + template + static constexpr bool inRefSet = Fortran::common::HasMember; + + template >> + ExtValue genref(const A &a) { + return gen(a); + } + template + ExtValue genref(const A &a) { + mlir::Type storageType = converter.genType(toEvExpr(a)); + return placeScalarValueInMemory(builder, getLoc(), genval(a), storageType); + } + + template typename T, + typename B = std::decay_t>, + std::enable_if_t< + std::is_same_v> || + std::is_same_v> || + std::is_same_v>, + bool> = true> + ExtValue genref(const T &x) { + return gen(x); + } private: mlir::Location location; Fortran::lower::AbstractConverter &converter; fir::FirOpBuilder &builder; + Fortran::lower::StatementContext &stmtCtx; Fortran::lower::SymMap &symMap; + bool useBoxArg = false; // expression lowered as argument }; } // namespace +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); + return {}; +} + fir::ExtendedValue Fortran::lower::createSomeExtendedExpression( mlir::Location loc, Fortran::lower::AbstractConverter &converter, - const Fortran::lower::SomeExpr &expr, Fortran::lower::SymMap &symMap) { + const Fortran::lower::SomeExpr &expr, Fortran::lower::SymMap &symMap, + Fortran::lower::StatementContext &stmtCtx) { LLVM_DEBUG(expr.AsFortran(llvm::dbgs() << "expr: ") << '\n'); - return ScalarExprLowering{loc, converter, symMap}.genval(expr); + return ScalarExprLowering{loc, converter, symMap, stmtCtx}.genval(expr); } diff --git a/flang/lib/Lower/ConvertType.cpp b/flang/lib/Lower/ConvertType.cpp --- a/flang/lib/Lower/ConvertType.cpp +++ b/flang/lib/Lower/ConvertType.cpp @@ -152,26 +152,100 @@ return {}; } -template <> -mlir::Type -genFIRType(mlir::MLIRContext *context, - int KIND) { +//===--------------------------------------------------------------------===// +// Intrinsic type translation helpers +//===--------------------------------------------------------------------===// + +static mlir::Type genRealType(mlir::MLIRContext *context, int kind) { + if (Fortran::evaluate::IsValidKindOfIntrinsicType( + Fortran::common::TypeCategory::Real, kind)) { + switch (kind) { + case 2: + return mlir::FloatType::getF16(context); + case 3: + return mlir::FloatType::getBF16(context); + case 4: + return mlir::FloatType::getF32(context); + case 8: + return mlir::FloatType::getF64(context); + case 10: + return mlir::FloatType::getF80(context); + case 16: + return mlir::FloatType::getF128(context); + } + } + llvm_unreachable("REAL type translation not implemented"); +} + +template +int getIntegerBits() { + return Fortran::evaluate::Type::Scalar::bits; +} +static mlir::Type genIntegerType(mlir::MLIRContext *context, int kind) { + if (Fortran::evaluate::IsValidKindOfIntrinsicType( + Fortran::common::TypeCategory::Integer, kind)) { + switch (kind) { + case 1: + return mlir::IntegerType::get(context, getIntegerBits<1>()); + case 2: + return mlir::IntegerType::get(context, getIntegerBits<2>()); + case 4: + return mlir::IntegerType::get(context, getIntegerBits<4>()); + case 8: + return mlir::IntegerType::get(context, getIntegerBits<8>()); + case 16: + return mlir::IntegerType::get(context, getIntegerBits<16>()); + } + } + llvm_unreachable("INTEGER type translation not implemented"); +} + +static mlir::Type genLogicalType(mlir::MLIRContext *context, int KIND) { + if (Fortran::evaluate::IsValidKindOfIntrinsicType( + Fortran::common::TypeCategory::Logical, KIND)) + return fir::LogicalType::get(context, KIND); + return {}; +} + +static mlir::Type genCharacterType( + mlir::MLIRContext *context, int KIND, + Fortran::lower::LenParameterTy len = fir::CharacterType::unknownLen()) { if (Fortran::evaluate::IsValidKindOfIntrinsicType( Fortran::common::TypeCategory::Character, KIND)) - return fir::CharacterType::get(context, KIND, 1); + return fir::CharacterType::get(context, KIND, len); return {}; } -template <> -mlir::Type -genFIRType(mlir::MLIRContext *context, - int KIND) { +static mlir::Type genComplexType(mlir::MLIRContext *context, int KIND) { if (Fortran::evaluate::IsValidKindOfIntrinsicType( Fortran::common::TypeCategory::Complex, KIND)) return fir::ComplexType::get(context, KIND); return {}; } +static mlir::Type +genFIRType(mlir::MLIRContext *context, Fortran::common::TypeCategory tc, + int kind, + llvm::ArrayRef lenParameters) { + switch (tc) { + case Fortran::common::TypeCategory::Real: + return genRealType(context, kind); + case Fortran::common::TypeCategory::Integer: + return genIntegerType(context, kind); + case Fortran::common::TypeCategory::Complex: + return genComplexType(context, kind); + case Fortran::common::TypeCategory::Logical: + return genLogicalType(context, kind); + case Fortran::common::TypeCategory::Character: + if (!lenParameters.empty()) + return genCharacterType(context, kind, lenParameters[0]); + return genCharacterType(context, kind); + default: + break; + } + llvm_unreachable("unhandled type category"); +} namespace { /// Discover the type of an Fortran::evaluate::Expr and convert it to an @@ -470,55 +544,11 @@ } // namespace -template -int getIntegerBits() { - return Fortran::evaluate::Type::Scalar::bits; -} -static mlir::Type genIntegerType(mlir::MLIRContext *context, int kind) { - if (Fortran::evaluate::IsValidKindOfIntrinsicType( - Fortran::common::TypeCategory::Integer, kind)) { - switch (kind) { - case 1: - return mlir::IntegerType::get(context, getIntegerBits<1>()); - case 2: - return mlir::IntegerType::get(context, getIntegerBits<2>()); - case 4: - return mlir::IntegerType::get(context, getIntegerBits<4>()); - case 8: - return mlir::IntegerType::get(context, getIntegerBits<8>()); - case 16: - return mlir::IntegerType::get(context, getIntegerBits<16>()); - } - } - llvm_unreachable("INTEGER kind not translated"); -} - -static mlir::Type genFIRType(mlir::MLIRContext *context, - Fortran::common::TypeCategory tc, int kind) { - switch (tc) { - case Fortran::common::TypeCategory::Integer: - return genIntegerType(context, kind); - case Fortran::common::TypeCategory::Real: - case Fortran::common::TypeCategory::Complex: - case Fortran::common::TypeCategory::Logical: - case Fortran::common::TypeCategory::Character: - default: - break; - } - llvm_unreachable("unhandled type category"); -} - mlir::Type Fortran::lower::getFIRType(mlir::MLIRContext *context, Fortran::common::TypeCategory tc, - int kind) { - return genFIRType(context, tc, kind); -} - -mlir::Type -Fortran::lower::getFIRType(Fortran::lower::AbstractConverter &converter, - Fortran::common::TypeCategory tc) { - return TypeBuilder{converter}.genFIRTy(tc); + int kind, + llvm::ArrayRef params) { + return genFIRType(context, tc, kind, params); } mlir::Type Fortran::lower::translateDataRefToFIRType( diff --git a/flang/lib/Lower/IntrinsicCall.cpp b/flang/lib/Lower/IntrinsicCall.cpp new file mode 100644 --- /dev/null +++ b/flang/lib/Lower/IntrinsicCall.cpp @@ -0,0 +1,882 @@ +//===-- IntrinsicCall.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 +// +//===----------------------------------------------------------------------===// +// +// Helper routines for constructing the FIR dialect of MLIR. As FIR is a +// dialect of MLIR, it makes extensive use of MLIR interfaces and MLIR's coding +// style (https://mlir.llvm.org/getting_started/DeveloperGuide/) is used in this +// module. +// +//===----------------------------------------------------------------------===// + +#include "flang/Lower/IntrinsicCall.h" +#include "flang/Common/static-multimap-view.h" +#include "flang/Lower/ConvertType.h" +#include "flang/Lower/Mangler.h" +#include "flang/Lower/Runtime.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/Character.h" +#include "flang/Optimizer/Builder/Runtime/Command.h" +#include "flang/Optimizer/Builder/Runtime/Inquiry.h" +#include "flang/Optimizer/Builder/Runtime/Numeric.h" +#include "flang/Optimizer/Builder/Runtime/RTBuilder.h" +#include "flang/Optimizer/Builder/Runtime/Reduction.h" +#include "flang/Optimizer/Builder/Runtime/Stop.h" +#include "flang/Optimizer/Builder/Runtime/Transformational.h" +#include "flang/Optimizer/Support/FatalError.h" +#include "mlir/Dialect/LLVMIR/LLVMDialect.h" +#include "llvm/Support/CommandLine.h" +#include "llvm/Support/Debug.h" +#include "llvm/Support/ErrorHandling.h" +#include +#include +#include + +#define DEBUG_TYPE "flang-lower-intrinsic" + +#define PGMATH_DECLARE +#include "flang/Evaluate/pgmath.h.inc" + +/// This file implements lowering of Fortran intrinsic procedures. +/// Intrinsics are lowered to a mix of FIR and MLIR operations as +/// well as call to runtime functions or LLVM intrinsics. + +/// Lowering of intrinsic procedure calls is based on a map that associates +/// Fortran intrinsic generic names to FIR generator functions. +/// All generator functions are member functions of the IntrinsicLibrary class +/// and have the same interface. +/// If no generator is given for an intrinsic name, a math runtime library +/// is searched for an implementation and, if a runtime function is found, +/// a call is generated for it. LLVM intrinsics are handled as a math +/// runtime library here. + +fir::ExtendedValue Fortran::lower::getAbsentIntrinsicArgument() { + return fir::UnboxedValue{}; +} + +// TODO error handling -> return a code or directly emit messages ? +struct IntrinsicLibrary { + + // Constructors. + 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; + + /// Generate FIR for call to Fortran intrinsic \p name with arguments \p arg + /// and expected result type \p resultType. + fir::ExtendedValue genIntrinsicCall(llvm::StringRef name, + llvm::Optional resultType, + llvm::ArrayRef arg); + + /// Search a runtime function that is associated to the generic intrinsic name + /// and whose signature matches the intrinsic arguments and result types. + /// If no such runtime function is found but a runtime function associated + /// with the Fortran generic exists and has the same number of arguments, + /// conversions will be inserted before and/or after the call. This is to + /// mainly to allow 16 bits float support even-though little or no math + /// runtime is currently available for it. + mlir::Value genRuntimeCall(llvm::StringRef name, mlir::Type, + llvm::ArrayRef); + + using RuntimeCallGenerator = std::function)>; + RuntimeCallGenerator + getRuntimeCallGenerator(llvm::StringRef name, + mlir::FunctionType soughtFuncType); + + mlir::Value genAbs(mlir::Type, llvm::ArrayRef); + + void genDateAndTime(llvm::ArrayRef); + mlir::Value genIand(mlir::Type, llvm::ArrayRef); + fir::ExtendedValue genLenTrim(mlir::Type, llvm::ArrayRef); + /// Implement all conversion functions like DBLE, the first argument is + /// the value to convert. There may be an additional KIND arguments that + /// is ignored because this is already reflected in the result type. + mlir::Value genConversion(mlir::Type, llvm::ArrayRef); + + /// Define the different FIR generators that can be mapped to intrinsic to + /// generate the related code. + using ElementalGenerator = decltype(&IntrinsicLibrary::genAbs); + using ExtendedGenerator = decltype(&IntrinsicLibrary::genLenTrim); + using SubroutineGenerator = decltype(&IntrinsicLibrary::genDateAndTime); + using Generator = + std::variant; + + /// Generate calls to ElementalGenerator, handling the elemental aspects + template + fir::ExtendedValue + genElementalCall(GeneratorType, llvm::StringRef name, mlir::Type resultType, + llvm::ArrayRef args, bool outline); + + /// Helper to invoke code generator for the intrinsics given arguments. + mlir::Value invokeGenerator(ElementalGenerator generator, + mlir::Type resultType, + llvm::ArrayRef args); + mlir::Value invokeGenerator(RuntimeCallGenerator generator, + mlir::Type resultType, + llvm::ArrayRef args); + mlir::Value invokeGenerator(ExtendedGenerator generator, + mlir::Type resultType, + llvm::ArrayRef args); + mlir::Value invokeGenerator(SubroutineGenerator generator, + llvm::ArrayRef args); + fir::FirOpBuilder &builder; + mlir::Location loc; + Fortran::lower::StatementContext *stmtCtx; +}; + +struct IntrinsicDummyArgument { + const char *name = nullptr; + Fortran::lower::LowerIntrinsicArgAs lowerAs = + Fortran::lower::LowerIntrinsicArgAs::Value; + bool handleDynamicOptional = false; +}; + +struct Fortran::lower::IntrinsicArgumentLoweringRules { + /// There is no more than 7 non repeated arguments in Fortran intrinsics. + IntrinsicDummyArgument args[7]; + constexpr bool hasDefaultRules() const { return args[0].name == nullptr; } +}; + +/// Structure describing what needs to be done to lower intrinsic "name". +struct IntrinsicHandler { + const char *name; + IntrinsicLibrary::Generator generator; + Fortran::lower::IntrinsicArgumentLoweringRules argLoweringRules = {}; + bool isElemental = true; + /// Code heavy intrinsic can be outlined to make FIR + /// more readable. + bool outline = false; +}; + +constexpr auto asValue = Fortran::lower::LowerIntrinsicArgAs::Value; +constexpr auto asAddr = Fortran::lower::LowerIntrinsicArgAs::Addr; +constexpr auto asBox = Fortran::lower::LowerIntrinsicArgAs::Box; +constexpr auto asInquired = Fortran::lower::LowerIntrinsicArgAs::Inquired; +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 +/// to look for a match in the runtime a emit a call. Note that the argument +/// lowering rules for an intrinsic need to be provided only if at least one +/// argument must not be lowered by value. In which case, the lowering rules +/// should be provided for all the intrinsic arguments for completeness. +static constexpr IntrinsicHandler handlers[]{ + {"iand", &I::genIand}, +}; + +static const IntrinsicHandler *findIntrinsicHandler(llvm::StringRef name) { + auto compare = [](const IntrinsicHandler &handler, llvm::StringRef name) { + return name.compare(handler.name) > 0; + }; + auto result = + std::lower_bound(std::begin(handlers), std::end(handlers), name, compare); + return result != std::end(handlers) && result->name == name ? result + : nullptr; +} + +/// To make fir output more readable for debug, one can outline all intrinsic +/// implementation in wrappers (overrides the IntrinsicHandler::outline flag). +static llvm::cl::opt outlineAllIntrinsics( + "outline-intrinsics", + llvm::cl::desc( + "Lower all intrinsic procedure implementation in their own functions"), + llvm::cl::init(false)); + +//===----------------------------------------------------------------------===// +// Math runtime description and matching utility +//===----------------------------------------------------------------------===// + +/// Command line option to modify math runtime version used to implement +/// intrinsics. +enum MathRuntimeVersion { + fastVersion, + relaxedVersion, + preciseVersion, + llvmOnly +}; +llvm::cl::opt mathRuntimeVersion( + "math-runtime", llvm::cl::desc("Select math runtime version:"), + llvm::cl::values( + clEnumValN(fastVersion, "fast", "use pgmath fast runtime"), + clEnumValN(relaxedVersion, "relaxed", "use pgmath relaxed runtime"), + clEnumValN(preciseVersion, "precise", "use pgmath precise runtime"), + clEnumValN(llvmOnly, "llvm", + "only use LLVM intrinsics (may be incomplete)")), + llvm::cl::init(fastVersion)); + +struct RuntimeFunction { + // llvm::StringRef comparison operator are not constexpr, so use string_view. + using Key = std::string_view; + // Needed for implicit compare with keys. + constexpr operator Key() const { return key; } + Key key; // intrinsic name + llvm::StringRef symbol; + fir::runtime::FuncTypeBuilderFunc typeGenerator; +}; + +#define RUNTIME_STATIC_DESCRIPTION(name, func) \ + {#name, #func, fir::runtime::RuntimeTableKey::getTypeModel()}, +static constexpr RuntimeFunction pgmathFast[] = { +#define PGMATH_FAST +#define PGMATH_USE_ALL_TYPES(name, func) RUNTIME_STATIC_DESCRIPTION(name, func) +#include "flang/Evaluate/pgmath.h.inc" +}; +static constexpr RuntimeFunction pgmathRelaxed[] = { +#define PGMATH_RELAXED +#define PGMATH_USE_ALL_TYPES(name, func) RUNTIME_STATIC_DESCRIPTION(name, func) +#include "flang/Evaluate/pgmath.h.inc" +}; +static constexpr RuntimeFunction pgmathPrecise[] = { +#define PGMATH_PRECISE +#define PGMATH_USE_ALL_TYPES(name, func) RUNTIME_STATIC_DESCRIPTION(name, func) +#include "flang/Evaluate/pgmath.h.inc" +}; + +static mlir::FunctionType genF32F32FuncType(mlir::MLIRContext *context) { + auto t = mlir::FloatType::getF32(context); + return mlir::FunctionType::get(context, {t}, {t}); +} + +static mlir::FunctionType genF64F64FuncType(mlir::MLIRContext *context) { + auto t = mlir::FloatType::getF64(context); + return mlir::FunctionType::get(context, {t}, {t}); +} + +static mlir::FunctionType genF32F32F32FuncType(mlir::MLIRContext *context) { + auto t = mlir::FloatType::getF32(context); + return mlir::FunctionType::get(context, {t, t}, {t}); +} + +static mlir::FunctionType genF64F64F64FuncType(mlir::MLIRContext *context) { + auto t = mlir::FloatType::getF64(context); + return mlir::FunctionType::get(context, {t, t}, {t}); +} + +static mlir::FunctionType genF80F80F80FuncType(mlir::MLIRContext *context) { + auto t = mlir::FloatType::getF80(context); + return mlir::FunctionType::get(context, {t, t}, {t}); +} + +static mlir::FunctionType genF128F128F128FuncType(mlir::MLIRContext *context) { + auto t = mlir::FloatType::getF128(context); + return mlir::FunctionType::get(context, {t, t}, {t}); +} + +template +static mlir::FunctionType genIntF64FuncType(mlir::MLIRContext *context) { + auto t = mlir::FloatType::getF64(context); + auto r = mlir::IntegerType::get(context, Bits); + return mlir::FunctionType::get(context, {t}, {r}); +} + +template +static mlir::FunctionType genIntF32FuncType(mlir::MLIRContext *context) { + auto t = mlir::FloatType::getF32(context); + auto r = mlir::IntegerType::get(context, Bits); + return mlir::FunctionType::get(context, {t}, {r}); +} + +// TODO : Fill-up this table with more intrinsic. +// Note: These are also defined as operations in LLVM dialect. See if this +// can be use and has advantages. +static constexpr RuntimeFunction llvmIntrinsics[] = { + {"abs", "llvm.fabs.f32", genF32F32FuncType}, + {"abs", "llvm.fabs.f64", genF64F64FuncType}, + {"aint", "llvm.trunc.f32", genF32F32FuncType}, + {"aint", "llvm.trunc.f64", genF64F64FuncType}, + {"anint", "llvm.round.f32", genF32F32FuncType}, + {"anint", "llvm.round.f64", genF64F64FuncType}, + {"atan", "atanf", genF32F32FuncType}, + {"atan", "atan", genF64F64FuncType}, + // ceil is used for CEILING but is different, it returns a real. + {"ceil", "llvm.ceil.f32", genF32F32FuncType}, + {"ceil", "llvm.ceil.f64", genF64F64FuncType}, + {"cos", "llvm.cos.f32", genF32F32FuncType}, + {"cos", "llvm.cos.f64", genF64F64FuncType}, + {"cosh", "coshf", genF32F32FuncType}, + {"cosh", "cosh", genF64F64FuncType}, + {"exp", "llvm.exp.f32", genF32F32FuncType}, + {"exp", "llvm.exp.f64", genF64F64FuncType}, + // llvm.floor is used for FLOOR, but returns real. + {"floor", "llvm.floor.f32", genF32F32FuncType}, + {"floor", "llvm.floor.f64", genF64F64FuncType}, + {"log", "llvm.log.f32", genF32F32FuncType}, + {"log", "llvm.log.f64", genF64F64FuncType}, + {"log10", "llvm.log10.f32", genF32F32FuncType}, + {"log10", "llvm.log10.f64", genF64F64FuncType}, + {"nint", "llvm.lround.i64.f64", genIntF64FuncType<64>}, + {"nint", "llvm.lround.i64.f32", genIntF32FuncType<64>}, + {"nint", "llvm.lround.i32.f64", genIntF64FuncType<32>}, + {"nint", "llvm.lround.i32.f32", genIntF32FuncType<32>}, + {"pow", "llvm.pow.f32", genF32F32F32FuncType}, + {"pow", "llvm.pow.f64", genF64F64F64FuncType}, + {"sign", "llvm.copysign.f32", genF32F32F32FuncType}, + {"sign", "llvm.copysign.f64", genF64F64F64FuncType}, + {"sign", "llvm.copysign.f80", genF80F80F80FuncType}, + {"sign", "llvm.copysign.f128", genF128F128F128FuncType}, + {"sin", "llvm.sin.f32", genF32F32FuncType}, + {"sin", "llvm.sin.f64", genF64F64FuncType}, + {"sinh", "sinhf", genF32F32FuncType}, + {"sinh", "sinh", genF64F64FuncType}, + {"sqrt", "llvm.sqrt.f32", genF32F32FuncType}, + {"sqrt", "llvm.sqrt.f64", genF64F64FuncType}, +}; + +// This helper class computes a "distance" between two function types. +// The distance measures how many narrowing conversions of actual arguments +// and result of "from" must be made in order to use "to" instead of "from". +// For instance, the distance between ACOS(REAL(10)) and ACOS(REAL(8)) is +// greater than the one between ACOS(REAL(10)) and ACOS(REAL(16)). This means +// if no implementation of ACOS(REAL(10)) is available, it is better to use +// ACOS(REAL(16)) with casts rather than ACOS(REAL(8)). +// Note that this is not a symmetric distance and the order of "from" and "to" +// arguments matters, d(foo, bar) may not be the same as d(bar, foo) because it +// may be safe to replace foo by bar, but not the opposite. +class FunctionDistance { +public: + FunctionDistance() : infinite{true} {} + + FunctionDistance(mlir::FunctionType from, mlir::FunctionType to) { + unsigned nInputs = from.getNumInputs(); + unsigned nResults = from.getNumResults(); + if (nResults != to.getNumResults() || nInputs != to.getNumInputs()) { + infinite = true; + } else { + for (decltype(nInputs) i{0}; i < nInputs && !infinite; ++i) + addArgumentDistance(from.getInput(i), to.getInput(i)); + for (decltype(nResults) i{0}; i < nResults && !infinite; ++i) + addResultDistance(to.getResult(i), from.getResult(i)); + } + } + + /// Beware both d1.isSmallerThan(d2) *and* d2.isSmallerThan(d1) may be + /// false if both d1 and d2 are infinite. This implies that + /// d1.isSmallerThan(d2) is not equivalent to !d2.isSmallerThan(d1) + bool isSmallerThan(const FunctionDistance &d) const { + return !infinite && + (d.infinite || std::lexicographical_compare( + conversions.begin(), conversions.end(), + d.conversions.begin(), d.conversions.end())); + } + + bool isLosingPrecision() const { + return conversions[narrowingArg] != 0 || conversions[extendingResult] != 0; + } + + bool isInfinite() const { return infinite; } + +private: + enum class Conversion { Forbidden, None, Narrow, Extend }; + + void addArgumentDistance(mlir::Type from, mlir::Type to) { + switch (conversionBetweenTypes(from, to)) { + case Conversion::Forbidden: + infinite = true; + break; + case Conversion::None: + break; + case Conversion::Narrow: + conversions[narrowingArg]++; + break; + case Conversion::Extend: + conversions[nonNarrowingArg]++; + break; + } + } + + void addResultDistance(mlir::Type from, mlir::Type to) { + switch (conversionBetweenTypes(from, to)) { + case Conversion::Forbidden: + infinite = true; + break; + case Conversion::None: + break; + case Conversion::Narrow: + conversions[nonExtendingResult]++; + break; + case Conversion::Extend: + conversions[extendingResult]++; + break; + } + } + + // Floating point can be mlir::FloatType or fir::real + static unsigned getFloatingPointWidth(mlir::Type t) { + if (auto f{t.dyn_cast()}) + return f.getWidth(); + // FIXME: Get width another way for fir.real/complex + // - use fir/KindMapping.h and llvm::Type + // - or use evaluate/type.h + if (auto r{t.dyn_cast()}) + return r.getFKind() * 4; + if (auto cplx{t.dyn_cast()}) + return cplx.getFKind() * 4; + llvm_unreachable("not a floating-point type"); + } + + static Conversion conversionBetweenTypes(mlir::Type from, mlir::Type to) { + if (from == to) { + return Conversion::None; + } + if (auto fromIntTy{from.dyn_cast()}) { + if (auto toIntTy{to.dyn_cast()}) { + return fromIntTy.getWidth() > toIntTy.getWidth() ? Conversion::Narrow + : Conversion::Extend; + } + } + if (fir::isa_real(from) && fir::isa_real(to)) { + return getFloatingPointWidth(from) > getFloatingPointWidth(to) + ? Conversion::Narrow + : Conversion::Extend; + } + if (auto fromCplxTy{from.dyn_cast()}) { + if (auto toCplxTy{to.dyn_cast()}) { + return getFloatingPointWidth(fromCplxTy) > + getFloatingPointWidth(toCplxTy) + ? Conversion::Narrow + : Conversion::Extend; + } + } + // Notes: + // - No conversion between character types, specialization of runtime + // functions should be made instead. + // - It is not clear there is a use case for automatic conversions + // around Logical and it may damage hidden information in the physical + // storage so do not do it. + return Conversion::Forbidden; + } + + // Below are indexes to access data in conversions. + // The order in data does matter for lexicographical_compare + enum { + narrowingArg = 0, // usually bad + extendingResult, // usually bad + nonExtendingResult, // usually ok + nonNarrowingArg, // usually ok + dataSize + }; + + std::array conversions{/* zero init*/}; + bool infinite{false}; // When forbidden conversion or wrong argument number +}; + +/// Build mlir::FuncOp from runtime symbol description and add +/// fir.runtime attribute. +static mlir::FuncOp getFuncOp(mlir::Location loc, fir::FirOpBuilder &builder, + const RuntimeFunction &runtime) { + mlir::FuncOp function = builder.addNamedFunction( + loc, runtime.symbol, runtime.typeGenerator(builder.getContext())); + function->setAttr("fir.runtime", builder.getUnitAttr()); + return function; +} + +/// Select runtime function that has the smallest distance to the intrinsic +/// function type and that will not imply narrowing arguments or extending the +/// result. +/// If nothing is found, the mlir::FuncOp will contain a nullptr. +mlir::FuncOp searchFunctionInLibrary( + mlir::Location loc, fir::FirOpBuilder &builder, + const Fortran::common::StaticMultimapView &lib, + llvm::StringRef name, mlir::FunctionType funcType, + const RuntimeFunction **bestNearMatch, + FunctionDistance &bestMatchDistance) { + auto range = lib.equal_range(name); + for (auto iter{range.first}; iter != range.second && iter; ++iter) { + const auto &impl = *iter; + auto implType = impl.typeGenerator(builder.getContext()); + if (funcType == implType) { + return getFuncOp(loc, builder, impl); // exact match + } else { + FunctionDistance distance(funcType, implType); + if (distance.isSmallerThan(bestMatchDistance)) { + *bestNearMatch = &impl; + bestMatchDistance = std::move(distance); + } + } + } + return {}; +} + +/// Search runtime for the best runtime function given an intrinsic name +/// and interface. The interface may not be a perfect match in which case +/// the caller is responsible to insert argument and return value conversions. +/// If nothing is found, the mlir::FuncOp will contain a nullptr. +static mlir::FuncOp getRuntimeFunction(mlir::Location loc, + fir::FirOpBuilder &builder, + llvm::StringRef name, + mlir::FunctionType funcType) { + const RuntimeFunction *bestNearMatch = nullptr; + FunctionDistance bestMatchDistance{}; + mlir::FuncOp match; + using RtMap = Fortran::common::StaticMultimapView; + static constexpr RtMap pgmathF(pgmathFast); + static_assert(pgmathF.Verify() && "map must be sorted"); + static constexpr RtMap pgmathR(pgmathRelaxed); + static_assert(pgmathR.Verify() && "map must be sorted"); + static constexpr RtMap pgmathP(pgmathPrecise); + static_assert(pgmathP.Verify() && "map must be sorted"); + if (mathRuntimeVersion == fastVersion) { + match = searchFunctionInLibrary(loc, builder, pgmathF, name, funcType, + &bestNearMatch, bestMatchDistance); + } else if (mathRuntimeVersion == relaxedVersion) { + match = searchFunctionInLibrary(loc, builder, pgmathR, name, funcType, + &bestNearMatch, bestMatchDistance); + } else if (mathRuntimeVersion == preciseVersion) { + match = searchFunctionInLibrary(loc, builder, pgmathP, name, funcType, + &bestNearMatch, bestMatchDistance); + } else { + assert(mathRuntimeVersion == llvmOnly && "unknown math runtime"); + } + if (match) + return match; + + // Go through llvm intrinsics if not exact match in libpgmath or if + // mathRuntimeVersion == llvmOnly + static constexpr RtMap llvmIntr(llvmIntrinsics); + static_assert(llvmIntr.Verify() && "map must be sorted"); + if (mlir::FuncOp exactMatch = + searchFunctionInLibrary(loc, builder, llvmIntr, name, funcType, + &bestNearMatch, bestMatchDistance)) + return exactMatch; + + if (bestNearMatch != nullptr) { + if (bestMatchDistance.isLosingPrecision()) { + // Using this runtime version requires narrowing the arguments + // or extending the result. It is not numerically safe. There + // is currently no quad math library that was described in + // lowering and could be used here. Emit an error and continue + // generating the code with the narrowing cast so that the user + // can get a complete list of the problematic intrinsic calls. + std::string message("TODO: no math runtime available for '"); + llvm::raw_string_ostream sstream(message); + if (name == "pow") { + assert(funcType.getNumInputs() == 2 && + "power operator has two arguments"); + sstream << funcType.getInput(0) << " ** " << funcType.getInput(1); + } else { + sstream << name << "("; + if (funcType.getNumInputs() > 0) + sstream << funcType.getInput(0); + for (mlir::Type argType : funcType.getInputs().drop_front()) + sstream << ", " << argType; + sstream << ")"; + } + sstream << "'"; + mlir::emitError(loc, message); + } + return getFuncOp(loc, builder, *bestNearMatch); + } + return {}; +} + +/// Helpers to get function type from arguments and result type. +static mlir::FunctionType getFunctionType(llvm::Optional resultType, + llvm::ArrayRef arguments, + fir::FirOpBuilder &builder) { + llvm::SmallVector argTypes; + for (mlir::Value arg : arguments) + argTypes.push_back(arg.getType()); + llvm::SmallVector resTypes; + if (resultType) + resTypes.push_back(*resultType); + 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, "descriptor or derived type not yet handled"); + } + + 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) { + mlir::emitError(loc, + "TODO: missing intrinsic lowering: " + llvm::Twine(name)); + exit(1); +} + +template +fir::ExtendedValue IntrinsicLibrary::genElementalCall( + GeneratorType generator, llvm::StringRef name, mlir::Type resultType, + llvm::ArrayRef args, bool outline) { + llvm::SmallVector scalarArgs; + for (const fir::ExtendedValue &arg : args) + if (arg.getUnboxed() || arg.getCharBox()) + scalarArgs.emplace_back(fir::getBase(arg)); + else + fir::emitFatalError(loc, "nonscalar intrinsic argument"); + 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"); + return std::invoke(generator, *this, resultType, args); +} + + +template <> +fir::ExtendedValue +IntrinsicLibrary::genElementalCall( + SubroutineGenerator 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"); + crashOnMissingIntrinsic(loc, name); + std::invoke(generator, *this, args); + return mlir::Value(); +} + +static fir::ExtendedValue +invokeHandler(IntrinsicLibrary::ElementalGenerator generator, + const IntrinsicHandler &handler, + llvm::Optional resultType, + llvm::ArrayRef args, bool outline, + IntrinsicLibrary &lib) { + assert(resultType && "expect elemental intrinsic to be functions"); + return lib.genElementalCall(generator, handler.name, *resultType, args, + 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"); + return std::invoke(generator, lib, *resultType, args); +} +static fir::ExtendedValue +invokeHandler(IntrinsicLibrary::SubroutineGenerator generator, + const IntrinsicHandler &handler, + llvm::Optional resultType, + llvm::ArrayRef args, bool outline, + IntrinsicLibrary &lib) { + std::invoke(generator, lib, args); + return mlir::Value{}; +} + +fir::ExtendedValue +IntrinsicLibrary::genIntrinsicCall(llvm::StringRef name, + llvm::Optional resultType, + llvm::ArrayRef args) { + if (const IntrinsicHandler *handler = findIntrinsicHandler(name)) { + bool outline = handler->outline || outlineAllIntrinsics; + return std::visit( + [&](auto &generator) -> fir::ExtendedValue { + return invokeHandler(generator, *handler, resultType, args, outline, + *this); + }, + handler->generator); + } + + TODO(loc, "genIntrinsicCall runtime"); + return {}; +} + +mlir::Value +IntrinsicLibrary::invokeGenerator(ElementalGenerator generator, + mlir::Type resultType, + llvm::ArrayRef args) { + return std::invoke(generator, *this, resultType, args); +} + +mlir::Value +IntrinsicLibrary::invokeGenerator(RuntimeCallGenerator generator, + mlir::Type resultType, + 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); +} + +mlir::Value +IntrinsicLibrary::invokeGenerator(SubroutineGenerator generator, + llvm::ArrayRef args) { + llvm::SmallVector extendedArgs; + for (mlir::Value arg : args) + extendedArgs.emplace_back(toExtendedValue(arg, builder, loc)); + std::invoke(generator, *this, extendedArgs); + 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); + } + + mlir::FunctionType actualFuncType = funcOp.getType(); + assert(actualFuncType.getNumResults() == soughtFuncType.getNumResults() && + actualFuncType.getNumInputs() == soughtFuncType.getNumInputs() && + actualFuncType.getNumResults() == 1 && "Bad intrinsic match"); + + return [funcOp, actualFuncType, + soughtFuncType](fir::FirOpBuilder &builder, mlir::Location loc, + llvm::ArrayRef args) { + llvm::SmallVector convertedArguments; + for (auto [fst, snd] : llvm::zip(actualFuncType.getInputs(), args)) + convertedArguments.push_back(builder.createConvert(loc, fst, snd)); + auto call = builder.create(loc, funcOp, convertedArguments); + mlir::Type soughtType = soughtFuncType.getResult(0); + return builder.createConvert(loc, soughtType, call.getResult(0)); + }; +} + +//===----------------------------------------------------------------------===// +// Code generators for the intrinsic +//===----------------------------------------------------------------------===// + +mlir::Value IntrinsicLibrary::genRuntimeCall(llvm::StringRef name, + mlir::Type resultType, + llvm::ArrayRef args) { + mlir::FunctionType soughtFuncType = + getFunctionType(resultType, args, builder); + return getRuntimeCallGenerator(name, soughtFuncType)(builder, loc, args); +} + +mlir::Value IntrinsicLibrary::genConversion(mlir::Type resultType, + llvm::ArrayRef args) { + // There can be an optional kind in second argument. + assert(args.size() >= 1); + return builder.convertWithSemantics(loc, resultType, args[0]); +} + +// IAND +mlir::Value IntrinsicLibrary::genIand(mlir::Type resultType, + llvm::ArrayRef args) { + assert(args.size() == 2); + return builder.create(loc, args[0], args[1]); +} + +//===----------------------------------------------------------------------===// +// Argument lowering rules interface +//===----------------------------------------------------------------------===// + +const Fortran::lower::IntrinsicArgumentLoweringRules * +Fortran::lower::getIntrinsicArgumentLowering(llvm::StringRef intrinsicName) { + if (const auto &handler = findIntrinsicHandler(intrinsicName)) + if (!handler->argLoweringRules.hasDefaultRules()) + return &handler->argLoweringRules; + return nullptr; +} + +/// Return how argument \p argName should be lowered given the rules for the +/// intrinsic function. +Fortran::lower::ArgLoweringRule Fortran::lower::lowerIntrinsicArgumentAs( + mlir::Location loc, const IntrinsicArgumentLoweringRules &rules, + llvm::StringRef argName) { + for (const auto &arg : rules.args) { + if (arg.name && arg.name == argName) + return {arg.lowerAs, arg.handleDynamicOptional}; + } + fir::emitFatalError( + loc, "internal: unknown intrinsic argument name in lowering '" + argName + + "'"); +} + +//===----------------------------------------------------------------------===// +// Public intrinsic call helpers +//===----------------------------------------------------------------------===// + +fir::ExtendedValue +Fortran::lower::genIntrinsicCall(fir::FirOpBuilder &builder, mlir::Location loc, + llvm::StringRef name, + llvm::Optional resultType, + llvm::ArrayRef args, + Fortran::lower::StatementContext &stmtCtx) { + return IntrinsicLibrary{builder, loc, &stmtCtx}.genIntrinsicCall( + name, resultType, args); +} diff --git a/flang/lib/Lower/OpenACC.cpp b/flang/lib/Lower/OpenACC.cpp --- a/flang/lib/Lower/OpenACC.cpp +++ b/flang/lib/Lower/OpenACC.cpp @@ -14,6 +14,7 @@ #include "flang/Common/idioms.h" #include "flang/Lower/Bridge.h" #include "flang/Lower/PFTBuilder.h" +#include "flang/Lower/StatementContext.h" #include "flang/Lower/Todo.h" #include "flang/Optimizer/Builder/BoxValue.h" #include "flang/Optimizer/Builder/FIRBuilder.h" @@ -121,6 +122,7 @@ Fortran::lower::pft::Evaluation &eval, const Fortran::parser::OpenACCLoopConstruct &loopConstruct) { + Fortran::lower::StatementContext stmtCtx; const auto &beginLoopDirective = std::get(loopConstruct.t); const auto &loopDirective = @@ -151,7 +153,7 @@ std::get>( x.t)) { gangNum = fir::getBase(converter.genExprValue( - *Fortran::semantics::GetExpr(gangNumValue.value()))); + *Fortran::semantics::GetExpr(gangNumValue.value()), stmtCtx)); } if (const auto &gangStaticValue = std::get>(x.t)) { @@ -160,7 +162,7 @@ gangStaticValue.value().t); if (expr) { gangStatic = fir::getBase( - converter.genExprValue(*Fortran::semantics::GetExpr(*expr))); + converter.genExprValue(*Fortran::semantics::GetExpr(*expr),stmtCtx)); } else { // * was passed as value and will be represented as a -1 constant // integer. @@ -176,7 +178,7 @@ &clause.u)) { if (workerClause->v) { workerNum = fir::getBase(converter.genExprValue( - *Fortran::semantics::GetExpr(*workerClause->v))); + *Fortran::semantics::GetExpr(*workerClause->v), stmtCtx)); } executionMapping |= mlir::acc::OpenACCExecMapping::WORKER; } else if (const auto *vectorClause = @@ -184,7 +186,7 @@ &clause.u)) { if (vectorClause->v) { vectorLength = fir::getBase(converter.genExprValue( - *Fortran::semantics::GetExpr(*vectorClause->v))); + *Fortran::semantics::GetExpr(*vectorClause->v), stmtCtx)); } executionMapping |= mlir::acc::OpenACCExecMapping::VECTOR; } else if (const auto *tileClause = @@ -196,7 +198,7 @@ accTileExpr.t); if (expr) { tileOperands.push_back(fir::getBase( - converter.genExprValue(*Fortran::semantics::GetExpr(*expr)))); + converter.genExprValue(*Fortran::semantics::GetExpr(*expr), stmtCtx))); } else { // * was passed as value and will be represented as a -1 constant // integer. @@ -281,6 +283,7 @@ auto &firOpBuilder = converter.getFirOpBuilder(); auto currentLocation = converter.getCurrentLocation(); + Fortran::lower::StatementContext stmtCtx; // Lower clauses values mapped to operands. // Keep track of each group of operands separatly as clauses can appear @@ -291,7 +294,7 @@ const auto &asyncClauseValue = asyncClause->v; if (asyncClauseValue) { // async has a value. async = fir::getBase(converter.genExprValue( - *Fortran::semantics::GetExpr(*asyncClauseValue))); + *Fortran::semantics::GetExpr(*asyncClauseValue), stmtCtx)); } else { addAsyncAttr = true; } @@ -304,7 +307,7 @@ std::get>(waitArg.t); for (const Fortran::parser::ScalarIntExpr &value : waitList) { Value v = fir::getBase( - converter.genExprValue(*Fortran::semantics::GetExpr(value))); + converter.genExprValue(*Fortran::semantics::GetExpr(value), stmtCtx)); waitOperands.push_back(v); } } else { @@ -314,21 +317,21 @@ std::get_if( &clause.u)) { numGangs = fir::getBase(converter.genExprValue( - *Fortran::semantics::GetExpr(numGangsClause->v))); + *Fortran::semantics::GetExpr(numGangsClause->v), stmtCtx)); } else if (const auto *numWorkersClause = std::get_if( &clause.u)) { numWorkers = fir::getBase(converter.genExprValue( - *Fortran::semantics::GetExpr(numWorkersClause->v))); + *Fortran::semantics::GetExpr(numWorkersClause->v), stmtCtx)); } else if (const auto *vectorLengthClause = std::get_if( &clause.u)) { vectorLength = fir::getBase(converter.genExprValue( - *Fortran::semantics::GetExpr(vectorLengthClause->v))); + *Fortran::semantics::GetExpr(vectorLengthClause->v), stmtCtx)); } else if (const auto *ifClause = std::get_if(&clause.u)) { Value cond = fir::getBase( - converter.genExprValue(*Fortran::semantics::GetExpr(ifClause->v))); + converter.genExprValue(*Fortran::semantics::GetExpr(ifClause->v), stmtCtx)); ifCond = firOpBuilder.createConvert(currentLocation, firOpBuilder.getI1Type(), cond); } else if (const auto *selfClause = @@ -339,7 +342,7 @@ &accSelfClause.u)) { if (*optCondition) { Value cond = fir::getBase(converter.genExprValue( - *Fortran::semantics::GetExpr(*optCondition))); + *Fortran::semantics::GetExpr(*optCondition), stmtCtx)); selfCond = firOpBuilder.createConvert(currentLocation, firOpBuilder.getI1Type(), cond); } else { @@ -442,6 +445,7 @@ auto &firOpBuilder = converter.getFirOpBuilder(); auto currentLocation = converter.getCurrentLocation(); + Fortran::lower::StatementContext stmtCtx; // Lower clauses values mapped to operands. // Keep track of each group of operands separatly as clauses can appear @@ -450,7 +454,7 @@ if (const auto *ifClause = std::get_if(&clause.u)) { Value cond = fir::getBase( - converter.genExprValue(*Fortran::semantics::GetExpr(ifClause->v))); + converter.genExprValue(*Fortran::semantics::GetExpr(ifClause->v), stmtCtx)); ifCond = firOpBuilder.createConvert(currentLocation, firOpBuilder.getI1Type(), cond); } else if (const auto *copyClause = @@ -546,6 +550,7 @@ auto &firOpBuilder = converter.getFirOpBuilder(); auto currentLocation = converter.getCurrentLocation(); + Fortran::lower::StatementContext stmtCtx; // Lower clauses values mapped to operands. // Keep track of each group of operands separatly as clauses can appear @@ -554,7 +559,7 @@ if (const auto *ifClause = std::get_if(&clause.u)) { mlir::Value cond = fir::getBase( - converter.genExprValue(*Fortran::semantics::GetExpr(ifClause->v))); + converter.genExprValue(*Fortran::semantics::GetExpr(ifClause->v), stmtCtx)); ifCond = firOpBuilder.createConvert(currentLocation, firOpBuilder.getI1Type(), cond); } else if (const auto *asyncClause = @@ -562,7 +567,7 @@ const auto &asyncClauseValue = asyncClause->v; if (asyncClauseValue) { // async has a value. async = fir::getBase(converter.genExprValue( - *Fortran::semantics::GetExpr(*asyncClauseValue))); + *Fortran::semantics::GetExpr(*asyncClauseValue), stmtCtx)); } else { addAsyncAttr = true; } @@ -575,7 +580,7 @@ std::get>(waitArg.t); for (const Fortran::parser::ScalarIntExpr &value : waitList) { mlir::Value v = fir::getBase( - converter.genExprValue(*Fortran::semantics::GetExpr(value))); + converter.genExprValue(*Fortran::semantics::GetExpr(value), stmtCtx)); waitOperands.push_back(v); } @@ -583,7 +588,7 @@ std::get>(waitArg.t); if (waitDevnumValue) waitDevnum = fir::getBase(converter.genExprValue( - *Fortran::semantics::GetExpr(*waitDevnumValue))); + *Fortran::semantics::GetExpr(*waitDevnumValue), stmtCtx)); } else { addWaitAttr = true; } @@ -646,6 +651,7 @@ auto &firOpBuilder = converter.getFirOpBuilder(); auto currentLocation = converter.getCurrentLocation(); + Fortran::lower::StatementContext stmtCtx; // Lower clauses values mapped to operands. // Keep track of each group of operands separatly as clauses can appear @@ -654,7 +660,7 @@ if (const auto *ifClause = std::get_if(&clause.u)) { Value cond = fir::getBase( - converter.genExprValue(*Fortran::semantics::GetExpr(ifClause->v))); + converter.genExprValue(*Fortran::semantics::GetExpr(ifClause->v), stmtCtx)); ifCond = firOpBuilder.createConvert(currentLocation, firOpBuilder.getI1Type(), cond); } else if (const auto *asyncClause = @@ -662,7 +668,7 @@ const auto &asyncClauseValue = asyncClause->v; if (asyncClauseValue) { // async has a value. async = fir::getBase(converter.genExprValue( - *Fortran::semantics::GetExpr(*asyncClauseValue))); + *Fortran::semantics::GetExpr(*asyncClauseValue), stmtCtx)); } else { addAsyncAttr = true; } @@ -675,7 +681,7 @@ std::get>(waitArg.t); for (const Fortran::parser::ScalarIntExpr &value : waitList) { Value v = fir::getBase( - converter.genExprValue(*Fortran::semantics::GetExpr(value))); + converter.genExprValue(*Fortran::semantics::GetExpr(value), stmtCtx)); waitOperands.push_back(v); } @@ -683,7 +689,7 @@ std::get>(waitArg.t); if (waitDevnumValue) waitDevnum = fir::getBase(converter.genExprValue( - *Fortran::semantics::GetExpr(*waitDevnumValue))); + *Fortran::semantics::GetExpr(*waitDevnumValue), stmtCtx)); } else { addWaitAttr = true; } @@ -737,6 +743,7 @@ auto &firOpBuilder = converter.getFirOpBuilder(); auto currentLocation = converter.getCurrentLocation(); + Fortran::lower::StatementContext stmtCtx; // Lower clauses values mapped to operands. // Keep track of each group of operands separatly as clauses can appear @@ -745,14 +752,14 @@ if (const auto *ifClause = std::get_if(&clause.u)) { mlir::Value cond = fir::getBase( - converter.genExprValue(*Fortran::semantics::GetExpr(ifClause->v))); + converter.genExprValue(*Fortran::semantics::GetExpr(ifClause->v), stmtCtx)); ifCond = firOpBuilder.createConvert(currentLocation, firOpBuilder.getI1Type(), cond); } else if (const auto *deviceNumClause = std::get_if( &clause.u)) { deviceNum = fir::getBase(converter.genExprValue( - *Fortran::semantics::GetExpr(deviceNumClause->v))); + *Fortran::semantics::GetExpr(deviceNumClause->v), stmtCtx)); } else if (const auto *deviceTypeClause = std::get_if( &clause.u)) { @@ -761,7 +768,7 @@ if (deviceTypeValue) { for (const auto &scalarIntExpr : *deviceTypeValue) { mlir::Value expr = fir::getBase(converter.genExprValue( - *Fortran::semantics::GetExpr(scalarIntExpr))); + *Fortran::semantics::GetExpr(scalarIntExpr), stmtCtx)); deviceTypeOperands.push_back(expr); } } else { @@ -800,6 +807,7 @@ auto &firOpBuilder = converter.getFirOpBuilder(); auto currentLocation = converter.getCurrentLocation(); + Fortran::lower::StatementContext stmtCtx; // Lower clauses values mapped to operands. // Keep track of each group of operands separatly as clauses can appear @@ -808,7 +816,7 @@ if (const auto *ifClause = std::get_if(&clause.u)) { mlir::Value cond = fir::getBase( - converter.genExprValue(*Fortran::semantics::GetExpr(ifClause->v))); + converter.genExprValue(*Fortran::semantics::GetExpr(ifClause->v), stmtCtx)); ifCond = firOpBuilder.createConvert(currentLocation, firOpBuilder.getI1Type(), cond); } else if (const auto *asyncClause = @@ -816,7 +824,7 @@ const auto &asyncClauseValue = asyncClause->v; if (asyncClauseValue) { // async has a value. async = fir::getBase(converter.genExprValue( - *Fortran::semantics::GetExpr(*asyncClauseValue))); + *Fortran::semantics::GetExpr(*asyncClauseValue), stmtCtx)); } else { addAsyncAttr = true; } @@ -829,7 +837,7 @@ std::get>(waitArg.t); for (const Fortran::parser::ScalarIntExpr &value : waitList) { mlir::Value v = fir::getBase( - converter.genExprValue(*Fortran::semantics::GetExpr(value))); + converter.genExprValue(*Fortran::semantics::GetExpr(value), stmtCtx)); waitOperands.push_back(v); } @@ -837,7 +845,7 @@ std::get>(waitArg.t); if (waitDevnumValue) waitDevnum = fir::getBase(converter.genExprValue( - *Fortran::semantics::GetExpr(*waitDevnumValue))); + *Fortran::semantics::GetExpr(*waitDevnumValue), stmtCtx)); } else { addWaitAttr = true; } @@ -849,7 +857,7 @@ if (deviceTypeValue) { for (const auto &scalarIntExpr : *deviceTypeValue) { mlir::Value expr = fir::getBase(converter.genExprValue( - *Fortran::semantics::GetExpr(scalarIntExpr))); + *Fortran::semantics::GetExpr(scalarIntExpr), stmtCtx)); deviceTypeOperands.push_back(expr); } } else { @@ -935,6 +943,7 @@ auto &firOpBuilder = converter.getFirOpBuilder(); auto currentLocation = converter.getCurrentLocation(); + Fortran::lower::StatementContext stmtCtx; if (waitArgument) { // wait has a value. const Fortran::parser::AccWaitArgument &waitArg = *waitArgument; @@ -942,7 +951,7 @@ std::get>(waitArg.t); for (const Fortran::parser::ScalarIntExpr &value : waitList) { mlir::Value v = fir::getBase( - converter.genExprValue(*Fortran::semantics::GetExpr(value))); + converter.genExprValue(*Fortran::semantics::GetExpr(value), stmtCtx)); waitOperands.push_back(v); } @@ -950,7 +959,7 @@ std::get>(waitArg.t); if (waitDevnumValue) waitDevnum = fir::getBase(converter.genExprValue( - *Fortran::semantics::GetExpr(*waitDevnumValue))); + *Fortran::semantics::GetExpr(*waitDevnumValue), stmtCtx)); } // Lower clauses values mapped to operands. @@ -960,7 +969,7 @@ if (const auto *ifClause = std::get_if(&clause.u)) { mlir::Value cond = fir::getBase( - converter.genExprValue(*Fortran::semantics::GetExpr(ifClause->v))); + converter.genExprValue(*Fortran::semantics::GetExpr(ifClause->v), stmtCtx)); ifCond = firOpBuilder.createConvert(currentLocation, firOpBuilder.getI1Type(), cond); } else if (const auto *asyncClause = @@ -968,7 +977,7 @@ const auto &asyncClauseValue = asyncClause->v; if (asyncClauseValue) { // async has a value. async = fir::getBase(converter.genExprValue( - *Fortran::semantics::GetExpr(*asyncClauseValue))); + *Fortran::semantics::GetExpr(*asyncClauseValue), stmtCtx)); } else { addAsyncAttr = true; } diff --git a/flang/lib/Lower/OpenMP.cpp b/flang/lib/Lower/OpenMP.cpp --- a/flang/lib/Lower/OpenMP.cpp +++ b/flang/lib/Lower/OpenMP.cpp @@ -14,6 +14,7 @@ #include "flang/Common/idioms.h" #include "flang/Lower/Bridge.h" #include "flang/Lower/PFTBuilder.h" +#include "flang/Lower/StatementContext.h" #include "flang/Lower/Todo.h" #include "flang/Optimizer/Builder/BoxValue.h" #include "flang/Optimizer/Builder/FIRBuilder.h" @@ -137,6 +138,7 @@ const auto &blockDirective = std::get(beginBlockDirective.t); + Fortran::lower::StatementContext stmtCtx; auto &firOpBuilder = converter.getFirOpBuilder(); auto currentLocation = converter.getCurrentLocation(); llvm::ArrayRef argTy; @@ -155,13 +157,13 @@ auto &expr = std::get(ifClause->v.t); ifClauseOperand = fir::getBase( - converter.genExprValue(*Fortran::semantics::GetExpr(expr))); + converter.genExprValue(*Fortran::semantics::GetExpr(expr), stmtCtx)); } else if (const auto &numThreadsClause = std::get_if( &clause.u)) { // OMPIRBuilder expects `NUM_THREAD` clause as a `Value`. numThreadsClauseOperand = fir::getBase(converter.genExprValue( - *Fortran::semantics::GetExpr(numThreadsClause->v))); + *Fortran::semantics::GetExpr(numThreadsClause->v), stmtCtx)); } else if (const auto &privateClause = std::get_if( &clause.u)) { diff --git a/flang/lib/Lower/Runtime.cpp b/flang/lib/Lower/Runtime.cpp --- a/flang/lib/Lower/Runtime.cpp +++ b/flang/lib/Lower/Runtime.cpp @@ -8,6 +8,7 @@ #include "flang/Lower/Runtime.h" #include "flang/Lower/Bridge.h" +#include "flang/Lower/StatementContext.h" #include "flang/Lower/Todo.h" #include "flang/Optimizer/Builder/FIRBuilder.h" #include "flang/Optimizer/Builder/Runtime/RTBuilder.h" @@ -38,13 +39,15 @@ const Fortran::parser::StopStmt &stmt) { fir::FirOpBuilder &builder = converter.getFirOpBuilder(); mlir::Location loc = converter.getCurrentLocation(); + Fortran::lower::StatementContext stmtCtx; llvm::SmallVector operands; mlir::FuncOp callee; mlir::FunctionType calleeType; // First operand is stop code (zero if absent) if (const auto &code = std::get>(stmt.t)) { - auto expr = converter.genExprValue(*Fortran::semantics::GetExpr(*code)); + auto expr = + converter.genExprValue(*Fortran::semantics::GetExpr(*code), stmtCtx); LLVM_DEBUG(llvm::dbgs() << "stop expression: "; expr.dump(); llvm::dbgs() << '\n'); expr.match( @@ -88,7 +91,7 @@ std::get>(stmt.t)) { const SomeExpr *expr = Fortran::semantics::GetExpr(*quiet); assert(expr && "failed getting typed expression"); - mlir::Value q = fir::getBase(converter.genExprValue(*expr)); + mlir::Value q = fir::getBase(converter.genExprValue(*expr, stmtCtx)); operands.push_back( builder.createConvert(loc, calleeType.getInput(operands.size()), q)); } else { diff --git a/flang/test/Lower/stop-statement.f90 b/flang/test/Lower/stop-statement.f90 --- a/flang/test/Lower/stop-statement.f90 +++ b/flang/test/Lower/stop-statement.f90 @@ -63,3 +63,16 @@ ! CHECK-NEXT: fir.unreachable stop 'crash' end subroutine stop_char_lit + +! CHECK-LABEL: stop_intrinsic +subroutine stop_intrinsic() + integer :: s1, s2 + stop iand(s1,s2) +end subroutine + ! CHECK-DAG: %[[S1:.*]] = fir.alloca i32 {bindc_name = "s1", {{.*}}} + ! CHECK-DAG: %[[S2:.*]] = fir.alloca i32 {bindc_name = "s2", {{.*}}} + ! CHECK-DAG: %[[S1_VAL:.*]] = fir.load %[[S1]] : !fir.ref + ! CHECK-DAG: %[[S2_VAL:.*]] = fir.load %[[S2]] : !fir.ref + ! CHECK-DAG: %[[ANDI:.*]] = arith.andi %[[S1_VAL]], %[[S2_VAL]] : i32 + ! CHECK: fir.call @_FortranAStopStatement(%[[ANDI]], {{.*}}, {{.*}}) : (i32, i1, i1) -> none + ! CHECK-NEXT: fir.unreachable