small-bytearray-builder 0.1.0.0 → 0.1.1.0

raw patch · 7 files changed

+330/−30 lines, 7 filesdep +bytestringdep +gaugedep ~basedep ~primitivePVP ok

version bump matches the API change (PVP)

Dependencies added: bytestring, gauge

Dependency ranges changed: base, primitive

API changes (from Hackage documentation)

Files

• CHANGELOG.md +6/−2
• bench/Main.hs +57/−0
• common/HexWord64.hs +50/−0
• small-bytearray-builder.cabal +19/−2
• src/Data/ByteArray/Builder/Small.hs +46/−1
• src/Data/ByteArray/Builder/Small/Unsafe.hs +115/−11
• test/Main.hs +37/−14

@@ -1,5 +1,9 @@ # Revision history for small-bytearray-builder -## 0.1.0.0 -- YYYY-mm-dd+## 0.1.1.0 -- 2019-07-30 -* First version. Released on an unsuspecting world.+* Add several additional functions for encoding numbers.++## 0.1.0.0 -- 2019-06-25++* First version

@@ -0,0 +1,57 @@+import Gauge (bgroup,bench,whnf)+import Gauge.Main (defaultMain)+import Data.Word (Word64)+import Data.Primitive (ByteArray)+import qualified Data.ByteArray.Builder.Small.Unsafe as U++import qualified HexWord64++main :: IO ()+main = defaultMain+  [ bgroup "w64"+    [ bgroup "hex"+      [ bench "library" (whnf encodeHexWord64s w64s)+      , bench "loop" (whnf encodeHexWord64sLoop w64s)+      ]+    ]+  ]++w64s :: Word64s+w64s = Word64s+  0xde2b8a480cf77113+  0x48f1668ca2a68b45+  0xd262fbaa0b2f473c+  0xbab20547f4919d9f+  0xb7ec16121704db43+  0x9c259f5bfa90e1eb+  0xd451eca11d9873ad+  0xbd927e8d4c879d02++data Word64s = Word64s+  !Word64 !Word64 !Word64 !Word64+  !Word64 !Word64 !Word64 !Word64++encodeHexWord64s :: Word64s -> ByteArray+{-# noinline encodeHexWord64s #-}+encodeHexWord64s (Word64s a b c d e f g h) = U.run $+  U.word64PaddedUpperHex a `U.append`+  U.word64PaddedUpperHex b `U.append`+  U.word64PaddedUpperHex c `U.append`+  U.word64PaddedUpperHex d `U.append`+  U.word64PaddedUpperHex e `U.append`+  U.word64PaddedUpperHex f `U.append`+  U.word64PaddedUpperHex g `U.append`+  U.word64PaddedUpperHex h++encodeHexWord64sLoop :: Word64s -> ByteArray+{-# noinline encodeHexWord64sLoop #-}+encodeHexWord64sLoop (Word64s a b c d e f g h) = U.run $+  HexWord64.word64PaddedUpperHex a `U.append`+  HexWord64.word64PaddedUpperHex b `U.append`+  HexWord64.word64PaddedUpperHex c `U.append`+  HexWord64.word64PaddedUpperHex d `U.append`+  HexWord64.word64PaddedUpperHex e `U.append`+  HexWord64.word64PaddedUpperHex f `U.append`+  HexWord64.word64PaddedUpperHex g `U.append`+  HexWord64.word64PaddedUpperHex h+

@@ -0,0 +1,50 @@+{-# language BangPatterns #-}+{-# language ScopedTypeVariables #-}+{-# language DataKinds #-}+{-# language UnboxedTuples #-}+{-# language MagicHash #-}+{-# language PolyKinds #-}+{-# language TypeApplications #-}++module HexWord64+  ( word64PaddedUpperHex+  ) where++-- We have to jump through some hoops to manually do worker-wrapper+-- since CPR doesn't work on nested products. Sadly, even with all+-- the hoop jumping, the explicit loop used here is still outperformed+-- by just inlining the loop.++import GHC.ST (ST(ST))+import Data.Bits+import Data.ByteArray.Builder.Small.Unsafe (Builder,construct)+import Data.Primitive+import Data.Word+import GHC.Exts++import qualified Control.Monad.Primitive as PM++type ST# s (a :: TYPE (r :: RuntimeRep)) = State# s -> (# State# s, a #)++word64PaddedUpperHex :: Word64 -> Builder 16+word64PaddedUpperHex w = construct $ \a b -> ST+  (\s0 -> case word64PaddedUpperHexLoop w 60 a b s0 of+    (# s1, i #) -> (# s1, I# i #)+  )++word64PaddedUpperHexLoop :: forall s. Word64 -> Int -> MutableByteArray s -> Int -> ST# s Int#+word64PaddedUpperHexLoop !w !shiftAmount !arr !i@(I# i#) s0 = if shiftAmount >= 0+  then case PM.internal @(ST s) (writeByteArray arr i (toHexUpper (unsafeShiftR w shiftAmount))) s0 of+    (# s1, (_ :: ()) #) -> word64PaddedUpperHexLoop w (shiftAmount - 4) arr (i + 1) s1+  else (# s0, i# #)++toHexUpper :: Word64 -> Word8+toHexUpper w' = fromIntegral+    $ (complement theMask .&. loSolved)+  .|. (theMask .&. hiSolved)+  where+  w = w' .&. 0xF+  -- This is all ones if the value was >= 10+  theMask = (1 .&. unsafeShiftR (w - 10) 63) - 1+  loSolved = w + 48+  hiSolved = w + 55

@@ -1,6 +1,6 @@ cabal-version: 2.2 name: small-bytearray-builder-version: 0.1.0.0+version: 0.1.1.0 synopsis: Serialize to a small byte arrays description:   This is similar to the builder facilities provided by@@ -55,14 +55,31 @@ test-suite test   default-language: Haskell2010   type: exitcode-stdio-1.0-  hs-source-dirs: test+  hs-source-dirs: test, common   main-is: Main.hs+  other-modules:+    HexWord64   build-depends:     , base >=4.12.0.0 && <5     , byteslice+    , bytestring     , small-bytearray-builder     , QuickCheck >=2.13.1 && <2.14     , tasty-quickcheck >=0.10.1 && <0.11     , tasty >=1.2.3 && <1.3     , primitive     , vector++benchmark bench+  type: exitcode-stdio-1.0+  build-depends:+    , base+    , gauge >= 0.2.4+    , primitive+    , small-bytearray-builder+  ghc-options: -Wall -O2+  default-language: Haskell2010+  hs-source-dirs: bench, common+  main-is: Main.hs+  other-modules:+    HexWord64

@@ -10,6 +10,7 @@   ( -- * Unsafe Primitives     Builder(..)   , construct+  , fromUnsafe     -- * Evaluation   , run   , pasteST@@ -21,10 +22,18 @@     -- * Materialized Byte Sequences   , bytes   , bytearray-    -- * Numbers+    -- * Encode Integral Types+    -- ** Human-Readable   , word64Dec+  , int64Dec   , word64PaddedUpperHex   , word32PaddedUpperHex+  , word16PaddedUpperHex+  , word8PaddedUpperHex+    -- ** Machine-Readable+  , word64BE+  , word32BE+  , word16BE   ) where  import Control.Monad.Primitive@@ -32,6 +41,7 @@ import Control.Monad.ST.Run (runByteArrayST) import Data.Bytes.Types import Data.Primitive+import Data.Int (Int64) import GHC.Exts import GHC.ST import GHC.Word@@ -182,6 +192,13 @@ word64Dec :: Word64 -> Builder word64Dec w = fromUnsafe (Unsafe.word64Dec w) +-- | Encodes a signed 64-bit integer as decimal.+-- This encoding never starts with a zero unless the argument was zero.+-- Negative numbers are preceded by a minus sign. Positive numbers+-- are not preceded by anything.+int64Dec :: Int64 -> Builder+int64Dec w = fromUnsafe (Unsafe.int64Dec w)+ -- | Encode a 64-bit unsigned integer as hexadecimal, zero-padding -- the encoding to 16 digits. This uses uppercase for the alphabetical -- digits. For example, this encodes the number 1022 as @00000000000003FE@.@@ -196,6 +213,20 @@ word32PaddedUpperHex w =   fromUnsafe (Unsafe.word32PaddedUpperHex w) +-- | Encode a 16-bit unsigned integer as hexadecimal, zero-padding+-- the encoding to 4 digits. This uses uppercase for the alphabetical+-- digits. For example, this encodes the number 1022 as @03FE@.+word16PaddedUpperHex :: Word16 -> Builder+word16PaddedUpperHex w =+  fromUnsafe (Unsafe.word16PaddedUpperHex w)++-- | Encode a 8-bit unsigned integer as hexadecimal, zero-padding+-- the encoding to 2 digits. This uses uppercase for the alphabetical+-- digits. For example, this encodes the number 11 as @0B@.+word8PaddedUpperHex :: Word8 -> Builder+word8PaddedUpperHex w =+  fromUnsafe (Unsafe.word8PaddedUpperHex w)+ unST :: ST s a -> State# s -> (# State# s, a #) unST (ST f) = f @@ -203,3 +234,17 @@ shrinkMutableByteArray (MutableByteArray arr) (I# sz) =   primitive_ (shrinkMutableByteArray# arr sz) +-- | Requires exactly 8 bytes. Dump the octets of a 64-bit+-- word in a big-endian fashion.+word64BE :: Word64 -> Builder+word64BE w = fromUnsafe (Unsafe.word64BE w)++-- | Requires exactly 4 bytes. Dump the octets of a 32-bit+-- word in a big-endian fashion.+word32BE :: Word32 -> Builder+word32BE w = fromUnsafe (Unsafe.word32BE w)++-- | Requires exactly 2 bytes. Dump the octets of a 16-bit+-- word in a big-endian fashion.+word16BE :: Word16 -> Builder+word16BE w = fromUnsafe (Unsafe.word16BE w)

@@ -8,6 +8,7 @@ {-# language LambdaCase #-} {-# language TypeOperators #-} {-# language DataKinds #-}+{-# language TypeApplications #-}  -- | The functions in this module do not check to -- see if there is enough space in the buffer.@@ -22,20 +23,28 @@     -- * Combine   , append     -- * Encode Integral Types+    -- ** Human-Readable   , word64Dec+  , int64Dec   , word64PaddedUpperHex   , word32PaddedUpperHex+  , word16PaddedUpperHex+  , word8PaddedUpperHex+    -- ** Machine-Readable+  , word64BE+  , word32BE+  , word16BE   ) where  import Control.Monad.Primitive import Control.Monad.ST import Data.Bits-import Data.Bytes.Types import Data.Char (ord) import Data.Primitive import GHC.Exts import GHC.ST import GHC.Word+import GHC.Int import Data.Kind import GHC.TypeLits (KnownNat,Nat,type (+),natVal') @@ -81,6 +90,8 @@     case unST (f (MutableByteArray arr) (I# off)) s0 of       (# s1, (I# n) #) -> (# s1, n #) +infixr 9 `append`+ -- | Concatenate two builders. append :: Builder n -> Builder m -> Builder (n + m) append (Builder f) (Builder g) =@@ -92,26 +103,50 @@ word64Dec :: Word64 -> Builder 19 word64Dec (W64# w) = word64Dec# w +-- | Requires up to 20 bytes. Encodes a signed 64-bit integer as decimal.+-- This encoding never starts with a zero unless the argument was zero.+-- Negative numbers are preceded by a minus sign. Positive numbers+-- are not preceded by anything.+int64Dec :: Int64 -> Builder 20+int64Dec (I64# w) = int64Dec# w+ -- | Requires up to 19 bytes. word64Dec# :: Word# -> Builder 19 {-# noinline word64Dec# #-} word64Dec# w# = construct $ \arr off0 -> if w /= 0-  then do-    let go off x = if x > 0-          then do-            let (y,z) = quotRem x 10-            writeByteArray arr off (fromIntegral (z + 0x30) :: Word8)-            go (off + 1) y-          else do-            reverseBytes arr off0 (off - 1)-            pure off-    go off0 w+  then internalWordLoop arr off0 (W# w#)   else do     writeByteArray arr off0 (c2w '0')     pure (off0 + 1)   where   w = W64# w# +internalWordLoop :: MutableByteArray s -> Int -> Word -> ST s Int+{-# inline internalWordLoop #-}+internalWordLoop arr off0 x0 = go off0 x0 where+  go !off !(x :: Word) = if x > 0+    then do+      let (y,z) = quotRem x 10+      writeByteArray arr off (fromIntegral (z + 0x30) :: Word8)+      go (off + 1) y+    else do+      reverseBytes arr off0 (off - 1)+      pure off++-- | Requires up to 19 bytes.+int64Dec# :: Int# -> Builder 20+{-# noinline int64Dec# #-}+int64Dec# w# = construct $ \arr off0 -> case compare w 0 of+  GT -> internalWordLoop arr off0 (fromIntegral w)+  EQ -> do+    writeByteArray arr off0 (c2w '0')+    pure (off0 + 1)+  LT -> do+    writeByteArray arr off0 (c2w '-')+    internalWordLoop arr (off0 + 1) (fromIntegral (negate w))+  where+  w = I64# w#+ -- Convert a number between 0 and 16 to the ASCII -- representation of its hexadecimal character. -- The use of fromIntegral causes us to incur an@@ -141,6 +176,20 @@ word32PaddedUpperHex :: Word32 -> Builder 8 word32PaddedUpperHex (W32# w) = word32PaddedUpperHex# w +-- | Requires exactly 4 bytes. Encodes a 16-bit unsigned integer as+-- hexadecimal, zero-padding the encoding to 4 digits. This uses+-- uppercase for the alphabetical digits.+word16PaddedUpperHex :: Word16 -> Builder 4+word16PaddedUpperHex (W16# w) = word16PaddedUpperHex# w++-- | Requires exactly 2 bytes. Encodes a 8-bit unsigned integer as+-- hexadecimal, zero-padding the encoding to 2 digits. This uses+-- uppercase for the alphabetical digits.+word8PaddedUpperHex :: Word8 -> Builder 2+word8PaddedUpperHex (W8# w) = word8PaddedUpperHex# w++-- TODO: Is it actually worth unrolling this loop. I suspect that it+-- might not be. Benchmark this. word64PaddedUpperHex# :: Word# -> Builder 16 {-# noinline word64PaddedUpperHex# #-} word64PaddedUpperHex# w# = construct $ \arr off -> do@@ -178,6 +227,61 @@   pure (off + 8)   where   w = W# w#++-- Not sure if it is beneficial to inline this. We just let+-- GHC make the decision. Open an issue on github if this is+-- a problem.+word16PaddedUpperHex# :: Word# -> Builder 4+word16PaddedUpperHex# w# = construct $ \arr off -> do+  writeByteArray arr off (toHexUpper (unsafeShiftR w 12))+  writeByteArray arr (off + 1) (toHexUpper (unsafeShiftR w 8))+  writeByteArray arr (off + 2) (toHexUpper (unsafeShiftR w 4))+  writeByteArray arr (off + 3) (toHexUpper (unsafeShiftR w 0))+  pure (off + 4)+  where+  w = W# w#++-- Definitely want this to inline. It's maybe a dozen instructions total.+word8PaddedUpperHex# :: Word# -> Builder 2+{-# inline word8PaddedUpperHex #-}+word8PaddedUpperHex# w# = construct $ \arr off -> do+  writeByteArray arr off (toHexUpper (unsafeShiftR w 4))+  writeByteArray arr (off + 1) (toHexUpper (unsafeShiftR w 0))+  pure (off + 2)+  where+  w = W# w#++-- | Requires exactly 8 bytes. Dump the octets of a 64-bit+-- word in a big-endian fashion.+word64BE :: Word64 -> Builder 8+word64BE w = construct $ \arr off -> do+  writeByteArray arr (off    ) (fromIntegral @Word64 @Word8 (unsafeShiftR w 56))+  writeByteArray arr (off + 1) (fromIntegral @Word64 @Word8 (unsafeShiftR w 48))+  writeByteArray arr (off + 2) (fromIntegral @Word64 @Word8 (unsafeShiftR w 40))+  writeByteArray arr (off + 3) (fromIntegral @Word64 @Word8 (unsafeShiftR w 32))+  writeByteArray arr (off + 4) (fromIntegral @Word64 @Word8 (unsafeShiftR w 24))+  writeByteArray arr (off + 5) (fromIntegral @Word64 @Word8 (unsafeShiftR w 16))+  writeByteArray arr (off + 6) (fromIntegral @Word64 @Word8 (unsafeShiftR w 8))+  writeByteArray arr (off + 7) (fromIntegral @Word64 @Word8 w)+  pure (off + 8)++-- | Requires exactly 4 bytes. Dump the octets of a 32-bit+-- word in a big-endian fashion.+word32BE :: Word32 -> Builder 4+word32BE w = construct $ \arr off -> do+  writeByteArray arr (off    ) (fromIntegral @Word32 @Word8 (unsafeShiftR w 24))+  writeByteArray arr (off + 1) (fromIntegral @Word32 @Word8 (unsafeShiftR w 16))+  writeByteArray arr (off + 2) (fromIntegral @Word32 @Word8 (unsafeShiftR w 8))+  writeByteArray arr (off + 3) (fromIntegral @Word32 @Word8 w)+  pure (off + 4)++-- | Requires exactly 2 bytes. Dump the octets of a 16-bit+-- word in a big-endian fashion.+word16BE :: Word16 -> Builder 2+word16BE w = construct $ \arr off -> do+  writeByteArray arr (off    ) (fromIntegral @Word16 @Word8 (unsafeShiftR w 8))+  writeByteArray arr (off + 1) (fromIntegral @Word16 @Word8 w)+  pure (off + 2)  -- Reverse the bytes in the designated slice. This takes -- an inclusive start offset and an inclusive end offset.

@@ -12,32 +12,55 @@ import Test.Tasty (defaultMain,testGroup,TestTree) import Test.QuickCheck ((===)) import Text.Printf (printf)+import qualified Data.ByteString.Builder as BB import qualified Data.Primitive as PM import qualified Data.List as L import qualified Data.Vector as V import qualified Test.Tasty.QuickCheck as TQC import qualified Test.QuickCheck as QC import qualified GHC.Exts as Exts+import qualified Data.ByteString.Lazy.Char8 as LB +import qualified HexWord64+ main :: IO () main = defaultMain tests  tests :: TestTree tests = testGroup "Tests"-  [ TQC.testProperty "word64Dec" $ \w ->-      run 1 (word64Dec w) === pack (show w)-  , TQC.testProperty "word64Dec-x3" $ \x y z ->-      run 1 (word64Dec x <> word64Dec y <> word64Dec z)-      ===-      pack (show x ++ show y ++ show z)-  , TQC.testProperty "word64PaddedUpperHex" $ \w ->-      run 1 (word64PaddedUpperHex w)-      ===-      pack (showWord64PaddedUpperHex w)-  , TQC.testProperty "pasteArrayST" $ \(xs :: [Word64]) ->-      (runArray word64Dec (V.fromList xs))-      ===-      pack (foldMap show xs)+  [ testGroup "live"+    [ TQC.testProperty "word64Dec" $ \w ->+        run 1 (word64Dec w) === pack (show w)+    , TQC.testProperty "word64Dec-x3" $ \x y z ->+        run 1 (word64Dec x <> word64Dec y <> word64Dec z)+        ===+        pack (show x ++ show y ++ show z)+    , TQC.testProperty "int64Dec-x3" $ \x y z ->+        run 1 (int64Dec x <> int64Dec y <> int64Dec z)+        ===+        pack (show x ++ show y ++ show z)+    , TQC.testProperty "word64BE-x3" $ \x y z ->+        run 1 (word64BE x <> word64BE y <> word64BE z)+        ===+        pack (LB.unpack (BB.toLazyByteString (BB.word64BE x <> BB.word64BE y <> BB.word64BE z)))+    , TQC.testProperty "word64PaddedUpperHex" $ \w ->+        run 1 (word64PaddedUpperHex w)+        ===+        pack (showWord64PaddedUpperHex w)+    , TQC.testProperty "pasteArrayST" $ \(xs :: [Word64]) ->+        (runArray word64Dec (V.fromList xs))+        ===+        pack (foldMap show xs)+    ]+  , testGroup "alternate"+    [ TQC.testProperty "HexWord64" $ \x y ->+        run 1+          (  fromUnsafe (HexWord64.word64PaddedUpperHex x)+          <> fromUnsafe (HexWord64.word64PaddedUpperHex y)+          )+        ===+        pack (showWord64PaddedUpperHex x <> showWord64PaddedUpperHex y)+    ]   ]  pack :: String -> ByteArray