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 @@ -111,8 +112,12 @@ 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; @@ -42,6 +43,18 @@ AbstractConverter &converter, const SomeExpr &expr, SymMap &symMap); +/// 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); /// Create an extended expression address. fir::ExtendedValue createSomeExtendedAddress(mlir::Location loc, 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 @@ -66,11 +66,7 @@ /// 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 @@ -19,7 +19,10 @@ #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; +} namespace Fortran::lower { using SomeExpr = Fortran::evaluate::Expr; 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 @@ -102,17 +102,24 @@ mlir::Type genType(Fortran::lower::SymbolRef sym) override final { return Fortran::lower::translateSymbolToFIRType(*this, sym); } + mlir::Type genType(const Fortran::lower::pft::Variable &var) override final { + return Fortran::lower::translateVariableToFIRType(*this, var); + } + 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 @@ -15,6 +15,8 @@ #include "flang/Evaluate/real.h" #include "flang/Evaluate/traverse.h" #include "flang/Lower/AbstractConverter.h" +#include "flang/Lower/IntrinsicCall.h" +#include "flang/Lower/StatementContext.h" #include "flang/Lower/SymbolMap.h" #include "flang/Lower/Todo.h" #include "flang/Semantics/expression.h" @@ -90,6 +92,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 @@ -99,9 +112,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; } @@ -426,20 +440,98 @@ 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) { - TODO(getLoc(), "gen FunctionRef"); + ExtValue retVal = genFunctionRef(funcRef); + mlir::Value retValBase = fir::getBase(retVal); + if (fir::conformsWithPassByRef(retValBase.getType())) + return retVal; + auto mem = builder.create(getLoc(), retValBase.getType()); + builder.create(getLoc(), retValBase, mem); + return fir::substBase(retVal, mem.getResult()); } 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"); } + /// 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(); + + 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); + 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: + TODO(getLoc(), "argument lowering for Box"); + continue; + case Fortran::lower::LowerIntrinsicArgAs::Inquired: + TODO(getLoc(), "argument lowering for Inquired"); + 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 ExtValue genval(const Fortran::evaluate::Expr &x) { if (isScalar(x)) @@ -447,6 +539,38 @@ TODO(getLoc(), "genval Expr arrays"); } + template + ExtValue genval(const Fortran::evaluate::Expr> &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); + 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); + + return {}; + } + + template + bool isScalar(const A &x) { + return x.Rank() == 0; + } + /// Helper to detect Transformational function reference. template bool isTransformationalRef(const T &) { @@ -462,6 +586,34 @@ 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 @@ -471,19 +623,11 @@ Fortran::evaluate::UnwrapWholeSymbolOrComponentDataRef(x) || isTransformationalRef(x)) return std::visit([&](const auto &e) { return genref(e); }, x.u); - TODO(getLoc(), "gen Expr non-scalar"); + if (useBoxArg) + return asArrayArg(x); + return asArray(x); } - template - bool isScalar(const A &x) { - return x.Rank() == 0; - } - - template - ExtValue genval(const Fortran::evaluate::Expr> &exp) { - return std::visit([&](const auto &e) { return genval(e); }, exp.u); - } using RefSet = std::tuple +mlir::Type +genFIRType(mlir::MLIRContext *context) { + return mlir::FloatType::getF16(context); +} + +template <> +mlir::Type +genFIRType(mlir::MLIRContext *context) { + return mlir::FloatType::getBF16(context); +} + +template <> +mlir::Type +genFIRType(mlir::MLIRContext *context) { + return mlir::FloatType::getF32(context); +} + +template <> +mlir::Type +genFIRType(mlir::MLIRContext *context) { + return mlir::FloatType::getF64(context); +} + +template <> +mlir::Type genFIRType( + mlir::MLIRContext *context) { + return fir::RealType::get(context, 10); +} + +template <> +mlir::Type genFIRType( + mlir::MLIRContext *context) { + return fir::RealType::get(context, 16); +} + +template <> +mlir::Type +genFIRType(mlir::MLIRContext *context, + int kind) { + if (Fortran::evaluate::IsValidKindOfIntrinsicType( + Fortran::common::TypeCategory::Real, kind)) { + switch (kind) { + case 2: + return genFIRType(context); + case 3: + return genFIRType(context); + case 4: + return genFIRType(context); + case 8: + return genFIRType(context); + case 10: + return genFIRType(context); + case 16: + return genFIRType(context); + } + } + llvm_unreachable("REAL type translation not implemented"); +} + +template <> +mlir::Type +genFIRType(mlir::MLIRContext *context, + int kind) { + if (Fortran::evaluate::IsValidKindOfIntrinsicType( + Fortran::common::TypeCategory::Integer, kind)) { + switch (kind) { + case 1: + return genFIRType(context); + case 2: + return genFIRType(context); + case 4: + return genFIRType(context); + case 8: + return genFIRType(context); + case 16: + return genFIRType(context); + } + } + llvm_unreachable("INTEGER type translation not implemented"); +} + +template <> +mlir::Type +genFIRType(mlir::MLIRContext *context, + int KIND) { + if (Fortran::evaluate::IsValidKindOfIntrinsicType( + Fortran::common::TypeCategory::Logical, KIND)) + return fir::LogicalType::get(context, KIND); + return {}; +} namespace { @@ -487,16 +578,11 @@ mlir::Type Fortran::lower::getFIRType(mlir::MLIRContext *context, Fortran::common::TypeCategory tc, - int kind) { + int kind, + llvm::ArrayRef params) { return genFIRType(context, tc, kind); } -mlir::Type -Fortran::lower::getFIRType(Fortran::lower::AbstractConverter &converter, - Fortran::common::TypeCategory tc) { - return TypeBuilder{converter}.genFIRTy(tc); -} - mlir::Type Fortran::lower::translateDataRefToFIRType( Fortran::lower::AbstractConverter &converter, const Fortran::evaluate::DataRef &dataRef) { 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,251 @@ +//===-- 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/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" + +/// 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); + + mlir::Value genIand(mlir::Type, llvm::ArrayRef); + + /// Define the different FIR generators that can be mapped to intrinsic to + /// generate the related code. + using ElementalGenerator = decltype(&IntrinsicLibrary::genIand); + 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); + 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 = {}; +}; + +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; +} + +//===----------------------------------------------------------------------===// +// IntrinsicLibrary +//===----------------------------------------------------------------------===// + +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); +} + +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); +} + +fir::ExtendedValue +IntrinsicLibrary::genIntrinsicCall(llvm::StringRef name, + llvm::Optional resultType, + llvm::ArrayRef args) { + if (const IntrinsicHandler *handler = findIntrinsicHandler(name)) { + bool outline = false; + 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); +} +//===----------------------------------------------------------------------===// +// Code generators for the intrinsic +//===----------------------------------------------------------------------===// + +// 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/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