@@ -1,3 +1,5 @@
1+{-# LANGUAGE MagicHash #-}
1-----------------------------------------------------------------------------
3-----------------------------------------------------------------------------
3-- Module : Data.Binary.Bits.Put
5-- Module : Data.Binary.Bits.Put
@@ -20,8 +22,10 @@ module Data.Binary.Bits.Put
20 -- * Data types
22 -- * Data types
21 -- ** Bool
23 -- ** Bool
24 -- ** Words
27 -- ** Words
25 , putWord8
29 , putWord8
26 , putWord16
30 , putWord16
27 , putWord32
31 , putWord32
@@ -46,11 +50,11 @@ import Data.Binary.Bits.Alignment
46import Data.ByteString as BS
50import Data.ByteString as BS
47import Data.ByteString.Unsafe as BS
51import Data.ByteString.Unsafe as BS
49−import Control.Applicative
50import Control.Monad (when)
53import Control.Monad (when)
51import Data.Bits
54import Data.Bits
53import Data.Word
55import Data.Word
56+import GHC.Base (Word#, shiftRL#, Int (..), Int#, (-#), (<#), isTrue#, (+#), shiftL#, wordToWord8#, orWord8#)
57+import GHC.Word (Word8(..))
55data BitPut a = BitPut { run :: (S -> PairS a) }
59data BitPut a = BitPut { run :: (S -> PairS a) }
@@ -62,11 +66,18 @@ data S = S !Builder !Word8 !Int !BitOrder
62putBool :: Bool -> BitPut ()
66putBool :: Bool -> BitPut ()
63putBool b = putWord8 1 (if b then 0xff else 0x00)
67putBool b = putWord8 1 (if b then 0xff else 0x00)
69+-- | Put a 1 bit 'Bool'.
70+putBool# :: Word# -> BitPut ()
71+putBool# b = putWord# 1# b
66-- | Generic putWord
74-- | Generic putWord
67putWord :: (Num a, FastBits a, Integral a) => Int -> a -> BitPut ()
75putWord :: (Num a, FastBits a, Integral a) => Int -> a -> BitPut ()
68putWord n w = BitPut $ \s -> PairS () (putWordS n w s)
76putWord n w = BitPut $ \s -> PairS () (putWordS n w s)
78+putWord# :: Int# -> Word# -> BitPut ()
79+putWord# n w = BitPut $ \s -> PairS () (putWordS# n w s)
70putWordS :: (Num a, FastBits a, Integral a) => Int -> a -> S -> S
81putWordS :: (Num a, FastBits a, Integral a) => Int -> a -> S -> S
71putWordS n w s@(S builder b o bo) = s'
82putWordS n w s@(S builder b o bo) = s'
@@ -85,8 +96,8 @@ putWordS n w s@(S builder b o bo) = s'
85 w' = case bo of
96 w' = case bo of
87 BL -> w `fastShiftR` cn
98 BL -> w `fastShiftR` cn
88− LB -> w `fastShiftR` cn
99+ LL -> w `fastShiftR` cn
91 -- Select bits to store in the current byte.
102 -- Select bits to store in the current byte.
92 -- Put them in the correct order and return them in the least-significant
103 -- Put them in the correct order and return them in the least-significant
@@ -94,8 +105,8 @@ putWordS n w s@(S builder b o bo) = s'
94 selectBits :: (Num a, FastBits a, Integral a) => a -> Word8
105 selectBits :: (Num a, FastBits a, Integral a) => a -> Word8
95 selectBits x = fromIntegral $ case bo of
106 selectBits x = fromIntegral $ case bo of
96 BB -> mask cn $ x `fastShiftR` (n-cn)
107 BB -> mask cn $ x `fastShiftR` (n-cn)
97− LL -> reverseBits cn $ mask cn $ x `fastShiftR` (n-cn)
108+ LB -> reverseBits cn $ mask cn $ x `fastShiftR` (n-cn)
98− LB -> mask cn x
109+ LL -> mask cn x
99 BL -> reverseBits cn $ mask cn x
110 BL -> reverseBits cn $ mask cn x
101 -- shift left at the correct position
112 -- shift left at the correct position
@@ -103,8 +114,55 @@ putWordS n w s@(S builder b o bo) = s'
103 shl x = case bo of
114 shl x = case bo of
104 BB -> x `fastShiftL` (8-o-cn)
115 BB -> x `fastShiftL` (8-o-cn)
105 BL -> x `fastShiftL` (8-o-cn)
116 BL -> x `fastShiftL` (8-o-cn)
106− LB -> x `fastShiftL` o
107 LL -> x `fastShiftL` o
117 LL -> x `fastShiftL` o
118+ LB -> x `fastShiftL` o
120+ flush s2@(S b2 w2 o2 bo2)
121+ | o2 == 8 = S (b2 `mappend` B.singleton w2) 0 0 bo2
124+putWordS# :: Int# -> Word# -> S -> S
125+putWordS# n w s@(S builder (W8# b) (I# o) bo) = s'
127+ min# :: Int# -> Int# -> Int#
128+ min# x y | isTrue# (x <# y) = x
131+ -- number of bits that will be stored in the current byte
132+ cn = min# (8# -# o) n
137+ _ -> putWordS# (n -# cn) w' (flush (S builder (W8# b') (I# (o +# cn)) bo))
140+ b' = wordToWord8# (shl (selectBits w)) `orWord8#` b
142+ -- Word containing the remaining (n-cn) bits to store in its LSB
145+ BL -> w `shiftRL#` cn
146+ LL -> w `shiftRL#` cn
149+ -- Select bits to store in the current byte.
150+ -- Put them in the correct order and return them in the least-significant
151+ -- bits of the returned value
152+ selectBits :: Word# -> Word#
153+ selectBits x = case bo of
154+ BB -> mask# cn (x `shiftRL#` (n -# cn))
155+ LB -> reverseBits# cn (mask# cn (x `shiftRL#` (n -# cn)))
157+ BL -> reverseBits# cn (mask# cn x)
159+ -- shift left at the correct position
160+ shl :: Word# -> Word#
162+ BB -> x `shiftL#` (8# -# o -# cn)
163+ BL -> x `shiftL#` (8# -# o -# cn)
109 flush s2@(S b2 w2 o2 bo2)
167 flush s2@(S b2 w2 o2 bo2)
110 | o2 == 8 = S (b2 `mappend` B.singleton w2) 0 0 bo2
168 | o2 == 8 = S (b2 `mappend` B.singleton w2) 0 0 bo2
@@ -143,9 +201,9 @@ putWord64be = putWord
144-- Examples: 3 bits are already written in the current byte
202-- Examples: 3 bits are already written in the current byte
145-- BB: ABCDEFGH IJKLMNOP -> xxxABCDE FGHIJKLM NOPxxxxx
203-- BB: ABCDEFGH IJKLMNOP -> xxxABCDE FGHIJKLM NOPxxxxx
146−-- LB: ABCDEFGH IJKLMNOP -> LMNOPxxx DEFGHIJK xxxxxABC
204+-- LL: ABCDEFGH IJKLMNOP -> LMNOPxxx DEFGHIJK xxxxxABC
147-- BL: ABCDEFGH IJKLMNOP -> xxxPONML KJIHGFED CBAxxxxx
205-- BL: ABCDEFGH IJKLMNOP -> xxxPONML KJIHGFED CBAxxxxx
148−-- LL: ABCDEFGH IJKLMNOP -> EDCBAxxx MLKJIHGF xxxxxPON
206+-- LB: ABCDEFGH IJKLMNOP -> EDCBAxxx MLKJIHGF xxxxxPON
149putByteString :: ByteString -> BitPut ()
207putByteString :: ByteString -> BitPut ()
150putByteString bs = BitPut $ \s -> PairS () (putByteStringS bs s)
208putByteString bs = BitPut $ \s -> PairS () (putByteStringS bs s)
@@ -154,13 +212,13 @@ putByteStringS bs s
154 | BS.null bs = s
212 | BS.null bs = s
155 | otherwise = case s of
213 | otherwise = case s of
156 (S builder b 0 BB) -> S (builder `mappend` B.fromByteString bs) b 0 BB
214 (S builder b 0 BB) -> S (builder `mappend` B.fromByteString bs) b 0 BB
157− (S builder b 0 LB) -> S (builder `mappend` B.fromByteString (BS.reverse bs)) b 0 LB
215+ (S builder b 0 LL) -> S (builder `mappend` B.fromByteString (BS.reverse bs)) b 0 LL
158− (S builder b 0 LL) -> S (builder `mappend` B.fromByteString (rev bs)) b 0 LL
216+ (S builder b 0 LB) -> S (builder `mappend` B.fromByteString (rev bs)) b 0 LB
159 (S builder b 0 BL) -> S (builder `mappend` B.fromByteString (rev (BS.reverse bs))) b 0 BL
217 (S builder b 0 BL) -> S (builder `mappend` B.fromByteString (rev (BS.reverse bs))) b 0 BL
160 (S _ _ _ BB) -> putByteStringS (BS.unsafeTail bs) (putWordS 8 (BS.unsafeHead bs) s)
218 (S _ _ _ BB) -> putByteStringS (BS.unsafeTail bs) (putWordS 8 (BS.unsafeHead bs) s)
161− (S _ _ _ LB) -> putByteStringS (BS.unsafeInit bs) (putWordS 8 (BS.unsafeLast bs) s)
219+ (S _ _ _ LL) -> putByteStringS (BS.unsafeInit bs) (putWordS 8 (BS.unsafeLast bs) s)
162 (S _ _ _ BL) -> putByteStringS (BS.unsafeInit bs) (putWordS 8 (BS.unsafeLast bs) s)
220 (S _ _ _ BL) -> putByteStringS (BS.unsafeInit bs) (putWordS 8 (BS.unsafeLast bs) s)
163− (S _ _ _ LL) -> putByteStringS (BS.unsafeTail bs) (putWordS 8 (BS.unsafeHead bs) s)
221+ (S _ _ _ LB) -> putByteStringS (BS.unsafeTail bs) (putWordS 8 (BS.unsafeHead bs) s)
165 rev = BS.map (reverseBits 8)
223 rev = BS.map (reverseBits 8)