add a benchmark

bench/Main.hs

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

common/HexWord64.hs

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

small-bytearray-builder.cabal

@@ -55,8 +55,10 @@ library
 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
@@ -67,3 +69,17 @@ test-suite test
     , 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 -ddump-simpl -ddump-to-file -dsuppress-all
+  default-language: Haskell2010
+  hs-source-dirs: bench, common
+  main-is: Main.hs
+  other-modules:
+    HexWord64

src/Data/ByteArray/Builder/Small.hs

@@ -10,6 +10,7 @@ module Data.ByteArray.Builder.Small
   ( -- * Unsafe Primitives
     Builder(..)
   , construct
+  , fromUnsafe
     -- * Evaluation
   , run
   , pasteST

src/Data/ByteArray/Builder/Small/Unsafe.hs

@@ -90,6 +90,8 @@ construct f = Builder
     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) =

test/Main.hs

@@ -21,33 +21,46 @@ 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 ->
+  [ testGroup "live"
-      run 1 (word64Dec w) === pack (show w)
+    [ TQC.testProperty "word64Dec" $ \w ->
-  , TQC.testProperty "word64Dec-x3" $ \x y z ->
+        run 1 (word64Dec w) === pack (show w)
-      run 1 (word64Dec x <> word64Dec y <> word64Dec z)
+    , 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 ->
+        pack (show x ++ show y ++ show z)
-      run 1 (int64Dec x <> int64Dec y <> int64Dec 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 ->
+        pack (show x ++ show y ++ show z)
-      run 1 (word64BE x <> word64BE y <> word64BE 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 ->
+        pack (LB.unpack (BB.toLazyByteString (BB.word64BE x <> BB.word64BE y <> BB.word64BE z)))
-      run 1 (word64PaddedUpperHex w)
+    , TQC.testProperty "word64PaddedUpperHex" $ \w ->
-      ===
+        run 1 (word64PaddedUpperHex w)
-      pack (showWord64PaddedUpperHex w)
+        ===
-  , TQC.testProperty "pasteArrayST" $ \(xs :: [Word64]) ->
+        pack (showWord64PaddedUpperHex w)
-      (runArray word64Dec (V.fromList xs))
+    , TQC.testProperty "pasteArrayST" $ \(xs :: [Word64]) ->
-      ===
+        (runArray word64Dec (V.fromList xs))
-      pack (foldMap show 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