1bfa8cb...master · binary-bits

.gitignore+1

since splitsnapshots

unifiedsplit

@@ -1,3 +1,4 @@

1.cabal-sandbox

2cabal.sandbox.config

3dist/

4+.stack-work

Data/Binary/Bits/Get.hs+23−1

@@ -60,6 +60,7 @@ module Data.Binary.Bits.Get

60

61 -- ** Get bytes

62 , getBool

63+ , getBool#

63 , getWord8

64 , getWord8

64 , getWord16

65 , getWord16

65 , getWord32

66 , getWord32

@@ -114,6 +115,8 @@ import Control.Applicative

114import Control.Monad (when,foldM_)

115import Control.Monad (when,foldM_)

115

116

116import Prelude as P

117import Prelude as P

118+import GHC.Word

119+import GHC.Base (uncheckedShiftLWord8#, wordToWord8#, Int (..), andWord8#, Word8#, (-#), Int#, xorI#, eqWord8#, TYPE)

117

120

118-- $bitget

121-- $bitget

119-- Parse bits using a monad.

122-- Parse bits using a monad.

@@ -182,6 +185,18 @@ readBool (S bs o bo) = case bo of

182 LL -> testBit (unsafeHead bs) o

185 LL -> testBit (unsafeHead bs) o

183 LB -> testBit (unsafeHead bs) o

186 LB -> testBit (unsafeHead bs) o

184

187

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+

185-- | Extract a range of bits from (ws :: ByteString)

200-- | Extract a range of bits from (ws :: ByteString)

186--

201--

187-- Constraint: 8 * (length ws -1 ) < o+n <= 8 * length ws

202-- Constraint: 8 * (length ws -1 ) < o+n <= 8 * length ws

@@ -272,7 +287,6 @@ newtype BitGet a = B { runState :: S -> Get (S,a) }

272

287

273instance Monad BitGet where

288instance Monad BitGet where

274 return x = B $ \s -> return (s,x)

289 return x = B $ \s -> return (s,x)

275− fail str = B $ \s -> putBackState s >> fail str

276 (B f) >>= g = B $ \s -> do (s',a) <- f s

290 (B f) >>= g = B $ \s -> do (s',a) <- f s

277 runState (g a) s'

291 runState (g a) s'

278

292

@@ -364,6 +378,10 @@ isEmpty = B $ \ (S bs o bo) -> if B.null bs

364getBool :: BitGet Bool

378getBool :: BitGet Bool

365getBool = block bool

379getBool = block bool

366

380

381+-- | Get 1 bit as a 'Bool'.

382+getBool# :: BitGet Int

383+getBool# = block bool#

384+

367-- | Get @n@ bits as a 'Word8'. @n@ must be within @[0..8]@.

385-- | Get @n@ bits as a 'Word8'. @n@ must be within @[0..8]@.

368getWord8 :: Int -> BitGet Word8

386getWord8 :: Int -> BitGet Word8

369getWord8 n = block (word8 n)

387getWord8 n = block (word8 n)

@@ -439,6 +457,10 @@ block (Block i p) = do

439bool :: Block Bool

457bool :: Block Bool

440bool = Block 1 readBool

458bool = Block 1 readBool

441

459

460+-- | Read a 1 bit 'Bool'.

461+bool# :: Block Int

462+bool# = Block 1 readBool#

463+

442-- | Read @n@ bits as a 'Word8'. @n@ must be within @[0..8]@.

464-- | Read @n@ bits as a 'Word8'. @n@ must be within @[0..8]@.

443word8 :: Int -> Block Word8

465word8 :: Int -> Block Word8

444word8 n = Block n (readWordChecked 8 n)

466word8 n = Block n (readWordChecked 8 n)

Data/Binary/Bits/Internal.hs+27−6

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

12

13module Data.Binary.Bits.Internal

14 ( make_mask

15+ , make_mask#

15 , mask

16 , mask

17+ , mask#

16 , bit_offset

18 , bit_offset

17 , byte_offset

19 , byte_offset

18 , reverseBits

20 , reverseBits

21+ , reverseBits#

19 , FastBits(..)

22 , FastBits(..)

20 )

23 )

21where

24where

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

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

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

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

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

40

43

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

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

46+

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

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

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

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

43mask n v = v .&. make_mask n

49mask n v = v .&. make_mask n

44{-# INLINE mask #-}

50{-# INLINE mask #-}

45

51

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+

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

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

47bit_offset :: Int -> Int

57bit_offset :: Int -> Int

48bit_offset n = make_mask 3 .&. n

58bit_offset n = make_mask 3 .&. n

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

65 rec 0 i r = r `fastShiftL` i

75 rec 0 i r = r `fastShiftL` i

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

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

67

77

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+

68

89

69---------------------------------------------------------------------

90---------------------------------------------------------------------

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

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

@@ -116,13 +137,13 @@ shiftr_w32 :: Word32 -> Int -> Word32

116shiftr_w64 :: Word64 -> Int -> Word64

137shiftr_w64 :: Word64 -> Int -> Word64

117

138

118#if defined(__GLASGOW_HASKELL__) && !defined(__HADDOCK__)

139#if defined(__GLASGOW_HASKELL__) && !defined(__HADDOCK__)

119−shiftl_w8 (W8# w) (I# i) = W8# (w `uncheckedShiftL#` i)

140+shiftl_w8 w i = w `unsafeShiftL` i

120−shiftl_w16 (W16# w) (I# i) = W16# (w `uncheckedShiftL#` i)

141+shiftl_w16 w i = w `unsafeShiftL` i

121−shiftl_w32 (W32# w) (I# i) = W32# (w `uncheckedShiftL#` i)

142+shiftl_w32 w i = w `unsafeShiftL` i

122

143

123−shiftr_w8 (W8# w) (I# i) = W8# (w `uncheckedShiftRL#` i)

144+shiftr_w8 w i = w `unsafeShiftR` i

124−shiftr_w16 (W16# w) (I# i) = W16# (w `uncheckedShiftRL#` i)

145+shiftr_w16 w i = w `unsafeShiftR` i

125−shiftr_w32 (W32# w) (I# i) = W32# (w `uncheckedShiftRL#` i)

146+shiftr_w32 w i = w `unsafeShiftR` i

126

147

127

148

128#if WORD_SIZE_IN_BITS < 64

149#if WORD_SIZE_IN_BITS < 64

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

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

1+{-# LANGUAGE MagicHash #-}

2+

1-----------------------------------------------------------------------------

3-----------------------------------------------------------------------------

2-- |

4-- |

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

22 , putBool

24 , putBool

25+ , putBool#

23

26

24 -- ** Words

27 -- ** Words

28+ , putWord#

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

48

52

49−import Control.Applicative

50import Control.Monad (when)

53import Control.Monad (when)

51import Data.Bits

54import Data.Bits

52−import Data.Monoid

53import Data.Word

55import Data.Word

56+import GHC.Base (Word#, shiftRL#, Int (..), Int#, (-#), (<#), isTrue#, (+#), shiftL#, wordToWord8#, orWord8#)

57+import GHC.Word (Word8(..))

54

58

55data BitPut a = BitPut { run :: (S -> PairS a) }

59data BitPut a = BitPut { run :: (S -> PairS a) }

56

60

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

64

68

69+-- | Put a 1 bit 'Bool'.

70+putBool# :: Word# -> BitPut ()

71+putBool# b = putWord# 1# b

72+

65

73

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)

69

77

78+putWord# :: Int# -> Word# -> BitPut ()

79+putWord# n w = BitPut $ \s -> PairS () (putWordS# n w s)

80+

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'

72 where

83 where

@@ -110,6 +121,53 @@ putWordS n w s@(S builder b o bo) = s'

110 | o2 == 8 = S (b2 `mappend` B.singleton w2) 0 0 bo2

121 | o2 == 8 = S (b2 `mappend` B.singleton w2) 0 0 bo2

111 | otherwise = s2

122 | otherwise = s2

112

123

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+

113

171

114-- | Put the @n@ lower bits of a 'Word8'.

172-- | Put the @n@ lower bits of a 'Word8'.

115putWord8 :: Int -> Word8 -> BitPut ()

173putWord8 :: Int -> Word8 -> BitPut ()

flake.locknew file+59

@@ -0,0 +1,59 @@

1+{

2+ "nodes": {

3+ "flake-utils": {

4+ "inputs": {

5+ "systems": "systems"

6+ },

7+ "locked": {

8+ "lastModified": 1731533236,

9+ "narHash": "sha256-l0KFg5HjrsfsO/JpG+r7fRrqm12kzFHyUHqHCVpMMbI=",

10+ "owner": "numtide",

11+ "repo": "flake-utils",

12+ "rev": "11707dc2f618dd54ca8739b309ec4fc024de578b",

13+ "type": "github"

14+ },

15+ "original": {

16+ "id": "flake-utils",

17+ "type": "indirect"

18+ }

19+ },

20+ "nixpkgs": {

21+ "locked": {

22+ "lastModified": 1737469691,

23+ "narHash": "sha256-nmKOgAU48S41dTPIXAq0AHZSehWUn6ZPrUKijHAMmIk=",

24+ "owner": "NixOS",

25+ "repo": "nixpkgs",

26+ "rev": "9e4d5190a9482a1fb9d18adf0bdb83c6e506eaab",

27+ "type": "github"

28+ },

29+ "original": {

30+ "id": "nixpkgs",

31+ "ref": "nixos-unstable",

32+ "type": "indirect"

33+ }

34+ },

35+ "root": {

36+ "inputs": {

37+ "flake-utils": "flake-utils",

38+ "nixpkgs": "nixpkgs"

39+ }

40+ },

41+ "systems": {

42+ "locked": {

43+ "lastModified": 1681028828,

44+ "narHash": "sha256-Vy1rq5AaRuLzOxct8nz4T6wlgyUR7zLU309k9mBC768=",

45+ "owner": "nix-systems",

46+ "repo": "default",

47+ "rev": "da67096a3b9bf56a91d16901293e51ba5b49a27e",

48+ "type": "github"

49+ },

50+ "original": {

51+ "owner": "nix-systems",

52+ "repo": "default",

53+ "type": "github"

54+ }

55+ }

56+ },

57+ "root": "root",

58+ "version": 7

59+}

flake.nixnew file+24

@@ -0,0 +1,24 @@

1+{

2+ inputs = {

3+ nixpkgs.url = "nixpkgs/nixos-unstable";

4+ flake-utils.url = "flake-utils";

5+ };

6+

7+ outputs = { self, flake-utils, nixpkgs }:

8+ let

9+ supportedSystems =

10+ [ "x86_64-linux" "x86_64-darwin" "aarch64-darwin" "aarch64-linux" ];

11+ compilerVersion = "966";

12+ in flake-utils.lib.eachSystem supportedSystems (system:

13+ let pkgs = import nixpkgs { inherit system; };

14+ in {

15+ devShells.default = pkgs.mkShell {

16+ buildInputs = with pkgs; [

17+ haskell.compiler."ghc${compilerVersion}"

18+ (pkgs.haskell-language-server.override {

19+ supportedGhcVersions = [ compilerVersion ];

20+ })

21+ ];

22+ };

23+ });

24+}

stack.yamlnew file+66

@@ -0,0 +1,66 @@

1+# This file was automatically generated by 'stack init'

2+#

3+# Some commonly used options have been documented as comments in this file.

4+# For advanced use and comprehensive documentation of the format, please see:

5+# https://docs.haskellstack.org/en/stable/yaml_configuration/

6+

7+# Resolver to choose a 'specific' stackage snapshot or a compiler version.

8+# A snapshot resolver dictates the compiler version and the set of packages

9+# to be used for project dependencies. For example:

10+#

11+# resolver: lts-3.5

12+# resolver: nightly-2015-09-21

13+# resolver: ghc-7.10.2

14+#

15+# The location of a snapshot can be provided as a file or url. Stack assumes

16+# a snapshot provided as a file might change, whereas a url resource does not.

17+#

18+# resolver: ./custom-snapshot.yaml

19+# resolver: https://example.com/snapshots/2018-01-01.yaml

20+resolver: lts-22.43

21+

22+# User packages to be built.

23+# Various formats can be used as shown in the example below.

24+#

25+# packages:

26+# - some-directory

27+# - https://example.com/foo/bar/baz-0.0.2.tar.gz

28+# subdirs:

29+# - auto-update

30+# - wai

31+packages:

32+- .

33+# Dependency packages to be pulled from upstream that are not in the resolver.

34+# These entries can reference officially published versions as well as

35+# forks / in-progress versions pinned to a git hash. For example:

36+#

37+# extra-deps:

38+# - acme-missiles-0.3

39+# - git: https://github.com/commercialhaskell/stack.git

40+# commit: e7b331f14bcffb8367cd58fbfc8b40ec7642100a

41+#

42+# extra-deps: []

43+

44+# Override default flag values for local packages and extra-deps

45+# flags: {}

46+

47+# Extra package databases containing global packages

48+# extra-package-dbs: []

49+

50+# Control whether we use the GHC we find on the path

51+# system-ghc: true

52+#

53+# Require a specific version of stack, using version ranges

54+# require-stack-version: -any # Default

55+# require-stack-version: ">=2.9"

56+#

57+# Override the architecture used by stack, especially useful on Windows

58+# arch: i386

59+# arch: x86_64

60+#

61+# Extra directories used by stack for building

62+# extra-include-dirs: [/path/to/dir]

63+# extra-lib-dirs: [/path/to/dir]

64+#

65+# Allow a newer minor version of GHC than the snapshot specifies

66+# compiler-check: newer-minor

stack.yaml.locknew file+12

@@ -0,0 +1,12 @@

1+# This file was autogenerated by Stack.

2+# You should not edit this file by hand.

3+# For more information, please see the documentation at:

4+# https://docs.haskellstack.org/en/stable/lock_files

5+

6+packages: []

7+snapshots:

8+- completed:

9+ sha256: 08bd13ce621b41a8f5e51456b38d5b46d7783ce114a50ab604d6bbab0d002146

10+ size: 720271

11+ url: https://raw.githubusercontent.com/commercialhaskell/stackage-snapshots/master/lts/22/43.yaml

12+ original: lts-22.43