Improve benchmarks for small Builders

Data/ByteString/Builder/Internal.hs

@@ -127,6 +127,7 @@ module Data.ByteString.Builder.Internal (
 ) where
 
 import           Control.Arrow (second)
+import           Control.DeepSeq (NFData(..))
 
 import           Data.Semigroup (Semigroup(..))
 import           Data.List.NonEmpty (NonEmpty(..))
@@ -154,11 +155,22 @@ import           System.IO.Unsafe (unsafeDupablePerformIO)
 data BufferRange = BufferRange {-# UNPACK #-} !(Ptr Word8)  -- First byte of range
                                {-# UNPACK #-} !(Ptr Word8)  -- First byte /after/ range
 
+-- | @since 0.12.2.0
+instance NFData BufferRange where
+  rnf !_ = ()
+
 -- | A 'Buffer' together with the 'BufferRange' of free bytes. The filled
 -- space starts at offset 0 and ends at the first free byte.
 data Buffer = Buffer {-# UNPACK #-} !(ForeignPtr Word8)
                      {-# UNPACK #-} !BufferRange
 
+-- | Like the @NFData@ instance for @StrictByteString@,
+-- this does not force the @ForeignPtrContents@ field
+-- of the underlying @ForeignPtr@.
+--
+-- @since 0.12.2.0
+instance NFData Buffer where
+  rnf !_ = ()
 
 -- | Combined size of the filled and free space in the buffer.
 {-# INLINE bufferSize #-}

bench/BenchAll.hs

@@ -19,26 +19,29 @@ import           Data.Monoid
 import           Data.Semigroup
 import           Data.String
 import           Test.Tasty.Bench
+
 import           Prelude                               hiding (words)
 import qualified Data.List                             as List
 import           Control.DeepSeq
+import           Control.Exception
 
 import qualified Data.ByteString                       as S
 import qualified Data.ByteString.Char8                 as S8
 import qualified Data.ByteString.Lazy                  as L
 import qualified Data.ByteString.Lazy.Char8            as L8
 
 import           Data.ByteString.Builder
-import           Data.ByteString.Builder.Extra         (byteStringCopy,
-                                                        byteStringInsert,
-                                                        intHost)
-import           Data.ByteString.Builder.Internal      (ensureFree)
+import qualified Data.ByteString.Builder.Extra         as Extra
+import qualified Data.ByteString.Builder.Internal      as BI
 import           Data.ByteString.Builder.Prim          (BoundedPrim, FixedPrim,
                                                         (>$<))
 import qualified Data.ByteString.Builder.Prim          as P
 import qualified Data.ByteString.Builder.Prim.Internal as PI
 
 import           Foreign
+import           Foreign.ForeignPtr
+import qualified GHC.Exts as Exts
+import           GHC.Ptr (Ptr(..))
 
 import System.Random
 
@@ -126,15 +129,45 @@ loremIpsum = S8.unlines $ map S8.pack
 -- benchmark wrappers
 ---------------------
 
-{-# INLINE benchB #-}
 benchB :: String -> a -> (a -> Builder) -> Benchmark
-benchB name x b =
-    bench (name ++" (" ++ show nRepl ++ ")") $
-        whnf (L.length . toLazyByteString . b) x
+{-# INLINE benchB #-}
+benchB name x b = benchB' (name ++" (" ++ show nRepl ++ ")") x b
 
-{-# INLINE benchB' #-}
 benchB' :: String -> a -> (a -> Builder) -> Benchmark
-benchB' name x b = bench name $ whnf (L.length . toLazyByteString . b) x
+{-# INLINE benchB' #-}
+benchB' name x mkB =
+  env (BI.newBuffer BI.defaultChunkSize) $ \buf ->
+    bench name $ whnfAppIO (runBuildStepOn buf . BI.runBuilder . mkB) x
+
+benchB'_ :: String -> Builder -> Benchmark
+{-# INLINE benchB'_ #-}
+benchB'_ name b =
+  env (BI.newBuffer BI.defaultChunkSize) $ \buf ->
+    bench name $ whnfIO (runBuildStepOn buf (BI.runBuilder b))
+
+-- | @runBuilderOn@ runs a @BuildStep@'s actions all on the same @Buffer@.
+-- It is used to avoid measuring driver allocation overhead.
+runBuildStepOn :: BI.Buffer -> BI.BuildStep () -> IO ()
+{-# NOINLINE runBuildStepOn #-}
+runBuildStepOn (BI.Buffer fp br@(BI.BufferRange op ope)) b = go b
+  where
+    !len = ope `minusPtr` op
+
+    go :: BI.BuildStep () -> IO ()
+    go bs = BI.fillWithBuildStep bs doneH fullH insertChunkH br
+
+    doneH :: Ptr Word8 -> () -> IO ()
+    doneH _ _ = touchForeignPtr fp
+    -- 'touchForeignPtr' is adequate because the given BuildStep
+    -- will always terminate. (We won't measure an infinite loop!)
+
+    fullH :: Ptr Word8 -> Int -> BI.BuildStep () -> IO ()
+    fullH _ minLen nextStep
+      | len < minLen = throwIO (ErrorCall "runBuilderOn: action expects too long of a BufferRange")
+      | otherwise    = go nextStep
+
+    insertChunkH :: Ptr Word8 -> S.ByteString -> BI.BuildStep () -> IO ()
+    insertChunkH _ _ nextStep = go nextStep
 
 {-# INLINE benchBInts #-}
 benchBInts :: String -> ([Int] -> Builder) -> Benchmark
@@ -252,18 +285,53 @@ largeTraversalInput = S.concat (replicate 10 byteStringData)
 smallTraversalInput :: S.ByteString
 smallTraversalInput = S8.pack "The quick brown fox"
 
+asciiBuf, utf8Buf, halfNullBuf, allNullBuf :: Ptr Word8
+asciiBuf = Ptr "xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx"#
+utf8Buf  = Ptr "xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx\xc0\x80xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx"#
+halfNullBuf = Ptr "\xc0\x80xx\xc0\x80x\xc0\x80\xc0\x80x\xc0\x80\xc0\x80xx\xc0\x80\xc0\x80xxx\xc0\x80x\xc0\x80x\xc0\x80\xc0\x80\xc0\x80\xc0\x80\xc0\x80\xc0\x80xxx\xc0\x80x\xc0\x80xx\xc0\x80\xc0\x80xxxxxxxxxx\xc0\x80\xc0\x80\xc0\x80\xc0\x80\xc0\x80x\xc0\x80\xc0\x80x\xc0\x80\xc0\x80\xc0\x80\xc0\x80\xc0\x80xxx"#
+allNullBuf  = Ptr "\xc0\x80\xc0\x80\xc0\x80\xc0\x80\xc0\x80\xc0\x80\xc0\x80\xc0\x80\xc0\x80\xc0\x80\xc0\x80\xc0\x80\xc0\x80\xc0\x80\xc0\x80\xc0\x80\xc0\x80\xc0\x80\xc0\x80\xc0\x80\xc0\x80\xc0\x80\xc0\x80\xc0\x80\xc0\x80\xc0\x80\xc0\x80\xc0\x80\xc0\x80\xc0\x80\xc0\x80\xc0\x80\xc0\x80\xc0\x80\xc0\x80\xc0\x80\xc0\x80\xc0\x80\xc0\x80\xc0\x80\xc0\x80\xc0\x80\xc0\x80\xc0\x80\xc0\x80\xc0\x80\xc0\x80\xc0\x80\xc0\x80\xc0\x80\xc0\x80\xc0\x80\xc0\x80\xc0\x80\xc0\x80\xc0\x80\xc0\x80\xc0\x80\xc0\x80\xc0\x80\xc0\x80\xc0\x80\xc0\x80\xc0\x80"#
+
+asciiLit, utf8Lit :: Ptr Word8 -> Builder
+asciiLit (Ptr p#) = P.cstring p#
+utf8Lit (Ptr p#) = P.cstringUtf8 p#
+
+asciiStr, utf8Str :: String
+asciiStr = "xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx"
+utf8Str  = "xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx\0xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx"
+
 main :: IO ()
 main = do
   defaultMain
     [ bgroup "Data.ByteString.Builder"
       [ bgroup "Small payload"
-        [ benchB' "mempty"        ()  (const mempty)
-        , benchB' "ensureFree 8"  ()  (const (ensureFree 8))
-        , benchB' "intHost 1"     1   intHost
-        , benchB' "UTF-8 String (naive)" "hello world\0" fromString
-        , benchB' "UTF-8 String"  () $ \() -> P.cstringUtf8 "hello world\0"#
-        , benchB' "String (naive)" "hello world!" fromString
-        , benchB' "String"        () $ \() -> P.cstring "hello world!"#
+        [ benchB'_ "mempty" mempty
+        , bench "toLazyByteString mempty" $ nf toLazyByteString mempty
+        , benchB'_ "empty (10000 times)" $
+            stimes (10000 :: Int) (Exts.lazy BI.empty)
+        , benchB'_ "ensureFree 8" (BI.ensureFree 8)
+        , benchB'  "intHost 1" 1 Extra.intHost
+        , benchB'  "UTF-8 String (12B, naive)" "hello world\0" fromString
+        , benchB'_ "UTF-8 String (12B)" $ utf8Lit (Ptr "hello world\xc0\x80"#)
+        , benchB'  "UTF-8 String (64B, naive)" utf8Str fromString
+        , benchB'_ "UTF-8 String (64B, one null)" $ utf8Lit utf8Buf
+        , benchB'
+            "UTF-8 String (64B, one null, no shared work)"
+            utf8Buf
+            utf8Lit
+        , benchB'_ "UTF-8 String (64B, half nulls)" $ utf8Lit halfNullBuf
+        , benchB'_ "UTF-8 String (64B, all nulls)"  $ utf8Lit allNullBuf
+        , benchB'
+            "UTF-8 String (64B, all nulls, no shared work)"
+            allNullBuf
+            utf8Lit
+        , benchB'
+            "UTF-8 String (1 byte, no shared work)"
+            (Ptr "\xc0\x80"#)
+            utf8Lit
+        , benchB'  "ASCII String (12B, naive)" "hello world!" fromString
+        , benchB'_ "ASCII String (12B)" $ asciiLit (Ptr "hello wurld!"#)
+        , benchB'  "ASCII String (64B, naive)" asciiStr fromString
+        , benchB'_ "ASCII String (64B)" $ asciiLit asciiBuf
         ]
 
       , bgroup "Encoding wrappers"
@@ -280,11 +348,11 @@ main = do
         ]
       , bgroup "ByteString insertion" $
             [ benchB "foldMap byteStringInsert" byteStringChunksData
-                (foldMap byteStringInsert)
+                (foldMap Extra.byteStringInsert)
             , benchB "foldMap byteString" byteStringChunksData
                 (foldMap byteString)
             , benchB "foldMap byteStringCopy" byteStringChunksData
-                (foldMap byteStringCopy)
+                (foldMap Extra.byteStringCopy)
             ]
 
       , bgroup "Non-bounded encodings"