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