21adca7 · binary-bits · git.iko.soy

git.iko.soy/binary-bits

putBool#

commit21adca7da6e378c8e3cc7bb1afa9dd441a721016 authoriko <mail@iko.soy> dateFri 24 Jan 2025, 01:56 (2 years ago) parent153d2b3

2 files changed+81−2

unifiedsplit

Data/Binary/Bits/Internal.hs+21 Data/Binary/Bits/Put.hs+60−2

Data/Binary/Bits/Internal.hs+21

@@ -12,10 +12,13 @@

1212

1313module Data.Binary.Bits.Internal

1414 ( make_mask

15+ , make_mask#

1516 , mask

17+ , mask#

1618 , bit_offset

1719 , byte_offset

1820 , reverseBits

21+ , reverseBits#

1922 , FastBits(..)

2023 )

2124where

@@ -38,11 +41,18 @@ make_mask n = (1 `shiftL` fromIntegral n) - 1

3841{-# SPECIALIZE make_mask :: Int -> Word32 #-}

3942{-# SPECIALIZE make_mask :: Int -> Word64 #-}

4043

44+make_mask# :: Int# -> Word#

45+make_mask# n = (1## `shiftL#` n) `minusWord#` 1##

46+

4147-- | Keep only the n least-significant bits of the given value

4248mask :: (Bits a, Num a) => Int -> a -> a

4349mask n v = v .&. make_mask n

4450{-# INLINE mask #-}

4551

52+-- | Keep only the n least-significant bits of the given value

53+mask# :: Int# -> Word# -> Word#

54+mask# n v = v `and#` make_mask# n

55+

4656-- | Compute bit offset (equivalent to x `mod` 8 but faster)

4757bit_offset :: Int -> Int

4858bit_offset n = make_mask 3 .&. n

@@ -65,6 +75,17 @@ reverseBits n value = rec value n 0

6575 rec 0 i r = r `fastShiftL` i

6676 rec v i r = rec (v `fastShiftR` 1) (i-1) ((r `fastShiftL` 1) .|. (v .&. 0x1))

6777

78+reverseBits# :: Int# -> Word# -> Word#

79+reverseBits# n value = rec value n 0##

80+ where

81+ -- rec v i r, where

82+ -- v is orginal value shifted

83+ -- i is the remaining number of bits

84+ -- r is current value

85+ rec 0## 0# r = r

86+ rec 0## i r = r `shiftL#` i

87+ rec v i r = rec (v `shiftRL#` 1#) (i -# 1#) ((r `shiftL#` 1#) `or#` (v `and#` 0x1##))

88+

6889

6990---------------------------------------------------------------------

7091-- Unchecked shifts, from the "binary" package

Data/Binary/Bits/Put.hs+60−2

@@ -1,3 +1,5 @@

1+{-# LANGUAGE MagicHash #-}

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 ()