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