[project @ 2005-01-11 16:04:08 by simonmar]
[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 class Num a => Bits a where
71 -- | Bitwise \"and\"
72 (.&.) :: a -> a -> a
73
74 -- | Bitwise \"or\"
75 (.|.) :: a -> a -> a
76
77 -- | Bitwise \"xor\"
78 xor :: a -> a -> a
79
80 {-| Reverse all the bits in the argument -}
81 complement :: a -> a
82
83 {-| Shift the argument left by the specified number of bits.
84 Right shifts (signed) are specified by giving a negative value.
85
86 An instance can define either this unified 'shift' or 'shiftL' and
87 'shiftR', depending on which is more convenient for the type in
88 question. -}
89 shift :: a -> Int -> a
90
91 x `shift` i | i<0 = x `shiftR` (-i)
92 | i==0 = x
93 | i>0 = x `shiftL` i
94
95 {-| Rotate the argument left by the specified number of bits.
96 Right rotates are specified by giving a negative value.
97
98 For unbounded types like 'Integer', 'rotate' is equivalent to 'shift'.
99
100 An instance can define either this unified 'rotate' or 'rotateL' and
101 'rotateR', depending on which is more convenient for the type in
102 question. -}
103 rotate :: a -> Int -> a
104
105 x `rotate` i | i<0 = x `rotateR` (-i)
106 | i==0 = x
107 | i>0 = x `rotateL` i
108
109 {-
110 -- Rotation can be implemented in terms of two shifts, but care is
111 -- needed for negative values. This suggested implementation assumes
112 -- 2's-complement arithmetic. It is commented out because it would
113 -- require an extra context (Ord a) on the signature of 'rotate'.
114 x `rotate` i | i<0 && isSigned x && x<0
115 = let left = i+bitSize x in
116 ((x `shift` i) .&. complement ((-1) `shift` left))
117 .|. (x `shift` left)
118 | i<0 = (x `shift` i) .|. (x `shift` (i+bitSize x))
119 | i==0 = x
120 | i>0 = (x `shift` i) .|. (x `shift` (i-bitSize x))
121 -}
122
123 -- | @bit i@ is a value with the @i@th bit set
124 bit :: Int -> a
125
126 -- | @x \`setBit\` i@ is the same as @x .|. bit i@
127 setBit :: a -> Int -> a
128
129 -- | @x \`clearBit\` i@ is the same as @x .&. complement (bit i)@
130 clearBit :: a -> Int -> a
131
132 -- | @x \`complementBit\` i@ is the same as @x \`xor\` bit i@
133 complementBit :: a -> Int -> a
134
135 -- | Return 'True' if the @n@th bit of the argument is 1
136 testBit :: a -> Int -> Bool
137
138 {-| Return the number of bits in the type of the argument. The actual
139 value of the argument is ignored. The function 'bitSize' is
140 undefined for types that do not have a fixed bitsize, like 'Integer'.
141 -}
142 bitSize :: a -> Int
143
144 {-| Return 'True' if the argument is a signed type. The actual
145 value of the argument is ignored -}
146 isSigned :: a -> Bool
147
148 bit i = 1 `shiftL` i
149 x `setBit` i = x .|. bit i
150 x `clearBit` i = x .&. complement (bit i)
151 x `complementBit` i = x `xor` bit i
152 x `testBit` i = (x .&. bit i) /= 0
153
154 {-| Shift the argument left by the specified number of bits
155 (which must be non-negative).
156
157 An instance can define either this and 'shiftR' or the unified
158 'shift', depending on which is more convenient for the type in
159 question. -}
160 shiftL :: a -> Int -> a
161 x `shiftL` i = x `shift` i
162
163 {-| Shift the argument right (signed) by the specified number of bits
164 (which must be non-negative).
165
166 An instance can define either this and 'shiftL' or the unified
167 'shift', depending on which is more convenient for the type in
168 question. -}
169 shiftR :: a -> Int -> a
170 x `shiftR` i = x `shift` (-i)
171
172 {-| Rotate the argument left by the specified number of bits
173 (which must be non-negative).
174
175 An instance can define either this and 'rotateR' or the unified
176 'rotate', depending on which is more convenient for the type in
177 question. -}
178 rotateL :: a -> Int -> a
179 x `rotateL` i = x `rotate` i
180
181 {-| Rotate the argument right by the specified number of bits
182 (which must be non-negative).
183
184 An instance can define either this and 'rotateL' or the unified
185 'rotate', depending on which is more convenient for the type in
186 question. -}
187 rotateR :: a -> Int -> a
188 x `rotateR` i = x `rotate` (-i)
189
190 instance Bits Int where
191 #ifdef __GLASGOW_HASKELL__
192 (I# x#) .&. (I# y#) = I# (word2Int# (int2Word# x# `and#` int2Word# y#))
193 (I# x#) .|. (I# y#) = I# (word2Int# (int2Word# x# `or#` int2Word# y#))
194 (I# x#) `xor` (I# y#) = I# (word2Int# (int2Word# x# `xor#` int2Word# y#))
195 complement (I# x#) = I# (word2Int# (int2Word# x# `xor#` int2Word# (-1#)))
196 (I# x#) `shift` (I# i#)
197 | i# >=# 0# = I# (x# `iShiftL#` i#)
198 | otherwise = I# (x# `iShiftRA#` negateInt# i#)
199 (I# x#) `rotate` (I# i#) =
200 I# (word2Int# ((x'# `shiftL#` i'#) `or#`
201 (x'# `shiftRL#` (wsib -# i'#))))
202 where
203 x'# = int2Word# x#
204 i'# = word2Int# (int2Word# i# `and#` int2Word# (wsib -# 1#))
205 wsib = WORD_SIZE_IN_BITS# {- work around preprocessor problem (??) -}
206 bitSize _ = WORD_SIZE_IN_BITS
207 #else /* !__GLASGOW_HASKELL__ */
208
209 #ifdef __HUGS__
210 (.&.) = primAndInt
211 (.|.) = primOrInt
212 xor = primXorInt
213 complement = primComplementInt
214 shift = primShiftInt
215 bit = primBitInt
216 testBit = primTestInt
217 bitSize _ = SIZEOF_HSINT*8
218 #elif defined(__NHC__)
219 (.&.) = nhc_primIntAnd
220 (.|.) = nhc_primIntOr
221 xor = nhc_primIntXor
222 complement = nhc_primIntCompl
223 shiftL = nhc_primIntLsh
224 shiftR = nhc_primIntRsh
225 bitSize _ = 32
226 #endif /* __NHC__ */
227
228 x `rotate` i
229 | i<0 && x<0 = let left = i+bitSize x in
230 ((x `shift` i) .&. complement ((-1) `shift` left))
231 .|. (x `shift` left)
232 | i<0 = (x `shift` i) .|. (x `shift` (i+bitSize x))
233 | i==0 = x
234 | i>0 = (x `shift` i) .|. (x `shift` (i-bitSize x))
235
236 #endif /* !__GLASGOW_HASKELL__ */
237
238 isSigned _ = True
239
240 #ifdef __NHC__
241 foreign import ccall nhc_primIntAnd :: Int -> Int -> Int
242 foreign import ccall nhc_primIntOr :: Int -> Int -> Int
243 foreign import ccall nhc_primIntXor :: Int -> Int -> Int
244 foreign import ccall nhc_primIntLsh :: Int -> Int -> Int
245 foreign import ccall nhc_primIntRsh :: Int -> Int -> Int
246 foreign import ccall nhc_primIntCompl :: Int -> Int
247 #endif /* __NHC__ */
248
249 instance Bits Integer where
250 #ifdef __GLASGOW_HASKELL__
251 (S# x) .&. (S# y) = S# (word2Int# (int2Word# x `and#` int2Word# y))
252 x@(S# _) .&. y = toBig x .&. y
253 x .&. y@(S# _) = x .&. toBig y
254 (J# s1 d1) .&. (J# s2 d2) =
255 case andInteger# s1 d1 s2 d2 of
256 (# s, d #) -> J# s d
257
258 (S# x) .|. (S# y) = S# (word2Int# (int2Word# x `or#` int2Word# y))
259 x@(S# _) .|. y = toBig x .|. y
260 x .|. y@(S# _) = x .|. toBig y
261 (J# s1 d1) .|. (J# s2 d2) =
262 case orInteger# s1 d1 s2 d2 of
263 (# s, d #) -> J# s d
264
265 (S# x) `xor` (S# y) = S# (word2Int# (int2Word# x `xor#` int2Word# y))
266 x@(S# _) `xor` y = toBig x `xor` y
267 x `xor` y@(S# _) = x `xor` toBig y
268 (J# s1 d1) `xor` (J# s2 d2) =
269 case xorInteger# s1 d1 s2 d2 of
270 (# s, d #) -> J# s d
271
272 complement (S# x) = S# (word2Int# (int2Word# x `xor#` int2Word# (0# -# 1#)))
273 complement (J# s d) = case complementInteger# s d of (# s, d #) -> J# s d
274 #else
275 -- reduce bitwise binary operations to special cases we can handle
276
277 x .&. y | x<0 && y<0 = complement (complement x `posOr` complement y)
278 | otherwise = x `posAnd` y
279
280 x .|. y | x<0 || y<0 = complement (complement x `posAnd` complement y)
281 | otherwise = x `posOr` y
282
283 x `xor` y | x<0 && y<0 = complement x `posXOr` complement y
284 | x<0 = complement (complement x `posXOr` y)
285 | y<0 = complement (x `posXOr` complement y)
286 | otherwise = x `posXOr` y
287
288 -- assuming infinite 2's-complement arithmetic
289 complement a = -1 - a
290 #endif
291
292 shift x i | i >= 0 = x * 2^i
293 | otherwise = x `div` 2^(-i)
294
295 rotate x i = shift x i -- since an Integer never wraps around
296
297 bitSize _ = error "Data.Bits.bitSize(Integer)"
298 isSigned _ = True
299
300 #ifndef __GLASGOW_HASKELL__
301 -- Crude implementation of bitwise operations on Integers: convert them
302 -- to finite lists of Ints (least significant first), zip and convert
303 -- back again.
304
305 -- posAnd requires at least one argument non-negative
306 -- posOr and posXOr require both arguments non-negative
307
308 posAnd, posOr, posXOr :: Integer -> Integer -> Integer
309 posAnd x y = fromInts $ zipWith (.&.) (toInts x) (toInts y)
310 posOr x y = fromInts $ longZipWith (.|.) (toInts x) (toInts y)
311 posXOr x y = fromInts $ longZipWith xor (toInts x) (toInts y)
312
313 longZipWith :: (a -> a -> a) -> [a] -> [a] -> [a]
314 longZipWith f xs [] = xs
315 longZipWith f [] ys = ys
316 longZipWith f (x:xs) (y:ys) = f x y:longZipWith f xs ys
317
318 toInts :: Integer -> [Int]
319 toInts n
320 | n == 0 = []
321 | otherwise = mkInt (n `mod` numInts):toInts (n `div` numInts)
322 where mkInt n | n > toInteger(maxBound::Int) = fromInteger (n-numInts)
323 | otherwise = fromInteger n
324
325 fromInts :: [Int] -> Integer
326 fromInts = foldr catInt 0
327 where catInt d n = (if d<0 then n+1 else n)*numInts + toInteger d
328
329 numInts = toInteger (maxBound::Int) - toInteger (minBound::Int) + 1
330 #endif /* !__GLASGOW_HASKELL__ */