From 7f1aca09a1c10c59066076a20fd887dc14346876 Mon Sep 17 00:00:00 2001 From: Viktor Dukhovni Date: Thu, 12 Jan 2023 21:59:41 -0500 Subject: [PATCH 1/8] Avoid per-byte loop in cstring{,Utf8} builders Copy chunks of the input to the output buffer with 'memcpy', up to the shorter of the available buffer space and the "null-free" portion of the remaining string. For the UTF8 version, encoded NUL bytes are located via strstr(3). --- Data/ByteString/Builder.hs | 21 +++-- Data/ByteString/Builder/Internal.hs | 76 ++++++++++++++++++- Data/ByteString/Builder/Prim.hs | 58 +++----------- Data/ByteString/Internal.hs | 2 +- Data/ByteString/Internal/Type.hs | 19 +++-- bench/BenchAll.hs | 26 ++++++- .../Data/ByteString/Builder/Prim/Tests.hs | 12 +-- .../builder/Data/ByteString/Builder/Tests.hs | 24 +++++- 8 files changed, 164 insertions(+), 74 deletions(-) diff --git a/Data/ByteString/Builder.hs b/Data/ByteString/Builder.hs index a6a6a0dae..68c8bbdbf 100644 --- a/Data/ByteString/Builder.hs +++ b/Data/ByteString/Builder.hs @@ -263,12 +263,14 @@ import qualified Data.ByteString.Builder.Prim as P import qualified Data.ByteString.Lazy.Internal as L import Data.ByteString.Builder.ASCII import Data.ByteString.Builder.RealFloat +import Data.ByteString.Internal (byteCountLiteral) import Data.String (IsString(..)) import System.IO (Handle, IOMode(..), withBinaryFile) import Foreign import GHC.Base (unpackCString#, unpackCStringUtf8#, unpackFoldrCString#, build) +import GHC.Ptr (Ptr(..)) -- | Execute a 'Builder' and return the generated chunks as a lazy 'L.ByteString'. -- The work is performed lazy, i.e., only when a chunk of the lazy 'L.ByteString' @@ -440,7 +442,7 @@ char8 :: Char -> Builder char8 = P.primFixed P.char8 -- | Char8 encode a 'String'. -{-# INLINE [1] string8 #-} -- phased to allow P.cstring rewrite +{-# NOINLINE string8 #-} string8 :: String -> Builder string8 = P.primMapListFixed P.char8 @@ -448,10 +450,12 @@ string8 = P.primMapListFixed P.char8 -- to promptly turn into build (unpackFoldrCString# s), so we match on both. {-# RULES "string8/unpackCString#" forall s. - string8 (unpackCString# s) = P.cstring s + string8 (unpackCString# s) = + ascLiteralCopy (Ptr s) (byteCountLiteral s) "string8/unpackFoldrCString#" forall s. - string8 (build (unpackFoldrCString# s)) = P.cstring s + string8 (build (unpackFoldrCString# s)) = + ascLiteralCopy (Ptr s) (byteCountLiteral s) #-} ------------------------------------------------------------------------------ @@ -467,19 +471,22 @@ charUtf8 = P.primBounded P.charUtf8 -- -- Note that 'stringUtf8' performs no codepoint validation and consequently may -- emit invalid UTF-8 if asked (e.g. single surrogates). -{-# INLINE [1] stringUtf8 #-} -- phased to allow P.cstring rewrite +{-# NOINLINE stringUtf8 #-} stringUtf8 :: String -> Builder stringUtf8 = P.primMapListBounded P.charUtf8 {-# RULES "stringUtf8/unpackCStringUtf8#" forall s. - stringUtf8 (unpackCStringUtf8# s) = P.cstringUtf8 s + stringUtf8 (unpackCStringUtf8# s) = + modUtf8LitCopy (Ptr s) (byteCountLiteral s) "stringUtf8/unpackCString#" forall s. - stringUtf8 (unpackCString# s) = P.cstring s + stringUtf8 (unpackCString# s) = + ascLiteralCopy (Ptr s) (byteCountLiteral s) "stringUtf8/unpackFoldrCString#" forall s. - stringUtf8 (build (unpackFoldrCString# s)) = P.cstring s + stringUtf8 (build (unpackFoldrCString# s)) = + ascLiteralCopy (Ptr s) (byteCountLiteral s) #-} instance IsString Builder where diff --git a/Data/ByteString/Builder/Internal.hs b/Data/ByteString/Builder/Internal.hs index e6c8174d0..061d72726 100644 --- a/Data/ByteString/Builder/Internal.hs +++ b/Data/ByteString/Builder/Internal.hs @@ -1,5 +1,5 @@ {-# LANGUAGE ScopedTypeVariables, CPP, BangPatterns, RankNTypes, TupleSections #-} -{-# LANGUAGE Unsafe #-} +{-# LANGUAGE MagicHash, ViewPatterns, Unsafe #-} {-# OPTIONS_HADDOCK not-home #-} -- | Copyright : (c) 2010 - 2011 Simon Meier -- License : BSD3-style (see LICENSE) @@ -84,6 +84,8 @@ module Data.ByteString.Builder.Internal ( -- , sizedChunksInsert , byteStringCopy + , ascLiteralCopy + , modUtf8LitCopy , byteStringInsert , byteStringThreshold @@ -127,6 +129,7 @@ module Data.ByteString.Builder.Internal ( ) where import Control.Arrow (second) +import Control.Monad (when) import Data.Semigroup (Semigroup(..)) @@ -138,10 +141,12 @@ import qualified Data.ByteString.Short.Internal as Sh import qualified GHC.IO.Buffer as IO (Buffer(..), newByteBuffer) import GHC.IO.Handle.Internals (wantWritableHandle, flushWriteBuffer) import GHC.IO.Handle.Types (Handle__, haByteBuffer, haBufferMode) +import GHC.Ptr (Ptr(..)) import System.IO (hFlush, BufferMode(..), Handle) import Data.IORef import Foreign +import Foreign.C.String (CString) import Foreign.ForeignPtr.Unsafe (unsafeForeignPtrToPtr) import System.IO.Unsafe (unsafeDupablePerformIO) @@ -874,6 +879,75 @@ byteStringInsert :: S.ByteString -> Builder byteStringInsert = \bs -> builder $ \k (BufferRange op _) -> return $ insertChunk op bs k + +------------------------------------------------------------------------------ +-- Raw CString encoding +------------------------------------------------------------------------------ + +-- | Builder for raw 'Addr#' pointers to null-terminated primitive ASCII +-- strings that are free of embedded (overlong-encoded as the two-byte sequence +-- @0xC0 0x80@) null characters. +-- +-- @since 0.11.5.0 +{-# INLINABLE ascLiteralCopy #-} +ascLiteralCopy :: Ptr Word8 -> Int -> Builder +ascLiteralCopy = \ !ip !len -> builder $ \k br -> do + let !ipe = ip `plusPtr` len + wrappedBytesCopyStep (BufferRange ip ipe) k br + +-- | GHC represents @NUL@ in string literals via an overlong 2-byte encoding, +-- which is part of "modified UTF-8" (GHC does not also implement CESU-8). +modifiedUtf8NUL :: CString +modifiedUtf8NUL = Ptr "\xc0\x80"# + +-- | Builder for raw 'Addr#' pointers to null-terminated primitive UTF-8 +-- encoded strings that may contain embedded overlong-encodings (as the +-- two-byte sequence @0xC0 0x80@) of null characters. +-- +-- @since 0.11.5.0 +{-# INLINABLE modUtf8LitCopy #-} +modUtf8LitCopy :: Ptr Word8 -> Int -> Builder +modUtf8LitCopy = \ !ip !len -> builder $ \k br -> do + nullAt <- c_strstr (castPtr ip) modifiedUtf8NUL + modUtf8_step ip len nullAt k br + +modUtf8_step :: Ptr Word8 -> Int -> Ptr Word8 -> BuildStep r -> BuildStep r +modUtf8_step !ip !len ((== nullPtr) -> True) k br = + -- Contains no encoded nulls, use simple copy codepath + wrappedBytesCopyStep (BufferRange ip ipe) k br + where + !ipe = ip `plusPtr` len +modUtf8_step !ip !len !nullAt k (BufferRange op0 ope) + -- Copy as much of the null-free portion of the string as fits into the + -- available buffer space. If the string is long enough, we may have asked + -- for less than its full length, filling the buffer with the rest will go + -- into the next builder step. + | avail > nullFree = do + when (nullFree > 0) (copyBytes op0 ip nullFree) + pokeElemOff op0 nullFree 0 + let used = nullFree + 2 + len' = len - used + !ip' = ip `plusPtr` used + !op' = op0 `plusPtr` (nullFree + 1) + nullAt' <- c_strstr ip' modifiedUtf8NUL + modUtf8_step ip' len' nullAt' k (BufferRange op' ope) + | avail > 0 = do + -- avail <= nullFree + copyBytes op0 ip avail + let len' = len - avail + !ip' = ip `plusPtr` avail + !op' = op0 `plusPtr` avail + return $ bufferFull 1 op' (modUtf8_step ip' len' nullAt k) + | otherwise = + return $ bufferFull 1 op0 (modUtf8_step ip len nullAt k) + where + !avail = ope `minusPtr` op0 + !nullFree = nullAt `minusPtr` ip + +foreign import ccall unsafe "string.h strstr" c_strstr + :: CString -> CString -> IO (Ptr Word8) + + -- Short bytestrings ------------------------------------------------------------------------------ diff --git a/Data/ByteString/Builder/Prim.hs b/Data/ByteString/Builder/Prim.hs index e08e69e03..7ec85bf88 100644 --- a/Data/ByteString/Builder/Prim.hs +++ b/Data/ByteString/Builder/Prim.hs @@ -663,59 +663,25 @@ primMapLazyByteStringBounded w = L.foldrChunks (\x b -> primMapByteStringBounded w x `mappend` b) mempty ------------------------------------------------------------------------------- --- Raw CString encoding ------------------------------------------------------------------------------- - --- | A null-terminated ASCII encoded 'Foreign.C.String.CString'. --- Null characters are not representable. +-- | Builder for raw 'Addr#' pointers to null-terminated primitive ASCII +-- strings that are free of embedded (overlong-encoded as the two-byte sequence +-- @0xC0 0x80@) null characters. -- -- @since 0.11.0.0 +{-# DEPRECATED cstring "Use ascLiteralCopy instead" #-} cstring :: Addr# -> Builder -cstring = - \addr0 -> builder $ step addr0 - where - step :: Addr# -> BuildStep r -> BuildStep r - step !addr !k br@(BufferRange op0@(Ptr op0#) ope) - | W8# ch == 0 = k br - | op0 == ope = - return $ bufferFull 1 op0 (step addr k) - | otherwise = do - IO $ \s -> case writeWord8OffAddr# op0# 0# ch s of - s' -> (# s', () #) - let br' = BufferRange (op0 `plusPtr` 1) ope - step (addr `plusAddr#` 1#) k br' - where - !ch = indexWord8OffAddr# addr 0# +cstring s = ascLiteralCopy (Ptr s) (S.byteCountLiteral s) +{-# INLINE cstring #-} --- | A null-terminated UTF-8 encoded 'Foreign.C.String.CString'. --- Null characters can be encoded as @0xc0 0x80@. +-- | Builder for raw 'Addr#' pointers to null-terminated primitive UTF-8 +-- encoded strings that may contain embedded overlong-encodings (as the +-- two-byte sequence @0xC0 0x80@) of null characters. -- -- @since 0.11.0.0 +{-# DEPRECATED cstringUtf8 "Use modUtf8LitCopy instead" #-} cstringUtf8 :: Addr# -> Builder -cstringUtf8 = - \addr0 -> builder $ step addr0 - where - step :: Addr# -> BuildStep r -> BuildStep r - step !addr !k br@(BufferRange op0@(Ptr op0#) ope) - | W8# ch == 0 = k br - | op0 == ope = - return $ bufferFull 1 op0 (step addr k) - -- NULL is encoded as 0xc0 0x80 - | W8# ch == 0xc0 - , W8# (indexWord8OffAddr# addr 1#) == 0x80 = do - let !(W8# nullByte#) = 0 - IO $ \s -> case writeWord8OffAddr# op0# 0# nullByte# s of - s' -> (# s', () #) - let br' = BufferRange (op0 `plusPtr` 1) ope - step (addr `plusAddr#` 2#) k br' - | otherwise = do - IO $ \s -> case writeWord8OffAddr# op0# 0# ch s of - s' -> (# s', () #) - let br' = BufferRange (op0 `plusPtr` 1) ope - step (addr `plusAddr#` 1#) k br' - where - !ch = indexWord8OffAddr# addr 0# +cstringUtf8 s = modUtf8LitCopy (Ptr s) (S.byteCountLiteral s) +{-# INLINE cstringUtf8 #-} ------------------------------------------------------------------------------ -- Char8 encoding diff --git a/Data/ByteString/Internal.hs b/Data/ByteString/Internal.hs index c4c831bc0..58639a4b9 100644 --- a/Data/ByteString/Internal.hs +++ b/Data/ByteString/Internal.hs @@ -36,7 +36,7 @@ module Data.ByteString.Internal ( unpackBytes, unpackAppendBytesLazy, unpackAppendBytesStrict, unpackChars, unpackAppendCharsLazy, unpackAppendCharsStrict, unsafePackAddress, unsafePackLenAddress, - unsafePackLiteral, unsafePackLenLiteral, + unsafePackLiteral, unsafePackLenLiteral, byteCountLiteral, -- * Low level imperative construction empty, diff --git a/Data/ByteString/Internal/Type.hs b/Data/ByteString/Internal/Type.hs index 3d287724c..8cb1ff8bf 100644 --- a/Data/ByteString/Internal/Type.hs +++ b/Data/ByteString/Internal/Type.hs @@ -39,7 +39,7 @@ module Data.ByteString.Internal.Type ( unpackBytes, unpackAppendBytesLazy, unpackAppendBytesStrict, unpackChars, unpackAppendCharsLazy, unpackAppendCharsStrict, unsafePackAddress, unsafePackLenAddress, - unsafePackLiteral, unsafePackLenLiteral, + unsafePackLiteral, unsafePackLenLiteral, byteCountLiteral, -- * Low level imperative construction empty, @@ -481,13 +481,22 @@ unsafePackLenAddress len addr# = do -- @since 0.11.1.0 unsafePackLiteral :: Addr# -> ByteString unsafePackLiteral addr# = + unsafePackLenLiteral (byteCountLiteral addr#) addr# +{-# INLINE unsafePackLiteral #-} + +-- | Byte count of null-terminated primitive literal string excluding the +-- terminating null byte. +byteCountLiteral :: Addr# -> Int +byteCountLiteral addr# = #if __GLASGOW_HASKELL__ >= 811 - unsafePackLenLiteral (I# (cstringLength# addr#)) addr# + I# (cstringLength# addr#) #else - let len = accursedUnutterablePerformIO (c_strlen (Ptr addr#)) - in unsafePackLenLiteral (fromIntegral len) addr# + fromIntegral (pure_strlen (Ptr addr#)) + +foreign import ccall unsafe "string.h strlen" pure_strlen + :: CString -> CSize #endif -{-# INLINE unsafePackLiteral #-} +{-# INLINE byteCountLiteral #-} -- | See 'unsafePackLiteral'. This function is similar, diff --git a/bench/BenchAll.hs b/bench/BenchAll.hs index 3daa09463..8191ca8bf 100644 --- a/bench/BenchAll.hs +++ b/bench/BenchAll.hs @@ -25,6 +25,7 @@ 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.Internal (byteCountLiteral) import Data.ByteString.Builder import Data.ByteString.Builder.Extra (byteStringCopy, @@ -33,10 +34,13 @@ import Data.ByteString.Builder.Extra (byteStringCopy, import Data.ByteString.Builder.Internal (ensureFree) import Data.ByteString.Builder.Prim (BoundedPrim, FixedPrim, (>$<)) +import qualified Data.ByteString.Builder.Internal as BI import qualified Data.ByteString.Builder.Prim as P import qualified Data.ByteString.Builder.Prim.Internal as PI import Foreign +import GHC.Exts (Addr#) +import GHC.Ptr (Ptr(..)) import System.Random @@ -247,6 +251,18 @@ largeTraversalInput = S.concat (replicate 10 byteStringData) smallTraversalInput :: S.ByteString smallTraversalInput = S8.pack "The quick brown fox" +ascBuf, utfBuf :: Ptr Word8 +ascBuf = Ptr "xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx"# +utfBuf = Ptr "xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx\xc0\x80xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx"# + +asclit, utflit :: Ptr Word8 -> Builder +asclit str@(Ptr addr) = BI.ascLiteralCopy str (byteCountLiteral addr) +utflit str@(Ptr addr) = BI.modUtf8LitCopy str (byteCountLiteral addr) + +ascStr, utfStr :: String +ascStr = "xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx" +utfStr = "xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx\0xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx" + main :: IO () main = do defaultMain @@ -256,9 +272,15 @@ main = do , 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' "UTF-8 String" () $ \() -> utflit (Ptr "hello world\xc0\x80"#) , benchB' "String (naive)" "hello world!" fromString - , benchB' "String" () $ \() -> P.cstring "hello world!"# + , benchB' "String" () $ \() -> asclit (Ptr "hello world!"#) + , benchB' "AsciiLit" () $ \() -> asclit ascBuf + , benchB' "Utf8Lit" () $ \() -> utflit utfBuf + , benchB' "strLit" () $ \() -> string8 ascStr + , benchB' "utfLit" () $ \() -> stringUtf8 utfStr + , benchB' "strLitInline" () $ \() -> string8 "XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX" + , benchB' "utfLitInline" () $ \() -> stringUtf8 "XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX\0XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX" ] , bgroup "Encoding wrappers" diff --git a/tests/builder/Data/ByteString/Builder/Prim/Tests.hs b/tests/builder/Data/ByteString/Builder/Prim/Tests.hs index 230882335..fa1ae5894 100644 --- a/tests/builder/Data/ByteString/Builder/Prim/Tests.hs +++ b/tests/builder/Data/ByteString/Builder/Prim/Tests.hs @@ -24,17 +24,7 @@ import Test.Tasty.QuickCheck tests :: [TestTree] tests = concat [ testsBinary, testsASCII, testsChar8, testsUtf8 - , testsCombinatorsB, [testCString, testCStringUtf8] ] - -testCString :: TestTree -testCString = testProperty "cstring" $ - toLazyByteString (BP.cstring "hello world!"#) == - LC.pack "hello" `L.append` L.singleton 0x20 `L.append` LC.pack "world!" - -testCStringUtf8 :: TestTree -testCStringUtf8 = testProperty "cstringUtf8" $ - toLazyByteString (BP.cstringUtf8 "hello\xc0\x80world!"#) == - LC.pack "hello" `L.append` L.singleton 0x00 `L.append` LC.pack "world!" + , testsCombinatorsB ] ------------------------------------------------------------------------------ -- Binary diff --git a/tests/builder/Data/ByteString/Builder/Tests.hs b/tests/builder/Data/ByteString/Builder/Tests.hs index a7ab9131a..a4acd3f74 100644 --- a/tests/builder/Data/ByteString/Builder/Tests.hs +++ b/tests/builder/Data/ByteString/Builder/Tests.hs @@ -34,6 +34,7 @@ import Data.Word import qualified Data.ByteString as S import qualified Data.ByteString.Internal as S import qualified Data.ByteString.Lazy as L +import qualified Data.ByteString.Lazy.Char8 as LC import qualified Data.ByteString.Short as Sh import Data.ByteString.Builder @@ -47,6 +48,7 @@ import Control.Exception (evaluate) import System.IO (openTempFile, hPutStr, hClose, hSetBinaryMode, hSetEncoding, utf8, hSetNewlineMode, noNewlineTranslation) import Foreign (ForeignPtr, withForeignPtr, castPtr) import Foreign.C.String (withCString) +import GHC.Ptr (Ptr(..)) import Numeric (showFFloat) import System.Posix.Internals (c_unlink) @@ -75,7 +77,8 @@ tests = testsASCII ++ testsFloating ++ testsChar8 ++ - testsUtf8 + testsUtf8 ++ + testCString ------------------------------------------------------------------------------ @@ -984,3 +987,22 @@ testsUtf8 = [ testBuilderConstr "charUtf8" charUtf8_list charUtf8 , testBuilderConstr "stringUtf8" (foldMap charUtf8_list) stringUtf8 ] + +testCString :: [TestTree] +testCString = + [ testProperty "cstring" $ + toLazyByteString (asclit (Ptr "hello world!"#)) == + LC.pack "hello" `L.append` L.singleton 0x20 + `L.append` LC.pack "world!" + , testProperty "cstringUtf8" $ + toLazyByteString (utflit (Ptr "hello\xc0\x80\xc0\x80world\xc0\x80!"#)) == + LC.pack "hello" `L.append` L.singleton 0x00 + `L.append` L.singleton 0x00 + `L.append` LC.pack "world" + `L.append` L.singleton 0x00 + `L.append` LC.singleton '!' + ] + +asclit, utflit :: Ptr Word8 -> Builder +asclit str@(Ptr addr) = BI.ascLiteralCopy str (S.byteCountLiteral addr) +utflit str@(Ptr addr) = BI.modUtf8LitCopy str (S.byteCountLiteral addr) From 01b5f36d5d078c5ffc402f6f9e1e86bea0838b23 Mon Sep 17 00:00:00 2001 From: Viktor Dukhovni Date: Mon, 9 Oct 2023 16:56:29 -0400 Subject: [PATCH 2/8] Cosmetic renames asc -> ascii --- Data/ByteString/Builder.hs | 8 ++--- Data/ByteString/Builder/Internal.hs | 8 ++--- Data/ByteString/Builder/Prim.hs | 4 +-- bench/BenchAll.hs | 32 +++++++++---------- .../builder/Data/ByteString/Builder/Tests.hs | 10 +++--- 5 files changed, 31 insertions(+), 31 deletions(-) diff --git a/Data/ByteString/Builder.hs b/Data/ByteString/Builder.hs index 68c8bbdbf..90e8984d4 100644 --- a/Data/ByteString/Builder.hs +++ b/Data/ByteString/Builder.hs @@ -451,11 +451,11 @@ string8 = P.primMapListFixed P.char8 {-# RULES "string8/unpackCString#" forall s. string8 (unpackCString# s) = - ascLiteralCopy (Ptr s) (byteCountLiteral s) + asciiLiteralCopy (Ptr s) (byteCountLiteral s) "string8/unpackFoldrCString#" forall s. string8 (build (unpackFoldrCString# s)) = - ascLiteralCopy (Ptr s) (byteCountLiteral s) + asciiLiteralCopy (Ptr s) (byteCountLiteral s) #-} ------------------------------------------------------------------------------ @@ -482,11 +482,11 @@ stringUtf8 = P.primMapListBounded P.charUtf8 "stringUtf8/unpackCString#" forall s. stringUtf8 (unpackCString# s) = - ascLiteralCopy (Ptr s) (byteCountLiteral s) + asciiLiteralCopy (Ptr s) (byteCountLiteral s) "stringUtf8/unpackFoldrCString#" forall s. stringUtf8 (build (unpackFoldrCString# s)) = - ascLiteralCopy (Ptr s) (byteCountLiteral s) + asciiLiteralCopy (Ptr s) (byteCountLiteral s) #-} instance IsString Builder where diff --git a/Data/ByteString/Builder/Internal.hs b/Data/ByteString/Builder/Internal.hs index 061d72726..5d41957c8 100644 --- a/Data/ByteString/Builder/Internal.hs +++ b/Data/ByteString/Builder/Internal.hs @@ -84,7 +84,7 @@ module Data.ByteString.Builder.Internal ( -- , sizedChunksInsert , byteStringCopy - , ascLiteralCopy + , asciiLiteralCopy , modUtf8LitCopy , byteStringInsert , byteStringThreshold @@ -889,9 +889,9 @@ byteStringInsert = -- @0xC0 0x80@) null characters. -- -- @since 0.11.5.0 -{-# INLINABLE ascLiteralCopy #-} -ascLiteralCopy :: Ptr Word8 -> Int -> Builder -ascLiteralCopy = \ !ip !len -> builder $ \k br -> do +{-# INLINABLE asciiLiteralCopy #-} +asciiLiteralCopy :: Ptr Word8 -> Int -> Builder +asciiLiteralCopy = \ !ip !len -> builder $ \k br -> do let !ipe = ip `plusPtr` len wrappedBytesCopyStep (BufferRange ip ipe) k br diff --git a/Data/ByteString/Builder/Prim.hs b/Data/ByteString/Builder/Prim.hs index 7ec85bf88..3d20e1b0a 100644 --- a/Data/ByteString/Builder/Prim.hs +++ b/Data/ByteString/Builder/Prim.hs @@ -668,9 +668,9 @@ primMapLazyByteStringBounded w = -- @0xC0 0x80@) null characters. -- -- @since 0.11.0.0 -{-# DEPRECATED cstring "Use ascLiteralCopy instead" #-} +{-# DEPRECATED cstring "Use asciiLiteralCopy instead" #-} cstring :: Addr# -> Builder -cstring s = ascLiteralCopy (Ptr s) (S.byteCountLiteral s) +cstring s = asciiLiteralCopy (Ptr s) (S.byteCountLiteral s) {-# INLINE cstring #-} -- | Builder for raw 'Addr#' pointers to null-terminated primitive UTF-8 diff --git a/bench/BenchAll.hs b/bench/BenchAll.hs index 8191ca8bf..332fb0213 100644 --- a/bench/BenchAll.hs +++ b/bench/BenchAll.hs @@ -251,17 +251,17 @@ largeTraversalInput = S.concat (replicate 10 byteStringData) smallTraversalInput :: S.ByteString smallTraversalInput = S8.pack "The quick brown fox" -ascBuf, utfBuf :: Ptr Word8 -ascBuf = Ptr "xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx"# -utfBuf = Ptr "xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx\xc0\x80xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx"# +asciiBuf, utf8Buf :: Ptr Word8 +asciiBuf = Ptr "xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx"# +utf8Buf = Ptr "xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx\xc0\x80xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx"# -asclit, utflit :: Ptr Word8 -> Builder -asclit str@(Ptr addr) = BI.ascLiteralCopy str (byteCountLiteral addr) -utflit str@(Ptr addr) = BI.modUtf8LitCopy str (byteCountLiteral addr) +asciiLit, utf8Lit :: Ptr Word8 -> Builder +asciiLit str@(Ptr addr) = BI.asciiLiteralCopy str (byteCountLiteral addr) +utf8Lit str@(Ptr addr) = BI.modUtf8LitCopy str (byteCountLiteral addr) -ascStr, utfStr :: String -ascStr = "xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx" -utfStr = "xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx\0xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx" +asciiStr, utf8Str :: String +asciiStr = "xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx" +utf8Str = "xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx\0xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx" main :: IO () main = do @@ -272,15 +272,15 @@ main = do , benchB' "ensureFree 8" () (const (ensureFree 8)) , benchB' "intHost 1" 1 intHost , benchB' "UTF-8 String (naive)" "hello world\0" fromString - , benchB' "UTF-8 String" () $ \() -> utflit (Ptr "hello world\xc0\x80"#) + , benchB' "UTF-8 String" () $ \() -> utf8Lit (Ptr "hello world\xc0\x80"#) , benchB' "String (naive)" "hello world!" fromString - , benchB' "String" () $ \() -> asclit (Ptr "hello world!"#) - , benchB' "AsciiLit" () $ \() -> asclit ascBuf - , benchB' "Utf8Lit" () $ \() -> utflit utfBuf - , benchB' "strLit" () $ \() -> string8 ascStr - , benchB' "utfLit" () $ \() -> stringUtf8 utfStr + , benchB' "String" () $ \() -> asciiLit (Ptr "hello world!"#) + , benchB' "AsciiLit" () $ \() -> asciiLit asciiBuf + , benchB' "Utf8Lit" () $ \() -> utf8Lit utf8Buf + , benchB' "strLit" () $ \() -> string8 asciiStr + , benchB' "stringUtf8" () $ \() -> stringUtf8 utf8Str , benchB' "strLitInline" () $ \() -> string8 "XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX" - , benchB' "utfLitInline" () $ \() -> stringUtf8 "XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX\0XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX" + , benchB' "utf8LitInline" () $ \() -> stringUtf8 "XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX\0XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX" ] , bgroup "Encoding wrappers" diff --git a/tests/builder/Data/ByteString/Builder/Tests.hs b/tests/builder/Data/ByteString/Builder/Tests.hs index a4acd3f74..12440b269 100644 --- a/tests/builder/Data/ByteString/Builder/Tests.hs +++ b/tests/builder/Data/ByteString/Builder/Tests.hs @@ -991,11 +991,11 @@ testsUtf8 = testCString :: [TestTree] testCString = [ testProperty "cstring" $ - toLazyByteString (asclit (Ptr "hello world!"#)) == + toLazyByteString (asciiLit (Ptr "hello world!"#)) == LC.pack "hello" `L.append` L.singleton 0x20 `L.append` LC.pack "world!" , testProperty "cstringUtf8" $ - toLazyByteString (utflit (Ptr "hello\xc0\x80\xc0\x80world\xc0\x80!"#)) == + toLazyByteString (utf8Lit (Ptr "hello\xc0\x80\xc0\x80world\xc0\x80!"#)) == LC.pack "hello" `L.append` L.singleton 0x00 `L.append` L.singleton 0x00 `L.append` LC.pack "world" @@ -1003,6 +1003,6 @@ testCString = `L.append` LC.singleton '!' ] -asclit, utflit :: Ptr Word8 -> Builder -asclit str@(Ptr addr) = BI.ascLiteralCopy str (S.byteCountLiteral addr) -utflit str@(Ptr addr) = BI.modUtf8LitCopy str (S.byteCountLiteral addr) +asciiLit, utf8Lit :: Ptr Word8 -> Builder +asciiLit str@(Ptr addr) = BI.asciiLiteralCopy str (S.byteCountLiteral addr) +utf8Lit str@(Ptr addr) = BI.modUtf8LitCopy str (S.byteCountLiteral addr) From 3ce03463fc26c4b8d96b1f50e4acec0cfe0e4d1b Mon Sep 17 00:00:00 2001 From: Matthew Craven Date: Tue, 13 Feb 2024 23:19:15 -0500 Subject: [PATCH 3/8] 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 d674964e5d9438bbddf51ca091f6501c40bbb614 Mon Sep 17 00:00:00 2001 From: Matthew Craven Date: Wed, 14 Feb 2024 22:52:22 -0500 Subject: [PATCH 4/8] Add pure-haskell implementation avoiding strstr --- Data/ByteString/Builder/Internal.hs | 35 +++++++++++++++++++++++------ Data/ByteString/Internal/Type.hs | 18 ++++++++------- 2 files changed, 38 insertions(+), 15 deletions(-) diff --git a/Data/ByteString/Builder/Internal.hs b/Data/ByteString/Builder/Internal.hs index bdc073605..efd9090f8 100644 --- a/Data/ByteString/Builder/Internal.hs +++ b/Data/ByteString/Builder/Internal.hs @@ -143,15 +143,18 @@ import qualified Data.ByteString.Short.Internal as Sh import qualified GHC.IO.Buffer as IO (Buffer(..), newByteBuffer) import GHC.IO.Handle.Internals (wantWritableHandle, flushWriteBuffer) import GHC.IO.Handle.Types (Handle__, haByteBuffer, haBufferMode) -import GHC.Ptr (Ptr(..)) import System.IO (hFlush, BufferMode(..), Handle) import Data.IORef import Foreign -import Foreign.C.String (CString) import Foreign.ForeignPtr.Unsafe (unsafeForeignPtrToPtr) import System.IO.Unsafe (unsafeDupablePerformIO) +#if !(PURE_HASKELL || defined(USE_MEMCHR)) +import Foreign.C.String (CString) +import GHC.Ptr (Ptr(..)) +#endif + ------------------------------------------------------------------------------ -- Buffers ------------------------------------------------------------------------------ @@ -909,11 +912,32 @@ asciiLiteralCopy = \ !ip !len -> builder $ \k br -> do let !ipe = ip `plusPtr` len wrappedBytesCopyStep (BufferRange ip ipe) k br +getNextEmbeddedNull :: Ptr Word8 -> Int -> IO (Ptr Word8) +#if PURE_HASKELL || defined(USE_MEMCHR) +getNextEmbeddedNull p len = do + c0loc <- S.memchr p 0xC0 (S.checkedCast len) + if c0loc == nullPtr + then pure c0loc + else do + let nextLoc = c0loc `plusPtr` 1 :: Ptr Word8 + nextByte <- peek nextLoc + if nextByte == 0x80 + then pure c0loc + else getNextEmbeddedNull nextLoc (p `minusPtr` nextLoc + len) + +#else +getNextEmbeddedNull p _len = c_strstr (castPtr p) modifiedUtf8NUL + -- | GHC represents @NUL@ in string literals via an overlong 2-byte encoding, -- which is part of "modified UTF-8" (GHC does not also implement CESU-8). modifiedUtf8NUL :: CString modifiedUtf8NUL = Ptr "\xc0\x80"# +foreign import ccall unsafe "string.h strstr" c_strstr + :: CString -> CString -> IO (Ptr Word8) +#endif + + -- | Builder for raw 'Addr#' pointers to null-terminated primitive UTF-8 -- encoded strings that may contain embedded overlong-encodings (as the -- two-byte sequence @0xC0 0x80@) of null characters. @@ -922,7 +946,7 @@ modifiedUtf8NUL = Ptr "\xc0\x80"# {-# INLINABLE modUtf8LitCopy #-} modUtf8LitCopy :: Ptr Word8 -> Int -> Builder modUtf8LitCopy = \ !ip !len -> builder $ \k br -> do - nullAt <- c_strstr (castPtr ip) modifiedUtf8NUL + nullAt <- getNextEmbeddedNull ip len modUtf8_step ip len nullAt k br modUtf8_step :: Ptr Word8 -> Int -> Ptr Word8 -> BuildStep r -> BuildStep r @@ -943,7 +967,7 @@ modUtf8_step !ip !len !nullAt k (BufferRange op0 ope) len' = len - used !ip' = ip `plusPtr` used !op' = op0 `plusPtr` (nullFree + 1) - nullAt' <- c_strstr ip' modifiedUtf8NUL + nullAt' <- getNextEmbeddedNull ip' len' modUtf8_step ip' len' nullAt' k (BufferRange op' ope) | avail > 0 = do -- avail <= nullFree @@ -958,9 +982,6 @@ modUtf8_step !ip !len !nullAt k (BufferRange op0 ope) !avail = ope `minusPtr` op0 !nullFree = nullAt `minusPtr` ip -foreign import ccall unsafe "string.h strstr" c_strstr - :: CString -> CString -> IO (Ptr Word8) - -- Short bytestrings ------------------------------------------------------------------------------ diff --git a/Data/ByteString/Internal/Type.hs b/Data/ByteString/Internal/Type.hs index 9b5b511cb..6c90377b3 100644 --- a/Data/ByteString/Internal/Type.hs +++ b/Data/ByteString/Internal/Type.hs @@ -82,6 +82,7 @@ module Data.ByteString.Internal.Type ( overflowError, checkedAdd, checkedMultiply, + checkedCast, -- * Standard C Functions c_strlen, @@ -137,8 +138,6 @@ import Foreign.Marshal.Utils #if PURE_HASKELL import qualified Data.ByteString.Internal.Pure as Pure -import Data.Bits (toIntegralSized, Bits) -import Data.Maybe (fromMaybe) import Control.Monad ((<$!>)) #endif @@ -154,8 +153,9 @@ import Data.String (IsString(..)) import Control.Exception (assert, throw, Exception) -import Data.Bits ((.&.)) +import Data.Bits ((.&.), toIntegralSized, Bits) import Data.Char (ord) +import Data.Maybe (fromMaybe) import Data.Word import Data.Data (Data(..), mkConstr ,mkDataType, Constr, DataType, Fixity(Prefix), constrIndex) @@ -164,6 +164,7 @@ import GHC.Base (nullAddr#,realWorld#,unsafeChr) import GHC.Exts (IsList(..), Addr#, minusAddr#, ByteArray#) import GHC.CString (unpackCString#) import GHC.Magic (runRW#, lazy) +import GHC.Stack.Types (HasCallStack) #define TIMES_INT_2_AVAILABLE MIN_VERSION_ghc_prim(0,7,0) #if TIMES_INT_2_AVAILABLE @@ -1073,6 +1074,12 @@ checkedIntegerToInt x | otherwise = Nothing where res = fromInteger x :: Int +checkedCast :: (HasCallStack, Bits a, Bits b, Integral a, Integral b) => a -> b +checkedCast x = + fromMaybe (error "checkedCast: overflow") + (toIntegralSized x) + + ------------------------------------------------------------------------ @@ -1281,11 +1288,6 @@ bool_to_cint :: Bool -> CInt bool_to_cint True = 1 bool_to_cint False = 0 -checkedCast :: (Bits a, Bits b, Integral a, Integral b) => a -> b -checkedCast x = - fromMaybe (errorWithoutStackTrace "checkedCast: overflow") - (toIntegralSized x) - ---------------------------------------------------------------- -- Haskell version of functions in itoa.c ---------------------------------------------------------------- From b297904ef25c106b1ed8ccf34779d24a5e76d7b3 Mon Sep 17 00:00:00 2001 From: Matthew Craven Date: Wed, 14 Feb 2024 22:56:24 -0500 Subject: [PATCH 5/8] Update "@since" of new functions to 0.12.1.0 --- 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 efd9090f8..886411550 100644 --- a/Data/ByteString/Builder/Internal.hs +++ b/Data/ByteString/Builder/Internal.hs @@ -905,7 +905,7 @@ byteStringInsert = -- strings that are free of embedded (overlong-encoded as the two-byte sequence -- @0xC0 0x80@) null characters. -- --- @since 0.11.5.0 +-- @since 0.12.1.0 {-# INLINABLE asciiLiteralCopy #-} asciiLiteralCopy :: Ptr Word8 -> Int -> Builder asciiLiteralCopy = \ !ip !len -> builder $ \k br -> do @@ -942,7 +942,7 @@ foreign import ccall unsafe "string.h strstr" c_strstr -- encoded strings that may contain embedded overlong-encodings (as the -- two-byte sequence @0xC0 0x80@) of null characters. -- --- @since 0.11.5.0 +-- @since 0.12.1.0 {-# INLINABLE modUtf8LitCopy #-} modUtf8LitCopy :: Ptr Word8 -> Int -> Builder modUtf8LitCopy = \ !ip !len -> builder $ \k br -> do From e1aab365046d308d9e29f4d8d8683de7673b965a Mon Sep 17 00:00:00 2001 From: Matthew Craven Date: Wed, 14 Feb 2024 22:58:40 -0500 Subject: [PATCH 6/8] Add deprecated-since info to docstrings --- Data/ByteString/Builder/Prim.hs | 4 ++++ 1 file changed, 4 insertions(+) diff --git a/Data/ByteString/Builder/Prim.hs b/Data/ByteString/Builder/Prim.hs index d8171e0f9..76e24e794 100644 --- a/Data/ByteString/Builder/Prim.hs +++ b/Data/ByteString/Builder/Prim.hs @@ -667,6 +667,8 @@ primMapLazyByteStringBounded w = -- strings that are free of embedded (overlong-encoded as the two-byte sequence -- @0xC0 0x80@) null characters. -- +-- Deprecated since @bytestring-0.12.1.0@. +-- -- @since 0.11.0.0 {-# DEPRECATED cstring "Use asciiLiteralCopy instead" #-} cstring :: Addr# -> Builder @@ -677,6 +679,8 @@ cstring s = asciiLiteralCopy (Ptr s) (S.byteCountLiteral s) -- encoded strings that may contain embedded overlong-encodings (as the -- two-byte sequence @0xC0 0x80@) of null characters. -- +-- Deprecated since @bytestring-0.12.1.0@. +-- -- @since 0.11.0.0 {-# DEPRECATED cstringUtf8 "Use modUtf8LitCopy instead" #-} cstringUtf8 :: Addr# -> Builder From 26030097e5d66077dd078b2dc8ffcf0e2075d805 Mon Sep 17 00:00:00 2001 From: Matthew Craven Date: Wed, 14 Feb 2024 23:09:36 -0500 Subject: [PATCH 7/8] Use Exts.lazy instead of Exts.noinline The magic noinline id just isn't available with ghc-8.0... --- bench/BenchAll.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/bench/BenchAll.hs b/bench/BenchAll.hs index f11dfb85c..55ea35512 100644 --- a/bench/BenchAll.hs +++ b/bench/BenchAll.hs @@ -307,7 +307,7 @@ 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 From cd02c617622853c7f88c194f00bd67c6627a05f4 Mon Sep 17 00:00:00 2001 From: Matthew Craven Date: Thu, 15 Feb 2024 09:40:23 -0500 Subject: [PATCH 8/8] Allow primMapListBounded to inline with one arg --- Data/ByteString/Builder/Prim.hs | 5 ++++- 1 file changed, 4 insertions(+), 1 deletion(-) diff --git a/Data/ByteString/Builder/Prim.hs b/Data/ByteString/Builder/Prim.hs index 76e24e794..52be31236 100644 --- a/Data/ByteString/Builder/Prim.hs +++ b/Data/ByteString/Builder/Prim.hs @@ -579,7 +579,10 @@ primBounded w x = -- because it moves several variables out of the inner loop. {-# INLINE primMapListBounded #-} primMapListBounded :: BoundedPrim a -> [a] -> Builder -primMapListBounded w xs0 = +primMapListBounded w = \xs0 -> + -- We want this to inline when there is one arg, so that we can + -- specialise on the BoundedPrim "w". So we move the \xs0 after the + -- "=" sign so that the INLINE pragma doesn't interfere with this. builder $ step xs0 where step xs1 k (BufferRange op0 ope0) =