#include "expression.h"
#include "host.h"
#include "int-power.h"
+#include "rte.h"
#include "tools.h"
#include "traversal.h"
#include "type.h"
FoldOperation(context, std::move(complex)), complexPart.part()};
}
-// helpers to fold intrinsic function references
namespace intrinsicHelper {
-// helper to produce hash of intrinsic names based the first 3 letters. All
-// intrinsic names are longer than 3 letters
-static constexpr inline std::int32_t CommonHash(const char *s, std::size_t n) {
- if (n < 3) {
- return 0;
- }
- return (((static_cast<std::int32_t>(s[0]) << 8) + s[1]) << 8) + s[2];
-}
-
-static constexpr std::int32_t operator"" _hash(const char *s, std::size_t n) {
- return CommonHash(s, n);
-}
-
-static std::int32_t DynamicHash(const std::string &s) {
- return CommonHash(s.data(), s.size());
-}
-
-// Define function pointer and callable types used in a common utility that
+// helpers to fold intrinsic function references
+// Define callable types used in a common utility that
// takes care of array and cast/conversion aspects for elemental intrinsics
-// Note: math complex functions from <complex> are passing arg as const ref
-template<typename TR, typename... TA> using FuncPointer = TR (*)(TA...);
-
-template<typename TR, typename... TA>
-using HostFuncPointer = FuncPointer<Host::HostType<TR>,
- std::conditional_t<TA::category == TypeCategory::Complex,
- const Host::HostType<TA> &, Host::HostType<TA>>...>;
template<typename TR, typename... TArgs>
using ScalarFunc = std::function<Scalar<TR>(const Scalar<TArgs> &...)>;
-
-// Helper that build std::function operating on Scalar types from host runtime
-// function. There is version that only works if the scalar has a matching host
-// type and one that allow conversions of scalar types toward "bigger" host
-// types. By "bigger", it is meant that all the scalar types can be converted to
-// and from this host type without any precision loss. The purpose of this is
-// mainly to allow folding of 16 bits float intrinsic function with the host
-// runtime for 32bit floats when it is acceptable (e.g acos).
-template<typename TR, typename... TA>
-static constexpr inline ScalarFunc<TR, TA...> HostFuncWrap(
- HostFuncPointer<TR, TA...> func) {
- return [=](const Scalar<TA> &... x) -> Scalar<TR> {
- // TODO fp-exception
- return Host::CastHostToFortran<TR>(func(Host::CastFortranToHost<TA>(x)...));
- };
-}
-
-// A utility that applies a scalar function over arrays or scalar for elemental
-// intrinsics.
-template<typename TR, typename... TA, std::size_t... I>
-static inline Expr<TR> FoldElementalIntrinsicHelper(FunctionRef<TR> &&funcRef,
- ScalarFunc<TR, TA...> scalarFunc, std::index_sequence<I...>) {
+template<typename TR, typename... TArgs>
+using ScalarFuncWithContext =
+ std::function<Scalar<TR>(FoldingContext &, const Scalar<TArgs> &...)>;
+
+template<template<typename, typename...> typename WrapperType, typename TR,
+ typename... TA, std::size_t... I>
+static inline Expr<TR> FoldElementalIntrinsicHelper(FoldingContext &context,
+ FunctionRef<TR> &&funcRef, WrapperType<TR, TA...> func,
+ std::index_sequence<I...>) {
static_assert(
(... && IsSpecificIntrinsicType<TA>)); // TODO derived types for MERGE?
std::tuple<const std::optional<Scalar<TA>>...> scalars{
GetScalarConstantValue<TA>(*funcRef.arguments()[I]->value)...};
if ((... && std::get<I>(scalars).has_value())) {
- return Expr<TR>{Constant<TR>{scalarFunc(*std::get<I>(scalars)...)}};
+ if constexpr (std::is_same_v<WrapperType<TR, TA...>,
+ ScalarFuncWithContext<TR, TA...>>) {
+ return Expr<TR>{Constant<TR>{func(context, *std::get<I>(scalars)...)}};
+ } else if constexpr (std::is_same_v<WrapperType<TR, TA...>,
+ ScalarFunc<TR, TA...>>) {
+ return Expr<TR>{Constant<TR>{func(*std::get<I>(scalars)...)}};
+ }
}
// TODO: handle arrays when Constant<T> can represent them
return Expr<TR>{std::move(funcRef)};
}
template<typename TR, typename... TA>
-static Expr<TR> FoldElementalIntrinsic(
- FunctionRef<TR> &&funcRef, ScalarFunc<TR, TA...> scalarFunc) {
- return FoldElementalIntrinsicHelper<TR, TA...>(
- std::move(funcRef), scalarFunc, std::index_sequence_for<TA...>{});
+static Expr<TR> FoldElementalIntrinsic(FoldingContext &context,
+ FunctionRef<TR> &&funcRef, ScalarFunc<TR, TA...> func) {
+ return FoldElementalIntrinsicHelper<ScalarFunc, TR, TA...>(
+ context, std::move(funcRef), func, std::index_sequence_for<TA...>{});
+}
+template<typename TR, typename... TA>
+static Expr<TR> FoldElementalIntrinsic(FoldingContext &context,
+ FunctionRef<TR> &&funcRef, ScalarFuncWithContext<TR, TA...> func) {
+ return FoldElementalIntrinsicHelper<ScalarFuncWithContext, TR, TA...>(
+ context, std::move(funcRef), func, std::index_sequence_for<TA...>{});
}
}
}
}
if (auto *intrinsic{std::get_if<SpecificIntrinsic>(&funcRef.proc().u)}) {
- std::string name{intrinsic->name};
- switch (DynamicHash(name)) {
- case "kin"_hash:
- if (name == "kind") {
- if constexpr (common::HasMember<T, IntegerTypes>) {
- return Expr<T>{funcRef.arguments()[0]->value()->GetType()->kind};
- } else {
- common::die("kind() result not integral");
- }
+ const std::string name{intrinsic->name};
+ if (name == "kind") {
+ if constexpr (common::HasMember<T, IntegerTypes>) {
+ return Expr<T>{funcRef.arguments()[0]->value()->GetType()->kind};
+ } else {
+ common::die("kind() result not integral");
}
- break;
- case "len"_hash:
- if (name == "len") {
- if constexpr (std::is_same_v<T, SubscriptInteger>) {
- if (auto *charExpr{UnwrapExpr<Expr<SomeCharacter>>(
- *funcRef.arguments()[0]->value())}) {
- return std::visit([](auto &kx) { return kx.LEN(); }, charExpr->u);
- }
- } else {
- common::die("len() result not SubscriptInteger");
+ } else if (name == "len") {
+ if constexpr (std::is_same_v<T, SubscriptInteger>) {
+ if (auto *charExpr{UnwrapExpr<Expr<SomeCharacter>>(
+ *funcRef.arguments()[0]->value())}) {
+ return std::visit([](auto &kx) { return kx.LEN(); }, charExpr->u);
}
+ } else {
+ common::die("len() result not SubscriptInteger");
}
- break;
- case "ian"_hash:
- if (name == "iand") {
- if (auto *x{std::get_if<BOZLiteralConstant>(
- &funcRef.arguments()[0]->value->u)}) {
- *funcRef.arguments()[0]->value =
- Fold(context, ConvertToType<T>(std::move(*x)));
- }
- if (auto *x{std::get_if<BOZLiteralConstant>(
- &funcRef.arguments()[1]->value->u)}) {
- *funcRef.arguments()[1]->value =
- Fold(context, ConvertToType<T>(std::move(*x)));
- }
- return FoldElementalIntrinsic<T, T, T>(
- std::move(funcRef), ScalarFunc<T, T, T>(&Scalar<T>::IAND));
+ } else if (name == "iand") {
+ if (auto *x{std::get_if<BOZLiteralConstant>(
+ &funcRef.arguments()[0]->value->u)}) {
+ *funcRef.arguments()[0]->value =
+ Fold(context, ConvertToType<T>(std::move(*x)));
}
- break;
- case "int"_hash:
- if (name == "int") {
- return std::visit(
- [&](auto &&x) -> Expr<T> {
- using From = std::decay_t<decltype(x)>;
- if constexpr (std::is_same_v<From, BOZLiteralConstant> ||
- std::is_same_v<From, Expr<SomeReal>> ||
- std::is_same_v<From, Expr<SomeInteger>> ||
- std::is_same_v<From, Expr<SomeComplex>>) {
- return Fold(context, ConvertToType<T>(std::move(x)));
- } else {
- common::die("int() argument type not valid");
- return Expr<T>{std::move(funcRef)}; // unreachable
- }
- },
- std::move(funcRef.arguments()[0]->value->u));
+ if (auto *x{std::get_if<BOZLiteralConstant>(
+ &funcRef.arguments()[1]->value->u)}) {
+ *funcRef.arguments()[1]->value =
+ Fold(context, ConvertToType<T>(std::move(*x)));
}
- break;
- default:
- // TODO: many more intrinsic functions
- break;
+ return FoldElementalIntrinsic<T, T, T>(
+ context, std::move(funcRef), ScalarFunc<T, T, T>(&Scalar<T>::IAND));
+ } else if (name == "int") {
+ return std::visit(
+ [&](auto &&x) -> Expr<T> {
+ using From = std::decay_t<decltype(x)>;
+ if constexpr (std::is_same_v<From, BOZLiteralConstant> ||
+ std::is_same_v<From, Expr<SomeReal>> ||
+ std::is_same_v<From, Expr<SomeInteger>> ||
+ std::is_same_v<From, Expr<SomeComplex>>) {
+ return Fold(context, ConvertToType<T>(std::move(x)));
+ } else {
+ common::die("int() argument type not valid");
+ return Expr<T>{std::move(funcRef)}; // unreachable
+ }
+ },
+ std::move(funcRef.arguments()[0]->value->u));
}
+ // TODO: many more intrinsic functions
}
return Expr<T>{std::move(funcRef)};
}
}
}
if (auto *intrinsic{std::get_if<SpecificIntrinsic>(&funcRef.proc().u)}) {
- std::string name{intrinsic->name};
- switch (DynamicHash(name)) {
- case "aco"_hash:
- if (name == "acos") {
- if constexpr (Host::HostTypeExists<T>()) {
- return FoldElementalIntrinsic<T, T>(std::move(funcRef),
- HostFuncWrap<T, T>(HostFuncPointer<T, T>{std::acos}));
- } else {
- context.messages().Say(
- "acos(real(kind=%d)) cannot be folded on host"_en_US, KIND);
+ const std::string name{intrinsic->name};
+ if (name == "acos" || name == "acosh") {
+ if (auto callable{
+ context.hostRte().GetHostProcedureWrapper<Scalar, T, T>(name)}) {
+ return FoldElementalIntrinsic<T, T>(
+ context, std::move(funcRef), *callable);
+ } else {
+ context.messages().Say(
+ "%s(real(kind=%d)) cannot be folded on host"_en_US, name.c_str(),
+ KIND);
+ }
+ } else if (name == "bessel_jn" || name == "bessel_yn") {
+ if (funcRef.arguments().size() == 2) { // elemental
+ using Int8 = Type<TypeCategory::Integer, 8>;
+ if (auto *n{std::get_if<Expr<SomeInteger>>(
+ &funcRef.arguments()[0]->value->u)}) {
+ *funcRef.arguments()[0]->value =
+ Fold(context, ConvertToType<Int8>(std::move(*n)));
}
- } else if (name == "acosh") {
- if constexpr (Host::HostTypeExists<T>()) {
- return FoldElementalIntrinsic<T, T>(std::move(funcRef),
- HostFuncWrap<T, T>(HostFuncPointer<T, T>{std::acosh}));
+ if (auto callable{
+ context.hostRte().GetHostProcedureWrapper<Scalar, T, Int8, T>(
+ name)}) {
+ return FoldElementalIntrinsic<T, Int8, T>(
+ context, std::move(funcRef), *callable);
} else {
context.messages().Say(
- "acosh(real(kind=%d)) cannot be folded on host"_en_US, KIND);
- }
- }
- case "bes"_hash:
- if (name == "bessel_jn" || name == "bessel_yn") {
- if (funcRef.arguments().size() == 2) { // elemental
- if constexpr (Host::HostTypeExists<T>()) {
- // TODO mapping to <cmath> function to be tested.<cmath> func takes
- // real arg for n
- if (auto *n{std::get_if<Expr<SomeInteger>>(
- &funcRef.arguments()[0]->value->u)}) {
- *funcRef.arguments()[0]->value =
- Fold(context, ConvertToType<T>(std::move(*n)));
- }
- auto hostFunc{name == "bessel_jn"
- ? HostFuncPointer<T, T, T>{std::cyl_bessel_j}
- : HostFuncPointer<T, T, T>{std::cyl_neumann}};
- return FoldElementalIntrinsic<T, T, T>(
- std::move(funcRef), HostFuncWrap<T, T, T>(hostFunc));
- }
+ "%s(integer(kind=8), real(kind=%d)) cannot be folded on host"_en_US,
+ name.c_str(), KIND);
}
}
- break;
- case "dpr"_hash:
- if (name == "dprod") {
- if (auto *x{std::get_if<Expr<SomeReal>>(
- &funcRef.arguments()[0]->value->u)}) {
- if (auto *y{std::get_if<Expr<SomeReal>>(
- &funcRef.arguments()[1]->value->u)}) {
- return Fold(context,
- Expr<T>{Multiply<T>{ConvertToType<T>(std::move(*x)),
- ConvertToType<T>(std::move(*y))}});
- }
+ } else if (name == "dprod") {
+ if (auto *x{
+ std::get_if<Expr<SomeReal>>(&funcRef.arguments()[0]->value->u)}) {
+ if (auto *y{std::get_if<Expr<SomeReal>>(
+ &funcRef.arguments()[1]->value->u)}) {
+ return Fold(context,
+ Expr<T>{Multiply<T>{ConvertToType<T>(std::move(*x)),
+ ConvertToType<T>(std::move(*y))}});
}
- common::die("Wrong argument type in dprod()");
- break;
}
- break;
- case "rea"_hash:
- if (name == "real") {
- return std::visit(
- [&](auto &&x) -> Expr<T> {
- using From = std::decay_t<decltype(x)>;
- if constexpr (std::is_same_v<From, BOZLiteralConstant>) {
- typename T::Scalar::Word::ValueWithOverflow result{
- T::Scalar::Word::ConvertUnsigned(x)};
- if (result.overflow) { // C1601
- context.messages().Say(
- "Non null truncated bits of boz literal constant in REAL intrinsic"_en_US);
- }
- return Expr<T>{Constant<T>{Scalar<T>(std::move(result.value))}};
- } else if constexpr (std::is_same_v<From, Expr<SomeReal>> ||
- std::is_same_v<From, Expr<SomeInteger>> ||
- std::is_same_v<From, Expr<SomeComplex>>) {
- return Fold(context, ConvertToType<T>(std::move(x)));
- } else {
- common::die("real() argument type not valid");
- return Expr<T>{std::move(funcRef)}; // unreachable
+ common::die("Wrong argument type in dprod()");
+ } else if (name == "real") {
+ return std::visit(
+ [&](auto &&x) -> Expr<T> {
+ using From = std::decay_t<decltype(x)>;
+ if constexpr (std::is_same_v<From, BOZLiteralConstant>) {
+ typename T::Scalar::Word::ValueWithOverflow result{
+ T::Scalar::Word::ConvertUnsigned(x)};
+ if (result.overflow) { // C1601
+ context.messages().Say(
+ "Non null truncated bits of boz literal constant in REAL intrinsic"_en_US);
}
- },
- std::move(funcRef.arguments()[0]->value->u));
- }
- break;
- default:
- // TODO: many more intrinsic functions
- break;
+ return Expr<T>{Constant<T>{Scalar<T>(std::move(result.value))}};
+ } else if constexpr (std::is_same_v<From, Expr<SomeReal>> ||
+ std::is_same_v<From, Expr<SomeInteger>> ||
+ std::is_same_v<From, Expr<SomeComplex>>) {
+ return Fold(context, ConvertToType<T>(std::move(x)));
+ } else {
+ common::die("real() argument type not valid");
+ return Expr<T>{std::move(funcRef)}; // unreachable
+ }
+ },
+ std::move(funcRef.arguments()[0]->value->u));
}
+ // TODO: many more intrinsic functions
}
return Expr<T>{std::move(funcRef)};
}
}
}
if (auto *intrinsic{std::get_if<SpecificIntrinsic>(&funcRef.proc().u)}) {
- std::string name{intrinsic->name};
- switch (DynamicHash(name)) {
- case "aco"_hash:
- if (name == "acos") {
- if constexpr (Host::HostTypeExists<T>()) {
- return FoldElementalIntrinsic<T, T>(std::move(funcRef),
- HostFuncWrap<T, T>(HostFuncPointer<T, T>{std::acos}));
- } else {
- context.messages().Say(
- "acos(complex(kind=%d)) cannot be folded on host"_en_US, KIND);
- }
- } else if (name == "acosh") {
- if constexpr (Host::HostTypeExists<T>()) {
- return FoldElementalIntrinsic<T, T>(std::move(funcRef),
- HostFuncWrap<T, T>(HostFuncPointer<T, T>{std::acosh}));
- } else {
- context.messages().Say(
- "acosh(complex(kind=%d)) cannot be folded on host"_en_US, KIND);
- }
+ const std::string name{intrinsic->name};
+ if (name == "acos" || name == "acosh" || name == "asin" || name == "atan" ||
+ name == "atanh") {
+ if (auto callable{
+ context.hostRte().GetHostProcedureWrapper<Scalar, T, T>(name)}) {
+ return FoldElementalIntrinsic<T, T>(
+ context, std::move(funcRef), *callable);
+ } else {
+ context.messages().Say(
+ "%s(complex(kind=%d)) cannot be folded on host"_en_US, name.c_str(),
+ KIND);
}
- case "cmp"_hash:
- if (name == "cmplx") {
- if (funcRef.arguments().size() == 2) {
- if (auto *x{std::get_if<Expr<SomeComplex>>(
- &funcRef.arguments()[0]->value->u)}) {
- return Fold(context, ConvertToType<T>(std::move(*x)));
- } else {
- common::die("x must be complex in cmplx(x[, kind])");
- }
+ }
+ if (name == "cmplx") {
+ if (funcRef.arguments().size() == 2) {
+ if (auto *x{std::get_if<Expr<SomeComplex>>(
+ &funcRef.arguments()[0]->value->u)}) {
+ return Fold(context, ConvertToType<T>(std::move(*x)));
} else {
- CHECK(funcRef.arguments().size() == 3);
- using Part = typename T::Part;
- Expr<SomeType> im{funcRef.arguments()[1].has_value()
- ? std::move(*funcRef.arguments()[1]->value)
- : AsGenericExpr(Constant<Part>{Scalar<Part>{}})};
- Expr<SomeType> re{std::move(*funcRef.arguments()[0]->value)};
- int reRank{re.Rank()};
- int imRank{im.Rank()};
- semantics::Attrs attrs;
- attrs.set(semantics::Attr::ELEMENTAL);
- auto reReal{
- FunctionRef<Part>{ProcedureDesignator{SpecificIntrinsic{
- "real", Part::GetType(), reRank, attrs}},
- ActualArguments{ActualArgument{std::move(re)}}}};
- auto imReal{
- FunctionRef<Part>{ProcedureDesignator{SpecificIntrinsic{
- "real", Part::GetType(), imRank, attrs}},
- ActualArguments{ActualArgument{std::move(im)}}}};
- return Fold(context,
- Expr<T>{ComplexConstructor<T::kind>{Expr<Part>{std::move(reReal)},
- Expr<Part>{std::move(imReal)}}});
+ common::die("x must be complex in cmplx(x[, kind])");
}
+ } else {
+ CHECK(funcRef.arguments().size() == 3);
+ using Part = typename T::Part;
+ Expr<SomeType> im{funcRef.arguments()[1].has_value()
+ ? std::move(*funcRef.arguments()[1]->value)
+ : AsGenericExpr(Constant<Part>{Scalar<Part>{}})};
+ Expr<SomeType> re{std::move(*funcRef.arguments()[0]->value)};
+ int reRank{re.Rank()};
+ int imRank{im.Rank()};
+ semantics::Attrs attrs;
+ attrs.set(semantics::Attr::ELEMENTAL);
+ auto reReal{
+ FunctionRef<Part>{ProcedureDesignator{SpecificIntrinsic{
+ "real", Part::GetType(), reRank, attrs}},
+ ActualArguments{ActualArgument{std::move(re)}}}};
+ auto imReal{
+ FunctionRef<Part>{ProcedureDesignator{SpecificIntrinsic{
+ "real", Part::GetType(), imRank, attrs}},
+ ActualArguments{ActualArgument{std::move(im)}}}};
+ return Fold(context,
+ Expr<T>{ComplexConstructor<T::kind>{
+ Expr<Part>{std::move(reReal)}, Expr<Part>{std::move(imReal)}}});
}
- break;
- default:
- // TODO: many more intrinsic functions
- break;
}
+ // TODO: many more intrinsic functions
}
return Expr<T>{std::move(funcRef)};
}
}
if (auto *intrinsic{std::get_if<SpecificIntrinsic>(&funcRef.proc().u)}) {
std::string name{intrinsic->name};
- switch (DynamicHash(name)) {
- case "bge"_hash:
- if (name == "bge") {
- using LargestInt = Type<TypeCategory::Integer, 16>;
- static_assert(std::is_same_v<Scalar<LargestInt>, BOZLiteralConstant>);
- if (auto *x{std::get_if<Expr<SomeInteger>>(
- &funcRef.arguments()[0]->value->u)}) {
- *funcRef.arguments()[0]->value =
- Fold(context, ConvertToType<LargestInt>(std::move(*x)));
- } else if (auto *x{std::get_if<BOZLiteralConstant>(
- &funcRef.arguments()[0]->value->u)}) {
- *funcRef.arguments()[0]->value =
- AsGenericExpr(Constant<LargestInt>{std::move(*x)});
- }
- if (auto *x{std::get_if<Expr<SomeInteger>>(
- &funcRef.arguments()[1]->value->u)}) {
- *funcRef.arguments()[1]->value =
- Fold(context, ConvertToType<LargestInt>(std::move(*x)));
- } else if (auto *x{std::get_if<BOZLiteralConstant>(
- &funcRef.arguments()[1]->value->u)}) {
- *funcRef.arguments()[1]->value =
- AsGenericExpr(Constant<LargestInt>{std::move(*x)});
- }
- return FoldElementalIntrinsic<T, LargestInt, LargestInt>(
- std::move(funcRef),
- ScalarFunc<T, LargestInt, LargestInt>(
- [](const Scalar<LargestInt> &i, const Scalar<LargestInt> &j) {
- return Scalar<T>{i.BGE(j)};
- }));
+ if (name == "bge") {
+ using LargestInt = Type<TypeCategory::Integer, 16>;
+ static_assert(std::is_same_v<Scalar<LargestInt>, BOZLiteralConstant>);
+ if (auto *x{std::get_if<Expr<SomeInteger>>(
+ &funcRef.arguments()[0]->value->u)}) {
+ *funcRef.arguments()[0]->value =
+ Fold(context, ConvertToType<LargestInt>(std::move(*x)));
+ } else if (auto *x{std::get_if<BOZLiteralConstant>(
+ &funcRef.arguments()[0]->value->u)}) {
+ *funcRef.arguments()[0]->value =
+ AsGenericExpr(Constant<LargestInt>{std::move(*x)});
+ }
+ if (auto *x{std::get_if<Expr<SomeInteger>>(
+ &funcRef.arguments()[1]->value->u)}) {
+ *funcRef.arguments()[1]->value =
+ Fold(context, ConvertToType<LargestInt>(std::move(*x)));
+ } else if (auto *x{std::get_if<BOZLiteralConstant>(
+ &funcRef.arguments()[1]->value->u)}) {
+ *funcRef.arguments()[1]->value =
+ AsGenericExpr(Constant<LargestInt>{std::move(*x)});
}
- break;
- default:
- // TODO: many more intrinsic functions
- break;
+ return FoldElementalIntrinsic<T, LargestInt, LargestInt>(context,
+ std::move(funcRef),
+ ScalarFunc<T, LargestInt, LargestInt>(
+ [](const Scalar<LargestInt> &i, const Scalar<LargestInt> &j) {
+ return Scalar<T>{i.BGE(j)};
+ }));
}
+ // TODO: many more intrinsic functions
}
return Expr<T>{std::move(funcRef)};
}
projects / platform / upstream / llvm.git / commitdiff