@@ -1,3 +1,5 @@
1+{-# LANGUAGE MagicHash #-}
2+
13-----------------------------------------------------------------------------
24-- |
35-- Module : Data.Binary.Bits.Put
@@ -20,8 +22,10 @@ module Data.Binary.Bits.Put
2022 -- * Data types
2123 -- ** Bool
2224 , putBool
25+ , putBool#
2326
2427 -- ** Words
28+ , putWord#
2529 , putWord8
2630 , putWord16
2731 , putWord32
@@ -46,11 +50,11 @@ import Data.Binary.Bits.Alignment
4650import Data.ByteString as BS
4751import Data.ByteString.Unsafe as BS
4852
49−import Control.Applicative
5053import Control.Monad (when)
5154import Data.Bits
52−import Data.Monoid
5355import Data.Word
56+import GHC.Base (Word#, shiftRL#, Int (..), Int#, (-#), (<#), isTrue#, (+#), shiftL#, wordToWord8#, orWord8#)
57+import GHC.Word (Word8(..))
5458
5559data BitPut a = BitPut { run :: (S -> PairS a) }
5660
@@ -62,11 +66,18 @@ data S = S !Builder !Word8 !Int !BitOrder
6266putBool :: Bool -> BitPut ()
6367putBool b = putWord8 1 (if b then 0xff else 0x00)
6468
69+-- | Put a 1 bit 'Bool'.
70+putBool# :: Word# -> BitPut ()
71+putBool# b = putWord# 1# b
72+
6573
6674-- | Generic putWord
6775putWord :: (Num a, FastBits a, Integral a) => Int -> a -> BitPut ()
6876putWord n w = BitPut $ \s -> PairS () (putWordS n w s)
6977
78+putWord# :: Int# -> Word# -> BitPut ()
79+putWord# n w = BitPut $ \s -> PairS () (putWordS# n w s)
80+
7081putWordS :: (Num a, FastBits a, Integral a) => Int -> a -> S -> S
7182putWordS n w s@(S builder b o bo) = s'
7283 where
@@ -110,6 +121,53 @@ putWordS n w s@(S builder b o bo) = s'
110121 | o2 == 8 = S (b2 `mappend` B.singleton w2) 0 0 bo2
111122 | otherwise = s2
112123
124+putWordS# :: Int# -> Word# -> S -> S
125+putWordS# n w s@(S builder (W8# b) (I# o) bo) = s'
126+ where
127+ min# :: Int# -> Int# -> Int#
128+ min# x y | isTrue# (x <# y) = x
129+ min# _ y = y
130+
131+ -- number of bits that will be stored in the current byte
132+ cn = min# (8# -# o) n
133+
134+ -- new state
135+ s' = case n of
136+ 0# -> s
137+ _ -> putWordS# (n -# cn) w' (flush (S builder (W8# b') (I# (o +# cn)) bo))
138+
139+ -- new current byte
140+ b' = wordToWord8# (shl (selectBits w)) `orWord8#` b
141+
142+ -- Word containing the remaining (n-cn) bits to store in its LSB
143+ w' = case bo of
144+ BB -> w
145+ BL -> w `shiftRL#` cn
146+ LL -> w `shiftRL#` cn
147+ LB -> w
148+
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)))
156+ LL -> mask# cn x
157+ BL -> reverseBits# cn (mask# cn x)
158+
159+ -- shift left at the correct position
160+ shl :: Word# -> Word#
161+ shl x = case bo of
162+ BB -> x `shiftL#` (8# -# o -# cn)
163+ BL -> x `shiftL#` (8# -# o -# cn)
164+ LL -> x `shiftL#` o
165+ LB -> x `shiftL#` o
166+
167+ flush s2@(S b2 w2 o2 bo2)
168+ | o2 == 8 = S (b2 `mappend` B.singleton w2) 0 0 bo2
169+ | otherwise = s2
170+
113171
114172-- | Put the @n@ lower bits of a 'Word8'.
115173putWord8 :: Int -> Word8 -> BitPut ()