From 3ce03463fc26c4b8d96b1f50e4acec0cfe0e4d1b Mon Sep 17 00:00:00 2001
From: Matthew Craven <clyring@gmail.com>
Date: Tue, 13 Feb 2024 23:19:15 -0500
Subject: [PATCH 1/3] Improve benchmarks for small Builders

   * Do not measure the overhead of allocating destination chunks
   * Add several more benchmarks for P.cstring and P.cstringUtf8
---
 Data/ByteString/Builder/Internal.hs | 12 ++++
 bench/BenchAll.hs                   | 95 +++++++++++++++++++++++------
 2 files changed, 88 insertions(+), 19 deletions(-)

diff --git a/Data/ByteString/Builder/Internal.hs b/Data/ByteString/Builder/Internal.hs
index 82bdf560c..96454a003 100644
--- a/Data/ByteString/Builder/Internal.hs
+++ b/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.1.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.1.0
+instance NFData Buffer where
+  rnf !_ = ()
 
 -- | Combined size of the filled and free space in the buffer.
 {-# INLINE bufferSize #-}
diff --git a/bench/BenchAll.hs b/bench/BenchAll.hs
index 85f348748..fc742b3e0 100644
--- a/bench/BenchAll.hs
+++ b/bench/BenchAll.hs
@@ -19,9 +19,11 @@ 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
@@ -29,16 +31,17 @@ 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,42 @@ 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"#
+
+asciiStr, utf8Str :: String
+asciiStr = "xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx"
+utf8Str  = "xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx\0xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx"
+
+unPtr :: Ptr a -> Exts.Addr#
+unPtr (Ptr p#) = p#
+
 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.noinline 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)" $ P.cstringUtf8 "hullo world\xc0\x80"#
+        , benchB'  "UTF-8 String (64B, naive)" utf8Str fromString
+        , benchB'_ "UTF-8 String (64B)" $ P.cstringUtf8 (unPtr utf8Buf)
+        , benchB'_ "UTF-8 String (64B, half nulls)" $
+            P.cstringUtf8 (unPtr halfNullBuf)
+        , benchB'_ "UTF-8 String (64B, all nulls)" $
+            P.cstringUtf8 (unPtr allNullBuf)
+        , benchB'  "String (12B, naive)" "hello world!" fromString
+        , benchB'_ "String (12B)" $ P.cstring "hello wurld!"#
+        , benchB'  "String (64B, naive)" asciiStr fromString
+        , benchB'_ "String (64B)" $ P.cstring (unPtr asciiBuf)
         ]
 
       , bgroup "Encoding wrappers"
@@ -280,11 +337,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"

From 5f387bcde1aa4a29c4dfc6061bfeed147efd12c1 Mon Sep 17 00:00:00 2001
From: Matthew Craven <clyring@gmail.com>
Date: Thu, 21 Mar 2024 19:09:25 -0400
Subject: [PATCH 2/3] More benchmark fiddling

---
 bench/BenchAll.hs | 39 +++++++++++++++++++++++++--------------
 1 file changed, 25 insertions(+), 14 deletions(-)

diff --git a/bench/BenchAll.hs b/bench/BenchAll.hs
index fc742b3e0..44e7e786c 100644
--- a/bench/BenchAll.hs
+++ b/bench/BenchAll.hs
@@ -291,13 +291,14 @@ utf8Buf  = Ptr "xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx\xc0\x80xxxxxxxxxxxxxxxxxxxxxxxx
 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"
 
-unPtr :: Ptr a -> Exts.Addr#
-unPtr (Ptr p#) = p#
-
 main :: IO ()
 main = do
   defaultMain
@@ -306,21 +307,31 @@ main = do
         [ benchB'_ "mempty" mempty
         , bench "toLazyByteString mempty" $ nf toLazyByteString mempty
         , benchB'_ "empty (10000 times)" $
-            stimes (10000 :: Int) (Exts.noinline BI.empty)
+            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)" $ P.cstringUtf8 "hullo world\xc0\x80"#
+        , benchB'_ "UTF-8 String (12B)" $ utf8Lit (Ptr "hello world\xc0\x80"#)
         , benchB'  "UTF-8 String (64B, naive)" utf8Str fromString
-        , benchB'_ "UTF-8 String (64B)" $ P.cstringUtf8 (unPtr utf8Buf)
-        , benchB'_ "UTF-8 String (64B, half nulls)" $
-            P.cstringUtf8 (unPtr halfNullBuf)
-        , benchB'_ "UTF-8 String (64B, all nulls)" $
-            P.cstringUtf8 (unPtr allNullBuf)
-        , benchB'  "String (12B, naive)" "hello world!" fromString
-        , benchB'_ "String (12B)" $ P.cstring "hello wurld!"#
-        , benchB'  "String (64B, naive)" asciiStr fromString
-        , benchB'_ "String (64B)" $ P.cstring (unPtr asciiBuf)
+        , 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"

From 818d2f09808c81b4fdf4e1f12d34692c730c0d92 Mon Sep 17 00:00:00 2001
From: Matthew Craven <clyring@gmail.com>
Date: Thu, 21 Mar 2024 19:10:44 -0400
Subject: [PATCH 3/3] Update "since" markers for new NFData instances

---
 Data/ByteString/Builder/Internal.hs | 4 ++--
 1 file changed, 2 insertions(+), 2 deletions(-)

diff --git a/Data/ByteString/Builder/Internal.hs b/Data/ByteString/Builder/Internal.hs
index 96454a003..40dfc84f9 100644
--- a/Data/ByteString/Builder/Internal.hs
+++ b/Data/ByteString/Builder/Internal.hs
@@ -155,7 +155,7 @@ 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.1.0
+-- | @since 0.12.2.0
 instance NFData BufferRange where
   rnf !_ = ()
 
@@ -168,7 +168,7 @@ data Buffer = Buffer {-# UNPACK #-} !(ForeignPtr Word8)
 -- this does not force the @ForeignPtrContents@ field
 -- of the underlying @ForeignPtr@.
 --
--- @since 0.12.1.0
+-- @since 0.12.2.0
 instance NFData Buffer where
   rnf !_ = ()