1 #include "testing.h"
2 #include "../../lib/Evaluate/host.h"
3 #include "flang/Evaluate/call.h"
4 #include "flang/Evaluate/expression.h"
5 #include "flang/Evaluate/fold.h"
6 #include "flang/Evaluate/intrinsics-library.h"
7 #include "flang/Evaluate/intrinsics.h"
8 #include "flang/Evaluate/tools.h"
9 #include <tuple>
10
11 using namespace Fortran::evaluate;
12
13 // helper to call functions on all types from tuple
14 template <typename... T> struct RunOnTypes {};
15 template <typename Test, typename... T>
16 struct RunOnTypes<Test, std::tuple<T...>> {
RunRunOnTypes17 static void Run() { (..., Test::template Run<T>()); }
18 };
19
20 // test for fold.h GetScalarConstantValue function
21 struct TestGetScalarConstantValue {
RunTestGetScalarConstantValue22 template <typename T> static void Run() {
23 Expr<T> exprFullyTyped{Constant<T>{Scalar<T>{}}};
24 Expr<SomeKind<T::category>> exprSomeKind{exprFullyTyped};
25 Expr<SomeType> exprSomeType{exprSomeKind};
26 TEST(GetScalarConstantValue<T>(exprFullyTyped).has_value());
27 TEST(GetScalarConstantValue<T>(exprSomeKind).has_value());
28 TEST(GetScalarConstantValue<T>(exprSomeType).has_value());
29 }
30 };
31
32 template <typename T>
CallHostRt(HostRuntimeWrapper func,FoldingContext & context,Scalar<T> x)33 Scalar<T> CallHostRt(
34 HostRuntimeWrapper func, FoldingContext &context, Scalar<T> x) {
35 return GetScalarConstantValue<T>(
36 func(context, {AsGenericExpr(Constant<T>{x})}))
37 .value();
38 }
39
TestHostRuntimeSubnormalFlushing()40 void TestHostRuntimeSubnormalFlushing() {
41 using R4 = Type<TypeCategory::Real, 4>;
42 if constexpr (std::is_same_v<host::HostType<R4>, float>) {
43 Fortran::parser::CharBlock src;
44 Fortran::parser::ContextualMessages messages{src, nullptr};
45 Fortran::common::IntrinsicTypeDefaultKinds defaults;
46 auto intrinsics{Fortran::evaluate::IntrinsicProcTable::Configure(defaults)};
47 FoldingContext flushingContext{
48 messages, defaults, intrinsics, defaultRounding, true};
49 FoldingContext noFlushingContext{
50 messages, defaults, intrinsics, defaultRounding, false};
51
52 DynamicType r4{R4{}.GetType()};
53 // Test subnormal argument flushing
54 if (auto callable{GetHostRuntimeWrapper("log", r4, {r4})}) {
55 // Biggest IEEE 32bits subnormal power of two
56 const Scalar<R4> x1{Scalar<R4>::Word{0x00400000}};
57 Scalar<R4> y1Flushing{CallHostRt<R4>(*callable, flushingContext, x1)};
58 Scalar<R4> y1NoFlushing{CallHostRt<R4>(*callable, noFlushingContext, x1)};
59 // We would expect y1Flushing to be NaN, but some libc logf implementation
60 // "workaround" subnormal flushing by returning a constant negative
61 // results for all subnormal values (-1.03972076416015625e2_4). In case of
62 // flushing, the result should still be different than -88 +/- 2%.
63 TEST(y1Flushing.IsInfinite() ||
64 std::abs(host::CastFortranToHost<R4>(y1Flushing) + 88.) > 2);
65 TEST(!y1NoFlushing.IsInfinite() &&
66 std::abs(host::CastFortranToHost<R4>(y1NoFlushing) + 88.) < 2);
67 } else {
68 TEST(false);
69 }
70 } else {
71 TEST(false); // Cannot run this test on the host
72 }
73 }
74
main()75 int main() {
76 RunOnTypes<TestGetScalarConstantValue, AllIntrinsicTypes>::Run();
77 TestHostRuntimeSubnormalFlushing();
78 return testing::Complete();
79 }
80