4564bced0f3af82829a04f6b7b8940521e1c9416
[packages/old-time.git] / Data / Bits.hs
1 {-# OPTIONS_GHC -fno-implicit-prelude #-}
2 -----------------------------------------------------------------------------
3 -- |
4 -- Module : Data.Bits
5 -- Copyright : (c) The University of Glasgow 2001
6 -- License : BSD-style (see the file libraries/base/LICENSE)
7 --
8 -- Maintainer : libraries@haskell.org
9 -- Stability : experimental
10 -- Portability : portable
11 --
12 -- This module defines bitwise operations for signed and unsigned
13 -- integers. Instances of the class 'Bits' for the 'Int' and
14 -- 'Integer' types are available from this module, and instances for
15 -- explicitly sized integral types are available from the
16 -- "Data.Int" and "Data.Word" modules.
17 --
18 -----------------------------------------------------------------------------
19
20 module Data.Bits (
21 Bits(
22 (.&.), (.|.), xor, -- :: a -> a -> a
23 complement, -- :: a -> a
24 shift, -- :: a -> Int -> a
25 rotate, -- :: a -> Int -> a
26 bit, -- :: Int -> a
27 setBit, -- :: a -> Int -> a
28 clearBit, -- :: a -> Int -> a
29 complementBit, -- :: a -> Int -> a
30 testBit, -- :: a -> Int -> Bool
31 bitSize, -- :: a -> Int
32 isSigned, -- :: a -> Bool
33 shiftL, shiftR, -- :: a -> Int -> a
34 rotateL, rotateR -- :: a -> Int -> a
35 )
36
37 -- instance Bits Int
38 -- instance Bits Integer
39 ) where
40
41 -- Defines the @Bits@ class containing bit-based operations.
42 -- See library document for details on the semantics of the
43 -- individual operations.
44
45 #if defined(__GLASGOW_HASKELL__) || defined(__HUGS__)
46 #include "MachDeps.h"
47 #endif
48
49 #ifdef __GLASGOW_HASKELL__
50 import GHC.Num
51 import GHC.Real
52 import GHC.Base
53 #endif
54
55 #ifdef __HUGS__
56 import Hugs.Bits
57 #endif
58
59 infixl 8 `shift`, `rotate`, `shiftL`, `shiftR`, `rotateL`, `rotateR`
60 infixl 7 .&.
61 infixl 6 `xor`
62 infixl 5 .|.
63
64 {-|
65 The 'Bits' class defines bitwise operations over integral types.
66
67 * Bits are numbered from 0 with bit 0 being the least
68 significant bit.
69
70 Minimal complete definition: '.&.', '.|.', 'xor', 'complement',
71 ('shift' or ('shiftL' and 'shiftR')), ('rotate' or ('rotateL' and 'rotateR')),
72 'bitSize' and 'isSigned'.
73 -}
74 class Num a => Bits a where
75 -- | Bitwise \"and\"
76 (.&.) :: a -> a -> a
77
78 -- | Bitwise \"or\"
79 (.|.) :: a -> a -> a
80
81 -- | Bitwise \"xor\"
82 xor :: a -> a -> a
83
84 {-| Reverse all the bits in the argument -}
85 complement :: a -> a
86
87 {-| Shift the argument left by the specified number of bits.
88 Right shifts (signed) are specified by giving a negative value.
89
90 An instance can define either this unified 'shift' or 'shiftL' and
91 'shiftR', depending on which is more convenient for the type in
92 question. -}
93 shift :: a -> Int -> a
94
95 x `shift` i | i<0 = x `shiftR` (-i)
96 | i==0 = x
97 | i>0 = x `shiftL` i
98
99 {-| Rotate the argument left by the specified number of bits.
100 Right rotates are specified by giving a negative value.
101
102 For unbounded types like 'Integer', 'rotate' is equivalent to 'shift'.
103
104 An instance can define either this unified 'rotate' or 'rotateL' and
105 'rotateR', depending on which is more convenient for the type in
106 question. -}
107 rotate :: a -> Int -> a
108
109 x `rotate` i | i<0 = x `rotateR` (-i)
110 | i==0 = x
111 | i>0 = x `rotateL` i
112
113 {-
114 -- Rotation can be implemented in terms of two shifts, but care is
115 -- needed for negative values. This suggested implementation assumes
116 -- 2's-complement arithmetic. It is commented out because it would
117 -- require an extra context (Ord a) on the signature of 'rotate'.
118 x `rotate` i | i<0 && isSigned x && x<0
119 = let left = i+bitSize x in
120 ((x `shift` i) .&. complement ((-1) `shift` left))
121 .|. (x `shift` left)
122 | i<0 = (x `shift` i) .|. (x `shift` (i+bitSize x))
123 | i==0 = x
124 | i>0 = (x `shift` i) .|. (x `shift` (i-bitSize x))
125 -}
126
127 -- | @bit i@ is a value with the @i@th bit set
128 bit :: Int -> a
129
130 -- | @x \`setBit\` i@ is the same as @x .|. bit i@
131 setBit :: a -> Int -> a
132
133 -- | @x \`clearBit\` i@ is the same as @x .&. complement (bit i)@
134 clearBit :: a -> Int -> a
135
136 -- | @x \`complementBit\` i@ is the same as @x \`xor\` bit i@
137 complementBit :: a -> Int -> a
138
139 -- | Return 'True' if the @n@th bit of the argument is 1
140 testBit :: a -> Int -> Bool
141
142 {-| Return the number of bits in the type of the argument. The actual
143 value of the argument is ignored. The function 'bitSize' is
144 undefined for types that do not have a fixed bitsize, like 'Integer'.
145 -}
146 bitSize :: a -> Int
147
148 {-| Return 'True' if the argument is a signed type. The actual
149 value of the argument is ignored -}
150 isSigned :: a -> Bool
151
152 bit i = 1 `shiftL` i
153 x `setBit` i = x .|. bit i
154 x `clearBit` i = x .&. complement (bit i)
155 x `complementBit` i = x `xor` bit i
156 x `testBit` i = (x .&. bit i) /= 0
157
158 {-| Shift the argument left by the specified number of bits
159 (which must be non-negative).
160
161 An instance can define either this and 'shiftR' or the unified
162 'shift', depending on which is more convenient for the type in
163 question. -}
164 shiftL :: a -> Int -> a
165 x `shiftL` i = x `shift` i
166
167 {-| Shift the argument right (signed) by the specified number of bits
168 (which must be non-negative).
169
170 An instance can define either this and 'shiftL' or the unified
171 'shift', depending on which is more convenient for the type in
172 question. -}
173 shiftR :: a -> Int -> a
174 x `shiftR` i = x `shift` (-i)
175
176 {-| Rotate the argument left by the specified number of bits
177 (which must be non-negative).
178
179 An instance can define either this and 'rotateR' or the unified
180 'rotate', depending on which is more convenient for the type in
181 question. -}
182 rotateL :: a -> Int -> a
183 x `rotateL` i = x `rotate` i
184
185 {-| Rotate the argument right by the specified number of bits
186 (which must be non-negative).
187
188 An instance can define either this and 'rotateL' or the unified
189 'rotate', depending on which is more convenient for the type in
190 question. -}
191 rotateR :: a -> Int -> a
192 x `rotateR` i = x `rotate` (-i)
193
194 instance Bits Int where
195 {-# INLINE shift #-}
196
197 #ifdef __GLASGOW_HASKELL__
198 (I# x#) .&. (I# y#) = I# (word2Int# (int2Word# x# `and#` int2Word# y#))
199 (I# x#) .|. (I# y#) = I# (word2Int# (int2Word# x# `or#` int2Word# y#))
200 (I# x#) `xor` (I# y#) = I# (word2Int# (int2Word# x# `xor#` int2Word# y#))
201 complement (I# x#) = I# (word2Int# (int2Word# x# `xor#` int2Word# (-1#)))
202 (I# x#) `shift` (I# i#)
203 | i# >=# 0# = I# (x# `iShiftL#` i#)
204 | otherwise = I# (x# `iShiftRA#` negateInt# i#)
205 (I# x#) `rotate` (I# i#) =
206 I# (word2Int# ((x'# `uncheckedShiftL#` i'#) `or#`
207 (x'# `uncheckedShiftRL#` (wsib -# i'#))))
208 where
209 x'# = int2Word# x#
210 i'# = word2Int# (int2Word# i# `and#` int2Word# (wsib -# 1#))
211 wsib = WORD_SIZE_IN_BITS# {- work around preprocessor problem (??) -}
212 bitSize _ = WORD_SIZE_IN_BITS
213 #else /* !__GLASGOW_HASKELL__ */
214
215 #ifdef __HUGS__
216 (.&.) = primAndInt
217 (.|.) = primOrInt
218 xor = primXorInt
219 complement = primComplementInt
220 shift = primShiftInt
221 bit = primBitInt
222 testBit = primTestInt
223 bitSize _ = SIZEOF_HSINT*8
224 #elif defined(__NHC__)
225 (.&.) = nhc_primIntAnd
226 (.|.) = nhc_primIntOr
227 xor = nhc_primIntXor
228 complement = nhc_primIntCompl
229 shiftL = nhc_primIntLsh
230 shiftR = nhc_primIntRsh
231 bitSize _ = 32
232 #endif /* __NHC__ */
233
234 x `rotate` i
235 | i<0 && x<0 = let left = i+bitSize x in
236 ((x `shift` i) .&. complement ((-1) `shift` left))
237 .|. (x `shift` left)
238 | i<0 = (x `shift` i) .|. (x `shift` (i+bitSize x))
239 | i==0 = x
240 | i>0 = (x `shift` i) .|. (x `shift` (i-bitSize x))
241
242 #endif /* !__GLASGOW_HASKELL__ */
243
244 isSigned _ = True
245
246 #ifdef __NHC__
247 foreign import ccall nhc_primIntAnd :: Int -> Int -> Int
248 foreign import ccall nhc_primIntOr :: Int -> Int -> Int
249 foreign import ccall nhc_primIntXor :: Int -> Int -> Int
250 foreign import ccall nhc_primIntLsh :: Int -> Int -> Int
251 foreign import ccall nhc_primIntRsh :: Int -> Int -> Int
252 foreign import ccall nhc_primIntCompl :: Int -> Int
253 #endif /* __NHC__ */
254
255 instance Bits Integer where
256 #ifdef __GLASGOW_HASKELL__
257 (S# x) .&. (S# y) = S# (word2Int# (int2Word# x `and#` int2Word# y))
258 x@(S# _) .&. y = toBig x .&. y
259 x .&. y@(S# _) = x .&. toBig y
260 (J# s1 d1) .&. (J# s2 d2) =
261 case andInteger# s1 d1 s2 d2 of
262 (# s, d #) -> J# s d
263
264 (S# x) .|. (S# y) = S# (word2Int# (int2Word# x `or#` int2Word# y))
265 x@(S# _) .|. y = toBig x .|. y
266 x .|. y@(S# _) = x .|. toBig y
267 (J# s1 d1) .|. (J# s2 d2) =
268 case orInteger# s1 d1 s2 d2 of
269 (# s, d #) -> J# s d
270
271 (S# x) `xor` (S# y) = S# (word2Int# (int2Word# x `xor#` int2Word# y))
272 x@(S# _) `xor` y = toBig x `xor` y
273 x `xor` y@(S# _) = x `xor` toBig y
274 (J# s1 d1) `xor` (J# s2 d2) =
275 case xorInteger# s1 d1 s2 d2 of
276 (# s, d #) -> J# s d
277
278 complement (S# x) = S# (word2Int# (int2Word# x `xor#` int2Word# (0# -# 1#)))
279 complement (J# s d) = case complementInteger# s d of (# s, d #) -> J# s d
280 #else
281 -- reduce bitwise binary operations to special cases we can handle
282
283 x .&. y | x<0 && y<0 = complement (complement x `posOr` complement y)
284 | otherwise = x `posAnd` y
285
286 x .|. y | x<0 || y<0 = complement (complement x `posAnd` complement y)
287 | otherwise = x `posOr` y
288
289 x `xor` y | x<0 && y<0 = complement x `posXOr` complement y
290 | x<0 = complement (complement x `posXOr` y)
291 | y<0 = complement (x `posXOr` complement y)
292 | otherwise = x `posXOr` y
293
294 -- assuming infinite 2's-complement arithmetic
295 complement a = -1 - a
296 #endif
297
298 shift x i | i >= 0 = x * 2^i
299 | otherwise = x `div` 2^(-i)
300
301 rotate x i = shift x i -- since an Integer never wraps around
302
303 bitSize _ = error "Data.Bits.bitSize(Integer)"
304 isSigned _ = True
305
306 #ifndef __GLASGOW_HASKELL__
307 -- Crude implementation of bitwise operations on Integers: convert them
308 -- to finite lists of Ints (least significant first), zip and convert
309 -- back again.
310
311 -- posAnd requires at least one argument non-negative
312 -- posOr and posXOr require both arguments non-negative
313
314 posAnd, posOr, posXOr :: Integer -> Integer -> Integer
315 posAnd x y = fromInts $ zipWith (.&.) (toInts x) (toInts y)
316 posOr x y = fromInts $ longZipWith (.|.) (toInts x) (toInts y)
317 posXOr x y = fromInts $ longZipWith xor (toInts x) (toInts y)
318
319 longZipWith :: (a -> a -> a) -> [a] -> [a] -> [a]
320 longZipWith f xs [] = xs
321 longZipWith f [] ys = ys
322 longZipWith f (x:xs) (y:ys) = f x y:longZipWith f xs ys
323
324 toInts :: Integer -> [Int]
325 toInts n
326 | n == 0 = []
327 | otherwise = mkInt (n `mod` numInts):toInts (n `div` numInts)
328 where mkInt n | n > toInteger(maxBound::Int) = fromInteger (n-numInts)
329 | otherwise = fromInteger n
330
331 fromInts :: [Int] -> Integer
332 fromInts = foldr catInt 0
333 where catInt d n = (if d<0 then n+1 else n)*numInts + toInteger d
334
335 numInts = toInteger (maxBound::Int) - toInteger (minBound::Int) + 1
336 #endif /* !__GLASGOW_HASKELL__ */