@@ -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,12 +56,11 @@ module Data.Binary.Bits.Get
5556 -- $bitget
5657
5758 BitGet
58− , BitOrder(..)
5959 , runBitGet
60− , selectBitOrder
6160
6261 -- ** Get bytes
6362 , getBool
63+ , getBool#
6464 , getWord8
6565 , getWord16
6666 , getWord32
@@ -97,6 +97,9 @@ module Data.Binary.Bits.Get
9797
9898import Data.Binary.Get as B ( Get, getLazyByteString, isEmpty )
9999import 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
100103
101104import Data.ByteString as B
102105import qualified Data.ByteString.Lazy as L
@@ -112,12 +115,8 @@ import Control.Applicative
112115import Control.Monad (when,foldM_)
113116
114117import Prelude as P
115−
116−#if defined(__GLASGOW_HASKELL__) && !defined(__HADDOCK__)
117−import GHC.Base
118118import GHC.Word
119−#endif
120−
119+import GHC.Base (uncheckedShiftLWord8#, wordToWord8#, Int (..), andWord8#, Word8#, (-#), Int#, xorI#, eqWord8#, TYPE)
121120
122121-- $bitget
123122-- Parse bits using a monad.
@@ -170,16 +169,6 @@ data S = S {-# UNPACK #-} !ByteString -- Input
170169 !BitOrder -- Bit order
171170 deriving (Show)
172171
173−-- | Compute bit offset (equivalent to x `mod` 8 but faster)
174−bit_offset :: Int -> Int
175−bit_offset n = make_mask 3 .&. n
176−{-# INLINE bit_offset #-}
177−
178−-- | Compute byte offset (equivalent to x `div` 8 but faster)
179−byte_offset :: Int -> Int
180−byte_offset n = n `shiftR` 3
181−{-# INLINE byte_offset #-}
182−
183172-- | Increment the current bit offset
184173incS :: Int -> S -> S
185174incS o (S bs n bo) = S (unsafeDrop d bs) n' bo
@@ -188,83 +177,70 @@ incS o (S bs n bo) = S (unsafeDrop d bs) n' bo
188177 !d = byte_offset o'
189178 !n' = bit_offset o'
190179
191−-- | Select the bit ordering
192−selectBitOrderS :: BitOrder -> S -> S
193−selectBitOrderS bo (S bs o _) = S bs o bo
194−
195−-- | make_mask 3 = 00000111
196−make_mask :: (Bits a, Num a) => Int -> a
197−make_mask n = (1 `shiftL` fromIntegral n) - 1
198−{-# SPECIALIZE make_mask :: Int -> Int #-}
199−{-# SPECIALIZE make_mask :: Int -> Word #-}
200−{-# SPECIALIZE make_mask :: Int -> Word8 #-}
201−{-# SPECIALIZE make_mask :: Int -> Word16 #-}
202−{-# SPECIALIZE make_mask :: Int -> Word32 #-}
203−{-# SPECIALIZE make_mask :: Int -> Word64 #-}
204−
205−-- | Keep only the n least-significant bits of the given value
206−mask :: (Bits a, Num a) => Int -> a -> a
207−mask n v = v .&. make_mask n
208−{-# INLINE mask #-}
209−
210−-- | Bit order
211−--
212−-- E.g. two words of 5 bits: ABCDE, VWXYZ
213−-- - BB: ABCDEVWX YZxxxxxx
214−-- - LB: XYZABCDE xxxxxxVW
215−-- - BL: EDCBAZYX WVxxxxxx -- not implemented
216−-- - LL: XWVEDCBA xxxxxxZY -- not implemented
217−data BitOrder = BB | LB deriving (Show)
218−
219−
220180-- | Read a single bit
221181readBool :: S -> Bool
222182readBool (S bs o bo) = case bo of
223183 BB -> testBit (unsafeHead bs) (7-o)
184+ BL -> testBit (unsafeHead bs) (7-o)
185+ LL -> testBit (unsafeHead bs) o
224186 LB -> testBit (unsafeHead bs) o
225187
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+
199+
226200-- | Extract a range of bits from (ws :: ByteString)
227201--
228202-- Constraint: 8 * (length ws -1 ) < o+n <= 8 * length ws
229−extract :: (Num a, Bits a, FastBits a) => BitOrder -> ByteString -> Int -> Int -> a
203+extract :: (Num a, FastBits a) => BitOrder -> ByteString -> Int -> Int -> a
230204extract bo bs o n
231205 | n == 0 = 0
232206 | B.length bs == 0 = error "Empty ByteString"
233− | otherwise = mask n (foldlWithIndex' f 0 bs)
207+ | otherwise = rev . mask n . foldlWithIndex' f 0 $ bs
234208 where
235209 -- B.foldl' with index
236210 foldlWithIndex' op b = fst . B.foldl' g (b,0)
237211 where g (b',i) w = (op b' w i, (i+1))
238212
239213 -- 'or' correctly shifted words
240− f b w i = b .|. (fromIntegral w `fastShift` off i)
214+ f b w i = b .|. (fromIntegral w `fastShift` off i)
241215
242216 -- co-offset
243− r = B.length bs * 8 - (o + n)
217+ r = B.length bs * 8 - (o + n)
244218
245219 -- shift offset depending on the byte position (0..B.length-1)
246− off i = case bo of
220+ off i = case bo of
221+ LL -> 8*i - o
247222 LB -> 8*i - o
248223 BB -> (B.length bs -1 - i) * 8 - r
224+ BL -> (B.length bs -1 - i) * 8 - r
225+
226+ -- reverse bits if necessary
227+ rev = case bo of
228+ LB -> reverseBits n
229+ BL -> reverseBits n
230+ BB -> id
231+ LL -> id
249232
250233
251234-- | Generic readWord
252−readWord :: (Num a, Bits a, FastBits a) => Int -> S -> a
235+readWord :: (Num a, FastBits a) => Int -> S -> a
253236readWord n (S bs o bo)
254237 | n == 0 = 0
255− | o+n <= 8 = extract bo (unsafeTake 1 bs) o n
256− | o+n <= 16 = extract bo (unsafeTake 2 bs) o n
257− | o+n <= 24 = extract bo (unsafeTake 3 bs) o n
258− | o+n <= 32 = extract bo (unsafeTake 4 bs) o n
259− | o+n <= 40 = extract bo (unsafeTake 5 bs) o n
260− | o+n <= 48 = extract bo (unsafeTake 6 bs) o n
261− | o+n <= 56 = extract bo (unsafeTake 7 bs) o n
262− | o+n <= 64 = extract bo (unsafeTake 8 bs) o n
263− | 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)
264240
265241-- | Check that the number of bits to read is not greater than the first parameter
266242{-# INLINE readWordChecked #-}
267−readWordChecked :: (Num a, Bits a, FastBits a) => Int -> Int -> S -> a
243+readWordChecked :: (Num a, FastBits a) => Int -> Int -> S -> a
268244readWordChecked m n s
269245 | n > m = error $ "Tried to read more than " ++ show m ++ " bits (" ++ show n ++")"
270246 | otherwise = readWord n s
@@ -272,39 +248,37 @@ readWordChecked m n s
272248-- | Read the given number of bytes and return them in Big-Endian order
273249--
274250-- Examples:
275−-- BB: xxxABCDE FGHIJKLM NOPQRxxx -> ABCDEFGH IJKLMNOP QRxxxxxx
276−-- LB: NOPQRxxx FGHIJKLM xxxABCDE -> ABCDEFGH IJKLMNOP QRxxxxxx
251+-- BB: xxxABCDE FGHIJKLM NOPxxxxx -> ABCDEFGH IJKLMNOP
252+-- LL: LMNOPxxx DEFGHIJK xxxxxABC -> ABCDEFGH IJKLMNOP
253+-- BL: xxxPONML KJIHGFED CBAxxxxx -> ABCDEFGH IJKLMNOP
254+-- LB: EDCBAxxx MLKJIHGF xxxxxPON -> ABCDEFGH IJKLMNOP
277255readByteString :: Int -> S -> ByteString
278−readByteString n (S bs o bo)
279− | o == 0 = case bo of
280− BB -> unsafeTake n bs
281− LB -> B.reverse (unsafeTake n bs)
282−
283− | otherwise = unsafePerformIO $ do
284− let len = n+1
285− ptr <- mallocBytes len
286− case bo of
287− BB -> do
288− let f r i = do
289− let
290− w = unsafeIndex bs (len-i)
291− w' = (w `fastShiftL` o) .|. r
292− r' = w `fastShiftR` (8-o)
293− poke (ptr `plusPtr` (len-i)) w'
294− return r'
295− foldM_ f 0 [1..len]
296− unsafeInit <$> unsafePackMallocCStringLen (ptr,len)
297−
298− LB -> do
299− let f r i = do
300− let
301− w = unsafeIndex bs (i-1)
302− w' = (w `fastShiftL` (8-o)) .|. r
303− r' = w `fastShiftR` o
304− poke (ptr `plusPtr` (len-i)) w'
305− return r'
306− foldM_ f 0 [1..len]
307− unsafeTail <$> unsafePackMallocCStringLen (ptr,len)
256+readByteString n (S bs o bo) =
257+ let
258+ bs' = unsafeTake (n+1) bs
259+ bs'' = unsafeTake n bs
260+ rev = B.map (reverseBits 8)
261+ in case (o,bo) of
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)
269+ (_,BB) -> unsafePerformIO $ do
270+ let len = n+1
271+ ptr <- mallocBytes len
272+ let f r i = do
273+ let
274+ w = unsafeIndex bs (len-i)
275+ w' = (w `fastShiftL` o) .|. r
276+ r' = w `fastShiftR` (8-o)
277+ poke (ptr `plusPtr` (len-i)) w'
278+ return r'
279+ foldM_ f 0 [1..len]
280+ unsafeInit <$> unsafePackMallocCStringLen (ptr,len)
281+
308282
309283------------------------------------------------------------------------
310284-- | 'BitGet' is a monad, applicative and a functor. See 'runBitGet'
@@ -313,7 +287,6 @@ newtype BitGet a = B { runState :: S -> Get (S,a) }
313287
314288instance Monad BitGet where
315289 return x = B $ \s -> return (s,x)
316− fail str = B $ \s -> putBackState s >> fail str
317290 (B f) >>= g = B $ \s -> do (s',a) <- f s
318291 runState (g a) s'
319292
@@ -324,6 +297,29 @@ instance Applicative BitGet where
324297 pure x = return x
325298 fm <*> m = fm >>= \f -> m >>= \v -> return (f v)
326299
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+
327323-- | Run a 'BitGet' within the Binary packages 'Get' monad. If a byte has
328324-- been partially consumed it will be discarded once 'runBitGet' is finished.
329325runBitGet :: BitGet a -> Get a
@@ -371,23 +367,6 @@ ensureBits n = do
371367 put B.empty
372368 return (S (bs`append`bs') o bo, ())
373369
374−-- | Skip the given number of bits
375−skipBits :: Int -> BitGet ()
376−skipBits n = do
377− ensureBits n
378− withState (incS n)
379−
380−-- | Skip bits if necessary to align to the next byte
381−alignByte :: BitGet ()
382−alignByte = do
383− (S _ o _) <- getState
384− when (o /= 0) $
385− skipBits (8-o)
386−
387−-- | Select the bit ordering
388−selectBitOrder :: BitOrder -> BitGet ()
389−selectBitOrder = withState . selectBitOrderS
390−
391370-- | Test whether all input has been consumed, i.e. there are no remaining
392371-- undecoded bytes.
393372isEmpty :: BitGet Bool
@@ -399,6 +378,10 @@ isEmpty = B $ \ (S bs o bo) -> if B.null bs
399378getBool :: BitGet Bool
400379getBool = block bool
401380
381+-- | Get 1 bit as a 'Bool'.
382+getBool# :: BitGet Int
383+getBool# = block bool#
384+
402385-- | Get @n@ bits as a 'Word8'. @n@ must be within @[0..8]@.
403386getWord8 :: Int -> BitGet Word8
404387getWord8 n = block (word8 n)
@@ -474,6 +457,10 @@ block (Block i p) = do
474457bool :: Block Bool
475458bool = Block 1 readBool
476459
460+-- | Read a 1 bit 'Bool'.
461+bool# :: Block Int
462+bool# = Block 1 readBool#
463+
477464-- | Read @n@ bits as a 'Word8'. @n@ must be within @[0..8]@.
478465word8 :: Int -> Block Word8
479466word8 n = Block n (readWordChecked 8 n)
@@ -507,84 +494,3 @@ byteString :: Int -> Block ByteString
507494byteString n | n > 0 = Block (n*8) (readByteString n)
508495 | otherwise = Block 0 (\_ -> B.empty)
509496
510−
511−---------------------------------------------------------------------
512−-- Unchecked shifts, from the "binary" package
513−
514−-- | Class for types supporting fast bit shifting
515−class FastBits a where
516− fastShiftR :: a -> Int -> a
517− fastShiftL :: a -> Int -> a
518−
519− {-# INLINE fastShift #-}
520− fastShift :: a -> Int -> a
521− fastShift x n
522− | n > 0 = fastShiftL x n
523− | n < 0 = fastShiftR x (negate n)
524− | otherwise = x
525−
526−instance FastBits Word8 where
527− fastShiftR = shiftr_w8
528− fastShiftL = shiftl_w8
529−
530−instance FastBits Word16 where
531− fastShiftR = shiftr_w16
532− fastShiftL = shiftl_w16
533−
534−instance FastBits Word32 where
535− fastShiftR = shiftr_w32
536− fastShiftL = shiftl_w32
537−
538−instance FastBits Word64 where
539− fastShiftR = shiftr_w64
540− fastShiftL = shiftl_w64
541−
542−
543−shiftl_w8 :: Word8 -> Int -> Word8
544−shiftl_w16 :: Word16 -> Int -> Word16
545−shiftl_w32 :: Word32 -> Int -> Word32
546−shiftl_w64 :: Word64 -> Int -> Word64
547−
548−shiftr_w8 :: Word8 -> Int -> Word8
549−shiftr_w16 :: Word16 -> Int -> Word16
550−shiftr_w32 :: Word32 -> Int -> Word32
551−shiftr_w64 :: Word64 -> Int -> Word64
552−
553−#if defined(__GLASGOW_HASKELL__) && !defined(__HADDOCK__)
554−shiftl_w8 (W8# w) (I# i) = W8# (w `uncheckedShiftL#` i)
555−shiftl_w16 (W16# w) (I# i) = W16# (w `uncheckedShiftL#` i)
556−shiftl_w32 (W32# w) (I# i) = W32# (w `uncheckedShiftL#` i)
557−
558−shiftr_w8 (W8# w) (I# i) = W8# (w `uncheckedShiftRL#` i)
559−shiftr_w16 (W16# w) (I# i) = W16# (w `uncheckedShiftRL#` i)
560−shiftr_w32 (W32# w) (I# i) = W32# (w `uncheckedShiftRL#` i)
561−
562−
563−#if WORD_SIZE_IN_BITS < 64
564−shiftl_w64 (W64# w) (I# i) = W64# (w `uncheckedShiftL64#` i)
565−shiftr_w64 (W64# w) (I# i) = W64# (w `uncheckedShiftRL64#` i)
566−
567−#if __GLASGOW_HASKELL__ <= 606
568−-- Exported by GHC.Word in GHC 6.8 and higher
569−foreign import ccall unsafe "stg_uncheckedShiftL64"
570− uncheckedShiftL64# :: Word64# -> Int# -> Word64#
571−foreign import ccall unsafe "stg_uncheckedShiftRL64"
572− uncheckedShiftRL64# :: Word64# -> Int# -> Word64#
573−#endif
574−
575−#else
576−shiftl_w64 (W64# w) (I# i) = W64# (w `uncheckedShiftL#` i)
577−shiftr_w64 (W64# w) (I# i) = W64# (w `uncheckedShiftRL#` i)
578−#endif
579−
580−#else
581−shiftl_w8 = shiftL
582−shiftl_w16 = shiftL
583−shiftl_w32 = shiftL
584−shiftl_w64 = shiftL
585−
586−shiftr_w8 = shiftR
587−shiftr_w16 = shiftR
588−shiftr_w32 = shiftR
589−shiftr_w64 = shiftR
590−#endif