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
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
|
{-# LANGUAGE MagicHash #-}
{-# LANGUAGE BlockArguments #-}
{-# LANGUAGE RecordWildCards #-}
-- | Test sized primops (Int8#, Word16#, etc.)
module Main where
import GHC.Exts
import GHC.Word
import GHC.Int
import GHC.Num.Integer
import Control.Monad
data N a = N
{ name :: String
, min_bound :: a
, max_bound :: a
, signed :: Bool
, nbits :: Word
, shift_right_logical :: a -> Word -> a
, shift_right_arith :: Maybe (a -> Word -> a)
, shift_left :: a -> Word -> a
, eq :: a -> a -> Bool
, gt :: a -> a -> Bool
, ge :: a -> a -> Bool
, lt :: a -> a -> Bool
, le :: a -> a -> Bool
, from_integer :: Integer -> a
, mbit_and :: Maybe (a -> a -> a)
, mbit_or :: Maybe (a -> a -> a)
, mbit_xor :: Maybe (a -> a -> a)
}
w8 :: N Word8
w8 = N
{ name = "W8"
, min_bound = minBound
, max_bound = maxBound
, signed = False
, nbits = 8
, shift_right_logical = \(W8# a) (W# n) -> W8# (uncheckedShiftRLWord8# a (word2Int# n))
, shift_right_arith = Nothing
, shift_left = \(W8# a) (W# n) -> W8# (uncheckedShiftLWord8# a (word2Int# n))
, eq = \(W8# a) (W8# b) -> isTrue# (eqWord8# a b)
, gt = \(W8# a) (W8# b) -> isTrue# (gtWord8# a b)
, ge = \(W8# a) (W8# b) -> isTrue# (geWord8# a b)
, lt = \(W8# a) (W8# b) -> isTrue# (ltWord8# a b)
, le = \(W8# a) (W8# b) -> isTrue# (leWord8# a b)
, from_integer = fromIntegral
, mbit_and = Just \(W8# a) (W8# b) -> W8# (andWord8# a b)
, mbit_or = Just \(W8# a) (W8# b) -> W8# (orWord8# a b)
, mbit_xor = Just \(W8# a) (W8# b) -> W8# (xorWord8# a b)
}
w16 :: N Word16
w16 = N
{ name = "W16"
, min_bound = minBound
, max_bound = maxBound
, signed = False
, nbits = 16
, shift_right_logical = \(W16# a) (W# n) -> W16# (uncheckedShiftRLWord16# a (word2Int# n))
, shift_right_arith = Nothing
, shift_left = \(W16# a) (W# n) -> W16# (uncheckedShiftLWord16# a (word2Int# n))
, eq = \(W16# a) (W16# b) -> isTrue# (eqWord16# a b)
, gt = \(W16# a) (W16# b) -> isTrue# (gtWord16# a b)
, ge = \(W16# a) (W16# b) -> isTrue# (geWord16# a b)
, lt = \(W16# a) (W16# b) -> isTrue# (ltWord16# a b)
, le = \(W16# a) (W16# b) -> isTrue# (leWord16# a b)
, from_integer = fromIntegral
, mbit_and = Just \(W16# a) (W16# b) -> W16# (andWord16# a b)
, mbit_or = Just \(W16# a) (W16# b) -> W16# (orWord16# a b)
, mbit_xor = Just \(W16# a) (W16# b) -> W16# (xorWord16# a b)
}
w32 :: N Word32
w32 = N
{ name = "W32"
, min_bound = minBound
, max_bound = maxBound
, signed = False
, nbits = 32
, shift_right_logical = \(W32# a) (W# n) -> W32# (uncheckedShiftRLWord32# a (word2Int# n))
, shift_right_arith = Nothing
, shift_left = \(W32# a) (W# n) -> W32# (uncheckedShiftLWord32# a (word2Int# n))
, eq = \(W32# a) (W32# b) -> isTrue# (eqWord32# a b)
, gt = \(W32# a) (W32# b) -> isTrue# (gtWord32# a b)
, ge = \(W32# a) (W32# b) -> isTrue# (geWord32# a b)
, lt = \(W32# a) (W32# b) -> isTrue# (ltWord32# a b)
, le = \(W32# a) (W32# b) -> isTrue# (leWord32# a b)
, from_integer = fromIntegral
, mbit_and = Just \(W32# a) (W32# b) -> W32# (andWord32# a b)
, mbit_or = Just \(W32# a) (W32# b) -> W32# (orWord32# a b)
, mbit_xor = Just \(W32# a) (W32# b) -> W32# (xorWord32# a b)
}
i8 :: N Int8
i8 = N
{ name = "I8"
, min_bound = minBound
, max_bound = maxBound
, signed = True
, nbits = 8
, shift_right_logical = \(I8# a) (W# n) -> I8# (uncheckedShiftRLInt8# a (word2Int# n))
, shift_right_arith = Just \(I8# a) (W# n) -> I8# (uncheckedShiftRAInt8# a (word2Int# n))
, shift_left = \(I8# a) (W# n) -> I8# (uncheckedShiftLInt8# a (word2Int# n))
, eq = \(I8# a) (I8# b) -> isTrue# (eqInt8# a b)
, gt = \(I8# a) (I8# b) -> isTrue# (gtInt8# a b)
, ge = \(I8# a) (I8# b) -> isTrue# (geInt8# a b)
, lt = \(I8# a) (I8# b) -> isTrue# (ltInt8# a b)
, le = \(I8# a) (I8# b) -> isTrue# (leInt8# a b)
, from_integer = fromIntegral
, mbit_and = Nothing
, mbit_or = Nothing
, mbit_xor = Nothing
}
i16 :: N Int16
i16 = N
{ name = "I16"
, min_bound = minBound
, max_bound = maxBound
, signed = True
, nbits = 16
, shift_right_logical = \(I16# a) (W# n) -> I16# (uncheckedShiftRLInt16# a (word2Int# n))
, shift_right_arith = Just \(I16# a) (W# n) -> I16# (uncheckedShiftRAInt16# a (word2Int# n))
, shift_left = \(I16# a) (W# n) -> I16# (uncheckedShiftLInt16# a (word2Int# n))
, eq = \(I16# a) (I16# b) -> isTrue# (eqInt16# a b)
, gt = \(I16# a) (I16# b) -> isTrue# (gtInt16# a b)
, ge = \(I16# a) (I16# b) -> isTrue# (geInt16# a b)
, lt = \(I16# a) (I16# b) -> isTrue# (ltInt16# a b)
, le = \(I16# a) (I16# b) -> isTrue# (leInt16# a b)
, from_integer = fromIntegral
, mbit_and = Nothing
, mbit_or = Nothing
, mbit_xor = Nothing
}
i32 :: N Int32
i32 = N
{ name = "I32"
, min_bound = minBound
, max_bound = maxBound
, signed = True
, nbits = 32
, shift_right_logical = \(I32# a) (W# n) -> I32# (uncheckedShiftRLInt32# a (word2Int# n))
, shift_right_arith = Just \(I32# a) (W# n) -> I32# (uncheckedShiftRAInt32# a (word2Int# n))
, shift_left = \(I32# a) (W# n) -> I32# (uncheckedShiftLInt32# a (word2Int# n))
, eq = \(I32# a) (I32# b) -> isTrue# (eqInt32# a b)
, gt = \(I32# a) (I32# b) -> isTrue# (gtInt32# a b)
, ge = \(I32# a) (I32# b) -> isTrue# (geInt32# a b)
, lt = \(I32# a) (I32# b) -> isTrue# (ltInt32# a b)
, le = \(I32# a) (I32# b) -> isTrue# (leInt32# a b)
, from_integer = fromIntegral
, mbit_and = Nothing
, mbit_or = Nothing
, mbit_xor = Nothing
}
main :: IO ()
main = do
test w8
test w16
test w32
test i8
test i16
test i32
{-# NOINLINE test #-}
test :: (Integral a, Show a) => N a -> IO ()
test sys@(N {..}) = do
putStrLn $ "--------------------------"
putStrLn $ "Testing " ++ name
putStrLn $ "--------------------------"
let assert s False = putStrLn ("FAILED: " ++ s)
--assert s True = return ()
assert s True = putStrLn ("PASSED: " ++ s)
let zero = from_integer 0
let one = from_integer 1
-- right-shift zero must be zero
forM_ [0..nbits-1] \n ->
assert ("0 >> " ++ show n ++ " == 0")
(zero `eq` shift_right_logical zero n)
-- left-shift zero must be zero
forM_ [0..nbits-1] \n ->
assert ("0 << " ++ show n ++ " == 0")
(zero `eq` shift_left zero n)
-- left-shift 1
forM_ [0..nbits-1] \n -> do
let expected = from_integer (1 `integerShiftL` n)
assert ("1 << " ++ show n ++ " == " ++ show expected)
(expected `eq` shift_left one n)
-- logical right-shift minBound
forM_ [0..nbits-1] \n -> do
let expected
| n == 0 = min_bound
| otherwise = from_integer (integerAbs (fromIntegral min_bound) `integerShiftR` n)
assert (show min_bound ++ " >> " ++ show n ++ " == " ++ show expected ++ " (logical)")
(expected `eq` shift_right_logical min_bound n)
-- arithmetic right-shift minBound
forM_ shift_right_arith \shift_right_arithmetic -> do
forM_ [0..nbits-1] \n -> do
let minb = fromIntegral min_bound :: Integer
let expected = from_integer (minb `integerShiftR` n)
assert (show min_bound ++ " >> " ++ show n ++ " == " ++ show expected ++ " (arithmetic)")
(expected `eq` shift_right_arithmetic min_bound n)
-- and with 0 must be 0
forM_ mbit_and \bit_and -> do
forM_ [0..nbits-1] \n -> do
let v = one `shift_left` n
assert ("0 .&. " ++ show v ++ " == 0")
(zero `eq` bit_and v zero)
-- test with an overflowed value
let v = max_bound + max_bound + max_bound
assert ("0 .&. " ++ show v ++ " == 0")
(zero `eq` bit_and v zero)
-- or with 0 must be constant
forM_ mbit_or \bit_or -> do
forM_ [0..nbits-1] \n -> do
let v = one `shift_left` n
assert ("0 .|. " ++ show v ++ " == " ++ show v)
(v `eq` bit_or v zero)
-- test with an overflowed value
let v = max_bound + max_bound + max_bound
assert ("0 .|. " ++ show v ++ " == " ++ show v)
(v `eq` bit_or v zero)
-- xor . xor = id
forM_ mbit_xor \bit_xor -> do
forM_ [0..nbits-2] \n -> do
-- v0 == v0' but hopefully GHC doesn't see it statically
let v0 = one `shift_left` n
let v1 = one `shift_left` (n+1)
let v0' = v1 `shift_right_logical` 1
let v = max_bound + max_bound + max_bound
assert (show v ++ " `xor` " ++ show v0 ++ " == " ++ show v0' ++ " `xor` " ++ show v)
(bit_xor v v0 `eq` bit_xor v0' v)
-- test comparison operators
forM_ [0..nbits-2-(if signed then 1 else 0)] \n -> do
-- v0 == v0' but hopefully GHC doesn't see it statically
let v0 = one `shift_left` n
let v1 = one `shift_left` (n+1)
let v0' = v1 `shift_right_logical` 1
assert (show v0 ++ " < " ++ show v1)
(v0 `lt` v1)
assert (show v0 ++ " <= " ++ show v1)
(v0 `le` v1)
assert (show v0 ++ " > " ++ show v1)
(v1 `gt` v0)
assert (show v0 ++ " <= " ++ show v0')
(v0 `le` v0')
assert (show v0 ++ " >= " ++ show v0')
(v0 `ge` v0')
assert (show v0 ++ " == " ++ show v0')
(v0 `eq` v0')
|
