diff --git a/flang/include/flang/Lower/CharacterExpr.h b/flang/include/flang/Lower/CharacterExpr.h --- a/flang/include/flang/Lower/CharacterExpr.h +++ b/flang/include/flang/Lower/CharacterExpr.h @@ -106,6 +106,19 @@ /// Character lengths. TODO: move this to FirOpBuilder? mlir::Type getLengthType() { return builder.getIndexType(); } + /// Create an extended value from: + /// - fir.boxchar + /// - fir.ref>> + /// - fir.array> + /// - fir.char + /// - fir.ref> + /// If the no length is passed, it is attempted to be extracted from \p + /// character (or its type). This will crash if this is not possible. + /// The returned value is a CharBoxValue if \p character is a scalar, + /// otherwise it is a CharArrayBoxValue. + fir::ExtendedValue toExtendedValue(mlir::Value character, + mlir::Value len = {}); + private: fir::CharBoxValue materializeValue(const fir::CharBoxValue &str); fir::CharBoxValue toDataLengthPair(mlir::Value character); 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 @@ -27,39 +27,40 @@ /// Helper for building calls to intrinsic functions in the runtime support /// libraries. -class IntrinsicCallOpsHelper { -public: - explicit IntrinsicCallOpsHelper(FirOpBuilder &builder, mlir::Location loc) - : builder(builder), loc(loc) {} - IntrinsicCallOpsHelper(const IntrinsicCallOpsHelper &) = delete; - /// 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. - fir::ExtendedValue genIntrinsicCall(llvm::StringRef name, - mlir::Type resultType, - llvm::ArrayRef args); +/// 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. +fir::ExtendedValue genIntrinsicCall(FirOpBuilder &, mlir::Location, + llvm::StringRef name, mlir::Type resultType, + llvm::ArrayRef args); - //===--------------------------------------------------------------------===// - // Direct access to intrinsics that may be used by lowering outside - // of intrinsic call lowering. - //===--------------------------------------------------------------------===// +/// Get SymbolRefAttr of runtime (or wrapper function containing inlined +// implementation) of an unrestricted intrinsic (defined by its signature +// and generic name) +mlir::SymbolRefAttr +getUnrestrictedIntrinsicSymbolRefAttr(FirOpBuilder &, mlir::Location, + llvm::StringRef name, + mlir::FunctionType signature); - /// Generate maximum. There must be at least one argument and all arguments - /// must have the same type. - mlir::Value genMax(llvm::ArrayRef args); +//===--------------------------------------------------------------------===// +// Direct access to intrinsics that may be used by lowering outside +// of intrinsic call lowering. +//===--------------------------------------------------------------------===// - /// Generate minimum. Same constraints as genMax. - mlir::Value genMin(llvm::ArrayRef args); +/// Generate maximum. There must be at least one argument and all arguments +/// must have the same type. +mlir::Value genMax(FirOpBuilder &, mlir::Location, + llvm::ArrayRef args); - /// Generate power function x**y with given the expected - /// result type. - mlir::Value genPow(mlir::Type resultType, mlir::Value x, mlir::Value y); +/// Generate minimum. Same constraints as genMax. +mlir::Value genMin(FirOpBuilder &, mlir::Location, + llvm::ArrayRef args); -private: - FirOpBuilder &builder; - mlir::Location loc; -}; +/// Generate power function x**y with given the expected +/// result type. +mlir::Value genPow(FirOpBuilder &, mlir::Location, mlir::Type resultType, + mlir::Value x, mlir::Value y); } // namespace Fortran::lower diff --git a/flang/include/flang/Lower/Mangler.h b/flang/include/flang/Lower/Mangler.h --- a/flang/include/flang/Lower/Mangler.h +++ b/flang/include/flang/Lower/Mangler.h @@ -5,19 +5,32 @@ // SPDX-License-Identifier: Apache-2.0 WITH LLVM-exception // //===----------------------------------------------------------------------===// +// +// Coding style: https://mlir.llvm.org/getting_started/DeveloperGuide/ +// +//===----------------------------------------------------------------------===// -#ifndef FORTRAN_LOWER_MANGLER_H_ -#define FORTRAN_LOWER_MANGLER_H_ +#ifndef FORTRAN_LOWER_MANGLER_H +#define FORTRAN_LOWER_MANGLER_H +#include "mlir/IR/StandardTypes.h" +#include "llvm/ADT/StringRef.h" #include namespace fir { struct NameUniquer; -} -namespace llvm { -class StringRef; -} +/// Returns a name suitable to define mlir functions for Fortran intrinsic +/// Procedure. These names are guaranteed to not conflict with user defined +/// procedures. This is needed to implement Fortran generic intrinsics as +/// several mlir functions specialized for the argument types. +/// The result is guaranteed to be distinct for different mlir::FunctionType +/// arguments. The mangling pattern is: +/// fir...... +/// e.g ACOS(COMPLEX(4)) is mangled as fir.acos.z4.z4 +std::string mangleIntrinsicProcedure(llvm::StringRef genericName, + mlir::FunctionType); +} // namespace fir namespace Fortran { namespace common { @@ -41,4 +54,4 @@ } // namespace lower } // namespace Fortran -#endif // FORTRAN_LOWER_MANGLER_H_ +#endif // FORTRAN_LOWER_MANGLER_H 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 @@ -242,7 +242,7 @@ static bool kindof(unsigned kind) { return kind == TypeKind::FIR_DIMS; } /// returns -1 if the rank is unknown - int getRank() const; + unsigned getRank() const; }; /// The type of a field name. Implementations may defer the layout of a Fortran @@ -437,6 +437,12 @@ return t.isa() || t.isa(); } +/// Is `t` an integral type? +inline bool isa_integer(mlir::Type t) { + return t.isa() || t.isa() || + t.isa(); +} + /// Is `t` a FIR or MLIR Complex type? inline bool isa_complex(mlir::Type t) { return t.isa() || t.isa(); 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 DoLoopHelper.cpp FIRBuilder.cpp + IntrinsicCall.cpp IO.cpp Mangler.cpp OpenMP.cpp diff --git a/flang/lib/Lower/CharacterExpr.cpp b/flang/lib/Lower/CharacterExpr.cpp --- a/flang/lib/Lower/CharacterExpr.cpp +++ b/flang/lib/Lower/CharacterExpr.cpp @@ -21,8 +21,10 @@ return boxType.getEleTy(); if (auto refType = type.dyn_cast()) type = refType.getEleTy(); - if (auto seqType = type.dyn_cast()) + if (auto seqType = type.dyn_cast()) { + assert(seqType.getShape().size() == 1 && "rank must be 1"); type = seqType.getEleTy(); + } if (auto charType = type.dyn_cast()) return charType; llvm_unreachable("Invalid character value type"); @@ -65,38 +67,66 @@ fir::CharBoxValue Fortran::lower::CharacterExprHelper::toDataLengthPair(mlir::Value character) { + // TODO: get rid of toDataLengthPair when adding support for arrays + auto charBox = toExtendedValue(character).getCharBox(); + assert(charBox && "Array unsupported in character lowering helper"); + return *charBox; +} + +fir::ExtendedValue +Fortran::lower::CharacterExprHelper::toExtendedValue(mlir::Value character, + mlir::Value len) { auto lenType = getLengthType(); auto type = character.getType(); - if (auto boxCharType = type.dyn_cast()) { + auto base = character; + mlir::Value resultLen = len; + llvm::SmallVector extents; + + if (auto refType = type.dyn_cast()) + type = refType.getEleTy(); + + if (auto arrayType = type.dyn_cast()) { + type = arrayType.getEleTy(); + auto shape = arrayType.getShape(); + auto cstLen = shape[0]; + if (!resultLen && cstLen != fir::SequenceType::getUnknownExtent()) + resultLen = builder.createIntegerConstant(loc, lenType, cstLen); + // FIXME: only allow `?` in last dimension ? + auto typeExtents = + llvm::ArrayRef{shape}.drop_front(); + auto indexType = builder.getIndexType(); + for (auto extent : typeExtents) { + 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 < typeExtents.size()) + mlir::emitError(loc, "cannot retrieve array extents from type"); + } else if (type.isa()) { + if (!resultLen) + resultLen = builder.createIntegerConstant(loc, lenType, 1); + } else if (auto boxCharType = type.dyn_cast()) { auto refType = builder.getRefType(boxCharType.getEleTy()); auto unboxed = builder.create(loc, refType, lenType, character); - return {unboxed.getResult(0), unboxed.getResult(1)}; - } - if (auto seqType = type.dyn_cast()) { - // Materialize length for usage into character manipulations. - auto len = builder.createIntegerConstant(loc, lenType, 1); - return {character, len}; - } - if (auto refType = type.dyn_cast()) - type = refType.getEleTy(); - if (auto seqType = type.dyn_cast()) { - assert(seqType.hasConstantShape() && - "ssa array value must have constant length"); - auto shape = seqType.getShape(); - assert(shape.size() == 1 && "only scalar character supported"); - // Materialize length for usage into character manipulations. - auto len = builder.createIntegerConstant(loc, lenType, shape[0]); - // FIXME: this seems to work for tests, but don't think it is correct - if (auto load = dyn_cast(character.getDefiningOp())) - return {load.memref(), len}; - return {character, len}; - } - if (auto charTy = type.dyn_cast()) { - auto len = builder.createIntegerConstant(loc, lenType, 1); - return {character, len}; + base = unboxed.getResult(0); + if (!resultLen) + resultLen = unboxed.getResult(1); + } else if (type.isa()) { + mlir::emitError(loc, "descriptor or derived type not yet handled"); + } else { + llvm_unreachable("Cannot translate mlir::Value to character ExtendedValue"); } - llvm::report_fatal_error("unexpected character type"); + + if (!resultLen) + mlir::emitError(loc, "no dynamic length found for character"); + if (!extents.empty()) + return fir::CharArrayBoxValue{base, resultLen, extents}; + return fir::CharBoxValue{base, resultLen}; } /// Get fir.ref> type. @@ -115,17 +145,15 @@ auto boxCharType = fir::BoxCharType::get(builder.getContext(), kind); auto refType = getReferenceType(str); // So far, fir.emboxChar fails lowering to llvm when it is given - // fir.data>> types, so convert to - // fir.data> if needed. + // fir.ref>> types, so convert to + // fir.ref> if needed. auto buff = str.getBuffer(); - if (refType != str.getBuffer().getType()) - buff = builder.createConvert(loc, refType, buff); + buff = builder.createConvert(loc, refType, buff); // Convert in case the provided length is not of the integer type that must // be used in boxchar. auto lenType = getLengthType(); auto len = str.getLen(); - if (str.getLen().getType() != lenType) - len = builder.createConvert(loc, lenType, len); + len = builder.createConvert(loc, lenType, len); return builder.create(loc, boxCharType, buff, len); } @@ -182,16 +210,20 @@ void Fortran::lower::CharacterExprHelper::createLengthOneAssign( const fir::CharBoxValue &lhs, const fir::CharBoxValue &rhs) { auto addr = lhs.getBuffer(); - auto refType = getReferenceType(lhs); - addr = builder.createConvert(loc, refType, addr); - auto val = rhs.getBuffer(); - if (!needToMaterialize(rhs)) { - mlir::Value rhsAddr = rhs.getBuffer(); - rhsAddr = builder.createConvert(loc, refType, rhsAddr); - val = builder.create(loc, rhsAddr); + // If rhs value resides in memory, load it. + if (!needToMaterialize(rhs)) + val = builder.create(loc, val); + auto valTy = val.getType(); + // Precondition is rhs is size 1, but it may be wrapped in a fir.array. + if (auto seqTy = valTy.dyn_cast()) { + auto zero = builder.createIntegerConstant(loc, builder.getIndexType(), 0); + valTy = seqTy.getEleTy(); + val = builder.create(loc, valTy, val, zero); } - + auto addrTy = fir::ReferenceType::get(valTy); + addr = builder.createConvert(loc, addrTy, addr); + assert(fir::dyn_cast_ptrEleTy(addr.getType()) == val.getType()); builder.create(loc, val, addr); } @@ -211,8 +243,8 @@ // if needed. mlir::Value copyCount = lhs.getLen(); if (!compileTimeSameLength) - copyCount = Fortran::lower::IntrinsicCallOpsHelper{builder, loc}.genMin( - {lhs.getLen(), rhs.getLen()}); + copyCount = + Fortran::lower::genMin(builder, loc, {lhs.getLen(), rhs.getLen()}); fir::CharBoxValue safeRhs = rhs; if (needToMaterialize(rhs)) { @@ -433,7 +465,8 @@ bool Fortran::lower::CharacterExprHelper::isCharacterLiteral(mlir::Type type) { if (auto seqType = type.dyn_cast()) - return seqType.getEleTy().isa(); + return (seqType.getShape().size() == 1) && + seqType.getEleTy().isa(); return false; } @@ -442,9 +475,9 @@ return true; if (auto refType = type.dyn_cast()) type = refType.getEleTy(); - if (auto seqType = type.dyn_cast()) { - type = seqType.getEleTy(); - } + if (auto seqType = type.dyn_cast()) + if (seqType.getShape().size() == 1) + type = seqType.getEleTy(); return type.isa(); } 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,1380 @@ +//===-- 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 "RTBuilder.h" +#include "flang/Lower/CharacterExpr.h" +#include "flang/Lower/ComplexExpr.h" +#include "flang/Lower/ConvertType.h" +#include "flang/Lower/FIRBuilder.h" +#include "flang/Lower/Mangler.h" +#include "flang/Lower/Runtime.h" +#include "llvm/Support/CommandLine.h" +#include "llvm/Support/ErrorHandling.h" +#include +#include + +#define PGMATH_DECLARE +#include "../runtime/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. + +/// Enums used to templatize and share lowering of MIN and MAX. +enum class Extremum { Min, Max }; + +// There are different ways to deal with NaNs in MIN and MAX. +// Known existing behaviors are listed below and can be selected for +// f18 MIN/MAX implementation. +enum class ExtremumBehavior { + // Note: the Signaling/quiet aspect of NaNs in the behaviors below are + // not described because there is no way to control/observe such aspect in + // MLIR/LLVM yet. The IEEE behaviors come with requirements regarding this + // aspect that are therefore currently not enforced. In the descriptions + // below, NaNs can be signaling or quite. Returned NaNs may be signaling + // if one of the input NaN was signaling but it cannot be guaranteed either. + // Existing compilers using an IEEE behavior (gfortran) also do not fulfill + // signaling/quiet requirements. + IeeeMinMaximumNumber, + // IEEE minimumNumber/maximumNumber behavior (754-2019, section 9.6): + // If one of the argument is and number and the other is NaN, return the + // number. If both arguements are NaN, return NaN. + // Compilers: gfortran. + IeeeMinMaximum, + // IEEE minimum/maximum behavior (754-2019, section 9.6): + // If one of the argument is NaN, return NaN. + MinMaxss, + // x86 minss/maxss behavior: + // If the second argument is a number and the other is NaN, return the number. + // In all other cases where at least one operand is NaN, return NaN. + // Compilers: xlf (only for MAX), ifort, pgfortran -nollvm, and nagfor. + PgfortranLlvm, + // "Opposite of" x86 minss/maxss behavior: + // If the first argument is a number and the other is NaN, return the + // number. + // In all other cases where at least one operand is NaN, return NaN. + // Compilers: xlf (only for MIN), and pgfortran (with llvm). + IeeeMinMaxNum + // IEEE minNum/maxNum behavior (754-2008, section 5.3.1): + // TODO: Not implemented. + // It is the only behavior where the signaling/quiet aspect of a NaN argument + // impacts if the result should be NaN or the argument that is a number. + // LLVM/MLIR do not provide ways to observe this aspect, so it is not + // possible to implement it without some target dependent runtime. +}; + +namespace { +/// StaticMultimapView is a constexpr friendly multimap +/// implementation over sorted constexpr arrays. +/// As the View name suggests, it does not duplicate the +/// sorted array but only brings range and search concepts +/// over it. It provides compile time search and can also +/// provide dynamic search (currently linear, can be improved to +/// log(n) due to the sorted array property). + +// TODO: Find a better place for this if this is retained. +// This is currently here because this was designed to provide +// maps over runtime description without the burden of having to +// instantiate these maps dynamically and to keep them somewhere. +template +class StaticMultimapView { +public: + using Key = typename V::Key; + struct Range { + using const_iterator = const V *; + constexpr const_iterator begin() const { return startPtr; } + constexpr const_iterator end() const { return endPtr; } + constexpr bool empty() const { + return startPtr == nullptr || endPtr == nullptr || endPtr <= startPtr; + } + constexpr std::size_t size() const { + return empty() ? 0 : static_cast(endPtr - startPtr); + } + const V *startPtr{nullptr}; + const V *endPtr{nullptr}; + }; + using const_iterator = typename Range::const_iterator; + + template + constexpr StaticMultimapView(const V (&array)[N]) + : range{&array[0], &array[0] + N} {} + template + constexpr bool verify() { + // TODO: sorted + // non empty increasing pointer direction + return !range.empty(); + } + constexpr const_iterator begin() const { return range.begin(); } + constexpr const_iterator end() const { return range.end(); } + + // Assume array is sorted. + // TODO make it a log(n) search based on sorted property + // std::equal_range will be constexpr in C++20 only. + constexpr Range getRange(const Key &key) const { + bool matched{false}; + const V *start{nullptr}, *end{nullptr}; + for (const auto &desc : range) { + if (desc.key == key) { + if (!matched) { + start = &desc; + matched = true; + } + } else if (matched) { + end = &desc; + matched = false; + } + } + if (matched) { + end = range.end(); + } + return Range{start, end}; + } + + constexpr std::pair + equal_range(const Key &key) const { + Range range{getRange(key)}; + return {range.begin(), range.end()}; + } + + constexpr typename Range::const_iterator find(Key key) const { + const Range subRange{getRange(key)}; + return subRange.size() == 1 ? subRange.begin() : end(); + } + +private: + Range range{nullptr, nullptr}; +}; +} // namespace + +// TODO error handling -> return a code or directly emit messages ? +struct IntrinsicLibrary { + + // Constructors. + explicit IntrinsicLibrary(Fortran::lower::FirOpBuilder &builder, + mlir::Location loc) + : builder{builder}, loc{loc} {} + 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, + mlir::Type 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); + mlir::Value genAimag(mlir::Type, llvm::ArrayRef); + mlir::Value genAint(mlir::Type, llvm::ArrayRef); + mlir::Value genAnint(mlir::Type, llvm::ArrayRef); + mlir::Value genCeiling(mlir::Type, llvm::ArrayRef); + mlir::Value genConjg(mlir::Type, llvm::ArrayRef); + mlir::Value genDim(mlir::Type, llvm::ArrayRef); + mlir::Value genDprod(mlir::Type, llvm::ArrayRef); + template + mlir::Value genExtremum(mlir::Type, llvm::ArrayRef); + mlir::Value genFloor(mlir::Type, llvm::ArrayRef); + mlir::Value genIAnd(mlir::Type, llvm::ArrayRef); + mlir::Value genIchar(mlir::Type, llvm::ArrayRef); + mlir::Value genIEOr(mlir::Type, llvm::ArrayRef); + mlir::Value genIOr(mlir::Type, llvm::ArrayRef); + fir::ExtendedValue genLen(mlir::Type, llvm::ArrayRef); + fir::ExtendedValue genLenTrim(mlir::Type, llvm::ArrayRef); + mlir::Value genMerge(mlir::Type, llvm::ArrayRef); + mlir::Value genMod(mlir::Type, llvm::ArrayRef); + mlir::Value genNint(mlir::Type, llvm::ArrayRef); + mlir::Value genSign(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 Generator = std::variant; + + /// All generators can be outlined. This will build a function named + /// "fir."+ + "." + and generate the + /// intrinsic implementation inside instead of at the intrinsic call sites. + /// This can be used to keep the FIR more readable. Only one function will + /// be generated for all the similar calls in a program. + /// If the Generator is nullptr, the wrapper uses genRuntimeCall. + template + mlir::Value outlineInWrapper(GeneratorType, llvm::StringRef name, + mlir::Type resultType, + llvm::ArrayRef args); + fir::ExtendedValue outlineInWrapper(ExtendedGenerator, llvm::StringRef name, + mlir::Type 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 + 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); + + /// Get pointer to unrestricted intrinsic. Generate the related unrestricted + /// intrinsic if it is not defined yet. + mlir::SymbolRefAttr + getUnrestrictedIntrinsicSymbolRefAttr(llvm::StringRef name, + mlir::FunctionType signature); + + Fortran::lower::FirOpBuilder &builder; + mlir::Location loc; +}; + +/// 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. +struct IntrinsicHandler { + const char *name; + IntrinsicLibrary::Generator generator; + bool isElemental = true; + /// Code heavy intrinsic can be outlined to make FIR + /// more readable. + bool outline = false; +}; +using I = IntrinsicLibrary; +static constexpr IntrinsicHandler handlers[]{ + {"abs", &I::genAbs}, + {"achar", &I::genConversion}, + {"aimag", &I::genAimag}, + {"aint", &I::genAint}, + {"anint", &I::genAnint}, + {"ceiling", &I::genCeiling}, + {"char", &I::genConversion}, + {"conjg", &I::genConjg}, + {"dim", &I::genDim}, + {"dble", &I::genConversion}, + {"dprod", &I::genDprod}, + {"floor", &I::genFloor}, + {"iand", &I::genIAnd}, + {"ichar", &I::genIchar}, + {"ieor", &I::genIEOr}, + {"ior", &I::genIOr}, + {"len", &I::genLen}, + {"len_trim", &I::genLenTrim}, + {"max", &I::genExtremum}, + {"min", &I::genExtremum}, + {"merge", &I::genMerge}, + {"mod", &I::genMod}, + {"nint", &I::genNint}, + {"sign", &I::genSign}, +}; + +/// 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 { + using Key = llvm::StringRef; + Key key; + llvm::StringRef symbol; + Fortran::lower::FuncTypeBuilderFunc typeGenerator; +}; + +#define RUNTIME_STATIC_DESCRIPTION(name, func) \ + {#name, #func, \ + Fortran::lower::RuntimeTableKey::getTypeModel()}, +static constexpr RuntimeFunction pgmathFast[] = { +#define PGMATH_FAST +#define PGMATH_USE_ALL_TYPES(name, func) RUNTIME_STATIC_DESCRIPTION(name, func) +#include "../runtime/pgmath.h.inc" +}; +static constexpr RuntimeFunction pgmathRelaxed[] = { +#define PGMATH_RELAXED +#define PGMATH_USE_ALL_TYPES(name, func) RUNTIME_STATIC_DESCRIPTION(name, func) +#include "../runtime/pgmath.h.inc" +}; +static constexpr RuntimeFunction pgmathPrecise[] = { +#define PGMATH_PRECISE +#define PGMATH_USE_ALL_TYPES(name, func) RUNTIME_STATIC_DESCRIPTION(name, func) +#include "../runtime/pgmath.h.inc" +}; + +static mlir::FunctionType genF32F32FuncType(mlir::MLIRContext *context) { + auto t = mlir::FloatType::getF32(context); + return mlir::FunctionType::get({t}, {t}, context); +} + +static mlir::FunctionType genF64F64FuncType(mlir::MLIRContext *context) { + auto t = mlir::FloatType::getF64(context); + return mlir::FunctionType::get({t}, {t}, context); +} + +template +static mlir::FunctionType genIntF64FuncType(mlir::MLIRContext *context) { + auto t = mlir::FloatType::getF64(context); + auto r = mlir::IntegerType::get(Bits, context); + return mlir::FunctionType::get({t}, {r}, context); +} + +template +static mlir::FunctionType genIntF32FuncType(mlir::MLIRContext *context) { + auto t = mlir::FloatType::getF32(context); + auto r = mlir::IntegerType::get(Bits, context); + return mlir::FunctionType::get({t}, {r}, context); +} + +// 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}, + // 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}, + // 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>}, + {"sin", "llvm.sin.f32", genF32F32FuncType}, + {"sin", "llvm.sin.f64", 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) { + auto nInputs = from.getNumInputs(); + auto 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, + Fortran::lower::FirOpBuilder &builder, + const RuntimeFunction &runtime) { + auto 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. +template +mlir::FuncOp searchFunctionInLibrary(mlir::Location loc, + Fortran::lower::FirOpBuilder &builder, + const RuntimeFunction (&lib)[N], + llvm::StringRef name, + mlir::FunctionType funcType, + const RuntimeFunction **bestNearMatch, + FunctionDistance &bestMatchDistance) { + auto map = StaticMultimapView(lib); + auto range = map.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, + Fortran::lower::FirOpBuilder &builder, + llvm::StringRef name, + mlir::FunctionType funcType) { + const RuntimeFunction *bestNearMatch = nullptr; + FunctionDistance bestMatchDistance{}; + mlir::FuncOp match; + if (mathRuntimeVersion == fastVersion) { + match = searchFunctionInLibrary(loc, builder, pgmathFast, name, funcType, + &bestNearMatch, bestMatchDistance); + } else if (mathRuntimeVersion == relaxedVersion) { + match = searchFunctionInLibrary(loc, builder, pgmathRelaxed, name, funcType, + &bestNearMatch, bestMatchDistance); + } else if (mathRuntimeVersion == preciseVersion) { + match = searchFunctionInLibrary(loc, builder, pgmathPrecise, 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 + if (auto exactMatch = + searchFunctionInLibrary(loc, builder, llvmIntrinsics, name, funcType, + &bestNearMatch, bestMatchDistance)) + return exactMatch; + + if (bestNearMatch != nullptr) { + assert(!bestMatchDistance.isLosingPrecision() && + "runtime selection loses precision"); + return getFuncOp(loc, builder, *bestNearMatch); + } + return {}; +} + +/// Helpers to get function type from arguments and result type. +static mlir::FunctionType +getFunctionType(mlir::Type resultType, llvm::ArrayRef arguments, + Fortran::lower::FirOpBuilder &builder) { + llvm::SmallVector argumentTypes; + for (auto &arg : arguments) + argumentTypes.push_back(arg.getType()); + return mlir::FunctionType::get(argumentTypes, resultType, + builder.getModule().getContext()); +} + +/// fir::ExtendedValue to mlir::Value translation layer + +fir::ExtendedValue toExtendedValue(mlir::Value val, + Fortran::lower::FirOpBuilder &builder, + mlir::Location loc) { + assert(val && "optional unhandled here"); + auto type = val.getType(); + auto base = val; + auto indexType = builder.getIndexType(); + llvm::SmallVector extents; + + Fortran::lower::CharacterExprHelper charHelper{builder, loc}; + if (charHelper.isCharacter(type)) + return charHelper.toExtendedValue(val); + + if (auto refType = type.dyn_cast()) + type = refType.getEleTy(); + + if (auto arrayType = type.dyn_cast()) { + type = arrayType.getEleTy(); + for (auto 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()) { + mlir::emitError(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, + Fortran::lower::FirOpBuilder &builder, mlir::Location loc) { + if (auto charBox = val.getCharBox()) { + auto buffer = charBox->getBuffer(); + if (buffer.getType().isa()) + return buffer; + return Fortran::lower::CharacterExprHelper{builder, loc}.createEmboxChar( + buffer, charBox->getLen()); + } + + // FIXME: need to access other ExtendedValue variants and handle them + // properly. + return fir::getBase(val); +} + +//===----------------------------------------------------------------------===// +// IntrinsicLibrary +//===----------------------------------------------------------------------===// + +template +fir::ExtendedValue IntrinsicLibrary::genElementalCall( + GeneratorType generator, llvm::StringRef name, mlir::Type resultType, + llvm::ArrayRef args, bool outline) { + llvm::SmallVector scalarArgs; + for (const auto &arg : args) { + if (arg.getUnboxed() || arg.getCharBox()) { + scalarArgs.emplace_back(fir::getBase(arg)); + } else { + // TODO: get the result shape and create the loop... + mlir::emitError(loc, "array or descriptor not yet handled in elemental " + "intrinsic lowering"); + exit(1); + } + } + if (outline) + return outlineInWrapper(generator, name, resultType, scalarArgs); + return invokeGenerator(generator, resultType, scalarArgs); +} + +/// Some ExtendedGenerator operating on characters are also elemental +/// (e.g LEN_TRIM). +template <> +fir::ExtendedValue +IntrinsicLibrary::genElementalCall( + ExtendedGenerator generator, llvm::StringRef name, mlir::Type resultType, + llvm::ArrayRef args, bool outline) { + for (const auto &arg : args) + if (!arg.getUnboxed() && !arg.getCharBox()) { + // TODO: get the result shape and create the loop... + mlir::emitError(loc, "array or descriptor not yet handled in elemental " + "intrinsic lowering"); + exit(1); + } + if (outline) + return outlineInWrapper(generator, name, resultType, args); + return std::invoke(generator, *this, resultType, args); +} + +fir::ExtendedValue +IntrinsicLibrary::genIntrinsicCall(llvm::StringRef name, mlir::Type resultType, + llvm::ArrayRef args) { + for (auto &handler : handlers) + if (name == handler.name) { + bool outline = handler.outline || outlineAllIntrinsics; + if (const auto *elementalGenerator = + std::get_if(&handler.generator)) + return genElementalCall(*elementalGenerator, name, resultType, args, + outline); + const auto &generator = std::get(handler.generator); + if (handler.isElemental) + return genElementalCall(generator, name, resultType, args, outline); + if (outline) + return outlineInWrapper(generator, name, resultType, args); + return std::invoke(generator, *this, resultType, args); + } + + // 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 auto &extendedVal : args) { + auto val = toValue(extendedVal, builder, loc); + if (!val) { + // If an absent optional gets there, most likely its handler has just + // not yet been defined. + mlir::emitError(loc, + "TODO: missing intrinsic lowering: " + llvm::Twine(name)); + exit(1); + } + mlirArgs.emplace_back(val); + } + mlir::FunctionType soughtFuncType = + getFunctionType(resultType, mlirArgs, builder); + + auto runtimeCallGenerator = getRuntimeCallGenerator(name, soughtFuncType); + return genElementalCall(runtimeCallGenerator, name, resultType, args, + /* outline */ true); +} + +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 (auto 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) { + assert(funcType.getNumResults() == 1 && + "expect one result for intrinsic functions"); + auto resultType = funcType.getResult(0); + std::string wrapperName = fir::mangleIntrinsicProcedure(name, funcType); + auto 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()); + 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. + auto 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}; + 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 auto &arg : args) + if (!arg) + return true; + return false; +} +bool static hasAbsentOptional(llvm::ArrayRef args) { + for (const auto &arg : args) + if (!fir::getBase(arg)) + return true; + return false; +} + +template +mlir::Value +IntrinsicLibrary::outlineInWrapper(GeneratorType generator, + llvm::StringRef name, mlir::Type resultType, + llvm::ArrayRef args) { + if (hasAbsentOptional(args)) { + // TODO: absent optional in outlining is an issue: we cannot just ignore + // them. Needs a better interface here. The issue is that we cannot easily + // tell that a value is optional or not here if it is presents. And if it is + // absent, we cannot tell what it type should be. + mlir::emitError(loc, "todo: cannot outline call to intrinsic " + + llvm::Twine(name) + + " with absent optional argument"); + exit(1); + } + + auto funcType = getFunctionType(resultType, args, builder); + auto wrapper = getWrapper(generator, name, funcType); + return builder.create(loc, wrapper, args).getResult(0); +} + +fir::ExtendedValue +IntrinsicLibrary::outlineInWrapper(ExtendedGenerator generator, + llvm::StringRef name, mlir::Type resultType, + llvm::ArrayRef args) { + if (hasAbsentOptional(args)) { + // TODO + mlir::emitError(loc, "todo: cannot outline call to intrinsic " + + llvm::Twine(name) + + " with absent optional argument"); + exit(1); + } + llvm::SmallVector mlirArgs; + for (const auto &extendedVal : args) + mlirArgs.emplace_back(toValue(extendedVal, builder, loc)); + auto funcType = getFunctionType(resultType, mlirArgs, builder); + auto wrapper = getWrapper(generator, name, funcType); + auto mlirResult = + builder.create(loc, wrapper, mlirArgs).getResult(0); + return toExtendedValue(mlirResult, builder, loc); +} + +IntrinsicLibrary::RuntimeCallGenerator +IntrinsicLibrary::getRuntimeCallGenerator(llvm::StringRef name, + mlir::FunctionType soughtFuncType) { + auto 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]( + Fortran::lower::FirOpBuilder &builder, mlir::Location loc, + llvm::ArrayRef args) { + llvm::SmallVector convertedArguments; + for (const auto &pair : llvm::zip(actualFuncType.getInputs(), args)) + convertedArguments.push_back( + builder.createConvert(loc, std::get<0>(pair), std::get<1>(pair))); + auto call = builder.create(loc, funcOp, convertedArguments); + mlir::Type soughtType = soughtFuncType.getResult(0); + return builder.createConvert(loc, soughtType, call.getResult(0)); + }; +} + +mlir::SymbolRefAttr IntrinsicLibrary::getUnrestrictedIntrinsicSymbolRefAttr( + llvm::StringRef name, mlir::FunctionType signature) { + // Unrestricted intrinsics signature follows implicit rules: argument + // are passed by references. But the runtime versions expect values. + // So instead of duplicating the runtime, just have the wrappers loading + // this before calling the code generators. + bool loadRefArguments = true; + mlir::FuncOp funcOp; + for (auto &handler : handlers) + if (name == handler.name) + funcOp = std::visit( + [&](auto generator) { + return getWrapper(generator, name, signature, loadRefArguments); + }, + handler.generator); + + if (!funcOp) { + llvm::SmallVector argTypes; + for (auto type : signature.getInputs()) { + if (auto refType = type.dyn_cast()) + argTypes.push_back(refType.getEleTy()); + else + argTypes.push_back(type); + } + auto soughtFuncType = + builder.getFunctionType(signature.getResults(), argTypes); + auto rtCallGenerator = getRuntimeCallGenerator(name, soughtFuncType); + funcOp = getWrapper(rtCallGenerator, name, signature, loadRefArguments); + } + + return builder.getSymbolRefAttr(funcOp.getName()); +} + +//===----------------------------------------------------------------------===// +// 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]); +} + +// ABS +mlir::Value IntrinsicLibrary::genAbs(mlir::Type resultType, + llvm::ArrayRef args) { + assert(args.size() == 1); + auto arg = args[0]; + auto type = arg.getType(); + if (fir::isa_real(type)) { + // Runtime call to fp abs. An alternative would be to use mlir AbsFOp + // but it does not support all fir floating point types. + return genRuntimeCall("abs", resultType, args); + } + if (auto intType = type.dyn_cast()) { + // At the time of this implementation there is no abs op in mlir. + // So, implement abs here without branching. + auto shift = + builder.createIntegerConstant(loc, intType, intType.getWidth() - 1); + auto mask = builder.create(loc, arg, shift); + auto xored = builder.create(loc, arg, mask); + return builder.create(loc, xored, mask); + } + if (fir::isa_complex(type)) { + // Use HYPOT to fulfill the no underflow/overflow requirement. + auto parts = + Fortran::lower::ComplexExprHelper{builder, loc}.extractParts(arg); + llvm::SmallVector args = {parts.first, parts.second}; + return genRuntimeCall("hypot", resultType, args); + } + llvm_unreachable("unexpected type in ABS argument"); +} + +// AIMAG +mlir::Value IntrinsicLibrary::genAimag(mlir::Type resultType, + llvm::ArrayRef args) { + assert(args.size() == 1); + return Fortran::lower::ComplexExprHelper{builder, loc}.extractComplexPart( + args[0], true /* isImagPart */); +} + +// ANINT +mlir::Value IntrinsicLibrary::genAnint(mlir::Type resultType, + llvm::ArrayRef args) { + assert(args.size() >= 1); + // Skip optional kind argument to search the runtime; it is already reflected + // in result type. + return genRuntimeCall("anint", resultType, {args[0]}); +} + +// AINT +mlir::Value IntrinsicLibrary::genAint(mlir::Type resultType, + llvm::ArrayRef args) { + assert(args.size() >= 1); + // Skip optional kind argument to search the runtime; it is already reflected + // in result type. + return genRuntimeCall("aint", resultType, {args[0]}); +} + +// CEILING +mlir::Value IntrinsicLibrary::genCeiling(mlir::Type resultType, + llvm::ArrayRef args) { + // Optional KIND argument. + assert(args.size() >= 1); + auto arg = args[0]; + // Use ceil that is not an actual Fortran intrinsic but that is + // an llvm intrinsic that does the same, but return a floating + // point. + auto ceil = genRuntimeCall("ceil", arg.getType(), {arg}); + return builder.createConvert(loc, resultType, ceil); +} + +// CONJG +mlir::Value IntrinsicLibrary::genConjg(mlir::Type resultType, + llvm::ArrayRef args) { + assert(args.size() == 1); + if (resultType != args[0].getType()) + llvm_unreachable("argument type mismatch"); + + mlir::Value cplx = args[0]; + auto imag = + Fortran::lower::ComplexExprHelper{builder, loc}.extractComplexPart( + cplx, /*isImagPart=*/true); + auto negImag = builder.create(loc, imag); + return Fortran::lower::ComplexExprHelper{builder, loc}.insertComplexPart( + cplx, negImag, /*isImagPart=*/true); +} + +// DIM +mlir::Value IntrinsicLibrary::genDim(mlir::Type resultType, + llvm::ArrayRef args) { + assert(args.size() == 2); + if (resultType.isa()) { + auto zero = builder.createIntegerConstant(loc, resultType, 0); + auto diff = builder.create(loc, args[0], args[1]); + auto cmp = + builder.create(loc, mlir::CmpIPredicate::sgt, diff, zero); + return builder.create(loc, cmp, diff, zero); + } + assert(fir::isa_real(resultType) && "Only expects real and integer in DIM"); + auto zero = builder.createRealZeroConstant(loc, resultType); + auto diff = builder.create(loc, args[0], args[1]); + auto cmp = + builder.create(loc, mlir::CmpFPredicate::OGT, diff, zero); + return builder.create(loc, cmp, diff, zero); +} + +// DPROD +mlir::Value IntrinsicLibrary::genDprod(mlir::Type resultType, + llvm::ArrayRef args) { + assert(args.size() == 2); + assert(fir::isa_real(resultType) && + "Result must be double precision in DPROD"); + auto a = builder.createConvert(loc, resultType, args[0]); + auto b = builder.createConvert(loc, resultType, args[1]); + return builder.create(loc, a, b); +} + +// FLOOR +mlir::Value IntrinsicLibrary::genFloor(mlir::Type resultType, + llvm::ArrayRef args) { + // Optional KIND argument. + assert(args.size() >= 1); + auto arg = args[0]; + // Use LLVM floor that returns real. + auto floor = genRuntimeCall("floor", arg.getType(), {arg}); + return builder.createConvert(loc, resultType, floor); +} + +// IAND +mlir::Value IntrinsicLibrary::genIAnd(mlir::Type resultType, + llvm::ArrayRef args) { + assert(args.size() == 2); + + return builder.create(loc, args[0], args[1]); +} + +// ICHAR +mlir::Value IntrinsicLibrary::genIchar(mlir::Type resultType, + llvm::ArrayRef args) { + // There can be an optional kind in second argument. + assert(args.size() >= 1); + + auto arg = args[0]; + Fortran::lower::CharacterExprHelper helper{builder, loc}; + auto dataAndLen = helper.createUnboxChar(arg); + auto charType = fir::CharacterType::get( + builder.getContext(), helper.getCharacterKind(arg.getType())); + auto refType = builder.getRefType(charType); + auto charAddr = builder.createConvert(loc, refType, dataAndLen.first); + auto charVal = builder.create(loc, charType, charAddr); + return builder.createConvert(loc, resultType, charVal); +} + +// IEOR +mlir::Value IntrinsicLibrary::genIEOr(mlir::Type resultType, + llvm::ArrayRef args) { + assert(args.size() == 2); + return builder.create(loc, args[0], args[1]); +} + +// IOR +mlir::Value IntrinsicLibrary::genIOr(mlir::Type resultType, + llvm::ArrayRef args) { + assert(args.size() == 2); + return builder.create(loc, args[0], args[1]); +} + +// LEN +// Note that this is only used for unrestricted intrinsic. +// Usage of LEN are otherwise rewritten as descriptor inquiries by the +// front-end. +fir::ExtendedValue +IntrinsicLibrary::genLen(mlir::Type resultType, + llvm::ArrayRef args) { + // Optional KIND argument reflected in result type. + assert(args.size() >= 1); + mlir::Value len; + if (const auto *charBox = args[0].getCharBox()) { + len = charBox->getLen(); + } else if (const auto *charBoxArray = args[0].getCharBox()) { + len = charBoxArray->getLen(); + } else { + Fortran::lower::CharacterExprHelper helper{builder, loc}; + len = helper.createUnboxChar(fir::getBase(args[0])).second; + } + + return builder.createConvert(loc, resultType, len); +} + +// LEN_TRIM +fir::ExtendedValue +IntrinsicLibrary::genLenTrim(mlir::Type resultType, + llvm::ArrayRef args) { + // Optional KIND argument reflected in result type. + assert(args.size() >= 1); + Fortran::lower::CharacterExprHelper helper{builder, loc}; + auto len = helper.createLenTrim(fir::getBase(args[0])); + return builder.createConvert(loc, resultType, len); +} + +// MERGE +mlir::Value IntrinsicLibrary::genMerge(mlir::Type, + llvm::ArrayRef args) { + assert(args.size() == 3); + + auto i1Type = mlir::IntegerType::get(1, builder.getContext()); + auto mask = builder.createConvert(loc, i1Type, args[2]); + return builder.create(loc, mask, args[0], args[1]); +} + +// MOD +mlir::Value IntrinsicLibrary::genMod(mlir::Type resultType, + llvm::ArrayRef args) { + assert(args.size() == 2); + if (resultType.isa()) + return builder.create(loc, args[0], args[1]); + + // Use runtime. Note that mlir::RemFOp implements floating point + // remainder, but it does not work with fir::Real type. + // TODO: consider using mlir::RemFOp when possible, that may help folding + // and optimizations. + return genRuntimeCall("mod", resultType, args); +} + +// NINT +mlir::Value IntrinsicLibrary::genNint(mlir::Type resultType, + llvm::ArrayRef args) { + assert(args.size() >= 1); + // Skip optional kind argument to search the runtime; it is already reflected + // in result type. + return genRuntimeCall("nint", resultType, {args[0]}); +} + +// SIGN +mlir::Value IntrinsicLibrary::genSign(mlir::Type resultType, + llvm::ArrayRef args) { + assert(args.size() == 2); + auto abs = genAbs(resultType, {args[0]}); + if (resultType.isa()) { + auto zero = builder.createIntegerConstant(loc, resultType, 0); + auto neg = builder.create(loc, zero, abs); + auto cmp = builder.create(loc, mlir::CmpIPredicate::slt, + args[1], zero); + return builder.create(loc, cmp, neg, abs); + } + // TODO: Requirements when second argument is +0./0. + auto zeroAttr = builder.getZeroAttr(resultType); + auto zero = builder.create(loc, resultType, zeroAttr); + auto neg = builder.create(loc, abs); + auto cmp = + builder.create(loc, mlir::CmpFPredicate::OLT, args[1], zero); + return builder.create(loc, cmp, neg, abs); +} + +// Compare two FIR values and return boolean result as i1. +template +static mlir::Value createExtremumCompare(mlir::Location loc, + Fortran::lower::FirOpBuilder &builder, + mlir::Value left, mlir::Value right) { + static constexpr auto integerPredicate = extremum == Extremum::Max + ? mlir::CmpIPredicate::sgt + : mlir::CmpIPredicate::slt; + static constexpr auto orderedCmp = extremum == Extremum::Max + ? mlir::CmpFPredicate::OGT + : mlir::CmpFPredicate::OLT; + auto type = left.getType(); + mlir::Value result; + if (fir::isa_real(type)) { + // Note: the signaling/quit aspect of the result required by IEEE + // cannot currently be obtained with LLVM without ad-hoc runtime. + if constexpr (behavior == ExtremumBehavior::IeeeMinMaximumNumber) { + // Return the number if one of the inputs is NaN and the other is + // a number. + auto leftIsResult = + builder.create(loc, orderedCmp, left, right); + auto rightIsNan = builder.create( + loc, mlir::CmpFPredicate::UNE, right, right); + result = builder.create(loc, leftIsResult, rightIsNan); + } else if constexpr (behavior == ExtremumBehavior::IeeeMinMaximum) { + // Always return NaNs if one the input is NaNs + auto leftIsResult = + builder.create(loc, orderedCmp, left, right); + auto leftIsNan = builder.create( + loc, mlir::CmpFPredicate::UNE, left, left); + result = builder.create(loc, leftIsResult, leftIsNan); + } else if constexpr (behavior == ExtremumBehavior::MinMaxss) { + // If the left is a NaN, return the right whatever it is. + result = builder.create(loc, orderedCmp, left, right); + } else if constexpr (behavior == ExtremumBehavior::PgfortranLlvm) { + // If one of the operand is a NaN, return left whatever it is. + static constexpr auto unorderedCmp = extremum == Extremum::Max + ? mlir::CmpFPredicate::UGT + : mlir::CmpFPredicate::ULT; + result = builder.create(loc, unorderedCmp, left, right); + } else { + // TODO: ieeeMinNum/ieeeMaxNum + static_assert(behavior == ExtremumBehavior::IeeeMinMaxNum, + "ieeeMinNum/ieeeMaxNum behavior not implemented"); + } + } else if (fir::isa_integer(type)) { + result = builder.create(loc, integerPredicate, left, right); + } else if (type.isa()) { + // TODO: ! character min and max is tricky because the result + // length is the length of the longest argument! + // So we may need a temp. + } + assert(result); + return result; +} + +// MIN and MAX +template +mlir::Value IntrinsicLibrary::genExtremum(mlir::Type, + llvm::ArrayRef args) { + assert(args.size() >= 1); + mlir::Value result = args[0]; + for (auto arg : args.drop_front()) { + auto mask = + createExtremumCompare(loc, builder, result, arg); + result = builder.create(loc, mask, result, arg); + } + return result; +} + +//===----------------------------------------------------------------------===// +// Public intrinsic call helpers +//===----------------------------------------------------------------------===// + +fir::ExtendedValue +Fortran::lower::genIntrinsicCall(Fortran::lower::FirOpBuilder &builder, + mlir::Location loc, llvm::StringRef name, + mlir::Type resultType, + llvm::ArrayRef args) { + return IntrinsicLibrary{builder, loc}.genIntrinsicCall(name, resultType, + args); +} + +mlir::Value Fortran::lower::genMax(Fortran::lower::FirOpBuilder &builder, + mlir::Location loc, + llvm::ArrayRef args) { + assert(args.size() > 0 && "max requires at least one argument"); + return IntrinsicLibrary{builder, loc} + .genExtremum(args[0].getType(), + args); +} + +mlir::Value Fortran::lower::genMin(Fortran::lower::FirOpBuilder &builder, + mlir::Location loc, + llvm::ArrayRef args) { + assert(args.size() > 0 && "min requires at least one argument"); + return IntrinsicLibrary{builder, loc} + .genExtremum(args[0].getType(), + args); +} + +mlir::Value Fortran::lower::genPow(Fortran::lower::FirOpBuilder &builder, + mlir::Location loc, mlir::Type type, + mlir::Value x, mlir::Value y) { + return IntrinsicLibrary{builder, loc}.genRuntimeCall("pow", type, {x, y}); +} + +mlir::SymbolRefAttr Fortran::lower::getUnrestrictedIntrinsicSymbolRefAttr( + Fortran::lower::FirOpBuilder &builder, mlir::Location loc, + llvm::StringRef name, mlir::FunctionType signature) { + return IntrinsicLibrary{builder, loc}.getUnrestrictedIntrinsicSymbolRefAttr( + name, signature); +} diff --git a/flang/lib/Lower/Mangler.cpp b/flang/lib/Lower/Mangler.cpp --- a/flang/lib/Lower/Mangler.cpp +++ b/flang/lib/Lower/Mangler.cpp @@ -9,11 +9,13 @@ #include "flang/Lower/Mangler.h" #include "flang/Common/reference.h" #include "flang/Lower/Utils.h" +#include "flang/Optimizer/Dialect/FIRType.h" #include "flang/Optimizer/Support/InternalNames.h" #include "flang/Semantics/tools.h" #include "llvm/ADT/ArrayRef.h" #include "llvm/ADT/Optional.h" #include "llvm/ADT/SmallVector.h" +#include "llvm/ADT/StringRef.h" #include "llvm/ADT/Twine.h" // recursively build the vector of module scopes @@ -118,3 +120,49 @@ auto result = fir::NameUniquer::deconstruct(name); return result.second.name; } + +//===----------------------------------------------------------------------===// +// Intrinsic Procedure Mangling +//===----------------------------------------------------------------------===// + +/// Helper to encode type into string for intrinsic procedure names. +/// Note: mlir has Type::dump(ostream) methods but it may add "!" that is not +/// suitable for function names. +static std::string typeToString(mlir::Type t) { + if (auto refT{t.dyn_cast()}) + return "ref_" + typeToString(refT.getEleTy()); + if (auto i{t.dyn_cast()}) { + return "i" + std::to_string(i.getWidth()); + } + if (auto cplx{t.dyn_cast()}) { + return "z" + std::to_string(cplx.getFKind()); + } + if (auto real{t.dyn_cast()}) { + return "r" + std::to_string(real.getFKind()); + } + if (auto f{t.dyn_cast()}) { + return "f" + std::to_string(f.getWidth()); + } + if (auto logical{t.dyn_cast()}) { + return "l" + std::to_string(logical.getFKind()); + } + if (auto character{t.dyn_cast()}) { + return "c" + std::to_string(character.getFKind()); + } + if (auto boxCharacter{t.dyn_cast()}) { + return "bc" + std::to_string(boxCharacter.getEleTy().getFKind()); + } + llvm_unreachable("no mangling for type"); +} + +std::string fir::mangleIntrinsicProcedure(llvm::StringRef intrinsic, + mlir::FunctionType funTy) { + std::string name = "fir."; + name.append(intrinsic.str()).append("."); + assert(funTy.getNumResults() == 1 && "only function mangling supported"); + name.append(typeToString(funTy.getResult(0))); + auto e = funTy.getNumInputs(); + for (decltype(e) i = 0; i < e; ++i) + name.append(".").append(typeToString(funTy.getInput(i))); + return name; +} 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 @@ -178,8 +178,10 @@ return SequenceType::get(shape, eleTy, map); } -static bool verifyIntegerType(mlir::Type ty) { - return ty.isa() || ty.isa(); +/// Is `ty` a standard or FIR integer type? +static bool isaIntegerType(mlir::Type ty) { + // TODO: why aren't we using isa_integer? investigatation required. + return ty.isa() || ty.isa(); } bool verifyRecordMemberType(mlir::Type ty) { @@ -205,7 +207,7 @@ return {}; } for (auto &p : lenPList) - if (!verifyIntegerType(p.second)) { + if (!isaIntegerType(p.second)) { parser.emitError(loc, "LEN parameter must be integral type"); return {}; } @@ -384,24 +386,22 @@ static unsigned hashKey(const KeyTy &key) { return llvm::hash_combine(key); } - bool operator==(const KeyTy &key) const { - return key == static_cast(getRank()); - } + bool operator==(const KeyTy &key) const { return key == getRank(); } static DimsTypeStorage *construct(mlir::TypeStorageAllocator &allocator, - int rank) { + unsigned rank) { auto *storage = allocator.allocate(); return new (storage) DimsTypeStorage{rank}; } - int getRank() const { return rank; } + unsigned getRank() const { return rank; } protected: - int rank; + unsigned rank; private: DimsTypeStorage() = delete; - explicit DimsTypeStorage(int rank) : rank{rank} {} + explicit DimsTypeStorage(unsigned rank) : rank{rank} {} }; /// The type of a derived type part reference @@ -832,6 +832,9 @@ } bool isa_fir_or_std_type(mlir::Type t) { + if (auto funcType = t.dyn_cast()) + return llvm::all_of(funcType.getInputs(), isa_fir_or_std_type) && + llvm::all_of(funcType.getResults(), isa_fir_or_std_type); return isa_fir_type(t) || isa_std_type(t); } @@ -874,7 +877,7 @@ return Base::get(ctxt, FIR_DIMS, rank); } -int fir::DimsType::getRank() const { return getImpl()->getRank(); } +unsigned fir::DimsType::getRank() const { return getImpl()->getRank(); } // Field @@ -999,10 +1002,7 @@ // Pointer PointerType fir::PointerType::get(mlir::Type elementType) { - if (!singleIndirectionLevel(elementType)) { - llvm_unreachable("FIXME: invalid element type"); - return {}; - } + assert(singleIndirectionLevel(elementType) && "invalid element type"); return Base::get(elementType.getContext(), FIR_POINTER, elementType); } @@ -1030,10 +1030,7 @@ // Heap HeapType fir::HeapType::get(mlir::Type elementType) { - if (!singleIndirectionLevel(elementType)) { - llvm_unreachable("FIXME: invalid element type"); - return {}; - } + assert(singleIndirectionLevel(elementType) && "invalid element type"); return Base::get(elementType.getContext(), FIR_HEAP, elementType); } @@ -1171,7 +1168,6 @@ for (auto f : getTypeList()) if (ident == f.first) return f.second; - llvm_unreachable("query for field not present in record"); return {}; } @@ -1216,9 +1212,9 @@ } // namespace void fir::verifyIntegralType(mlir::Type type) { - if (verifyIntegerType(type) || type.isa()) + if (isaIntegerType(type) || type.isa()) return; - llvm_unreachable("expected integral type"); + llvm::report_fatal_error("expected integral type"); } void fir::printFirType(FIROpsDialect *, mlir::Type ty,