@@ -4,6 +4,7 @@
44-- |
55-- Module : Data.Binary.Bits.Get
66-- Copyright : (c) Lennart Kolmodin 2010-2011
7+-- (c) Sylvain Henry 2015
78-- License : BSD3-style (see LICENSE)
89--
910-- Maintainer : kolmodin@gmail.com
@@ -55,14 +56,11 @@ module Data.Binary.Bits.Get
5556 -- $bitget
5657
5758 BitGet
58− , BitOrder(..)
5959 , runBitGet
60− , getBitOrder
61− , selectBitOrder
62− , withBitOrder
6360
6461 -- ** Get bytes
6562 , getBool
63+ , getBool#
6664 , getWord8
6765 , getWord16
6866 , getWord32
@@ -99,6 +97,9 @@ module Data.Binary.Bits.Get
9997
10098import Data.Binary.Get as B ( Get, getLazyByteString, isEmpty )
10199import Data.Binary.Get.Internal as B ( get, put, ensureN )
100+import Data.Binary.Bits.BitOrder
101+import Data.Binary.Bits.Internal
102+import Data.Binary.Bits.Alignment
102103
103104import Data.ByteString as B
104105import qualified Data.ByteString.Lazy as L
@@ -114,12 +115,8 @@ import Control.Applicative
114115import Control.Monad (when,foldM_)
115116
116117import Prelude as P
117−
118−#if defined(__GLASGOW_HASKELL__) && !defined(__HADDOCK__)
119−import GHC.Base
120118import GHC.Word
121−#endif
122−
119+import GHC.Base (uncheckedShiftLWord8#, wordToWord8#, Int (..), andWord8#, Word8#, (-#), Int#, xorI#, eqWord8#, TYPE)
123120
124121-- $bitget
125122-- Parse bits using a monad.
@@ -172,16 +169,6 @@ data S = S {-# UNPACK #-} !ByteString -- Input
172169 !BitOrder -- Bit order
173170 deriving (Show)
174171
175−-- | Compute bit offset (equivalent to x `mod` 8 but faster)
176−bit_offset :: Int -> Int
177−bit_offset n = make_mask 3 .&. n
178−{-# INLINE bit_offset #-}
179−
180−-- | Compute byte offset (equivalent to x `div` 8 but faster)
181−byte_offset :: Int -> Int
182−byte_offset n = n `shiftR` 3
183−{-# INLINE byte_offset #-}
184−
185172-- | Increment the current bit offset
186173incS :: Int -> S -> S
187174incS o (S bs n bo) = S (unsafeDrop d bs) n' bo
@@ -190,58 +177,30 @@ incS o (S bs n bo) = S (unsafeDrop d bs) n' bo
190177 !d = byte_offset o'
191178 !n' = bit_offset o'
192179
193−-- | Select the bit ordering
194−selectBitOrderS :: BitOrder -> S -> S
195−selectBitOrderS bo (S bs o _) = S bs o bo
196−
197−-- | make_mask 3 = 00000111
198−make_mask :: (Bits a, Num a) => Int -> a
199−make_mask n = (1 `shiftL` fromIntegral n) - 1
200−{-# SPECIALIZE make_mask :: Int -> Int #-}
201−{-# SPECIALIZE make_mask :: Int -> Word #-}
202−{-# SPECIALIZE make_mask :: Int -> Word8 #-}
203−{-# SPECIALIZE make_mask :: Int -> Word16 #-}
204−{-# SPECIALIZE make_mask :: Int -> Word32 #-}
205−{-# SPECIALIZE make_mask :: Int -> Word64 #-}
206−
207−-- | Keep only the n least-significant bits of the given value
208−mask :: (Bits a, Num a) => Int -> a -> a
209−mask n v = v .&. make_mask n
210−{-# INLINE mask #-}
211−
212−-- | Bit order
213−--
214−-- E.g. two words of 5 bits: ABCDE, VWXYZ
215−-- - BB: ABCDEVWX YZxxxxxx
216−-- - LB: XYZABCDE xxxxxxVW
217−-- - BL: EDCBAZYX WVxxxxxx
218−-- - LL: XWVEDCBA xxxxxxZY
219−data BitOrder = BB | LB | BL | LL deriving (Show)
220−
221−-- | Reverse the @n@ least important bits of the given value
222−reverseBits :: (Num a, FastBits a, Bits a) => Int -> a -> a
223−reverseBits n value = rec value n 0
224− where
225− -- rec v i r, where
226− -- v is orginal value shifted
227− -- i is the remaining number of bits
228− -- r is current value
229− rec 0 0 r = r
230− rec 0 i r = r `fastShiftL` i
231− rec v i r = rec (v `fastShiftR` 1) (i-1) ((r `fastShiftL` 1) .|. (v .&. 0x1))
232−
233180-- | Read a single bit
234181readBool :: S -> Bool
235182readBool (S bs o bo) = case bo of
236183 BB -> testBit (unsafeHead bs) (7-o)
237184 BL -> testBit (unsafeHead bs) (7-o)
238− LB -> testBit (unsafeHead bs) o
239185 LL -> testBit (unsafeHead bs) o
186+ LB -> testBit (unsafeHead bs) o
187+
188+-- | Read a single bit
189+readBool# :: S -> Int
190+readBool# (S bs (I# o) bo) = case bo of
191+ BB -> testBit# (7# -# o)
192+ BL -> testBit# (7# -# o)
193+ LL -> testBit# o
194+ LB -> testBit# o
195+ where
196+ !(W8# w) = unsafeHead bs
197+ testBit# n = I# (((w `andWord8#` (wordToWord8# 1## `uncheckedShiftLWord8#` n)) `eqWord8#` wordToWord8# 0##) `xorI#` 1#)
198+
240199
241200-- | Extract a range of bits from (ws :: ByteString)
242201--
243202-- Constraint: 8 * (length ws -1 ) < o+n <= 8 * length ws
244−extract :: (Num a, Bits a, FastBits a) => BitOrder -> ByteString -> Int -> Int -> a
203+extract :: (Num a, FastBits a) => BitOrder -> ByteString -> Int -> Int -> a
245204extract bo bs o n
246205 | n == 0 = 0
247206 | B.length bs == 0 = error "Empty ByteString"
@@ -259,36 +218,29 @@ extract bo bs o n
259218
260219 -- shift offset depending on the byte position (0..B.length-1)
261220 off i = case bo of
262− LB -> 8*i - o
263221 LL -> 8*i - o
222+ LB -> 8*i - o
264223 BB -> (B.length bs -1 - i) * 8 - r
265224 BL -> (B.length bs -1 - i) * 8 - r
266225
267226 -- reverse bits if necessary
268227 rev = case bo of
269− LL -> reverseBits n
228+ LB -> reverseBits n
270229 BL -> reverseBits n
271230 BB -> id
272− LB -> id
231+ LL -> id
273232
274233
275234-- | Generic readWord
276−readWord :: (Num a, Bits a, FastBits a) => Int -> S -> a
235+readWord :: (Num a, FastBits a) => Int -> S -> a
277236readWord n (S bs o bo)
278237 | n == 0 = 0
279− | o+n <= 8 = extract bo (unsafeTake 1 bs) o n
280− | o+n <= 16 = extract bo (unsafeTake 2 bs) o n
281− | o+n <= 24 = extract bo (unsafeTake 3 bs) o n
282− | o+n <= 32 = extract bo (unsafeTake 4 bs) o n
283− | o+n <= 40 = extract bo (unsafeTake 5 bs) o n
284− | o+n <= 48 = extract bo (unsafeTake 6 bs) o n
285− | o+n <= 56 = extract bo (unsafeTake 7 bs) o n
286− | o+n <= 64 = extract bo (unsafeTake 8 bs) o n
287− | otherwise = extract bo (unsafeTake ((o+n+7) `div` 8) bs) o n
238+ | otherwise = extract bo (unsafeTake nbytes bs) o n
239+ where nbytes = byte_offset (o+n+7)
288240
289241-- | Check that the number of bits to read is not greater than the first parameter
290242{-# INLINE readWordChecked #-}
291−readWordChecked :: (Num a, Bits a, FastBits a) => Int -> Int -> S -> a
243+readWordChecked :: (Num a, FastBits a) => Int -> Int -> S -> a
292244readWordChecked m n s
293245 | n > m = error $ "Tried to read more than " ++ show m ++ " bits (" ++ show n ++")"
294246 | otherwise = readWord n s
@@ -297,22 +249,23 @@ readWordChecked m n s
297249--
298250-- Examples:
299251-- BB: xxxABCDE FGHIJKLM NOPxxxxx -> ABCDEFGH IJKLMNOP
300−-- LB: LMNOPxxx DEFGHIJK xxxxxABC -> ABCDEFGH IJKLMNOP
252+-- LL: LMNOPxxx DEFGHIJK xxxxxABC -> ABCDEFGH IJKLMNOP
301253-- BL: xxxPONML KJIHGFED CBAxxxxx -> ABCDEFGH IJKLMNOP
302−-- LL: EDCBAxxx MLKJIHGF xxxxxPON -> ABCDEFGH IJKLMNOP
254+-- LB: EDCBAxxx MLKJIHGF xxxxxPON -> ABCDEFGH IJKLMNOP
303255readByteString :: Int -> S -> ByteString
304256readByteString n (S bs o bo) =
305257 let
306− bs' = unsafeTake (n+1) bs
307− rev = B.map (reverseBits 8)
258+ bs' = unsafeTake (n+1) bs
259+ bs'' = unsafeTake n bs
260+ rev = B.map (reverseBits 8)
308261 in case (o,bo) of
309− (0,BB) -> unsafeTake n bs
310− (0,LB) -> B.reverse (unsafeTake n bs)
311− (0,BL) -> rev (unsafeTake n bs)
312− (0,LL) -> rev (B.reverse (unsafeTake n bs))
313− (_,BL) -> rev (readByteString n (S (B.reverse bs') o LB))
314− (_,LL) -> rev (readByteString n (S (B.reverse bs') o BB))
315− (_,LB) -> readByteString n (S (B.reverse bs') o BB)
262+ (0,BB) -> bs''
263+ (0,LL) -> B.reverse bs''
264+ (0,LB) -> rev bs''
265+ (0,BL) -> rev . B.reverse $ bs''
266+ (_,LL) -> readByteString n (S (B.reverse bs') (8-o) BB)
267+ (_,BL) -> rev . B.reverse $ readByteString n (S bs' o BB)
268+ (_,LB) -> rev . B.reverse $ readByteString n (S bs' o LL)
316269 (_,BB) -> unsafePerformIO $ do
317270 let len = n+1
318271 ptr <- mallocBytes len
@@ -334,7 +287,6 @@ newtype BitGet a = B { runState :: S -> Get (S,a) }
334287
335288instance Monad BitGet where
336289 return x = B $ \s -> return (s,x)
337− fail str = B $ \s -> putBackState s >> fail str
338290 (B f) >>= g = B $ \s -> do (s',a) <- f s
339291 runState (g a) s'
340292
@@ -345,6 +297,29 @@ instance Applicative BitGet where
345297 pure x = return x
346298 fm <*> m = fm >>= \f -> m >>= \v -> return (f v)
347299
300+instance BitOrderable BitGet where
301+ setBitOrder bo = do
302+ (S bs o _) <- getState
303+ putState (S bs o bo)
304+
305+ getBitOrder = do
306+ (S _ _ bo) <- getState
307+ return bo
308+
309+instance Alignable BitGet where
310+ -- | Skip the given number of bits
311+ skipBits n = do
312+ ensureBits n
313+ withState (incS n)
314+
315+ -- | Skip bits if necessary to align to the next byte
316+ alignByte = do
317+ (S _ o _) <- getState
318+ when (o /= 0) $
319+ skipBits (8-o)
320+
321+
322+
348323-- | Run a 'BitGet' within the Binary packages 'Get' monad. If a byte has
349324-- been partially consumed it will be discarded once 'runBitGet' is finished.
350325runBitGet :: BitGet a -> Get a
@@ -379,13 +354,6 @@ withState f = do
379354 s <- getState
380355 putState $! f s
381356
382−-- | Get the bit ordering
383−getBitOrder :: BitGet BitOrder
384−getBitOrder = do
385− (S _ _ bo) <- getState
386− return bo
387−
388−
389357-- | Make sure there are at least @n@ bits.
390358ensureBits :: Int -> BitGet ()
391359ensureBits n = do
@@ -399,33 +367,6 @@ ensureBits n = do
399367 put B.empty
400368 return (S (bs`append`bs') o bo, ())
401369
402−-- | Skip the given number of bits
403−skipBits :: Int -> BitGet ()
404−skipBits n = do
405− ensureBits n
406− withState (incS n)
407−
408−-- | Skip bits if necessary to align to the next byte
409−alignByte :: BitGet ()
410−alignByte = do
411− (S _ o _) <- getState
412− when (o /= 0) $
413− skipBits (8-o)
414−
415−-- | Select the bit ordering
416−selectBitOrder :: BitOrder -> BitGet ()
417−selectBitOrder = withState . selectBitOrderS
418−
419−withBitOrder :: BitOrder -> BitGet a -> BitGet a
420−withBitOrder bo f = do
421− bo' <- getBitOrder
422− selectBitOrder bo
423− r <- f
424− selectBitOrder bo'
425− return r
426−
427−
428−
429370-- | Test whether all input has been consumed, i.e. there are no remaining
430371-- undecoded bytes.
431372isEmpty :: BitGet Bool
@@ -437,6 +378,10 @@ isEmpty = B $ \ (S bs o bo) -> if B.null bs
437378getBool :: BitGet Bool
438379getBool = block bool
439380
381+-- | Get 1 bit as a 'Bool'.
382+getBool# :: BitGet Int
383+getBool# = block bool#
384+
440385-- | Get @n@ bits as a 'Word8'. @n@ must be within @[0..8]@.
441386getWord8 :: Int -> BitGet Word8
442387getWord8 n = block (word8 n)
@@ -512,6 +457,10 @@ block (Block i p) = do
512457bool :: Block Bool
513458bool = Block 1 readBool
514459
460+-- | Read a 1 bit 'Bool'.
461+bool# :: Block Int
462+bool# = Block 1 readBool#
463+
515464-- | Read @n@ bits as a 'Word8'. @n@ must be within @[0..8]@.
516465word8 :: Int -> Block Word8
517466word8 n = Block n (readWordChecked 8 n)
@@ -545,84 +494,3 @@ byteString :: Int -> Block ByteString
545494byteString n | n > 0 = Block (n*8) (readByteString n)
546495 | otherwise = Block 0 (\_ -> B.empty)
547496
548−
549−---------------------------------------------------------------------
550−-- Unchecked shifts, from the "binary" package
551−
552−-- | Class for types supporting fast bit shifting
553−class FastBits a where
554− fastShiftR :: a -> Int -> a
555− fastShiftL :: a -> Int -> a
556−
557− {-# INLINE fastShift #-}
558− fastShift :: a -> Int -> a
559− fastShift x n
560− | n > 0 = fastShiftL x n
561− | n < 0 = fastShiftR x (negate n)
562− | otherwise = x
563−
564−instance FastBits Word8 where
565− fastShiftR = shiftr_w8
566− fastShiftL = shiftl_w8
567−
568−instance FastBits Word16 where
569− fastShiftR = shiftr_w16
570− fastShiftL = shiftl_w16
571−
572−instance FastBits Word32 where
573− fastShiftR = shiftr_w32
574− fastShiftL = shiftl_w32
575−
576−instance FastBits Word64 where
577− fastShiftR = shiftr_w64
578− fastShiftL = shiftl_w64
579−
580−
581−shiftl_w8 :: Word8 -> Int -> Word8
582−shiftl_w16 :: Word16 -> Int -> Word16
583−shiftl_w32 :: Word32 -> Int -> Word32
584−shiftl_w64 :: Word64 -> Int -> Word64
585−
586−shiftr_w8 :: Word8 -> Int -> Word8
587−shiftr_w16 :: Word16 -> Int -> Word16
588−shiftr_w32 :: Word32 -> Int -> Word32
589−shiftr_w64 :: Word64 -> Int -> Word64
590−
591−#if defined(__GLASGOW_HASKELL__) && !defined(__HADDOCK__)
592−shiftl_w8 (W8# w) (I# i) = W8# (w `uncheckedShiftL#` i)
593−shiftl_w16 (W16# w) (I# i) = W16# (w `uncheckedShiftL#` i)
594−shiftl_w32 (W32# w) (I# i) = W32# (w `uncheckedShiftL#` i)
595−
596−shiftr_w8 (W8# w) (I# i) = W8# (w `uncheckedShiftRL#` i)
597−shiftr_w16 (W16# w) (I# i) = W16# (w `uncheckedShiftRL#` i)
598−shiftr_w32 (W32# w) (I# i) = W32# (w `uncheckedShiftRL#` i)
599−
600−
601−#if WORD_SIZE_IN_BITS < 64
602−shiftl_w64 (W64# w) (I# i) = W64# (w `uncheckedShiftL64#` i)
603−shiftr_w64 (W64# w) (I# i) = W64# (w `uncheckedShiftRL64#` i)
604−
605−#if __GLASGOW_HASKELL__ <= 606
606−-- Exported by GHC.Word in GHC 6.8 and higher
607−foreign import ccall unsafe "stg_uncheckedShiftL64"
608− uncheckedShiftL64# :: Word64# -> Int# -> Word64#
609−foreign import ccall unsafe "stg_uncheckedShiftRL64"
610− uncheckedShiftRL64# :: Word64# -> Int# -> Word64#
611−#endif
612−
613−#else
614−shiftl_w64 (W64# w) (I# i) = W64# (w `uncheckedShiftL#` i)
615−shiftr_w64 (W64# w) (I# i) = W64# (w `uncheckedShiftRL#` i)
616−#endif
617−
618−#else
619−shiftl_w8 = shiftL
620−shiftl_w16 = shiftL
621−shiftl_w32 = shiftL
622−shiftl_w64 = shiftL
623−
624−shiftr_w8 = shiftR
625−shiftr_w16 = shiftR
626−shiftr_w32 = shiftR
627−shiftr_w64 = shiftR
628−#endif