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"