1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
|
(* Testing Z.to_float *)
open Printf
type rounding_mode =
FE_DOWNWARD | FE_TONEAREST | FE_TOWARDZERO | FE_UPWARD
external setround: rounding_mode -> bool = "caml_ztest_setround"
external format_float: string -> float -> string = "caml_format_float"
let hex_of_float f = format_float "%a" f
(* For testing, we use randomly-generated integers of the form
<signed 64-bit integer> * 2^<exponent>
We can predict their FP value by converting the integer part to FP,
then scale by the exponent using ldexp. *)
let test1 (mant: int64) (exp: int) =
let expected = ldexp (Int64.to_float mant) exp in
let actual = Z.to_float (Z.shift_left (Z.of_int64 mant) exp) in
if actual = expected then true else begin
printf "%Ld * 2^%d: expected %s, got %s\n"
mant exp (hex_of_float expected) (hex_of_float actual);
false
end
let rnd64 () =
let m1 = Random.bits() in (* 30 bits *)
let m2 = Random.bits() in (* 30 bits *)
let m3 = Random.bits() in
Int64.(logor (of_int m1)
(logor (shift_left (of_int m2) 30)
(shift_left (of_int m3) 60)))
let testN numrounds =
printf " (%d tests)... %!" numrounds;
let errors = ref 0 in
(* Some random int64 values *)
for i = 1 to numrounds do
let m = Random.int64 Int64.max_int in
if not (test1 m 0) then incr errors;
if not (test1 (Int64.neg m) 0) then incr errors
done;
(* Some random int64 values scaled by some random power of 2 *)
for i = 1 to numrounds do
let m = rnd64() in
let exp = Random.int 1100 in (* sometimes +inf will result *)
if not (test1 m exp) then incr errors
done;
(* Special test close to a rounding point *)
for i = 0 to 15 do
let m = Int64.(add 0xfffffffffffff0L (of_int i)) in
if not (test1 m 32) then incr errors;
if not (test1 (Int64.neg m) 32) then incr errors
done;
if !errors = 0
then printf "passed\n%!"
else printf "FAILED (%d errors)\n%!" !errors
let testQ1 (mant1: int64) (exp1: int) (mant2: int64) (exp2: int) =
let expected =
ldexp (Int64.to_float mant1) exp1 /. ldexp (Int64.to_float mant2) exp2 in
let actual =
Q.to_float (Q.make (Z.shift_left (Z.of_int64 mant1) exp1)
(Z.shift_left (Z.of_int64 mant2) exp2)) in
if compare actual expected = 0 then true else begin
printf "%Ld * 2^%d / %Ld * 2^%d : expected %s, got %s\n"
mant1 exp1 mant2 exp2 (hex_of_float expected) (hex_of_float actual);
false
end
let testQN numrounds =
printf " (%d tests)... %!" numrounds;
let errors = ref 0 in
(* Some special values *)
if not (testQ1 0L 0 1L 0) then incr errors;
if not (testQ1 1L 0 0L 0) then incr errors;
if not (testQ1 (-1L) 0 0L 0) then incr errors;
if not (testQ1 0L 0 0L 0) then incr errors;
(* Some random fractions *)
for i = 1 to numrounds do
let m1 = Random.int64 0x20000000000000L in
let m1 = if Random.bool() then m1 else Int64.neg m1 in
let exp1 = Random.int 500 in
let m2 = Random.int64 0x20000000000000L in
let exp2 = Random.int 500 in
if not (testQ1 m1 exp1 m2 exp2) then incr errors
done;
if !errors = 0
then printf "passed\n%!"
else printf "FAILED (%d errors)\n%!" !errors
let _ =
let numrounds =
if Array.length Sys.argv >= 2
then int_of_string Sys.argv.(1)
else 100_000 in
printf "Default rounding mode (Z)";
testN numrounds;
printf "Default rounding mode (Q)";
testQN numrounds;
if setround FE_TOWARDZERO then begin
printf "Round toward zero (Z)";
testN numrounds;
printf "Round toward zero (Q)";
testQN numrounds
end else begin
printf "Round toward zero not supported, skipping\n"
end;
if setround FE_DOWNWARD then begin
printf "Round downward (Z)";
testN numrounds;
printf "Round downward (Q)";
testQN numrounds
end else begin
printf "Round downward not supported, skipping\n"
end;
if setround FE_UPWARD then begin
printf "Round upward (Z)";
testN numrounds;
printf "Round upward (Q)";
testQN numrounds
end else begin
printf "Round upward not supported, skipping\n"
end;
if setround FE_TONEAREST then begin
printf "Round to nearest (Z)";
testN numrounds;
printf "Round to nearest (Q)";
testQN numrounds
end else begin
printf "Round to nearest not supported, skipping\n"
end
|
