diff --git a/beamable.cabal b/beamable.cabal --- a/beamable.cabal +++ b/beamable.cabal @@ -10,7 +10,7 @@ -- PVP summary: +-+------- breaking API changes -- | | +----- non-breaking API additions -- | | | +--- code changes with no API change -version: 0.1.0.1 +version: 0.1.0.2 -- A short (one-line) description of the package. synopsis: Generic serializer/deserializer with compact representation @@ -60,6 +60,7 @@ other-modules: Data.Beamable.Int Data.Beamable.Integer + Data.Beamable.Splits -- Other library packages from which modules are imported. build-depends: @@ -87,6 +88,22 @@ ghc-prim, integer-gmp >= 0.4 && < 0.6, murmur-hash >= 0.1 && < 0.2 + +benchmark beamable-bench + type: exitcode-stdio-1.0 + hs-source-dirs: src bench + main-is: Bench.hs + + build-depends: + criterion >= 0.6 && < 0.9, + -- Copied from regular dependencies... + base >= 4.5 && < 4.8, + blaze-builder >= 0.3, + bytestring >= 0.9, + ghc-prim, + integer-gmp >= 0.4 && < 0.6, + murmur-hash >= 0.1 && < 0.2 + source-repository head type: git diff --git a/bench/Bench.hs b/bench/Bench.hs new file mode 100644 --- /dev/null +++ b/bench/Bench.hs @@ -0,0 +1,31 @@ +{-# LANGUAGE BangPatterns #-} +module Main where + +import Criterion +import Criterion.Main +import Data.Beamable +import Data.List (sort) +import Data.Word + +main :: IO () +main = defaultMain + [ bgroup "roundTrip" rtGroup + ] + where + !_unused = sum testWords + !_unused' = sum testInts + +rtGroup = + [ bgroup "Int" $ map mkBenchRT testInts + , bgroup "Word" $ map mkBenchRT testWords + ] + +mkBenchRT x = bench (show x) $ whnf ((`asTypeOf` x) . decode . encode) x + +test10s :: [Word] +test10s = 0:[10^x | x <- [0..10]] +testWords = sort $ test10s ++ map (*5) test10s + +testInts :: [Int] +testInts = let xs = map fromIntegral testWords + in reverse (map negate xs) ++ tail xs diff --git a/src/Data/Beamable/Int.hs b/src/Data/Beamable/Int.hs --- a/src/Data/Beamable/Int.hs +++ b/src/Data/Beamable/Int.hs @@ -1,81 +1,81 @@ +{-# LANGUAGE BangPatterns #-} + module Data.Beamable.Int ( beamInt , unbeamInt + , pokeWord8 ) where -import Data.Bits ((.|.), (.&.), shift, testBit) -import qualified Data.ByteString as B -import Data.List (unfoldr) -import Data.Word (Word8) -import Data.Int (Int64) - +import Data.Beamable.Splits import Blaze.ByteString.Builder +import qualified Blaze.ByteString.Builder.Internal.Write as Write +import Data.Bits ((.|.), (.&.), shift, shiftR) +import Data.Int (Int64) +import Data.Monoid ((<>)) +import Foreign.Storable +import GHC.Word +import qualified Data.ByteString as B {- Beamed int representation: -1. The integer is chunked up into 7-bit groups. Each of these 7bit -chunks are encoded as a single octet. +1. The integer is chunked up into 7-bit groups, little-endian. + Each of these 7bit chunks are encoded as a single octet. 2. All the octets except the last one has its 8th bit set. -3. 7th bit of the first octet represents sign. - -3. Octets with bits 1..7 containing only 1 or 0 can be ignored when it's not affecting the sign: +3. 7th bit of the last octet represents sign. 0 | 0 0000000 1 | 0 0000001 63 | 0 0111111 -64 | 1 0000000 0 1000000 -127 | 1 0000000 0 1111111 -128 | 1 0000001 0 0000000 -8191 | 1 0111111 0 1111111 +64 | 1 1000000 0 0000000 +127 | 1 1111111 0 0000000 +128 | 1 0000000 0 0000001 +8191 | 1 1111111 0 0111111 8192 | 1 0000000 1 1000000 0 0000000 -65535 | 1 0000011 1 1111111 0 1111111 +65535 | 1 1111111 1 1111111 0 0000011 -1 | 0 1111111 -64 | 0 1000000 --65 | 1 1111111 0 0111111 --127 | 1 1111111 0 0000001 --128 | 1 1111111 0 0000000 --129 | 1 1111110 0 0111111 --8191 | 1 1000000 0 0000001 --8192 | 1 1000000 0 0000000 +-65 | 1 0111111 0 1111111 +-127 | 1 0000001 0 1111111 +-128 | 1 0000000 0 1111111 +-129 | 1 1111111 0 1111110 +-8191 | 1 0000001 0 1000000 +-8192 | 1 0000000 0 1000000 -8193 | 1 1111111 1 0111111 0 1111111 -} --- This might not work well for 32bit platform -beamInt :: Int64 -> Builder -- {{{ -beamInt 0 = fromWord8 0 -beamInt n = toBldr . bitmark . reverse . unfoldr f $ n +beamInt :: Int64 -> Builder +beamInt !n = fromWrite $ Write.boundedWrite 10 $ beamIntPoke n +{-# INLINE beamInt #-} + +beamIntPoke :: Int64 -> Write.Poke +beamIntPoke n + | isZeroOrMinus1 (n `shiftR` 6) = pokeWord8 firstSeptet + | otherwise = + pokeWord8 (firstSeptet .|. 0x80) <> beamIntPoke next where - f :: Int64 -> Maybe (Word8, Int64) - f 0 = Nothing - f x = let w = fromIntegral x .&. 0x7F :: Word8 - rest = x `shift` (negate 7) - in Just (w, if rest == (-1) then 0 else rest) + firstSeptet :: Word8 + firstSeptet = fromIntegral $ n .&. 0x7F + next = n `shiftR` 7 - bitmark :: [Word8] -> [Word8] - bitmark (w:[]) = [w] - bitmark (w:ws) = (w .|. 0x80) : bitmark ws - bitmark [] = [] + isZeroOrMinus1 x = (x + 1) `shiftR` 1 == 0 - toBldr :: [Word8] -> Builder - toBldr ws = - let ws' = if testBit (head ws) 6 - then if n > 0 then 0x80:ws else ws - else if n > 0 then ws else 0xFF:ws - in fromWriteList writeWord8 ws' +pokeWord8 :: Word8 -> Write.Poke +pokeWord8 w = Write.pokeN 1 $ flip poke w +{-# INLINE unbeamInt #-} -- This might not work well for 32bit platform unbeamInt :: B.ByteString -> (Int64, B.ByteString) -unbeamInt bs = (fixSign (B.foldl f 0 this), rest) +unbeamInt bs = (fixSign (B.foldr' f 0 this), rest) where - f :: Int64 -> Word8 -> Int64 - f i w = (i `shift` 7) .|. fromIntegral (w .&. 0x7F) + f :: Word8 -> Int64 -> Int64 + f w i = (i `shift` 7) .|. fromIntegral (w .&. 0x7F) fixSign :: Int64 -> Int64 fixSign x = x `shift` (64 - l * 7) `shift` (l * 7 - 64) - Just lastWord = B.findIndex (not . flip testBit 7) bs - l = lastWord + 1 - (this, rest) = B.splitAt l bs-- }}} + !l = B.length this + !(!this, !rest) = splitAtLastWord bs + -- }}} diff --git a/src/Data/Beamable/Internal.hs b/src/Data/Beamable/Internal.hs --- a/src/Data/Beamable/Internal.hs +++ b/src/Data/Beamable/Internal.hs @@ -15,17 +15,19 @@ import Data.Beamable.Int import Data.Beamable.Integer +import Data.Beamable.Splits import Data.Beamable.Util import Blaze.ByteString.Builder +import qualified Blaze.ByteString.Builder.Internal.Write as Write import Data.Digest.Murmur64 import Control.Arrow (first) -import Data.Bits ((.|.), (.&.), shift, testBit) +import Data.Bits ((.|.), (.&.), shift, shiftL, shiftR, testBit) import Data.ByteString (ByteString) import Data.Char (ord, chr) import Data.Int (Int8, Int16, Int32, Int64) -import Data.Monoid (mempty, mappend, mconcat) +import Data.Monoid (mempty, mappend, mconcat, (<>)) import Data.Word (Word, Word8, Word16, Word32, Word64) import Foreign.Storable import GHC.Generics @@ -94,6 +96,7 @@ -- values are prefixed by uniq number for each constructor instance (GBeamable a, Constructor c) => GBeamable (M1 C c a) where gbeam (M1 x) t@(_, dirs) = mappend (beamWord $ fromIntegral dirs) (gbeam x t) + {-# INLINE gbeam #-} gunbeam bs = first M1 . gunbeam bs gtypeSign prev x = signMur (conName x, '<', gtypeSign prev (unM1 x)) @@ -110,7 +113,7 @@ -- choose correct constructor based on the first word uncoded from the BS (dirs variable) instance (GBeamable a, GBeamable b) => GBeamable (a :+: b) where gbeam (L1 x) (lev, dirs) = gbeam x (lev + 1, dirs) - gbeam (R1 x) (lev, dirs) = gbeam x (lev + 1, dirs + 2^lev) + gbeam (R1 x) (lev, dirs) = gbeam x (lev + 1, dirs + (1 `shiftL` lev)) gunbeam bs (lev, dirs) = if testBit dirs lev then first R1 $ gunbeam bs (lev + 1, dirs) else first L1 $ gunbeam bs (lev + 1, dirs) @@ -138,29 +141,37 @@ gunbeam bs _ = first K1 (unbeam bs) gtypeSign prev x = signMur ('K', typeSignR prev (unK1 x)) --- | [un]beamWord functions are a bit more efficient than [un]beamInt --- it assumes that values are non-negative which allows more compact representation +{- +Beamed word representation: + Same as positive ints, except that the last octet is dropped if it's 0. -beamWord :: Word64 -> Builder-- {{{ -beamWord 0 = fromWord8 0 -beamWord i = fromByteString . B.reverse . fst $ B.unfoldrN 10 octets (i, True) - where - octets :: (Word64, Bool) -> Maybe (Word8, (Word64, Bool)) - octets (x, isFirst) - | x > 0 = let r = (fromIntegral (x .&. 0x7F)) .|. (if isFirst then 0 else 0x80) - in Just (r, (x `shift` (negate 7), False)) - | otherwise = Nothing +63 | 0 0111111 +64 | 1 1000000 +127 | 1 1111111 +128 | 1 0000000 0 0000001 +-} +beamWord :: Word64 -> Builder +beamWord !n = fromWrite $ Write.boundedWrite 10 $ beamWordPoke n +{-# INLINE beamWord #-} -unbeamWord :: B.ByteString -> (Word64, B.ByteString) -unbeamWord bs = (B.foldl f 0 this, rest) +beamWordPoke :: Word64 -> Write.Poke +beamWordPoke n + | next == 0 = pokeWord8 firstSeptet + | otherwise = pokeWord8 (firstSeptet .|. 0x80) <> beamWordPoke next where - f :: Word64 -> Word8 -> Word64 - f i w = (i `shift` 7) .|. fromIntegral (w .&. 0x7F) - - Just lastWord = B.findIndex (not . flip testBit 7) bs - (this, rest) = B.splitAt (lastWord + 1) bs + firstSeptet :: Word8 + firstSeptet = fromIntegral $ n .&. 0x7F + next = n `shiftR` 7 +{-# INLINE unbeamWord #-} +unbeamWord :: B.ByteString -> (Word64, B.ByteString) +unbeamWord bs = (B.foldr' f 0 this, rest) + where + f :: Word8 -> Word64 -> Word64 + f w i = (i `shift` 7) .|. fromIntegral (w .&. 0x7F) + !(!this, !rest) = splitAtLastWord bs +--}} {-# SPECIALIZE beamWordX :: Word8 -> Builder #-} {-# SPECIALIZE beamWordX :: Word16 -> Builder #-} diff --git a/src/Data/Beamable/Splits.hs b/src/Data/Beamable/Splits.hs new file mode 100644 --- /dev/null +++ b/src/Data/Beamable/Splits.hs @@ -0,0 +1,19 @@ +{-# LANGUAGE BangPatterns #-} + +module Data.Beamable.Splits ( + splitAtLastWord, +) where + +import Data.Bits ((.&.)) +import qualified Data.ByteString as B +import qualified Data.ByteString.Unsafe as B + +{-# INLINE splitAtLastWord #-} +splitAtLastWord :: B.ByteString -> (B.ByteString, B.ByteString) +splitAtLastWord bs = let err = error "corrupted stream" + !pos = maybe err (+1) $ B.findIndex (\w -> w .&. 0x80 /= 0x80) bs + !this = B.unsafeTake pos bs + !rest = B.unsafeDrop pos bs + in (this, rest) + +