diff --git a/Blaze/ByteString/Builder.hs b/Blaze/ByteString/Builder.hs --- a/Blaze/ByteString/Builder.hs +++ b/Blaze/ByteString/Builder.hs @@ -62,7 +62,6 @@ Builder -- * Creating builders - , module Blaze.ByteString.Builder.Write , module Blaze.ByteString.Builder.Int , module Blaze.ByteString.Builder.Word , module Blaze.ByteString.Builder.ByteString @@ -74,132 +73,11 @@ , toByteString , toByteStringIO , toByteStringIOWith - - -- * Compatibility to Data.Binary.Builder from the binary package - -- - -- | The following functions ensure that @"Blaze.ByteString.Builder"@ is a - -- drop-in replacement for @Data.Binary.Builder@ from the @binary@ - -- package. Note that these functions are deprecated and may be removed - -- in future versions of the @blaze-builder@ package. - -- - , empty -- DEPRECATED: use 'mempty' instead - , singleton -- DEPRECATED: use 'fromByte' instead - , append -- DEPRECATED: use 'mappend' instead - - , putWord16be -- DEPRECATED: use 'fromWord' instead - , putWord32be -- - , putWord64be -- - , putWord16le -- - , putWord32le -- - , putWord64le -- for all these functions - , putWordhost -- - , putWord16host -- - , putWord32host -- - , putWord64host -- ) where import Blaze.ByteString.Builder.Internal -import Blaze.ByteString.Builder.Write import Blaze.ByteString.Builder.Int import Blaze.ByteString.Builder.Word import Blaze.ByteString.Builder.ByteString - -import Data.Monoid -import Data.Word - ------------------------------------------------------------------------------- --- API Compatibility to Data.Binary.Builder from 'binary' ------------------------------------------------------------------------------- - --- | /O(1)/. An empty builder. --- --- /Deprecated:/ use 'mempty' instead. -empty :: Builder -empty = mempty -{-# DEPRECATED empty "Use 'mempty' instead." #-} - --- | /O(1)/. Append two builders. --- --- /Deprecated:/ use 'mappend' instead. -append :: Builder -> Builder -> Builder -append = mappend -{-# DEPRECATED append "Use 'mappend' instead." #-} - --- | /O(1)/. Serialize a single byte. --- --- /Deprecated:/ use 'fromWord8' instead. -singleton :: Word8 -> Builder -singleton = fromWriteSingleton writeWord8 -{-# DEPRECATED singleton "Use 'fromWord8' instead." #-} - --- | /O(1)/. Serialize a 'Word16' in big endian format. --- --- /Deprecated:/ use 'fromWord16be' instead. -putWord16be :: Word16 -> Builder -putWord16be = fromWord16be -{-# DEPRECATED putWord16be "Use 'fromWord16be' instead." #-} - --- | /O(1)/. Serialize a 'Word32' in big endian format. --- --- /Deprecated:/ use 'fromWord32be' instead. -putWord32be :: Word32 -> Builder -putWord32be = fromWord32be -{-# DEPRECATED putWord32be "Use 'fromWord32be' instead." #-} - --- | /O(1)/. Serialize a 'Word64' in big endian format. --- --- /Deprecated:/ use 'fromWord64be' instead. -putWord64be :: Word64 -> Builder -putWord64be = fromWord64be -{-# DEPRECATED putWord64be "Use 'fromWord64be' instead." #-} - --- | /O(1)/. Serialize a 'Word16' in little endian format. --- --- /Deprecated:/ use 'fromWord16le' instead. -putWord16le :: Word16 -> Builder -putWord16le = fromWord16le -{-# DEPRECATED putWord16le "Use 'fromWord16le' instead." #-} - --- | /O(1)/. Serialize a 'Word32' in little endian format. --- --- /Deprecated:/ use 'fromWord32le' instead. -putWord32le :: Word32 -> Builder -putWord32le = fromWord32le -{-# DEPRECATED putWord32le "Use 'fromWord32le' instead." #-} - --- | /O(1)/. Serialize a 'Word64' in little endian format. --- --- /Deprecated:/ use 'fromWord64le' instead. -putWord64le :: Word64 -> Builder -putWord64le = fromWord64le -{-# DEPRECATED putWord64le "Use 'fromWord64le' instead." #-} - --- | /O(1)/. Serialize a 'Word' in host endian format. --- --- /Deprecated:/ use 'fromWordhost' instead. -putWordhost :: Word -> Builder -putWordhost = fromWordhost -{-# DEPRECATED putWordhost "Use 'fromWordhost' instead." #-} - --- | /O(1)/. Serialize a 'Word16' in host endian format. --- --- /Deprecated:/ use 'fromWord16host' instead. -putWord16host :: Word16 -> Builder -putWord16host = fromWord16host -{-# DEPRECATED putWord16host "Use 'fromWord16host' instead." #-} - --- | /O(1)/. Serialize a 'Word32' in host endian format. --- --- /Deprecated:/ use 'fromWord32host' instead. -putWord32host :: Word32 -> Builder -putWord32host = fromWord32host -{-# DEPRECATED putWord32host "Use 'fromWord32host' instead." #-} - --- | /O(1)/. Serialize a 'Word64' in host endian format. --- --- /Deprecated:/ use 'fromWord64host' instead. -putWord64host :: Word64 -> Builder -putWord64host = fromWord64host -{-# DEPRECATED putWord64host "Use 'fromWord64host' instead." #-} diff --git a/Blaze/ByteString/Builder/ByteString.hs b/Blaze/ByteString/Builder/ByteString.hs --- a/Blaze/ByteString/Builder/ByteString.hs +++ b/Blaze/ByteString/Builder/ByteString.hs @@ -34,8 +34,8 @@ ) where -import Blaze.ByteString.Builder.Write -import Blaze.ByteString.Builder.Internal +import Blaze.ByteString.Builder.Internal hiding (insertByteString) +import qualified Blaze.ByteString.Builder.Internal as I (insertByteString) import Foreign import Data.Monoid @@ -59,7 +59,7 @@ -- | Write a strict 'S.ByteString' to a buffer. -- writeByteString :: S.ByteString -> Write -writeByteString bs = Write l io +writeByteString bs = exactWrite l io where (fptr, o, l) = S.toForeignPtr bs io pf = withForeignPtr fptr $ \p -> copyBytes pf (p `plusPtr` o) l @@ -97,22 +97,14 @@ fromByteStringWith :: Int -- ^ Maximal number of bytes to copy. -> S.ByteString -- ^ Strict 'S.ByteString' to serialize. -> Builder -- ^ Resulting 'Builder'. -fromByteStringWith maximalCopySize bs = Builder step +fromByteStringWith maxCopySize = + \bs -> fromBuildStepCont $ step bs where - step k pf pe - | maximalCopySize < size = - return $ ModifyChunks pf (L.Chunk bs) k - | pf `plusPtr` size <= pe = do - withForeignPtr fpbuf $ \pbuf -> - copyBytes pf (pbuf `plusPtr` offset) size - let pf' = pf `plusPtr` size - pf' `seq` k pf' pe - | otherwise = return $ BufferFull size pf (step k) - where - (fpbuf, offset, size) = S.toForeignPtr bs + step !bs !k br@(BufRange !op _) + | maxCopySize < S.length bs = return $ I.insertByteString op bs k + | otherwise = copyByteStringStep bs k br {-# INLINE fromByteStringWith #-} - -- | @copyByteString bs@ serialize the strict bytestring @bs@ by copying it to -- the output buffer. -- @@ -120,9 +112,31 @@ -- to be smallish (@<= 4kb@). -- copyByteString :: S.ByteString -> Builder -copyByteString = fromWriteSingleton writeByteString +copyByteString = \bs -> fromBuildStepCont $ copyByteStringStep bs {-# INLINE copyByteString #-} +copyByteStringStep :: S.ByteString + -> (BufRange -> IO (BuildSignal a)) + -> (BufRange -> IO (BuildSignal a)) +copyByteStringStep (S.PS ifp ioff isize) !k = + goBS (unsafeForeignPtrToPtr ifp `plusPtr` ioff) + where + !ipe = unsafeForeignPtrToPtr ifp `plusPtr` (ioff + isize) + goBS !ip !(BufRange op ope) + | inpRemaining <= outRemaining = do + copyBytes op ip inpRemaining + touchForeignPtr ifp -- input consumed: OK to release from here + let !br' = BufRange (op `plusPtr` inpRemaining) ope + k br' + | otherwise = do + copyBytes op ip outRemaining + let !ip' = ip `plusPtr` outRemaining + return $ bufferFull 1 ope (goBS ip') + where + outRemaining = ope `minusPtr` op + inpRemaining = ipe `minusPtr` ip +{-# INLINE copyByteStringStep #-} + -- | @insertByteString bs@ serializes the strict bytestring @bs@ by inserting -- it directly as a chunk of the output stream. -- @@ -132,8 +146,10 @@ -- to be processed efficiently. -- insertByteString :: S.ByteString -> Builder -insertByteString bs = Builder $ \ k pf _ -> - return $ ModifyChunks pf (L.Chunk bs) k +insertByteString = + \bs -> fromBuildStepCont $ step bs + where + step !bs !k !(BufRange op _) = return $ I.insertByteString op bs k {-# INLINE insertByteString #-} @@ -172,31 +188,8 @@ fromLazyByteStringWith :: Int -- ^ Maximal number of bytes to copy. -> L.ByteString -- ^ Lazy 'L.ByteString' to serialize. -> Builder -- ^ Resulting 'Builder'. -fromLazyByteStringWith maximalCopySize = - makeBuilder - where - -- FIXME: Justify this first case split. Can we justify it at all? I seem - -- to remember that its idea was to enable a partial inlining; i.e. sharing - -- of 'step' between different calls to 'fromLazyByteStringWith'. - makeBuilder L.Empty = mempty - makeBuilder lbs0 = Builder $ step lbs0 - where - step lbs1 k pf0 pe0 = go lbs1 pf0 - where - go L.Empty !pf = k pf pe0 - go lbs@(L.Chunk bs' lbs') !pf - | maximalCopySize < size = - return $ ModifyChunks pf (L.Chunk bs') (step lbs' k) - - | pf' <= pe0 = do - withForeignPtr fpbuf $ \pbuf -> - copyBytes pf (pbuf `plusPtr` offset) size - go lbs' pf' - - | otherwise = return $ BufferFull size pf (step lbs k) - where - pf' = pf `plusPtr` size - (fpbuf, offset, size) = S.toForeignPtr bs' +fromLazyByteStringWith maxCopySize = + L.foldrChunks (\bs b -> fromByteStringWith maxCopySize bs `mappend` b) mempty {-# INLINE fromLazyByteStringWith #-} @@ -205,10 +198,9 @@ -- -- See 'copyByteString' for usage considerations. -- - --- FIXME: Implement fused L.toChunks and fromWrite1List copyLazyByteString :: L.ByteString -> Builder -copyLazyByteString = fromWrite1List writeByteString . L.toChunks +copyLazyByteString = + L.foldrChunks (\bs b -> copyByteString bs `mappend` b) mempty {-# INLINE copyLazyByteString #-} -- | /O(n)/. Serialize a lazy bytestring by inserting /all/ its chunks directly @@ -220,10 +212,7 @@ -- need an /O(1)/ lazy bytestring insert based on difference lists. -- insertLazyByteString :: L.ByteString -> Builder -insertLazyByteString lbs = Builder step - where - step k pf _ = - return $ ModifyChunks pf (\lbs' -> L.foldrChunks L.Chunk lbs' lbs) k - +insertLazyByteString = + L.foldrChunks (\bs b -> insertByteString bs `mappend` b) mempty {-# INLINE insertLazyByteString #-} diff --git a/Blaze/ByteString/Builder/Char/Utf8.hs b/Blaze/ByteString/Builder/Char/Utf8.hs --- a/Blaze/ByteString/Builder/Char/Utf8.hs +++ b/Blaze/ByteString/Builder/Char/Utf8.hs @@ -35,45 +35,26 @@ import qualified Data.Text.Lazy.Encoding as TS -- imported for documentation links import Blaze.ByteString.Builder.Internal -import Blaze.ByteString.Builder.Write -- | Write a UTF-8 encoded Unicode character to a buffer. -- --- Note that the control flow of 'writeChar' is more complicated than the one --- of 'writeWord8', as the size of the write depends on the 'Char' written. --- Therefore, --- --- > fromWrite $ writeChar a `mappend` writeChar b --- --- must not always be faster than --- --- > fromChar a `mappend` fromChar b --- --- Use benchmarking to make informed decisions. --- - --- FIXME: Use a Write that always checks if 4 bytes are available and only take --- care of the precise pointer advance once the data has been written. Either --- formulate it using continuation passing or returning the increment using the --- IO action. The latter is probably simpler and better understandable. --- +{-# INLINE writeChar #-} writeChar :: Char -> Write -writeChar = encodeCharUtf8 f1 f2 f3 f4 +writeChar c = boundedWrite 4 (encodeCharUtf8 f1 f2 f3 f4 c) where - f1 x = Write 1 $ \ptr -> poke ptr x - - f2 x1 x2 = Write 2 $ \ptr -> do poke ptr x1 - poke (ptr `plusPtr` 1) x2 + f1 x1 = writeN 1 $ \op -> do pokeByteOff op 0 x1 - f3 x1 x2 x3 = Write 3 $ \ptr -> do poke ptr x1 - poke (ptr `plusPtr` 1) x2 - poke (ptr `plusPtr` 2) x3 + f2 x1 x2 = writeN 2 $ \op -> do pokeByteOff op 0 x1 + pokeByteOff op 1 x2 + + f3 x1 x2 x3 = writeN 3 $ \op -> do pokeByteOff op 0 x1 + pokeByteOff op 1 x2 + pokeByteOff op 2 x3 - f4 x1 x2 x3 x4 = Write 4 $ \ptr -> do poke ptr x1 - poke (ptr `plusPtr` 1) x2 - poke (ptr `plusPtr` 2) x3 - poke (ptr `plusPtr` 3) x4 -{-# INLINE writeChar #-} + f4 x1 x2 x3 x4 = writeN 4 $ \op -> do pokeByteOff op 0 x1 + pokeByteOff op 1 x2 + pokeByteOff op 2 x3 + pokeByteOff op 3 x4 -- | Encode a Unicode character to another datatype, using UTF-8. This function -- acts as an abstract way of encoding characters, as it is unaware of what @@ -113,7 +94,7 @@ -- | /O(n)/. Serialize a Unicode 'String' using the UTF-8 encoding. -- fromString :: String -> Builder -fromString = fromWrite1List writeChar +fromString = fromWriteList writeChar -- Performance note: ^^^ -- -- fromWrite2List made things slightly worse for the blaze-html benchmarks diff --git a/Blaze/ByteString/Builder/Char8.hs b/Blaze/ByteString/Builder/Char8.hs new file mode 100644 --- /dev/null +++ b/Blaze/ByteString/Builder/Char8.hs @@ -0,0 +1,78 @@ +{-# OPTIONS_GHC -fno-warn-unused-imports #-} +-- ignore warning from 'import Data.Text.Encoding' + +-- | +-- Module : Blaze.ByteString.Builder.Char8 +-- Copyright : (c) 2010 Simon Meier +-- License : BSD3-style (see LICENSE) +-- +-- Maintainer : Simon Meier +-- Stability : experimental +-- Portability : tested on GHC only +-- +-- //Note:// This package is intended for low-level use like implementing +-- protocols. If you need to //serialize// Unicode characters use one of the +-- UTF encodings (e.g. 'Blaze.ByteString.Builder.Char.UTF-8'). +-- +-- 'Write's and 'Builder's for serializing the lower 8-bits of characters. +-- +-- This corresponds to what the 'bytestring' package offer in +-- 'Data.ByteString.Char8'. +-- +module Blaze.ByteString.Builder.Char8 + ( + -- * Writing Latin-1 (ISO 8859-1) encodable characters to a buffer + writeChar + + -- * Creating Builders from Latin-1 (ISO 8859-1) encodable characters + , fromChar + , fromString + , fromShow + , fromText + , fromLazyText + ) where + +import Foreign +import Data.Char (ord) + +import qualified Data.Text as TS +import qualified Data.Text.Encoding as TS -- imported for documentation links +import qualified Data.Text.Lazy as TL +import qualified Data.Text.Lazy.Encoding as TS -- imported for documentation links + +import Blaze.ByteString.Builder.Internal +import Blaze.ByteString.Builder.Word + +-- | Write the lower 8-bits of a character to a buffer. +-- +{-# INLINE writeChar #-} +writeChar :: Char -> Write +writeChar = writeWord8 . fromIntegral . ord + +-- | /O(1)/. Serialize the lower 8-bits of a character. +-- +fromChar :: Char -> Builder +fromChar = fromWriteSingleton writeChar + +-- | /O(n)/. Serialize the lower 8-bits of all characters of a string +-- +fromString :: String -> Builder +fromString = fromWriteList writeChar + +-- | /O(n)/. Serialize a value by 'Show'ing it and serializing the lower 8-bits +-- of the resulting string. +-- +fromShow :: Show a => a -> Builder +fromShow = fromString . show + +-- | /O(n)/. Serialize the lower 8-bits of all characters in the strict text. +-- +{-# INLINE fromText #-} +fromText :: TS.Text -> Builder +fromText = fromString . TS.unpack + +-- | /O(n)/. Serialize the lower 8-bits of all characters in the lazy text. +-- +{-# INLINE fromLazyText #-} +fromLazyText :: TL.Text -> Builder +fromLazyText = fromString . TL.unpack diff --git a/Blaze/ByteString/Builder/HTTP.hs b/Blaze/ByteString/Builder/HTTP.hs new file mode 100644 --- /dev/null +++ b/Blaze/ByteString/Builder/HTTP.hs @@ -0,0 +1,210 @@ +{-# LANGUAGE BangPatterns, CPP, MagicHash, OverloadedStrings #-} +-- | Support for HTTP response encoding. +-- +-- TODO: Cleanup! +module Blaze.ByteString.Builder.HTTP ( + -- * Chunked HTTP transfer encoding + chunkedTransferEncoding + , chunkedTransferTerminator + ) where + +import Data.Monoid +import qualified Data.ByteString as S + +import Foreign + +import Blaze.ByteString.Builder.Internal +import Blaze.ByteString.Builder.Internal.Types +import Blaze.ByteString.Builder.Internal.UncheckedShifts + +import qualified Blaze.ByteString.Builder.Char8 as Char8 + +-- only required by test-code +-- import qualified Data.ByteString.Lazy as L +-- import qualified Blaze.ByteString.Builder.ByteString as B +-- import Data.ByteString.Char8 () + + +-- | Write a CRLF sequence. +writeCRLF :: Write +writeCRLF = Char8.writeChar '\r' `mappend` Char8.writeChar '\n' +{-# INLINE writeCRLF #-} + +-- | Execute a write +{-# INLINE execWrite #-} +execWrite :: Write -> Ptr Word8 -> IO () +execWrite w op = do + _ <- runWriteIO (runWrite w) op + return () + + +------------------------------------------------------------------------------ +-- Hex Encoding Infrastructure +------------------------------------------------------------------------------ + +{- +pokeWord16Hex :: Word16 -> Ptr Word8 -> IO () +pokeWord16Hex x op = do + pokeNibble 0 12 + pokeNibble 1 8 + pokeNibble 2 4 + pokeNibble 3 0 + where + pokeNibble off s + | n < 10 = pokeWord8 off (fromIntegral $ 48 + n) + | otherwise = pokeWord8 off (fromIntegral $ 55 + n) + where + n = shiftr_w16 x s .&. 0xF + + pokeWord8 :: Int -> Word8 -> IO () + pokeWord8 off = poke (op `plusPtr` off) + +writeWord16Hex :: Word16 -> Write +writeWord16Hex = exactWrite 4 . pokeWord16Hex + +-} + +pokeWord32HexN :: Int -> Word32 -> Ptr Word8 -> IO () +pokeWord32HexN n0 w0 op0 = + go w0 (op0 `plusPtr` (n0 - 1)) + where + go !w !op + | op < op0 = return () + | otherwise = do + let nibble :: Word8 + nibble = fromIntegral w .&. 0xF + hex | nibble < 10 = 48 + nibble + | otherwise = 55 + nibble + poke op hex + go (w `shiftr_w32` 4) (op `plusPtr` (-1)) +{-# INLINE pokeWord32HexN #-} + +iterationsUntilZero :: Integral a => (a -> a) -> a -> Int +iterationsUntilZero f = go 0 + where + go !count 0 = count + go !count !x = go (count+1) (f x) +{-# INLINE iterationsUntilZero #-} + +-- | Length of the hex-string required to encode the given 'Word32'. +word32HexLength :: Word32 -> Int +word32HexLength = max 1 . iterationsUntilZero (`shiftr_w32` 4) +{-# INLINE word32HexLength #-} + +writeWord32Hex :: Word32 -> Write +writeWord32Hex w = + boundedWrite (2 * sizeOf w) (writeN len $ pokeWord32HexN len w) + where + len = word32HexLength w +{-# INLINE writeWord32Hex #-} + +{- +test = flip (toLazyByteStringWith 32 32 32) L.empty + $ chunkedTransferEncoding + $ mconcat $ map oneLine [0..16] ++ + [B.insertByteString "hello"] ++ + map oneLine [0,1] ++ + [B.insertByteString ""] ++ + map oneLine [0..16] + + where + oneLine x = fromWriteSingleton writeWord32Hex x `mappend` Char8.fromChar ' ' +-} + +------------------------------------------------------------------------------ +-- Chunked transfer encoding +------------------------------------------------------------------------------ + +-- | Transform a builder such that it uses chunked HTTP transfer encoding. +chunkedTransferEncoding :: Builder -> Builder +chunkedTransferEncoding (Builder b) = + fromBuildStepCont transferEncodingStep + where + transferEncodingStep k = go (b (buildStep k)) + where + go :: BuildStep a -> BufRange -> IO (BuildSignal a) + go innerStep !(BufRange op ope) + -- FIXME: Assert that outRemaining < maxBound :: Word32 + | outRemaining < minimalBufferSize = + return $ bufferFull minimalBufferSize op (go innerStep) + | otherwise = do + let !brInner@(BufRange opInner _) = BufRange + (op `plusPtr` (chunkSizeLength + 2)) -- leave space for chunk header + (ope `plusPtr` (-maxAfterBufferOverhead)) -- leave space at end of data + + -- wraps the chunk, if it is non-empty, and returns the + -- signal constructed with the correct end-of-data pointer + {-# INLINE wrapChunk #-} + wrapChunk :: Ptr Word8 -> (Ptr Word8 -> IO (BuildSignal a)) + -> IO (BuildSignal a) + wrapChunk !opInner' mkSignal + | opInner' == opInner = mkSignal op + | otherwise = do + pokeWord32HexN chunkSizeLength + (fromIntegral $ opInner' `minusPtr` opInner) + op + execWrite writeCRLF (opInner `plusPtr` (-2)) + execWrite writeCRLF opInner' + mkSignal (opInner' `plusPtr` 2) + + -- execute inner builder with reduced boundaries + signal <- runBuildStep innerStep brInner + case signal of + Done opInner' x -> + wrapChunk opInner' $ \op' -> + return $! done op' x + + BufferFull minRequiredSize opInner' nextInnerStep -> + wrapChunk opInner' $ \op' -> + return $! bufferFull + (minRequiredSize + maxEncodingOverhead) + op' + (go nextInnerStep) + + InsertByteString opInner' bs nextInnerStep + | S.null bs -> -- flush + wrapChunk opInner' $ \op' -> + return $! insertByteString + op' S.empty + (go nextInnerStep) + + | otherwise -> -- insert non-empty bytestring + wrapChunk opInner' $ \op' -> do + -- add header for inserted bytestring + -- FIXME: assert(S.length bs < maxBound :: Word32) + !op'' <- (`runWriteIO` op') $ runWrite $ + writeWord32Hex (fromIntegral $ S.length bs) + `mappend` writeCRLF + -- insert bytestring and write CRLF in next buildstep + return $! InsertByteString + op'' bs + (unBuilder (fromWrite writeCRLF) $ + buildStep $ go nextInnerStep) + + where + -- minimal size guaranteed for actual data no need to require more + -- than 1 byte to guarantee progress the larger sizes will be + -- hopefully provided by the driver or requested by the wrapped + -- builders. + minimalChunkSize = 1 + + -- overhead computation + maxBeforeBufferOverhead = sizeOf (undefined :: Int) + 2 -- max chunk size and CRLF after header + maxAfterBufferOverhead = 2 + -- CRLF after data + sizeOf (undefined :: Int) + 2 -- max bytestring size, CRLF after header + + maxEncodingOverhead = maxBeforeBufferOverhead + maxAfterBufferOverhead + + minimalBufferSize = minimalChunkSize + maxEncodingOverhead + + -- remaining and required space computation + outRemaining :: Int + outRemaining = ope `minusPtr` op + chunkSizeLength = word32HexLength $ fromIntegral outRemaining + + +-- | The '0\r\n' chunk header signaling the termination of the data transfer. +chunkedTransferTerminator :: Builder +chunkedTransferTerminator = + fromWrite $ Char8.writeChar '0' `mappend` writeCRLF + diff --git a/Blaze/ByteString/Builder/Html/Utf8.hs b/Blaze/ByteString/Builder/Html/Utf8.hs --- a/Blaze/ByteString/Builder/Html/Utf8.hs +++ b/Blaze/ByteString/Builder/Html/Utf8.hs @@ -36,17 +36,22 @@ import qualified Data.Text.Lazy as TL import Blaze.ByteString.Builder +import Blaze.ByteString.Builder.Internal import Blaze.ByteString.Builder.Char.Utf8 -- | Write a HTML escaped and UTF-8 encoded Unicode character to a bufffer. -- writeHtmlEscapedChar :: Char -> Write -writeHtmlEscapedChar '<' = writeByteString "<" -writeHtmlEscapedChar '>' = writeByteString ">" -writeHtmlEscapedChar '&' = writeByteString "&" -writeHtmlEscapedChar '"' = writeByteString """ -writeHtmlEscapedChar '\'' = writeByteString "'" -writeHtmlEscapedChar c = writeChar c +writeHtmlEscapedChar c0 = + boundedWrite 6 (io c0) + -- WARNING: Don't forget to change the bound if you change the bytestrings. + where + io '<' = runWrite $ writeByteString "<" + io '>' = runWrite $ writeByteString ">" + io '&' = runWrite $ writeByteString "&" + io '"' = runWrite $ writeByteString """ + io '\'' = runWrite $ writeByteString "'" + io c = runWrite $ writeChar c {-# INLINE writeHtmlEscapedChar #-} -- | /O(1)./ Serialize a HTML escaped Unicode character using the UTF-8 @@ -59,7 +64,7 @@ -- encoding. -- fromHtmlEscapedString :: String -> Builder -fromHtmlEscapedString = fromWrite1List writeHtmlEscapedChar +fromHtmlEscapedString = fromWriteList writeHtmlEscapedChar -- | /O(n)/. Serialize a value by 'Show'ing it and then, HTML escaping and -- UTF-8 encoding the resulting 'String'. diff --git a/Blaze/ByteString/Builder/Int.hs b/Blaze/ByteString/Builder/Int.hs --- a/Blaze/ByteString/Builder/Int.hs +++ b/Blaze/ByteString/Builder/Int.hs @@ -1,4 +1,3 @@ -{-# LANGUAGE CPP #-} -- | -- Module : Blaze.ByteString.Builder.Int -- Copyright : (c) 2010 Simon Meier @@ -14,10 +13,6 @@ -- See "Blaze.ByteString.Builder.Word" for information about how to best write several -- integers at once. -- -#if defined(__GLASGOW_HASKELL__) && !defined(__HADDOCK__) -#include "MachDeps.h" -#endif - module Blaze.ByteString.Builder.Int ( -- * Writing integers to a buffer @@ -45,8 +40,7 @@ -- | We provide serialization functions both for singleton integers as well as -- for lists of integers. Using these list serialization functions is /much/ faster -- than using @mconcat . map fromInt/@, as the list serialization - -- functions use a tighter inner loop and a chunked write like it is - -- provided by functions such as 'fromWrite2List'. + -- functions use a tighter inner loop. , fromInt8 , fromInt8s @@ -80,7 +74,6 @@ ) where import Blaze.ByteString.Builder.Internal -import Blaze.ByteString.Builder.Write import Blaze.ByteString.Builder.Word import Foreign @@ -142,26 +135,22 @@ -- conversion. -- writeInthost :: Int -> Write -writeInthost w = - Write (sizeOf (undefined :: Int)) (\p -> poke (castPtr p) w) +writeInthost = writeStorable {-# INLINE writeInthost #-} -- | Write an 'Int16' in native host order and host endianness. writeInt16host :: Int16 -> Write -writeInt16host w16 = - Write (sizeOf (undefined :: Int16)) (\p -> poke (castPtr p) w16) +writeInt16host = writeStorable {-# INLINE writeInt16host #-} -- | Write an 'Int32' in native host order and host endianness. writeInt32host :: Int32 -> Write -writeInt32host w32 = - Write (sizeOf (undefined :: Int32)) (\p -> poke (castPtr p) w32) +writeInt32host = writeStorable {-# INLINE writeInt32host #-} -- | Write an 'Int64' in native host order and host endianness. writeInt64host :: Int64 -> Write -writeInt64host w = - Write (sizeOf (undefined :: Int64)) (\p -> poke (castPtr p) w) +writeInt64host = writeStorable {-# INLINE writeInt64host #-} @@ -180,7 +169,7 @@ -- | Serialize a list of bytes. -- fromInt8s :: [Int8] -> Builder -fromInt8s = fromWrite8List writeInt8 +fromInt8s = fromWriteList writeInt8 -- Int16 @@ -193,7 +182,7 @@ -- | Serialize a list of 'Int16's in big endian format. fromInt16sbe :: [Int16] -> Builder -fromInt16sbe = fromWrite4List writeInt16be +fromInt16sbe = fromWriteList writeInt16be {-# INLINE fromInt16sbe #-} -- | Serialize an 'Int16' in little endian format. @@ -203,7 +192,7 @@ -- | Serialize a list of 'Int16's in little endian format. fromInt16sle :: [Int16] -> Builder -fromInt16sle = fromWrite4List writeInt16le +fromInt16sle = fromWriteList writeInt16le {-# INLINE fromInt16sle #-} @@ -217,7 +206,7 @@ -- | Serialize a list of 'Int32's in big endian format. fromInt32sbe :: [Int32] -> Builder -fromInt32sbe = fromWrite2List writeInt32be +fromInt32sbe = fromWriteList writeInt32be {-# INLINE fromInt32sbe #-} -- | Serialize an 'Int32' in little endian format. @@ -227,7 +216,7 @@ -- | Serialize a list of 'Int32's in little endian format. fromInt32sle :: [Int32] -> Builder -fromInt32sle = fromWrite2List writeInt32le +fromInt32sle = fromWriteList writeInt32le {-# INLINE fromInt32sle #-} -- | Serialize an 'Int64' in big endian format. @@ -237,7 +226,7 @@ -- | Serialize a list of 'Int64's in big endian format. fromInt64sbe :: [Int64] -> Builder -fromInt64sbe = fromWrite1List writeInt64be +fromInt64sbe = fromWriteList writeInt64be {-# INLINE fromInt64sbe #-} -- | Serialize an 'Int64' in little endian format. @@ -247,7 +236,7 @@ -- | Serialize a list of 'Int64's in little endian format. fromInt64sle :: [Int64] -> Builder -fromInt64sle = fromWrite1List writeInt64le +fromInt64sle = fromWriteList writeInt64le {-# INLINE fromInt64sle #-} @@ -267,7 +256,7 @@ -- | Serialize a list of 'Int's. -- See 'fromInthost' for usage considerations. fromIntshost :: [Int] -> Builder -fromIntshost = fromWrite2List writeInthost +fromIntshost = fromWriteList writeInthost {-# INLINE fromIntshost #-} -- | Write an 'Int16' in native host order and host endianness. @@ -277,7 +266,7 @@ -- | Write a list of 'Int16's in native host order and host endianness. fromInt16shost :: [Int16] -> Builder -fromInt16shost = fromWrite4List writeInt16host +fromInt16shost = fromWriteList writeInt16host {-# INLINE fromInt16shost #-} -- | Write an 'Int32' in native host order and host endianness. @@ -287,7 +276,7 @@ -- | Write a list of 'Int32's in native host order and host endianness. fromInt32shost :: [Int32] -> Builder -fromInt32shost = fromWrite2List writeInt32host +fromInt32shost = fromWriteList writeInt32host {-# INLINE fromInt32shost #-} -- | Write an 'Int64' in native host order and host endianness. @@ -297,5 +286,5 @@ -- | Write a list of 'Int64's in native host order and host endianness. fromInt64shost :: [Int64] -> Builder -fromInt64shost = fromWrite1List writeInt64host +fromInt64shost = fromWriteList writeInt64host {-# INLINE fromInt64shost #-} diff --git a/Blaze/ByteString/Builder/Internal.hs b/Blaze/ByteString/Builder/Internal.hs --- a/Blaze/ByteString/Builder/Internal.hs +++ b/Blaze/ByteString/Builder/Internal.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE CPP, BangPatterns #-} +{-# LANGUAGE CPP, BangPatterns, Rank2Types #-} -- | -- Module : Blaze.ByteString.Builder.Internal -- Copyright : (c) 2010 Simon Meier @@ -8,158 +8,57 @@ -- Stability : experimental -- Portability : tested on GHC only -- --- Implementation of the 'Builder' monoid. --- --- A standard library user must never import this module directly. Instead, he --- should import "Blaze.ByteString.Builder", which re-exports the 'Builder' type and --- its associated public functions defined in this module. --- --- Developers of other libraries may import this module to gain access to the --- internal representation of builders. For example, in some cases, creating a --- 'Builder' with a custom low-level 'BuildStep' may improve performance --- considerably compared to the creating it using the public 'Builder' --- combinators (e.g., @'fromWrite1List'@ in "Blaze.ByteString.Builder.Write"). --- Another example, is the use of 'ModifyChunks' to efficiently wire the --- 'Builder' type with another library that generates lazy bytestrings. --- --- In any case, whenever you import this module you /must/ reference the full --- version of the 'blaze-builder' package in your cabal file, as the --- implementation and the guarantees given in this file may change in any --- version! The release notes will tell, if this was the case. +-- Core types and functions for the 'Builder' monoid and the 'Put' monad. -- -module Blaze.ByteString.Builder.Internal - ( - -- * The @Builder@ type - Builder(..) - , BuildStep - , BuildSignal(..) - - -- * Flushing the buffer - , flush - - -- * Executing builders - , toLazyByteStringWith - , toLazyByteString - , toByteString - , toByteStringIOWith - , toByteStringIO +module Blaze.ByteString.Builder.Internal ( - -- * Default sizes - , defaultBufferSize - , defaultMinimalBufferSize - , defaultMaximalCopySize - ) where + -- * Build Steps + BufRange(..) + , BuildSignal + , BuildStep + , done + , bufferFull + , insertByteString + -- * Builder + , Builder + , fromBuildStepCont + , fromPut + , flush -import Foreign -import Data.Monoid -import Control.Monad (unless) -import qualified Data.ByteString as S -import qualified Data.ByteString.Lazy as L + -- * Put + , Put + , putBuilder + , putBuildStepCont -#ifdef BYTESTRING_IN_BASE -import Data.ByteString.Base (inlinePerformIO) -import qualified Data.ByteString.Base as S -import qualified Data.ByteString.Lazy.Base as L -- FIXME: is this the right module for access to 'Chunks'? -#else -import Data.ByteString.Internal (inlinePerformIO) -import qualified Data.ByteString.Internal as S -import qualified Data.ByteString.Lazy.Internal as L -#endif + -- * Writes + , module Blaze.ByteString.Builder.Internal.Write + -- * Execution + , toLazyByteString + , toLazyByteStringWith + , toByteString + , toByteStringIO + , toByteStringIOWith ------------------------------------------------------------------------------- --- The Builder type ------------------------------------------------------------------------------- + -- * Deafult Sizes + , defaultFirstBufferSize + , defaultMinimalBufferSize + , defaultBufferSize + , defaultMaximalCopySize +) where --- | Intuitively, a builder denotes the construction of a lazy bytestring. --- --- Builders can be created from primitive buffer manipulations using the --- @'Write'@ abstraction provided by in "Blaze.ByteString.Builder.Write". However for --- many Haskell values, there exist predefined functions doing that already. --- For example, UTF-8 encoding 'Char' and 'String' values is provided by the --- functions in "Blaze.ByteString.Builder.Char.Utf8". Concatenating builders is done --- using their 'Monoid' instance. --- --- Semantically, builders are nothing special. They just denote a sequence of --- bytes. However, their representation is chosen such that this sequence of --- bytes can be efficiently (in terms of CPU cycles) computed in an --- incremental, chunk-wise fashion such that the average chunk-size is large. --- Note that the large average chunk size allows to make good use of cache --- prefetching in later processing steps (e.g. compression) or to reduce the --- sytem call overhead when writing the resulting lazy bytestring to a file or --- sending it over the network. --- --- For precisely understanding the performance of a specific 'Builder', --- benchmarking is unavoidable. Moreover, it also helps to understand the --- implementation of builders and the predefined combinators. This should be --- amenable to the average Haskell programmer by reading the source code of --- "Blaze.ByteString.Builder.Internal" and the other modules of this library. --- --- The guiding implementation principle was to reduce the abstraction cost per --- output byte. We use continuation passing to achieve a constant time append. --- The output buffer is filled by the individual builders as long as possible. --- They call each other directly when they are done and control is returned to --- the driver (e.g., 'toLazyByteString') only when the buffer is full, a --- bytestring needs to be inserted directly, or no more bytes can be written. --- We also try to take the pressure off the cache by moving variables as far --- out of loops as possible. This leads to some duplication of code, but --- results in sometimes dramatic increases in performance. For example, see the --- @'fromWord8s'@ function in "Blaze.ByteString.Builder.Word". --- -newtype Builder = Builder (BuildStep -> BuildStep) +import Foreign --- | A 'BuildSignal' signals to the driver of the 'Builder' execution the next --- step to be taken. --- -data BuildSignal = - -- | @Done pf@ signals that the 'BuildStep' is finished and data has been - -- written up to the next free byte @pf@. - Done {-# UNPACK #-} !(Ptr Word8) - -- | @BufferFull newSize pf nextStep@ signals that the buffer is full and - -- data has been written up to the next free byte @pf@. Moreover, the next - -- build step to be executed @nextStep@ requires a buffer of at least size - -- @newSize@ to execute successfully. - -- - -- A driver /must/ guarantee that the buffer used to call @nextStep@ is at - -- least of size @newSize@. - | BufferFull - {-# UNPACK #-} !Int - {-# UNPACK #-} !(Ptr Word8) - !BuildStep - -- | @ModifyChunks pf fbs nextStep@ signals that the data written up to the - -- next free byte @pf@ must be output and the remaining lazy bytestring that - -- is produced by executing @nextStep@ must be modified using the function - -- @fbs@. - -- - -- This signal is used to insert bytestrings directly into the output stream. - -- It can also be used to efficiently hand over control to another library - -- for generating streams of strict bytestrings. - | ModifyChunks - {-# UNPACK #-} !(Ptr Word8) - !(L.ByteString -> L.ByteString) - !BuildStep +import Control.Monad (unless) --- | A 'BuildStep' fills a buffer from the given start pointer as long as --- possible and returns control to the caller using a 'BuildSignal', once it is --- required. --- -type BuildStep = Ptr Word8 -- ^ Pointer to the next free byte in the - -- buffer. A 'BuildStep' must start writing - -- its data from this address. - -> Ptr Word8 -- ^ Pointer to the first byte /after/ the - -- buffer. A 'BuildStep' must never write - -- data at or after this address. - -> IO BuildSignal -- ^ Signal to the driver about the next step - -- to be taken. +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.Internal as L -instance Monoid Builder where - mempty = Builder id - {-# INLINE mempty #-} - mappend (Builder f) (Builder g) = Builder $ f . g - {-# INLINE mappend #-} - mconcat = foldr mappend mempty - {-# INLINE mconcat #-} +import Blaze.ByteString.Builder.Internal.Types +import Blaze.ByteString.Builder.Internal.Write ------------------------------------------------------------------------------ -- Internal global constants. @@ -202,6 +101,12 @@ ------------------------------------------------------------------------------ -- Flushing and running a Builder ------------------------------------------------------------------------------ + +-- | Prepend the chunk if it is non-empty. +{-# INLINE nonEmptyChunk #-} +nonEmptyChunk :: S.ByteString -> L.ByteString -> L.ByteString +nonEmptyChunk bs lbs | S.null bs = lbs + | otherwise = L.Chunk bs lbs -- | Output all data written in the current buffer and start a new chunk. @@ -216,8 +121,11 @@ -- 'L.ByteString'. The remaining part of the buffer is spilled, if the -- reamining free space is smaller than the minimal desired buffer size. -- +{-# INLINE flush #-} flush :: Builder -flush = Builder $ \k pf _ -> return $ ModifyChunks pf id k +flush = fromBuildStepCont step + where + step k !(BufRange op _) = return $ insertByteString op S.empty k -- | Run a 'Builder' with the given buffer sizes. -- @@ -258,9 +166,9 @@ -- finished. -> L.ByteString -- ^ Resulting lazy bytestring toLazyByteStringWith bufSize minBufSize firstBufSize (Builder b) k = - inlinePerformIO $ fillFirstBuffer (b finalStep) + S.inlinePerformIO $ fillFirstBuffer (b (buildStep finalStep)) where - finalStep pf _ = return $ Done pf + finalStep (BufRange pf _) = return $ Done pf () -- fill a first very small buffer, if we need more space then copy it -- to the new buffer of size 'minBufSize'. This way we don't pay the -- allocation cost of the big 'bufSize' buffer, when outputting only @@ -273,25 +181,26 @@ let !pe = pf `plusPtr` firstBufSize mkbs pf' = S.PS fpbuf 0 (pf' `minusPtr` pf) {-# INLINE mkbs #-} - next <- step0 pf pe + next <- runBuildStep step0 (BufRange pf pe) case next of - Done pf' + Done pf' _ | pf' == pf -> return k | otherwise -> return $ L.Chunk (mkbs pf') k BufferFull newSize pf' nextStep -> do let !l = pf' `minusPtr` pf - fillNewBuffer (max (l + newSize) minBufSize) $ - \pfNew peNew -> do + fillNewBuffer (max (l + newSize) minBufSize) $ buildStep $ + \(BufRange pfNew peNew) -> do copyBytes pfNew pf l - nextStep (pfNew `plusPtr` l) peNew + let !br' = BufRange (pfNew `plusPtr` l) peNew + runBuildStep nextStep br' - ModifyChunks pf' bsk nextStep + InsertByteString pf' bs nextStep | pf' == pf -> - return $ bsk (inlinePerformIO $ fillNewBuffer bufSize nextStep) + return $ nonEmptyChunk bs (S.inlinePerformIO $ fillNewBuffer bufSize nextStep) | otherwise -> return $ L.Chunk (mkbs pf') - (bsk (inlinePerformIO $ fillNewBuffer bufSize nextStep)) + (nonEmptyChunk bs (S.inlinePerformIO $ fillNewBuffer bufSize nextStep)) -- allocate and fill a new buffer fillNewBuffer !size !step0 = do @@ -302,28 +211,31 @@ where !pe = pbuf `plusPtr` size fill !pf !step = do - next <- step pf pe + next <- runBuildStep step (BufRange pf pe) let mkbs pf' = S.PS fpbuf (pf `minusPtr` pbuf) (pf' `minusPtr` pf) {-# INLINE mkbs #-} case next of - Done pf' + Done pf' _ | pf' == pf -> return k | otherwise -> return $ L.Chunk (mkbs pf') k - BufferFull newSize pf' nextStep -> - return $ L.Chunk (mkbs pf') - (inlinePerformIO $ - fillNewBuffer (max newSize bufSize) nextStep) + BufferFull newSize pf' nextStep + | pf' == pf -> + fillNewBuffer (max newSize bufSize) nextStep + | otherwise -> + return $ L.Chunk (mkbs pf') + (S.inlinePerformIO $ + fillNewBuffer (max newSize bufSize) nextStep) - ModifyChunks pf' bsk nextStep + InsertByteString pf' bs nextStep | pf' == pf -> - return $ bsk (inlinePerformIO $ fill pf' nextStep) + return $ nonEmptyChunk bs (S.inlinePerformIO $ fill pf' nextStep) | minBufSize < pe `minusPtr` pf' -> return $ L.Chunk (mkbs pf') - (bsk (inlinePerformIO $ fill pf' nextStep)) + (nonEmptyChunk bs (S.inlinePerformIO $ fill pf' nextStep)) | otherwise -> return $ L.Chunk (mkbs pf') - (bsk (inlinePerformIO $ fillNewBuffer bufSize nextStep)) + (nonEmptyChunk bs (S.inlinePerformIO $ fillNewBuffer bufSize nextStep)) -- | Extract the lazy 'L.ByteString' from the builder by running it with default @@ -395,35 +307,30 @@ -> Builder -- ^ 'Builder' to run. -> IO () -- ^ Resulting 'IO' action. toByteStringIOWith bufSize io (Builder b) = - fillNewBuffer bufSize (b finalStep) + fillBuffer bufSize (b (buildStep finalStep)) where - finalStep pf _ = return $ Done pf + finalStep !(BufRange pf _) = return $ Done pf () - fillNewBuffer !size !step0 = do - S.mallocByteString size >>= fillBuffer + fillBuffer !size step = do + S.mallocByteString size >>= fill where - fillBuffer fpbuf = fill step0 - where - -- safe because the constructed ByteString references the foreign - -- pointer AFTER its buffer was filled. - pf = unsafeForeignPtrToPtr fpbuf - fill !step = do - next <- step pf (pf `plusPtr` size) - case next of - Done pf' -> - unless (pf' == pf) (io $ S.PS fpbuf 0 (pf' `minusPtr` pf)) + fill fpbuf = do + let !pf = unsafeForeignPtrToPtr fpbuf + !br = BufRange pf (pf `plusPtr` size) + -- safe due to later reference of fpbuf + -- BETTER than withForeignPtr, as we lose a tail call otherwise + signal <- runBuildStep step br + case signal of + Done pf' _ -> io $ S.PS fpbuf 0 (pf' `minusPtr` pf) - BufferFull newSize pf' nextStep -> do - io $ S.PS fpbuf 0 (pf' `minusPtr` pf) - if bufSize < newSize - then fillNewBuffer newSize nextStep - else fill nextStep - - ModifyChunks pf' bsk nextStep -> do - unless (pf' == pf) (io $ S.PS fpbuf 0 (pf' `minusPtr` pf)) - -- was: mapM_ io $ L.toChunks (bsk L.empty) - L.foldrChunks (\bs -> (io bs >>)) (return ()) (bsk L.empty) - fill nextStep + BufferFull minSize pf' nextStep -> do + io $ S.PS fpbuf 0 (pf' `minusPtr` pf) + fillBuffer (max bufSize minSize) nextStep + + InsertByteString pf' bs nextStep -> do + io $ S.PS fpbuf 0 (pf' `minusPtr` pf) + unless (S.null bs) (io bs) + fillBuffer bufSize nextStep -- | Run the builder with a 'defaultBufferSize'd buffer and execute the given -- 'IO' action whenever the buffer is full or gets flushed. @@ -439,3 +346,66 @@ toByteStringIO = toByteStringIOWith defaultBufferSize {-# INLINE toByteStringIO #-} + +------------------------------------------------------------------------------ +-- Draft of new builder/put execution code +------------------------------------------------------------------------------ + +{- FIXME: Generalize this code such that it can replace the above clunky + - implementations. + +-- | A monad for lazily composing lazy bytestrings using continuations. +newtype LBSM a = LBSM { unLBSM :: (a, L.ByteString -> L.ByteString) } + +instance Monad LBSM where + return x = LBSM (x, id) + (LBSM (x,k)) >>= f = let LBSM (x',k') = f x in LBSM (x', k . k') + (LBSM (_,k)) >> (LBSM (x',k')) = LBSM (x', k . k') + +-- | Execute a put and return the written buffers as the chunks of a lazy +-- bytestring. +toLazyByteString :: Put a -> (a, L.ByteString) +toLazyByteString put = + (fst result, k (bufToLBSCont (snd result) L.empty)) + where + + -- FIXME: Check with ByteString guys why allocation in inlinePerformIO is + -- bad. + + -- initial buffer + buf0 = S.inlinePerformIO $ allocBuffer defaultBufferSize + -- run put, but don't force result => we're lazy enough + LBSM (result, k) = runPut liftIO outputBuf outputBS put buf0 + -- convert a buffer to a lazy bytestring continuation + bufToLBSCont = maybe id L.Chunk . unsafeFreezeNonEmptyBuffer + -- lifting an io putsignal to a lazy bytestring monad + liftIO io = LBSM (S.inlinePerformIO io, id) + -- add buffer as a chunk prepare allocation of new one + outputBuf minSize buf = LBSM + ( S.inlinePerformIO $ allocBuffer (max minSize defaultBufferSize) + , bufToLBSCont buf ) + -- add bytestring directly as a chunk; exploits postcondition of runPut + -- that bytestrings are non-empty + outputBS bs = LBSM ((), L.Chunk bs) + + +{- +-- | A Builder that traces a message +traceBuilder :: String -> Builder +traceBuilder msg = fromBuildStepCont $ \k br@(BufRange op ope) -> do + putStrLn $ "traceBuilder " ++ show (op, ope) ++ ": " ++ msg + k br + +test2 :: Word8 -> [S.ByteString] +test2 x = L.toChunks $ toLazyByteString2 $ fromBuilder $ mconcat + [ traceBuilder "before flush" + , fromWord8 48 + , flushBuilder + , flushBuilder + , traceBuilder "after flush" + , fromWord8 x + ] + +-} + +-} diff --git a/Blaze/ByteString/Builder/Internal/Buffer.hs b/Blaze/ByteString/Builder/Internal/Buffer.hs new file mode 100644 --- /dev/null +++ b/Blaze/ByteString/Builder/Internal/Buffer.hs @@ -0,0 +1,214 @@ +{-# LANGUAGE CPP, BangPatterns, Rank2Types #-} +-- | +-- Module : Blaze.ByteString.Builder.Internal.Buffer +-- Copyright : (c) 2010 Simon Meier +-- License : BSD3-style (see LICENSE) +-- +-- Maintainer : Simon Meier +-- Stability : experimental +-- Portability : tested on GHC only +-- +-- Execution of the 'Put' monad and hence also 'Builder's with respect to +-- buffers. +-- +module Blaze.ByteString.Builder.Internal.Buffer ( + -- * Buffers + Buffer + + -- ** Status information + , freeSize + , sliceSize + , bufferSize + + -- ** Creation and modification + , allocBuffer + , reuseBuffer + , nextSlice + , updateEndOfSlice + , execBuildStep + + -- ** Conversion to bytestings + , unsafeFreezeBuffer + , unsafeFreezeNonEmptyBuffer + + -- * Buffer allocation strategies + , BufferAllocStrategy + , allNewBuffersStrategy + , reuseBufferStrategy + + -- * Executing puts respect to some monad + , runPut + ) where + +import Prelude +import Foreign + +import qualified Data.ByteString as S + +#ifdef BYTESTRING_IN_BASE +import qualified Data.ByteString.Base as S +#else +import qualified Data.ByteString.Internal as S +#endif + +import Blaze.ByteString.Builder.Internal.Types +------------------------------------------------------------------------------ +-- Buffers +------------------------------------------------------------------------------ + +-- | A buffer @Buffer fpbuf p0 op ope@ describes a buffer with the underlying +-- byte array @fpbuf..ope@, the currently written slice @p0..op@ and the free +-- space @op..ope@. +data Buffer = Buffer {-# UNPACK #-} !(ForeignPtr Word8) -- underlying pinned array + {-# UNPACK #-} !(Ptr Word8) -- beginning of slice + {-# UNPACK #-} !(Ptr Word8) -- next free byte + {-# UNPACK #-} !(Ptr Word8) -- first byte after buffer + +-- | The size of the free space of the buffer. +freeSize :: Buffer -> Int +freeSize (Buffer _ _ op ope) = ope `minusPtr` op + +-- | The size of the written slice in the buffer. +sliceSize :: Buffer -> Int +sliceSize (Buffer _ p0 op _) = op `minusPtr` p0 + +-- | The size of the whole byte array underlying the buffer. +bufferSize :: Buffer -> Int +bufferSize (Buffer fpbuf _ _ ope) = + ope `minusPtr` unsafeForeignPtrToPtr fpbuf + +-- | @allocBuffer size@ allocates a new buffer of size @size@. +{-# INLINE allocBuffer #-} +allocBuffer :: Int -> IO Buffer +allocBuffer size = do + fpbuf <- S.mallocByteString size + let !pbuf = unsafeForeignPtrToPtr fpbuf + return $! Buffer fpbuf pbuf pbuf (pbuf `plusPtr` size) + +-- | Resets the beginning of the next slice and the next free byte such that +-- the whole buffer can be filled again. +{-# INLINE reuseBuffer #-} +reuseBuffer :: Buffer -> Buffer +reuseBuffer (Buffer fpbuf _ _ ope) = Buffer fpbuf p0 p0 ope + where + p0 = unsafeForeignPtrToPtr fpbuf + +-- | Convert the buffer to a bytestring. This operation is unsafe in the sense +-- that created bytestring shares the underlying byte array with the buffer. +-- Hence, depending on the later use of this buffer (e.g., if it gets reset and +-- filled again) referential transparency may be lost. +{-# INLINE unsafeFreezeBuffer #-} +unsafeFreezeBuffer :: Buffer -> S.ByteString +unsafeFreezeBuffer (Buffer fpbuf p0 op _) = + S.PS fpbuf (p0 `minusPtr` unsafeForeignPtrToPtr fpbuf) (op `minusPtr` p0) + +-- | Convert a buffer to a non-empty bytestring. See 'unsafeFreezeBuffer' for +-- the explanation of why this operation may be unsafe. +{-# INLINE unsafeFreezeNonEmptyBuffer #-} +unsafeFreezeNonEmptyBuffer :: Buffer -> Maybe S.ByteString +unsafeFreezeNonEmptyBuffer buf + | sliceSize buf <= 0 = Nothing + | otherwise = Just $ unsafeFreezeBuffer buf + +-- | Update the end of slice pointer. +{-# INLINE updateEndOfSlice #-} +updateEndOfSlice :: Buffer -- Old buffer + -> Ptr Word8 -- New end of slice + -> Buffer -- Updated buffer +updateEndOfSlice (Buffer fpbuf p0 _ ope) op' = Buffer fpbuf p0 op' ope + +-- | Execute a build step on the given buffer. +{-# INLINE execBuildStep #-} +execBuildStep :: BuildStep a + -> Buffer + -> IO (BuildSignal a) +execBuildStep step (Buffer _ _ op ope) = runBuildStep step (BufRange op ope) + +-- | Move the beginning of the slice to the next free byte such that the +-- remaining free space of the buffer can be filled further. This operation +-- is safe and can be used to fill the remaining part of the buffer after a +-- direct insertion of a bytestring or a flush. +{-# INLINE nextSlice #-} +nextSlice :: Int -> Buffer -> Maybe Buffer +nextSlice minSize (Buffer fpbuf _ op ope) + | ope `minusPtr` op <= minSize = Nothing + | otherwise = Just (Buffer fpbuf op op ope) + +------------------------------------------------------------------------------ +-- Buffer allocation strategies +------------------------------------------------------------------------------ + +-- | A buffer allocation strategy @(buf0, nextBuf)@ specifies the initial +-- buffer to use and how to compute a new buffer @nextBuf minSize buf@ with at +-- least size @minSize@ from a filled buffer @buf@. The double nesting of the +-- @IO@ monad helps to ensure that the reference to the filled buffer @buf@ is +-- lost as soon as possible, but the new buffer doesn't have to be allocated +-- too early. +type BufferAllocStrategy = (IO Buffer, Int -> Buffer -> IO (IO Buffer)) + +-- | The simplest buffer allocation strategy: whenever a buffer is requested, +-- allocate a new one that is big enough for the next build step to execute. +-- +-- NOTE that this allocation strategy may spill quite some memory upon direct +-- insertion of a bytestring by the builder. Thats no problem for garbage +-- collection, but it may lead to unreasonably high memory consumption in +-- special circumstances. +allNewBuffersStrategy :: Int -- Minimal buffer size. + -> BufferAllocStrategy +allNewBuffersStrategy bufSize = + ( allocBuffer bufSize + , \reqSize _ -> return (allocBuffer (max reqSize bufSize)) ) + +-- | An unsafe, but possibly more efficient buffer allocation strategy: +-- reuse the buffer, if it is big enough for the next build step to execute. +reuseBufferStrategy :: IO Buffer + -> BufferAllocStrategy +reuseBufferStrategy buf0 = + (buf0, tryReuseBuffer) + where + tryReuseBuffer reqSize buf + | bufferSize buf >= reqSize = return $ return (reuseBuffer buf) + | otherwise = return $ allocBuffer reqSize + +------------------------------------------------------------------------------ +-- Executing puts on a buffer +------------------------------------------------------------------------------ + + +-- | Execute a put on a buffer. +-- +-- TODO: Generalize over buffer allocation strategy. +{-# INLINE runPut #-} +runPut :: Monad m + => (IO (BuildSignal a) -> m (BuildSignal a)) -- lifting of buildsteps + -> (Int -> Buffer -> m Buffer) -- output function for a guaranteedly non-empty buffer, the returned buffer will be filled next + -> (S.ByteString -> m ()) -- output function for guaranteedly non-empty bytestrings, that are inserted directly into the stream + -> Put a -- put to execute + -> Buffer -- initial buffer to be used + -> m (a, Buffer) -- result of put and remaining buffer +runPut liftIO outputBuf outputBS (Put put) = + runStep (put (finalStep)) + where + finalStep x = buildStep $ \(BufRange op _) -> return $ Done op x + + runStep step buf@(Buffer fpbuf p0 op ope) = do + let !br = BufRange op ope + signal <- liftIO $ runBuildStep step br + case signal of + Done op' x -> -- put completed, buffer partially runSteped + return (x, Buffer fpbuf p0 op' ope) + + BufferFull minSize op' nextStep -> do + buf' <- outputBuf minSize (Buffer fpbuf p0 op' ope) + runStep nextStep buf' + + InsertByteString op' bs nextStep + | S.null bs -> -- flushing of buffer required + outputBuf 1 (Buffer fpbuf p0 op' ope) >>= runStep nextStep + | p0 == op' -> do -- no bytes written: just insert bytestring + outputBS bs + runStep nextStep buf + | otherwise -> do -- bytes written, insert buffer and bytestring + buf' <- outputBuf 1 (Buffer fpbuf p0 op' ope) + outputBS bs + runStep nextStep buf' diff --git a/Blaze/ByteString/Builder/Internal/Types.hs b/Blaze/ByteString/Builder/Internal/Types.hs new file mode 100644 --- /dev/null +++ b/Blaze/ByteString/Builder/Internal/Types.hs @@ -0,0 +1,137 @@ +{-# LANGUAGE CPP, BangPatterns, Rank2Types #-} +-- | +-- Module : Blaze.ByteString.Builder.Internal.Types +-- Copyright : (c) 2010 Simon Meier +-- License : BSD3-style (see LICENSE) +-- +-- Maintainer : Simon Meier +-- Stability : experimental +-- Portability : tested on GHC only +-- +-- Core types and functions for the 'Builder' monoid and the 'Put' monad based +-- based on the 'blaze-builder' library by Jasper van der Jeugt and Simon +-- Meier. +-- +module Blaze.ByteString.Builder.Internal.Types where + +#ifdef APPLICATIVE_IN_BASE +import Control.Applicative +#endif + +import Data.Monoid +import qualified Data.ByteString as S + +import Foreign + +------------------------------------------------------------------------------ +-- The core: BuildSteps +------------------------------------------------------------------------------ + +data BufRange = BufRange {-# UNPACK #-} !(Ptr Word8) {-# UNPACK #-} !(Ptr Word8) + +data BuildSignal a = + Done {-# UNPACK #-} !(Ptr Word8) a + | BufferFull + {-# UNPACK #-} !Int + {-# UNPACK #-} !(Ptr Word8) + !(BuildStep a) + | InsertByteString + {-# UNPACK #-} !(Ptr Word8) + !S.ByteString + !(BuildStep a) + +newtype BuildStep a = + BuildStep { runBuildStep :: BufRange -> IO (BuildSignal a) } + +-- Hiding the implementation of 'BuildStep's + +done :: Ptr Word8 -> a -> BuildSignal a +done = Done + +bufferFull :: Int -> Ptr Word8 -> (BufRange -> IO (BuildSignal a)) -> BuildSignal a +bufferFull size op step = BufferFull size op (buildStep step) + +insertByteString :: Ptr Word8 -> S.ByteString -> (BufRange -> IO (BuildSignal a)) -> BuildSignal a +insertByteString op bs step = InsertByteString op bs (buildStep step) + +buildStep :: (BufRange -> IO (BuildSignal a)) -> BuildStep a +buildStep = BuildStep + +------------------------------------------------------------------------------ +-- The 'Builder' Monoid and the 'Put' Monad +------------------------------------------------------------------------------ + +newtype Builder = Builder { + unBuilder :: forall r. BuildStep r -> BuildStep r + } + +instance Monoid Builder where + mempty = Builder id + {-# INLINE mempty #-} + (Builder b1) `mappend` (Builder b2) = Builder $ b1 . b2 + {-# INLINE mappend #-} + mconcat = foldr mappend mempty + {-# INLINE mconcat #-} + +newtype Put a = Put { + unPut :: forall r. (a -> BuildStep r) -> BuildStep r + } + +instance Functor Put where + fmap f (Put put) = Put $ \k -> put (\x -> k (f x)) + {-# INLINE fmap #-} + +#ifdef APPLICATIVE_IN_BASE +instance Applicative Put where + pure x = Put $ \k -> k x + {-# INLINE pure #-} + f <*> a = Put $ \k -> unPut f (\f' -> unPut a (\a' -> k (f' a'))) + {-# INLINE (<*>) #-} + a <* b = Put $ \k -> unPut a (\a' -> unPut b (\_ -> k a')) + {-# INLINE (<*) #-} + a *> b = Put $ \k -> unPut a (\_ -> unPut b k) + {-# INLINE (*>) #-} +#endif + +instance Monad Put where + return x = Put $ \k -> k x + {-# INLINE return #-} + m >>= f = Put $ \k -> unPut m (\m' -> unPut (f m') k) + {-# INLINE (>>=) #-} + m >> n = Put $ \k -> unPut m (\_ -> unPut n k) + {-# INLINE (>>) #-} + + +-- Creation from concrete 'BuildStep's +------------------------------------------------------------------------------ + +putBuildStepCont :: (forall r. (a -> BufRange -> IO (BuildSignal r)) -> + ( BufRange -> IO (BuildSignal r)) + ) -> Put a +putBuildStepCont step = Put step' + where + step' k = BuildStep $ step (\x -> runBuildStep (k x)) + + +fromBuildStepCont :: (forall r. (BufRange -> IO (BuildSignal r)) -> + (BufRange -> IO (BuildSignal r)) + ) -> Builder +fromBuildStepCont step = Builder step' + where + step' k = BuildStep $ step (runBuildStep k) + + + +-- Conversion between Put and Builder +------------------------------------------------------------------------------ + +-- | Put the given builder. +putBuilder :: Builder -> Put () +putBuilder (Builder build) = Put $ \k -> build (k ()) + + +-- | Ignore the value of a put and only exploit its output side effect. +fromPut :: Put a -> Builder +fromPut (Put put) = Builder $ \k -> put (\_ -> k) + + diff --git a/Blaze/ByteString/Builder/Internal/UncheckedShifts.hs b/Blaze/ByteString/Builder/Internal/UncheckedShifts.hs new file mode 100644 --- /dev/null +++ b/Blaze/ByteString/Builder/Internal/UncheckedShifts.hs @@ -0,0 +1,73 @@ +{-# LANGUAGE CPP, MagicHash #-} +-- | +-- Module : Blaze.ByteString.Builder.Internal.UncheckedShifts +-- Copyright : (c) 2010 Simon Meier +-- +-- Original serialization code from 'Data.Binary.Builder': +-- (c) Lennart Kolmodin, Ross Patterson +-- +-- License : BSD3-style (see LICENSE) +-- +-- Maintainer : Simon Meier +-- Stability : experimental +-- Portability : tested on GHC only +-- +-- Utilty module defining unchecked shifts. +-- +#if defined(__GLASGOW_HASKELL__) && !defined(__HADDOCK__) +#include "MachDeps.h" +#endif + +module Blaze.ByteString.Builder.Internal.UncheckedShifts ( + shiftr_w16 + , shiftr_w32 + , shiftr_w64 + ) where + +-- TODO: Check validity of this implementation + +#if defined(__GLASGOW_HASKELL__) && !defined(__HADDOCK__) +import GHC.Base +import GHC.Word (Word32(..),Word16(..),Word64(..)) + +#if WORD_SIZE_IN_BITS < 64 && __GLASGOW_HASKELL__ >= 608 +import GHC.Word (uncheckedShiftRL64#) +#endif +#else +import Data.Word +#endif + + +------------------------------------------------------------------------ +-- Unchecked shifts + +{-# INLINE shiftr_w16 #-} +shiftr_w16 :: Word16 -> Int -> Word16 +{-# INLINE shiftr_w32 #-} +shiftr_w32 :: Word32 -> Int -> Word32 +{-# INLINE shiftr_w64 #-} +shiftr_w64 :: Word64 -> Int -> Word64 + +#if defined(__GLASGOW_HASKELL__) && !defined(__HADDOCK__) +shiftr_w16 (W16# w) (I# i) = W16# (w `uncheckedShiftRL#` i) +shiftr_w32 (W32# w) (I# i) = W32# (w `uncheckedShiftRL#` i) + +#if WORD_SIZE_IN_BITS < 64 +shiftr_w64 (W64# w) (I# i) = W64# (w `uncheckedShiftRL64#` i) + +#if __GLASGOW_HASKELL__ <= 606 +-- Exported by GHC.Word in GHC 6.8 and higher +foreign import ccall unsafe "stg_uncheckedShiftRL64" + uncheckedShiftRL64# :: Word64# -> Int# -> Word64# +#endif + +#else +shiftr_w64 (W64# w) (I# i) = W64# (w `uncheckedShiftRL#` i) +#endif + +#else +shiftr_w16 = shiftR +shiftr_w32 = shiftR +shiftr_w64 = shiftR +#endif + diff --git a/Blaze/ByteString/Builder/Internal/Write.hs b/Blaze/ByteString/Builder/Internal/Write.hs new file mode 100644 --- /dev/null +++ b/Blaze/ByteString/Builder/Internal/Write.hs @@ -0,0 +1,187 @@ +{-# LANGUAGE CPP, BangPatterns #-} +-- | +-- Module : Blaze.ByteString.Builder.Internal.WriteIO +-- Copyright : (c) 2010 Simon Meier +-- (c) 2010 Jasper van der Jeugt +-- License : BSD3-style (see LICENSE) +-- +-- Maintainer : Simon Meier +-- Stability : experimental +-- Portability : tested on GHC only +-- +-- A general and efficient write type that allows for the easy construction of +-- builders for (smallish) bounded size writes to a buffer. +-- +module Blaze.ByteString.Builder.Internal.Write ( + -- * Abstracting writes to a buffer + Write + , WriteIO + , writeN + , exactWrite + , boundedWrite + , runWrite + , runWriteIO + + -- * Constructing builders from writes + , fromWrite + , fromWriteSingleton + , fromWriteList + + -- * Writing 'Storable's + , writeStorable + , fromStorable + , fromStorables + + ) where + +import Foreign + +import Data.Monoid + +import Control.Monad + +import Blaze.ByteString.Builder.Internal.Types + + +------------------------------------------------------------------------------ +-- The Write WriteIO Type +------------------------------------------------------------------------------ + +-- Sadly GHC is not smart enough: code where we branch and each branch should +-- execute a few IO actions and then return a value cannot be taught to GHC. At +-- least not such that it returns the value of the branches unpacked. +-- +-- Hmm.. at least he behaves much better for the Monoid instance of Write +-- than the one for WriteIO. Serializing UTF-8 chars gets a slowdown of a +-- factor 2 when 2 chars are composed. Perhaps I should try out the writeList +-- instances also, as they may be more sensitive to to much work per Char. +-- + +-- | A write to a buffer. +-- +-- FIXME: Find better name: what about 'Poke' ? +newtype WriteIO = + WriteIO { runWriteIO :: Ptr Word8 -> IO (Ptr Word8) } + +-- | A write of a bounded number of bytes. +data Write = Write {-# UNPACK #-} !Int WriteIO + +-- | Extract the 'WriteIO' action of a write. +{-# INLINE runWrite #-} +runWrite :: Write -> WriteIO +runWrite (Write _ wio) = wio + +instance Monoid WriteIO where + mempty = WriteIO $ return + {-# INLINE mempty #-} + (WriteIO w1) `mappend` (WriteIO w2) = WriteIO $ w1 >=> w2 + {-# INLINE mappend #-} + mconcat = foldr mappend mempty + {-# INLINE mconcat #-} + +instance Monoid Write where + mempty = Write 0 mempty + {-# INLINE mempty #-} + (Write bound1 w1) `mappend` (Write bound2 w2) = + Write (bound1 + bound2) (w1 `mappend` w2) + {-# INLINE mappend #-} + mconcat = foldr mappend mempty + {-# INLINE mconcat #-} + + +-- | @writeN size io@ creates a write that denotes the writing of @size@ bytes +-- to a buffer using the IO action @io@. Note that @io@ MUST write EXACTLY @size@ +-- bytes to the buffer! +writeN :: Int + -> (Ptr Word8 -> IO ()) -> WriteIO +writeN size io = WriteIO $ \op -> io op >> return (op `plusPtr` size) +{-# INLINE writeN #-} + + +-- | @exactWrite size io@ creates a bounded write that can later be converted to +-- a builder that writes exactly @size@ bytes. Note that @io@ MUST write +-- EXACTLY @size@ bytes to the buffer! +exactWrite :: Int + -> (Ptr Word8 -> IO ()) + -> Write +exactWrite size io = Write size (writeN size io) +{-# INLINE exactWrite #-} + +-- | @boundedWrite size write@ creates a bounded write from a @write@ that does +-- not write more than @size@ bytes. +boundedWrite :: Int -> WriteIO -> Write +boundedWrite = Write +{-# INLINE boundedWrite #-} + +fromWrite :: Write -> Builder +fromWrite (Write maxSize wio) = + fromBuildStepCont step + where + step k (BufRange op ope) + | op `plusPtr` maxSize <= ope = do + op' <- runWriteIO wio op + let !br' = BufRange op' ope + k br' + | otherwise = return $ bufferFull maxSize op (step k) +{-# INLINE fromWrite #-} + +fromWriteSingleton :: (a -> Write) -> a -> Builder +fromWriteSingleton write = + mkBuilder + where + mkBuilder x = fromBuildStepCont step + where + step k (BufRange op ope) + | op `plusPtr` maxSize <= ope = do + op' <- runWriteIO wio op + let !br' = BufRange op' ope + k br' + | otherwise = return $ bufferFull maxSize op (step k) + where + Write maxSize wio = write x +{-# INLINE fromWriteSingleton #-} + +-- | Construct a 'Builder' writing a list of data one element at a time. +fromWriteList :: (a -> Write) -> [a] -> Builder +fromWriteList write = + makeBuilder + where + makeBuilder xs0 = fromBuildStepCont $ step xs0 + where + step xs1 k !(BufRange op0 ope0) = go xs1 op0 + where + go [] !op = do + let !br' = BufRange op ope0 + k br' + + go xs@(x':xs') !op + | op `plusPtr` maxSize <= ope0 = do + !op' <- runWriteIO wio op + go xs' op' + | otherwise = return $ bufferFull maxSize op (step xs k) + where + Write maxSize wio = write x' +{-# INLINE fromWriteList #-} + + + +------------------------------------------------------------------------------ +-- Writing storables +------------------------------------------------------------------------------ + + +-- | Write a storable value. +{-# INLINE writeStorable #-} +writeStorable :: Storable a => a -> Write +writeStorable x = exactWrite (sizeOf x) (\op -> poke (castPtr op) x) + +-- | A builder that serializes a storable value. No alignment is done. +{-# INLINE fromStorable #-} +fromStorable :: Storable a => a -> Builder +fromStorable = fromWriteSingleton writeStorable + +-- | A builder that serializes a list of storable values by writing them +-- consecutively. No alignment is done. Parsing information needs to be +-- provided externally. +fromStorables :: Storable a => [a] -> Builder +fromStorables = fromWriteList writeStorable diff --git a/Blaze/ByteString/Builder/Word.hs b/Blaze/ByteString/Builder/Word.hs --- a/Blaze/ByteString/Builder/Word.hs +++ b/Blaze/ByteString/Builder/Word.hs @@ -1,6 +1,3 @@ -{-# OPTIONS_GHC -fglasgow-exts #-} --- for unboxed shifts - {-# LANGUAGE CPP #-} -- | -- Module : Blaze.ByteString.Builder.Word @@ -34,7 +31,6 @@ #if defined(__GLASGOW_HASKELL__) && !defined(__HADDOCK__) #include "MachDeps.h" #endif - module Blaze.ByteString.Builder.Word ( -- * Writing words to a buffer @@ -62,8 +58,7 @@ -- | We provide serialization functions both for singleton words as well as -- for lists of words. Using these list serialization functions is /much/ faster -- than using @mconcat . map fromWord/@, as the list serialization - -- functions use a tighter inner loop and a chunked write like it is - -- provided by functions such as 'fromWrite2List'. + -- functions use a tighter inner loop. , fromWord8 , fromWord8s @@ -97,17 +92,12 @@ ) where import Blaze.ByteString.Builder.Internal -import Blaze.ByteString.Builder.Write +import Blaze.ByteString.Builder.Internal.UncheckedShifts import Foreign #if defined(__GLASGOW_HASKELL__) && !defined(__HADDOCK__) -import GHC.Base import GHC.Word (Word32(..),Word16(..),Word64(..)) - -#if WORD_SIZE_IN_BITS < 64 && __GLASGOW_HASKELL__ >= 608 -import GHC.Word (uncheckedShiftRL64#) -#endif #else import Data.Word #endif @@ -125,7 +115,7 @@ -- | Write a single byte. -- writeWord8 :: Word8 -> Write -writeWord8 x = Write 1 (\pf -> poke pf x) +writeWord8 x = exactWrite 1 (\pf -> poke pf x) {-# INLINE writeWord8 #-} -- @@ -135,23 +125,23 @@ -- | Write a 'Word16' in big endian format. writeWord16be :: Word16 -> Write -writeWord16be w = Write 2 $ \p -> do +writeWord16be w = exactWrite 2 $ \p -> do poke p (fromIntegral (shiftr_w16 w 8) :: Word8) poke (p `plusPtr` 1) (fromIntegral (w) :: Word8) {-# INLINE writeWord16be #-} -- | Write a 'Word16' in little endian format. writeWord16le :: Word16 -> Write -writeWord16le w = Write 2 $ \p -> do +writeWord16le w = exactWrite 2 $ \p -> do poke p (fromIntegral (w) :: Word8) poke (p `plusPtr` 1) (fromIntegral (shiftr_w16 w 8) :: Word8) {-# INLINE writeWord16le #-} --- writeWord16le w16 = Write 2 (\p -> poke (castPtr p) w16) +-- writeWord16le w16 = exactWrite 2 (\p -> poke (castPtr p) w16) -- | Write a 'Word32' in big endian format. writeWord32be :: Word32 -> Write -writeWord32be w = Write 4 $ \p -> do +writeWord32be w = exactWrite 4 $ \p -> do poke p (fromIntegral (shiftr_w32 w 24) :: Word8) poke (p `plusPtr` 1) (fromIntegral (shiftr_w32 w 16) :: Word8) poke (p `plusPtr` 2) (fromIntegral (shiftr_w32 w 8) :: Word8) @@ -160,7 +150,7 @@ -- | Write a 'Word32' in little endian format. writeWord32le :: Word32 -> Write -writeWord32le w = Write 4 $ \p -> do +writeWord32le w = exactWrite 4 $ \p -> do poke p (fromIntegral (w) :: Word8) poke (p `plusPtr` 1) (fromIntegral (shiftr_w32 w 8) :: Word8) poke (p `plusPtr` 2) (fromIntegral (shiftr_w32 w 16) :: Word8) @@ -168,7 +158,7 @@ {-# INLINE writeWord32le #-} -- on a little endian machine: --- writeWord32le w32 = Write 4 (\p -> poke (castPtr p) w32) +-- writeWord32le w32 = exactWrite 4 (\p -> poke (castPtr p) w32) -- | Write a 'Word64' in big endian format. writeWord64be :: Word64 -> Write @@ -180,7 +170,7 @@ writeWord64be w = let a = fromIntegral (shiftr_w64 w 32) :: Word32 b = fromIntegral w :: Word32 - in Write 8 $ \p -> do + in exactWrite 8 $ \p -> do poke p (fromIntegral (shiftr_w32 a 24) :: Word8) poke (p `plusPtr` 1) (fromIntegral (shiftr_w32 a 16) :: Word8) poke (p `plusPtr` 2) (fromIntegral (shiftr_w32 a 8) :: Word8) @@ -190,7 +180,7 @@ poke (p `plusPtr` 6) (fromIntegral (shiftr_w32 b 8) :: Word8) poke (p `plusPtr` 7) (fromIntegral (b) :: Word8) #else -writeWord64be w = Write 8 $ \p -> do +writeWord64be w = exactWrite 8 $ \p -> do poke p (fromIntegral (shiftr_w64 w 56) :: Word8) poke (p `plusPtr` 1) (fromIntegral (shiftr_w64 w 48) :: Word8) poke (p `plusPtr` 2) (fromIntegral (shiftr_w64 w 40) :: Word8) @@ -209,7 +199,7 @@ writeWord64le w = let b = fromIntegral (shiftr_w64 w 32) :: Word32 a = fromIntegral w :: Word32 - in Write 8 $ \p -> do + in exactWrite 8 $ \p -> do poke (p) (fromIntegral (a) :: Word8) poke (p `plusPtr` 1) (fromIntegral (shiftr_w32 a 8) :: Word8) poke (p `plusPtr` 2) (fromIntegral (shiftr_w32 a 16) :: Word8) @@ -219,7 +209,7 @@ poke (p `plusPtr` 6) (fromIntegral (shiftr_w32 b 16) :: Word8) poke (p `plusPtr` 7) (fromIntegral (shiftr_w32 b 24) :: Word8) #else -writeWord64le w = Write 8 $ \p -> do +writeWord64le w = exactWrite 8 $ \p -> do poke p (fromIntegral (w) :: Word8) poke (p `plusPtr` 1) (fromIntegral (shiftr_w64 w 8) :: Word8) poke (p `plusPtr` 2) (fromIntegral (shiftr_w64 w 16) :: Word8) @@ -232,7 +222,7 @@ {-# INLINE writeWord64le #-} -- on a little endian machine: --- writeWord64le w64 = Write 8 (\p -> poke (castPtr p) w64) +-- writeWord64le w64 = exactWrite 8 (\p -> poke (castPtr p) w64) ------------------------------------------------------------------------ -- Unaligned, word size ops @@ -245,61 +235,28 @@ -- writeWordhost :: Word -> Write writeWordhost w = - Write (sizeOf (undefined :: Word)) (\p -> poke (castPtr p) w) + exactWrite (sizeOf (undefined :: Word)) (\p -> poke (castPtr p) w) {-# INLINE writeWordhost #-} -- | Write a 'Word16' in native host order and host endianness. writeWord16host :: Word16 -> Write writeWord16host w16 = - Write (sizeOf (undefined :: Word16)) (\p -> poke (castPtr p) w16) + exactWrite (sizeOf (undefined :: Word16)) (\p -> poke (castPtr p) w16) {-# INLINE writeWord16host #-} -- | Write a 'Word32' in native host order and host endianness. writeWord32host :: Word32 -> Write writeWord32host w32 = - Write (sizeOf (undefined :: Word32)) (\p -> poke (castPtr p) w32) + exactWrite (sizeOf (undefined :: Word32)) (\p -> poke (castPtr p) w32) {-# INLINE writeWord32host #-} -- | Write a 'Word64' in native host order and host endianness. writeWord64host :: Word64 -> Write writeWord64host w = - Write (sizeOf (undefined :: Word64)) (\p -> poke (castPtr p) w) + exactWrite (sizeOf (undefined :: Word64)) (\p -> poke (castPtr p) w) {-# INLINE writeWord64host #-} ------------------------------------------------------------------------- --- Unchecked shifts -{-# INLINE shiftr_w16 #-} -shiftr_w16 :: Word16 -> Int -> Word16 -{-# INLINE shiftr_w32 #-} -shiftr_w32 :: Word32 -> Int -> Word32 -{-# INLINE shiftr_w64 #-} -shiftr_w64 :: Word64 -> Int -> Word64 - -#if defined(__GLASGOW_HASKELL__) && !defined(__HADDOCK__) -shiftr_w16 (W16# w) (I# i) = W16# (w `uncheckedShiftRL#` i) -shiftr_w32 (W32# w) (I# i) = W32# (w `uncheckedShiftRL#` i) - -#if WORD_SIZE_IN_BITS < 64 -shiftr_w64 (W64# w) (I# i) = W64# (w `uncheckedShiftRL64#` i) - -#if __GLASGOW_HASKELL__ <= 606 --- Exported by GHC.Word in GHC 6.8 and higher -foreign import ccall unsafe "stg_uncheckedShiftRL64" - uncheckedShiftRL64# :: Word64# -> Int# -> Word64# -#endif - -#else -shiftr_w64 (W64# w) (I# i) = W64# (w `uncheckedShiftRL#` i) -#endif - -#else -shiftr_w16 = shiftR -shiftr_w32 = shiftR -shiftr_w64 = shiftR -#endif - - ------------------------------------------------------------------------------ -- Builders corresponding to the word writes ------------------------------------------------------------------------------ @@ -315,7 +272,7 @@ -- | Serialize a list of bytes. -- fromWord8s :: [Word8] -> Builder -fromWord8s = fromWrite8List writeWord8 +fromWord8s = fromWriteList writeWord8 -- Word16 @@ -328,7 +285,7 @@ -- | Serialize a list of 'Word16's in big endian format. fromWord16sbe :: [Word16] -> Builder -fromWord16sbe = fromWrite4List writeWord16be +fromWord16sbe = fromWriteList writeWord16be {-# INLINE fromWord16sbe #-} -- | Serialize a 'Word16' in little endian format. @@ -338,7 +295,7 @@ -- | Serialize a list of 'Word16's in little endian format. fromWord16sle :: [Word16] -> Builder -fromWord16sle = fromWrite4List writeWord16le +fromWord16sle = fromWriteList writeWord16le {-# INLINE fromWord16sle #-} @@ -352,7 +309,7 @@ -- | Serialize a list of 'Word32's in big endian format. fromWord32sbe :: [Word32] -> Builder -fromWord32sbe = fromWrite2List writeWord32be +fromWord32sbe = fromWriteList writeWord32be {-# INLINE fromWord32sbe #-} -- | Serialize a 'Word32' in little endian format. @@ -362,7 +319,7 @@ -- | Serialize a list of 'Word32's in little endian format. fromWord32sle :: [Word32] -> Builder -fromWord32sle = fromWrite2List writeWord32le +fromWord32sle = fromWriteList writeWord32le {-# INLINE fromWord32sle #-} -- | Serialize a 'Word64' in big endian format. @@ -372,7 +329,7 @@ -- | Serialize a list of 'Word64's in big endian format. fromWord64sbe :: [Word64] -> Builder -fromWord64sbe = fromWrite1List writeWord64be +fromWord64sbe = fromWriteList writeWord64be {-# INLINE fromWord64sbe #-} -- | Serialize a 'Word64' in little endian format. @@ -382,7 +339,7 @@ -- | Serialize a list of 'Word64's in little endian format. fromWord64sle :: [Word64] -> Builder -fromWord64sle = fromWrite1List writeWord64le +fromWord64sle = fromWriteList writeWord64le {-# INLINE fromWord64sle #-} @@ -402,7 +359,7 @@ -- | Serialize a list of 'Word's. -- See 'fromWordhost' for usage considerations. fromWordshost :: [Word] -> Builder -fromWordshost = fromWrite2List writeWordhost +fromWordshost = fromWriteList writeWordhost {-# INLINE fromWordshost #-} -- | Write a 'Word16' in native host order and host endianness. @@ -412,7 +369,7 @@ -- | Write a list of 'Word16's in native host order and host endianness. fromWord16shost :: [Word16] -> Builder -fromWord16shost = fromWrite4List writeWord16host +fromWord16shost = fromWriteList writeWord16host {-# INLINE fromWord16shost #-} -- | Write a 'Word32' in native host order and host endianness. @@ -422,7 +379,7 @@ -- | Write a list of 'Word32's in native host order and host endianness. fromWord32shost :: [Word32] -> Builder -fromWord32shost = fromWrite2List writeWord32host +fromWord32shost = fromWriteList writeWord32host {-# INLINE fromWord32shost #-} -- | Write a 'Word64' in native host order and host endianness. @@ -432,5 +389,5 @@ -- | Write a list of 'Word64's in native host order and host endianness. fromWord64shost :: [Word64] -> Builder -fromWord64shost = fromWrite1List writeWord64host +fromWord64shost = fromWriteList writeWord64host {-# INLINE fromWord64shost #-} diff --git a/Blaze/ByteString/Builder/Write.hs b/Blaze/ByteString/Builder/Write.hs deleted file mode 100644 --- a/Blaze/ByteString/Builder/Write.hs +++ /dev/null @@ -1,384 +0,0 @@ -{-# LANGUAGE CPP, BangPatterns #-} - --- | --- Module : Blaze.ByteString.Builder.Write --- Copyright : (c) 2010 Jasper Van der Jeugt & Simon Meier --- License : BSD3-style (see LICENSE) --- --- Maintainer : Simon Meier --- Stability : experimental --- Portability : tested on GHC only --- --- This module provides the 'Write' type, which abstracts direct writes to a --- buffer. 'Write's form the public interface for lifting direct buffer --- manipulations to 'Builder's. --- -module Blaze.ByteString.Builder.Write - ( - -- * Atomic writes to a buffer - Write (..) - - -- * Creating builders from 'Write' abstractions - , fromWrite - , fromWriteSingleton - , fromWrite1List - , fromWrite2List - , fromWrite4List - , fromWrite8List - , fromWrite16List - - ) where - -import Blaze.ByteString.Builder.Internal - -import Foreign -import Data.Monoid - - ------------------------------------------------------------------------------- --- Atomic writes to a buffer ------------------------------------------------------------------------------- - --- | A value @Write n io@ denotes the write of @n@ bytes to a buffer. The --- actual write is executed by calling @io@ with a pointer @pf@ to the first --- free byte that the write should start with. Note that the caller of @io pf@ --- must ensure that @n@ bytes are free starting from @pf@. --- --- For example, the function @'writeWord8'@ provided by --- "Blaze.ByteString.Builder.Word" creates a 'Write' that writes a single fixed byte --- to a buffer. --- --- > writeWord8 :: Word8 -> Write --- > writeWord8 x = Write 1 (\pf -> poke pf x) --- --- The benefit of writes is that they abstract low-level manipulations (e.g. --- 'poke' and 'copyBytes') of sequences of bytes in a form that that can be --- completely optimized away in many cases. --- --- For example, the 'Monoid' instance of 'Write' allows to formulate writing a --- three-tuple of bytes as follows. --- --- > writeThreeWord8 :: (Word8, Word8, Word8) -> Write --- > writeThreeWord8 (x,y,z) = --- > writeWord8 x `mappend` writeWord8 y `mappend` writeWord8 z --- --- This expression will be optimized by the compiler to the following efficient --- 'Write'. --- --- > writeThreeWord8 (x, y, z) = Write 3 $ \pf -> do --- > poke pf x --- > poke (pf `plusPtr` 1) y --- > poke (pf `plusPtr` 2) z --- --- Writes are /atomic/. This means that the written data cannot be wrapped --- over buffer boundaries as it can be done for builders. For writes it holds --- that either the buffer has enough free space and the write can proceed or a --- new buffer with a size larger or equal to the number of bytes to write has --- to be allocated. --- --- Moreover, for a 'Write', the size of the data to be written must be known --- before the data can be written. Hence, if this size is data-dependent, the --- control flow becomes complicated: first, all data must be forced and stored, --- then the size check happens, and only afterwards the stored data can be --- written. Therefore, because of cache misses, composing writes with --- data-dependent size computations may actually be slower than combining the --- resulting builders. Use benchmarking to make informed decisions. --- -data Write = Write - {-# UNPACK #-} !Int -- Number of bytes that will be written. - (Ptr Word8 -> IO ()) -- Function to write the bytes starting from the given - -- pointer - --- A monoid interface for the 'Write' actions. -instance Monoid Write where - mempty = Write 0 (const $ return ()) - {-# INLINE mempty #-} - - mappend (Write l1 f1) (Write l2 f2) = Write (l1 + l2) $ \ptr -> do - f1 ptr - f2 (ptr `plusPtr` l1) - {-# INLINE mappend #-} - - --- Lifting Writes to Builders ------------------------------ - --- | Create a 'Builder' from a single write @w@. For good performance, @w@ must --- feature an outermost 'Write' constructor such that the pattern match can be --- eliminated during compilation. --- --- Semantically, it holds that --- --- > fromWrite . write = fromWriteSingleton write --- --- However, performance-wise the right-hand side is more efficient due to --- currently unknown reasons. Use the second form, when --- defining functions for creating builders from writes of Haskell values. --- --- (Use the standard benchmark in the @blaze-html@ package when investigating --- this phenomenon.) -fromWrite :: Write -> Builder -fromWrite (Write size io) = - Builder step - where - step k pf pe - | pf `plusPtr` size <= pe = do - io pf - let pf' = pf `plusPtr` size - pf' `seq` k pf' pe - | otherwise = return $ BufferFull size pf (step k) -{-# INLINE fromWrite #-} - --- | Create a 'Builder' constructor from a single 'Write' constructor. --- -fromWriteSingleton :: (a -> Write) -> a -> Builder -fromWriteSingleton write = makeBuilder - where - makeBuilder x = Builder step - where - step k pf pe - | pf `plusPtr` size <= pe = do - io pf - let pf' = pf `plusPtr` size - pf' `seq` k pf' pe - | otherwise = return $ BufferFull size pf (step k) - where - Write size io = write x -{-# INLINE fromWriteSingleton #-} - --- | Construct a 'Builder' writing a list of data one element at a time from a 'Write' abstraction. --- -fromWrite1List :: (a -> Write) -> [a] -> Builder -fromWrite1List write = makeBuilder - where - makeBuilder [] = mempty - makeBuilder xs0 = Builder $ step xs0 - where - step xs1 k pf0 pe0 = go xs1 pf0 - where - go [] !pf = k pf pe0 - go xs@(x':xs') !pf - | pf `plusPtr` size <= pe0 = do - io pf - go xs' (pf `plusPtr` size) - | otherwise = do return $ BufferFull size pf (step xs k) - where - Write size io = write x' -{-# INLINE fromWrite1List #-} - --- | Construct a 'Builder' writing a list of data two elements at a time from a --- 'Write' abstraction. --- -fromWrite2List :: (a -> Write) -> [a] -> Builder -fromWrite2List write = makeBuilder - where - makeBuilder [] = mempty - makeBuilder xs0 = Builder $ step xs0 - where - step xs1 k pf0 pe0 = go xs1 pf0 - where - go [] !pf = k pf pe0 - - go xs@[x'1] !pf - | pf' <= pe0 = do - io pf - k pf' pe0 - | otherwise = do return $ BufferFull size pf (step xs k) - where - Write size io = write x'1 - pf' = pf `plusPtr` size - - go xs@(x'1:x'2:xs') !pf - | pf' <= pe0 = do - io pf - go xs' pf' - | otherwise = do return $ BufferFull size pf (step xs k) - where - Write size io = write x'1 `mappend` write x'2 - pf' = pf `plusPtr` size -{-# INLINE fromWrite2List #-} - --- | Construct a 'Builder' writing a list of data four elements at a time from a --- 'Write' abstraction. --- -fromWrite4List :: (a -> Write) -> [a] -> Builder -fromWrite4List write = makeBuilder - where - makeBuilder [] = mempty - makeBuilder xs0 = Builder $ step xs0 - where - step xs1 k pf0 pe0 = go xs1 pf0 - where - go xs@(x'1:x'2:x'3:x'4:xs') !pf - | pf' <= pe0 = do - io pf - go xs' pf' - | otherwise = do return $ BufferFull size pf (step xs k) - where - Write size io = write x'1 `mappend` write x'2 - `mappend` write x'3 - `mappend` write x'4 - pf' = pf `plusPtr` size - - go xs@(x'1:x'2:xs') !pf - | pf' <= pe0 = do - io pf - go xs' pf' - | otherwise = do return $ BufferFull size pf (step xs k) - where - Write size io = write x'1 `mappend` write x'2 - pf' = pf `plusPtr` size - - go xs@[x'1] !pf - | pf' <= pe0 = do - io pf - k pf' pe0 - | otherwise = do return $ BufferFull size pf (step xs k) - where - Write size io = write x'1 - pf' = pf `plusPtr` size - - go [] !pf = k pf pe0 -{-# INLINE fromWrite4List #-} - --- | Construct a 'Builder' writing a list of data eight elements at a time from a --- 'Write' abstraction. --- -fromWrite8List :: (a -> Write) -> [a] -> Builder -fromWrite8List write = makeBuilder - where - makeBuilder [] = mempty - makeBuilder xs0 = Builder $ step xs0 - where - step xs1 k pf0 pe0 = go xs1 pf0 - where - go xs@(x'1:x'2:x'3:x'4:x'5:x'6:x'7:x'8:xs') !pf - | pf' <= pe0 = do - io pf - go xs' pf' - | otherwise = do return $ BufferFull size pf (step xs k) - where - Write size io = write x'1 `mappend` write x'2 - `mappend` write x'3 - `mappend` write x'4 - `mappend` write x'5 - `mappend` write x'6 - `mappend` write x'7 - `mappend` write x'8 - pf' = pf `plusPtr` size - - go xs@(x'1:x'2:x'3:x'4:xs') !pf - | pf' <= pe0 = do - io pf - go xs' pf' - | otherwise = do return $ BufferFull size pf (step xs k) - where - Write size io = write x'1 `mappend` write x'2 - `mappend` write x'3 - `mappend` write x'4 - pf' = pf `plusPtr` size - - go xs@(x'1:x'2:xs') !pf - | pf' <= pe0 = do - io pf - go xs' pf' - | otherwise = do return $ BufferFull size pf (step xs k) - where - Write size io = write x'1 `mappend` write x'2 - pf' = pf `plusPtr` size - - go xs@[x'1] !pf - | pf' <= pe0 = do - io pf - k pf' pe0 - | otherwise = do return $ BufferFull size pf (step xs k) - where - Write size io = write x'1 - pf' = pf `plusPtr` size - - go [] !pf = k pf pe0 -{-# INLINE fromWrite8List #-} - --- | Construct a 'Builder' writing a list of data 16 elements at a time from a --- 'Write' abstraction. --- -fromWrite16List :: (a -> Write) -> [a] -> Builder -fromWrite16List write = makeBuilder - where - makeBuilder [] = mempty - makeBuilder xs0 = Builder $ step xs0 - where - step xs1 k pf0 pe0 = go xs1 pf0 - where - go xs@(x'1:x'2:x'3:x'4:x'5:x'6:x'7:x'8:x'9:x'10:x'11:x'12:x'13:x'14:x'15:x'16:xs') !pf - | pf' <= pe0 = do - io pf - go xs' pf' - | otherwise = do return $ BufferFull size pf (step xs k) - where - Write size io = write x'1 `mappend` write x'2 - `mappend` write x'3 - `mappend` write x'4 - `mappend` write x'5 - `mappend` write x'6 - `mappend` write x'7 - `mappend` write x'8 - `mappend` write x'9 - `mappend` write x'10 - `mappend` write x'11 - `mappend` write x'12 - `mappend` write x'13 - `mappend` write x'14 - `mappend` write x'15 - `mappend` write x'16 - pf' = pf `plusPtr` size - - go xs@(x'1:x'2:x'3:x'4:x'5:x'6:x'7:x'8:xs') !pf - | pf' <= pe0 = do - io pf - go xs' pf' - | otherwise = do return $ BufferFull size pf (step xs k) - where - Write size io = write x'1 `mappend` write x'2 - `mappend` write x'3 - `mappend` write x'4 - `mappend` write x'5 - `mappend` write x'6 - `mappend` write x'7 - `mappend` write x'8 - pf' = pf `plusPtr` size - - - go xs@(x'1:x'2:x'3:x'4:xs') !pf - | pf' <= pe0 = do - io pf - go xs' pf' - | otherwise = do return $ BufferFull size pf (step xs k) - where - Write size io = write x'1 `mappend` write x'2 - `mappend` write x'3 - `mappend` write x'4 - pf' = pf `plusPtr` size - - go xs@(x'1:x'2:xs') !pf - | pf' <= pe0 = do - io pf - go xs' pf' - | otherwise = do return $ BufferFull size pf (step xs k) - where - Write size io = write x'1 `mappend` write x'2 - pf' = pf `plusPtr` size - - go xs@[x'1] !pf - | pf' <= pe0 = do - io pf - k pf' pe0 - | otherwise = do return $ BufferFull size pf (step xs k) - where - Write size io = write x'1 - pf' = pf `plusPtr` size - - go [] !pf = k pf pe0 -{-# INLINE fromWrite16List #-} - - diff --git a/CHANGES b/CHANGES --- a/CHANGES +++ b/CHANGES @@ -1,3 +1,32 @@ +* 0.2.1.0 + + Incorporated several design changes: + - Writable buffer range is now represented in a packed form. This improves + speed slightly, as less currying is used. + - Writes are abstracted such that their internal representation can be + exchanged without breaking other library code. + - Writes are represented in a form that allows for efficient monoid + instances for branching code like UTF-8 encoding. For single character + encoding this results currently in a slight slowdown due to GHC not + recognizing the strictness of the returned value. This will be fixed in + the future. + - BuildSteps support returning a result in `Done`, which enables to + implement a `Put` monad using CPS. + - chunked list writes were removed, as they result in worse performance + when writing non-trivial lists. (cf. benchmarks) + - An internal buffering abstraction is introduced, which is used both + by the adaption of the `binary` package, as well as by the + `blaze-builder-enumeratee` package, to execute puts and builders. + It will be used later also by the execution functions of the + `blaze-builder` package. + + Implemented new functionality + - `Blaze.ByteString.Builder.HTTP` provides a builder transformer for + doing in-buffer chunked HTTP encoding of an arbitary other builder. + - `Blaze.ByteString.Builder.Char8` provides functions to serialize the + lower 8-bits of characters similiar to what `Data.ByteString.Char8` + provides for bytestrings. + * 0.2.0.3 Loosen 'text' dependency to '>= 0.10 && < 0.12' diff --git a/Makefile b/Makefile --- a/Makefile +++ b/Makefile @@ -6,9 +6,11 @@ ## Config ######### -GHC = ghc-6.12.3 -# GHC = ghc-7.0.0.20100924 +GHC6 = ghc-6.12.3 +GHC7 = ghc-7.0.1 +GHC = $(GHC7) + GHCI = ghci-6.12.3 @@ -67,6 +69,49 @@ $(GHC) --make -O2 -fforce-recomp -ibenchmarks -main-is Compression Compression ./benchmarks/Compression --resamples 10000 +# Benchmark the use of unboxed continuation calls +bench-unboxed-append: + $(GHC) --make -O2 -fforce-recomp -ibenchmarks -main-is UnboxedAppend UnboxedAppend + ./benchmarks/UnboxedAppend --resamples 10000 + +# Core of the use of unboxed continuation calls +core-unboxed-append: + ghc-core -- --make -O2 -fforce-recomp -main-is UnboxedAppend benchmarks/UnboxedAppend.hs + +# Benchmark the cost of the Put monad vs. the Builder monoid +bench-put-vs-builder: + $(GHC) --make -O2 -fforce-recomp -ibenchmarks -main-is FastPut FastPut + ./benchmarks/FastPut --resamples 10000 + +# Benchmark the cost/benefit of a more general write type +bench-bounded-write: + $(GHC7) --make -O2 -fforce-recomp -ibenchmarks -main-is BoundedWrite BoundedWrite + ./benchmarks/BoundedWrite --resamples 10000 + +core-bounded-write: + ghc-core -- --make -O2 -fforce-recomp -main-is BoundedWrite benchmarks/BoundedWrite.hs + + +# Benchmark the benefit of using a packed representation for the buffer range +bench-buffer-range: + $(GHC) --make -O2 -fforce-recomp -ibenchmarks -main-is BuilderBufferRange BuilderBufferRange + ./benchmarks/BuilderBufferRange --resamples 10000 + +# Benchmark improvements to lazy bytestring functions +bench-lazy-bytestring: + $(GHC) --make -O2 -fforce-recomp -ibenchmarks -main-is LazyByteString LazyByteString + ./benchmarks/LazyByteString --resamples 10000 + +# Benchmark benefit of compaction before compression +bench-server: + $(GHC) --make -O2 -ibenchmarks -main-is BenchmarkServer BenchmarkServer + # ./benchmarks/BenchmarkServer --resamples 10000 + ./benchmarks/BenchmarkServer 9999 100000 +RTS -s& + ab -n 1000 localhost:9999/lbs + curl localhost:9999/kill > /dev/null 2>&1 + + + ############################################################################## ## Plots ############################################################################## @@ -81,7 +126,7 @@ ############################################################################## test: - $(GHC) --make -O2 -itests -main-is Tests Tests + $(GHC) --make -fforce-recomp -O2 -itests -main-is Tests Tests ./tests/Tests clean-tests: diff --git a/TODO b/TODO --- a/TODO +++ b/TODO @@ -1,3 +1,7 @@ + +!! UPDATE TODO !! + +!! UPDATE BENCHMARKS !! * custom serialization functions for lists of 'WordX's - benchmark chunk size speedup for more complicated computations of list @@ -19,6 +23,12 @@ cheaper than one list thunk per element. It is even likely that we can amortize three copies per element, which allows to avoid spilling any buffer space by doing a last compaction copy. + - we could provide builders that honor alignment restrictions, either as + builder transformers or as specialized write to builder converters. The + trick is for the driver to ensure that the buffer beginning is aligned + to the largest aligning (8 or 16 bytes?) required. This is probably the + case by default. Then we can always align a pointer in the buffer by + appropriately aligning the write pointer. * extend tests to new functions diff --git a/benchmarks/BenchmarkServer.hs b/benchmarks/BenchmarkServer.hs new file mode 100644 --- /dev/null +++ b/benchmarks/BenchmarkServer.hs @@ -0,0 +1,97 @@ +{- Benchmark server based upon Jasper van der Jeugt's 'BenchmarkServer.lhs' + from blaze-html. Modified for network-2.3 by Simon Meier +-} + +{-# LANGUAGE OverloadedStrings #-} +module BenchmarkServer where + +import Prelude hiding (putStrLn) + +import Data.Char (ord) +import Data.Monoid +import Data.ByteString.Char8 () -- IsString instance only +import qualified Data.ByteString as S +import qualified Data.ByteString.Lazy as L +import qualified Data.ByteString.Lazy.Internal as L + +import Control.Concurrent (forkIO, putMVar, takeMVar, newEmptyMVar) +import Control.Exception (bracket) +import Control.Monad + +import Network.Socket (Socket, accept, sClose) +import Network (listenOn, PortID (PortNumber)) +import Network.Socket.ByteString as S +import Network.Socket.ByteString.Lazy as L + +import System (getArgs) + +import Blaze.ByteString.Builder +import Blaze.ByteString.Builder.Internal (defaultBufferSize, defaultMinimalBufferSize) +import Blaze.ByteString.Builder.Char.Utf8 + +import Criterion.Main + +httpOkHeader :: S.ByteString +httpOkHeader = S.concat + [ "HTTP/1.1 200 OK\r\n" + , "Content-Type: text/html; charset=UTF-8\r\n" + , "\r\n" ] + +response :: Int -> Builder +response n = + fromByteString httpOkHeader `mappend` + fromString (take n $ cycle "hello λ-world! ") + +sendVectoredBuilderLBS :: Socket -> Builder -> IO () +sendVectoredBuilderLBS s = L.sendAll s . toLazyByteString +{-# NOINLINE sendVectoredBuilderLBS #-} + +sendBuilderLBS :: Socket -> Builder -> IO () +sendBuilderLBS s = + -- mapM_ (S.sendAll s) . L.toChunks . toLazyByteString + L.foldrChunks (\c -> (S.sendAll s c >>)) (return ()). toLazyByteString +{-# NOINLINE sendBuilderLBS #-} + +sendBuilderBSIO :: Socket -> Builder -> IO () +sendBuilderBSIO s = toByteStringIO $ S.sendAll s +{-# NOINLINE sendBuilderBSIO #-} + +-- criterion benchmark determining the speed of response +main2 = defaultMain + [ bench ("response " ++ show n) $ whnf + (L.length . toLazyByteString . response) n + ] + where + n :: Int + n = 1000000 + +main :: IO () +main = do + [port, nChars] <- map read `liftM` getArgs + killSignal <- newEmptyMVar + bracket (listenOn . PortNumber . fromIntegral $ port) sClose + (\socket -> do + _ <- forkIO $ loop (putMVar killSignal ()) nChars socket + takeMVar killSignal) + where + loop killServer nChars socket = forever $ do + (s, _) <- accept socket + forkIO (respond s nChars) + where + respond s n = do + input <- S.recv s 1024 + let requestUrl = (S.split (fromIntegral $ ord ' ') input) !! 1 + case tail (S.split (fromIntegral $ ord '/') requestUrl) of + ["lbs"] -> sendBuilderLBS s $ response n + ["lbs-vec"] -> sendVectoredBuilderLBS s $ response n + ["bs-io"] -> sendBuilderBSIO s $ response n + ["kill"] -> notFound s >> killServer + _ -> notFound s + sClose s + + notFound s = do + _ <- S.sendAll s $ "HTTP/1.1 404 Not Found\r\n" + `mappend` "Content-Type: text/html; charset=UTF-8\r\n" + `mappend` "\r\n" + `mappend` "

Page not found

" + return () diff --git a/benchmarks/BlazeVsBinary.hs b/benchmarks/BlazeVsBinary.hs --- a/benchmarks/BlazeVsBinary.hs +++ b/benchmarks/BlazeVsBinary.hs @@ -42,7 +42,7 @@ main :: IO () main = defaultMain $ concat [ benchmark "[String]" - (mconcat . concatMap (map $ Binary.singleton . fromIntegral . ord)) + (mconcat . map (mconcat . (map $ Binary.singleton . fromIntegral . ord))) (mconcat . map Blaze.fromString) strings , benchmark "L.ByteString" diff --git a/benchmarks/BoundedWrite.hs b/benchmarks/BoundedWrite.hs new file mode 100644 --- /dev/null +++ b/benchmarks/BoundedWrite.hs @@ -0,0 +1,241 @@ +{-# LANGUAGE CPP, BangPatterns #-} +-- | +-- Module : BoundedWrite +-- Copyright : (c) 2010 Simon Meier +-- License : BSD3-style (see LICENSE) +-- +-- Maintainer : Simon Meier +-- Stability : experimental +-- Portability : tested on GHC only +-- +-- A more general/efficient write type. +-- +module BoundedWrite (main) where + +import Foreign +import Data.Monoid +import Data.Char + +import Foreign.UPtr + +import qualified Data.ByteString.Internal as S +import qualified Data.ByteString.Lazy as L + +import Blaze.ByteString.Builder.Internal +import Blaze.ByteString.Builder.Write +import Blaze.ByteString.Builder.Word + +import Criterion.Main + +------------------------------------------------------------------------------ +-- Benchmarks +------------------------------------------------------------------------------ + +main :: IO () +main = defaultMain $ concat + {- + [ benchmark "mconcat . map (fromWriteSingleton writeChar)" + bfrom3Chars + from3Chars + chars3 + ] + -} + [ benchmark "mconcat . map fromWord8" + (mconcat . map bfromWord8) + (mconcat . map fromWord8) + word8s + ] + where + benchmark name boundedF staticF x = + [ bench (name ++ " <- bounded write") $ + whnf (L.length . toLazyByteString . boundedF) x + , bench (name ++ " <- static write") $ + whnf (L.length . toLazyByteString . staticF) x + ] + +word8s :: [Word8] +word8s = take 100000 $ cycle [0..] +{-# NOINLINE word8s #-} + +chars :: [Char] +chars = take 100000 $ ['\0'..] +{-# NOINLINE chars #-} + +chars2 :: [(Char,Char)] +chars2 = zip chars chars +{-# NOINLINE chars2 #-} + +chars3 :: [(Char, Char, Char)] +chars3 = zip3 chars (reverse chars) (reverse chars) +{-# NOINLINE chars3 #-} + +bfromChars = (mconcat . map (fromBWriteSingleton bwriteChar)) +{-# NOINLINE bfromChars #-} + +fromChars = (mconcat . map (fromWriteSingleton writeChar)) +{-# NOINLINE fromChars #-} + +bfrom2Chars = (mconcat . map (fromBWriteSingleton (\(c1, c2) -> bwriteChar c1 `mappend` bwriteChar c2))) +{-# NOINLINE bfrom2Chars #-} + +from2Chars = (mconcat . map (fromWriteSingleton (\(c1, c2) -> writeChar c1 `mappend` writeChar c2))) +{-# NOINLINE from2Chars #-} + +bfrom3Chars = (mconcat . map (fromBWriteSingleton (\(c1, c2, c3) -> bwriteChar c1 `mappend` bwriteChar c2 `mappend` bwriteChar c3))) +{-# NOINLINE bfrom3Chars #-} + +from3Chars = (mconcat . map (fromWriteSingleton (\(c1, c2, c3) -> writeChar c1 `mappend` writeChar c2 `mappend` writeChar c3))) +{-# NOINLINE from3Chars #-} + +------------------------------------------------------------------------------ +-- The Bounded Write Type +------------------------------------------------------------------------------ + +-- * GRRR* GHC is too 'clever'... code where we branch and each branch should +-- execute a few IO actions and then return a value cannot be taught to GHC. +-- At least not such that it returns the value of the branches unpacked. +-- +-- Hmm.. at least he behaves much better for the Monoid instance of BWrite +-- than the one for Write. Serializing UTF-8 chars gets a slowdown of a +-- factor 2 when 2 chars are composed. Perhaps I should try out the writeList +-- instances also, as they may be more sensitive to to much work per Char. +-- +data BWrite = BWrite {-# UNPACK #-} !Int (UPtr -> UPtr) + +newtype UWrite = UWrite { runUWrite :: UPtr -> UPtr } + +instance Monoid UWrite where + mempty = UWrite $ \x -> x + {-# INLINE mempty #-} + (UWrite uw1) `mappend` (UWrite uw2) = UWrite (\up -> uw2 (uw1 up)) + {-# INLINE mappend #-} + +instance Monoid BWrite where + mempty = BWrite 0 (\x -> x) + {-# INLINE mempty #-} + (BWrite b1 io1) `mappend` (BWrite b2 io2) = + BWrite (b1 + b2) (\op -> io2 (io1 op)) + {-# INLINE mappend #-} + +execWrite :: IO () -> UPtr -> UPtr +execWrite io op' = S.inlinePerformIO io `seq` op' +{-# INLINE execWrite #-} + +execWriteSize :: (Ptr Word8 -> IO ()) -> Int -> UPtr -> UPtr +execWriteSize io size op = execWrite (io (uptrToPtr op)) (op `plusUPtr` size) +{-# INLINE execWriteSize #-} + +staticBWrite :: Int -> (Ptr Word8 -> IO ()) -> BWrite +staticBWrite size io = BWrite size (execWriteSize io size) +{-# INLINE staticBWrite #-} + +bwriteWord8 :: Word8 -> BWrite +bwriteWord8 x = staticBWrite 1 (`poke` x) +{-# INLINE bwriteWord8 #-} + +fromBWrite :: BWrite -> Builder +fromBWrite (BWrite size io) = + Builder step + where + step k !pf !pe + | pf `plusPtr` size <= pe = do + let !pf' = io (ptrToUPtr pf) + k (uptrToPtr pf') pe + | otherwise = return $ BufferFull size pf (step k) +{-# INLINE fromBWrite #-} + +fromBWriteSingleton :: (a -> BWrite) -> a -> Builder +fromBWriteSingleton write = + mkPut + where + mkPut x = Builder step + where + step k !pf !pe + | pf `plusPtr` size <= pe = do + let !pf' = io (ptrToUPtr pf) + k (uptrToPtr pf') pe + | otherwise = return $ BufferFull size pf (step k) + where + BWrite size io = write x +{-# INLINE fromBWriteSingleton #-} + +bfromWord8 :: Word8 -> Builder +bfromWord8 = fromBWriteSingleton bwriteWord8 + +-- Utf-8 encoding +----------------- + +bwriteChar :: Char -> BWrite +bwriteChar c = BWrite 4 (encodeCharUtf8 f1 f2 f3 f4 c) + where + f1 x = \uptr -> execWrite (do let !ptr = uptrToPtr uptr + poke ptr x ) + (uptr `plusUPtr` 1) + + f2 x1 x2 = \uptr -> execWrite (do let !ptr = uptrToPtr uptr + poke ptr x1 + poke (ptr `plusPtr` 1) x2 ) + (uptr `plusUPtr` 2) + + f3 x1 x2 x3 = \uptr -> execWrite (do let !ptr = uptrToPtr uptr + poke ptr x1 + poke (ptr `plusPtr` 1) x2 + poke (ptr `plusPtr` 2) x3 ) + (uptr `plusUPtr` 3) + + f4 x1 x2 x3 x4 = \uptr -> execWrite (do let !ptr = uptrToPtr uptr + poke ptr x1 + poke (ptr `plusPtr` 1) x2 + poke (ptr `plusPtr` 2) x3 + poke (ptr `plusPtr` 3) x4 ) + (uptr `plusUPtr` 4) +{-# INLINE bwriteChar #-} + +writeChar :: Char -> Write +writeChar = encodeCharUtf8 f1 f2 f3 f4 + where + f1 x = Write 1 $ \ptr -> poke ptr x + + f2 x1 x2 = Write 2 $ \ptr -> do poke ptr x1 + poke (ptr `plusPtr` 1) x2 + + f3 x1 x2 x3 = Write 3 $ \ptr -> do poke ptr x1 + poke (ptr `plusPtr` 1) x2 + poke (ptr `plusPtr` 2) x3 + + f4 x1 x2 x3 x4 = Write 4 $ \ptr -> do poke ptr x1 + poke (ptr `plusPtr` 1) x2 + poke (ptr `plusPtr` 2) x3 + poke (ptr `plusPtr` 3) x4 +{-# INLINE writeChar #-} + +-- | Encode a Unicode character to another datatype, using UTF-8. This function +-- acts as an abstract way of encoding characters, as it is unaware of what +-- needs to happen with the resulting bytes: you have to specify functions to +-- deal with those. +-- +encodeCharUtf8 :: (Word8 -> a) -- ^ 1-byte UTF-8 + -> (Word8 -> Word8 -> a) -- ^ 2-byte UTF-8 + -> (Word8 -> Word8 -> Word8 -> a) -- ^ 3-byte UTF-8 + -> (Word8 -> Word8 -> Word8 -> Word8 -> a) -- ^ 4-byte UTF-8 + -> Char -- ^ Input 'Char' + -> a -- ^ Result +encodeCharUtf8 f1 f2 f3 f4 c = case ord c of + x | x <= 0x7F -> f1 $ fromIntegral x + | x <= 0x07FF -> + let x1 = fromIntegral $ (x `shiftR` 6) + 0xC0 + x2 = fromIntegral $ (x .&. 0x3F) + 0x80 + in f2 x1 x2 + | x <= 0xFFFF -> + let x1 = fromIntegral $ (x `shiftR` 12) + 0xE0 + x2 = fromIntegral $ ((x `shiftR` 6) .&. 0x3F) + 0x80 + x3 = fromIntegral $ (x .&. 0x3F) + 0x80 + in f3 x1 x2 x3 + | otherwise -> + let x1 = fromIntegral $ (x `shiftR` 18) + 0xF0 + x2 = fromIntegral $ ((x `shiftR` 12) .&. 0x3F) + 0x80 + x3 = fromIntegral $ ((x `shiftR` 6) .&. 0x3F) + 0x80 + x4 = fromIntegral $ (x .&. 0x3F) + 0x80 + in f4 x1 x2 x3 x4 +{-# INLINE encodeCharUtf8 #-} + diff --git a/benchmarks/BuilderBufferRange.hs b/benchmarks/BuilderBufferRange.hs new file mode 100644 --- /dev/null +++ b/benchmarks/BuilderBufferRange.hs @@ -0,0 +1,463 @@ +{-# LANGUAGE CPP, BangPatterns #-} +-- | +-- Module : BuilderBufferRange +-- Copyright : (c) 2010 Simon Meier +-- License : BSD3-style (see LICENSE) +-- +-- Maintainer : Simon Meier +-- Stability : experimental +-- Portability : tested on GHC only +-- +-- Benchmark the benefit of using a packed representation for the buffer range. +-- +module BuilderBufferRange where + + +import Foreign +import Data.Monoid +import Control.Monad (unless) +import qualified Data.ByteString as S +import qualified Data.ByteString.Lazy as L + +#ifdef BYTESTRING_IN_BASE +import Data.ByteString.Base (inlinePerformIO) +import qualified Data.ByteString.Base as S +import qualified Data.ByteString.Lazy.Base as L -- FIXME: is this the right module for access to 'Chunks'? +#else +import Data.ByteString.Internal (inlinePerformIO) +import qualified Data.ByteString.Internal as S +import qualified Data.ByteString.Lazy.Internal as L +#endif + +import qualified Blaze.ByteString.Builder.Internal as B +import Blaze.ByteString.Builder.Write +import Blaze.ByteString.Builder.Word + +import Criterion.Main + +------------------------------------------------------------------------------ +-- Benchmarks +------------------------------------------------------------------------------ + +main :: IO () +main = defaultMain $ concat + [ benchmark "putBuilder" + (putBuilder . mconcat . map fromWord8) + (mconcat . map fromWord8) + word8s + , benchmark "fromWriteSingleton" + (mconcat . map putWord8) + (mconcat . map fromWord8) + word8s + , benchmark "fromWrite" + (mconcat . map (putWrite . writeWord8)) + (mconcat . map (fromWrite . writeWord8)) + word8s + ] + where + benchmark name putF builderF x = + [ bench (name ++ " Put") $ + whnf (L.length . toLazyByteString . putF) x + , bench (name ++ " Builder") $ + whnf (L.length . B.toLazyByteString . builderF) x + ] + +word8s :: [Word8] +word8s = take 100000 $ cycle [0..] +{-# NOINLINE word8s #-} + + +------------------------------------------------------------------------------ +-- The Builder type +------------------------------------------------------------------------------ + +data BufferRange = BR {-# UNPACK #-} !(Ptr Word8) + {-# UNPACK #-} !(Ptr Word8) + +newtype Put = Put (PutStep -> PutStep) + +data PutSignal = + Done {-# UNPACK #-} !(Ptr Word8) + | BufferFull + {-# UNPACK #-} !Int + {-# UNPACK #-} !(Ptr Word8) + !PutStep + | ModifyChunks + {-# UNPACK #-} !(Ptr Word8) + !(L.ByteString -> L.ByteString) + !PutStep + +type PutStep = BufferRange -> IO PutSignal + +instance Monoid Put where + mempty = Put id + {-# INLINE mempty #-} + (Put p1) `mappend` (Put p2) = Put $ p1 . p2 + {-# INLINE mappend #-} + mconcat = foldr mappend mempty + {-# INLINE mconcat #-} + +putWrite :: Write -> Put +putWrite (Write size io) = + Put step + where + step k (BR pf pe) + | pf `plusPtr` size <= pe = do + io pf + let !br' = BR (pf `plusPtr` size) pe + k br' + | otherwise = return $ BufferFull size pf (step k) +{-# INLINE putWrite #-} + +putWriteSingleton :: (a -> Write) -> a -> Put +putWriteSingleton write = + mkPut + where + mkPut x = Put step + where + step k (BR pf pe) + | pf `plusPtr` size <= pe = do + io pf + let !br' = BR (pf `plusPtr` size) pe + k br' + | otherwise = return $ BufferFull size pf (step k) + where + Write size io = write x +{-# INLINE putWriteSingleton #-} + +putBuilder :: B.Builder -> Put +putBuilder (B.Builder b) = + Put step + where + finalStep _ pf = return $ B.Done pf + + step k = go (b finalStep) + where + go buildStep (BR pf pe) = do + signal <- buildStep pf pe + case signal of + B.Done pf' -> do + let !br' = BR pf' pe + k br' + B.BufferFull minSize pf' nextBuildStep -> + return $ BufferFull minSize pf' (go nextBuildStep) + B.ModifyChunks _ _ _ -> + error "putBuilder: ModifyChunks not implemented" + +putWord8 :: Word8 -> Put +putWord8 = putWriteSingleton writeWord8 + +{- + m >>= f = GetC $ \done empty pe -> + runGetC m (\pr' x -> runGetC (f x) done empty pe pr') + (\m' -> empty (m' >>= f)) + pe + + +newtype GetC r a = GetC { + runGetC :: + (Ptr Word8 -> a -> IO r) -> -- done + (GetC r a -> IO r ) -> -- empty buffer + Ptr Word8 -> -- end of buffer + Ptr Word8 -> -- next byte to read + IO r + } + +instance Functor (GetC r) where + fmap f g = GetC $ \done empty -> + runGetC g (\pr' x -> done pr' (f x)) + (\g' -> empty (fmap f g')) + +instance Monad (GetC r) where + return x = GetC $ \done _ _ pr -> done pr x + m >>= f = GetC $ \done empty pe -> + runGetC m (\pr' x -> runGetC (f x) done empty pe pr') + (\m' -> empty (m' >>= f)) + pe + +-} + +------------------------------------------------------------------------------ +-- Internal global constants. +------------------------------------------------------------------------------ + +-- | Default size (~32kb) for the buffer that becomes a chunk of the output +-- stream once it is filled. +-- +defaultBufferSize :: Int +defaultBufferSize = 32 * 1024 - overhead -- Copied from Data.ByteString.Lazy. + where overhead = 2 * sizeOf (undefined :: Int) + +-- | The minimal length (~4kb) a buffer must have before filling it and +-- outputting it as a chunk of the output stream. +-- +-- This size determines when a buffer is spilled after a 'flush' or a direct +-- bytestring insertion. It is also the size of the first chunk generated by +-- 'toLazyByteString'. +defaultMinimalBufferSize :: Int +defaultMinimalBufferSize = 4 * 1024 - overhead + where overhead = 2 * sizeOf (undefined :: Int) + +-- | The default length (64) for the first buffer to be allocated when +-- converting a 'Builder' to a lazy bytestring. +-- +-- See 'toLazyByteStringWith' for further explanation. +defaultFirstBufferSize :: Int +defaultFirstBufferSize = 64 + +-- | The maximal number of bytes for that copying is cheaper than direct +-- insertion into the output stream. This takes into account the fragmentation +-- that may occur in the output buffer due to the early 'flush' implied by the +-- direct bytestring insertion. +-- +-- @'defaultMaximalCopySize' = 2 * 'defaultMinimalBufferSize'@ +-- +defaultMaximalCopySize :: Int +defaultMaximalCopySize = 2 * defaultMinimalBufferSize + +------------------------------------------------------------------------------ +-- Flushing and running a Builder +------------------------------------------------------------------------------ + + +-- | Output all data written in the current buffer and start a new chunk. +-- +-- The use uf this function depends on how the resulting bytestrings are +-- consumed. 'flush' is possibly not very useful in non-interactive scenarios. +-- However, it is kept for compatibility with the builder provided by +-- Data.Binary.Builder. +-- +-- When using 'toLazyByteString' to extract a lazy 'L.ByteString' from a +-- 'Builder', this means that a new chunk will be started in the resulting lazy +-- 'L.ByteString'. The remaining part of the buffer is spilled, if the +-- reamining free space is smaller than the minimal desired buffer size. +-- +{- +flush :: Builder +flush = Builder $ \k pf _ -> return $ ModifyChunks pf id k +-} + +-- | Run a 'Builder' with the given buffer sizes. +-- +-- Use this function for integrating the 'Builder' type with other libraries +-- that generate lazy bytestrings. +-- +-- Note that the builders should guarantee that on average the desired chunk +-- size is attained. Builders may decide to start a new buffer and not +-- completely fill the existing buffer, if this is faster. However, they should +-- not spill too much of the buffer, if they cannot compensate for it. +-- +-- A call @toLazyByteStringWith bufSize minBufSize firstBufSize@ will generate +-- a lazy bytestring according to the following strategy. First, we allocate +-- a buffer of size @firstBufSize@ and start filling it. If it overflows, we +-- allocate a buffer of size @minBufSize@ and copy the first buffer to it in +-- order to avoid generating a too small chunk. Finally, every next buffer will +-- be of size @bufSize@. This, slow startup strategy is required to achieve +-- good speed for short (<200 bytes) resulting bytestrings, as for them the +-- allocation cost is of a large buffer cannot be compensated. Moreover, this +-- strategy also allows us to avoid spilling too much memory for short +-- resulting bytestrings. +-- +-- Note that setting @firstBufSize >= minBufSize@ implies that the first buffer +-- is no longer copied but allocated and filled directly. Hence, setting +-- @firstBufSize = bufSize@ means that all chunks will use an underlying buffer +-- of size @bufSize@. This is recommended, if you know that you always output +-- more than @minBufSize@ bytes. +toLazyByteStringWith + :: Int -- ^ Buffer size (upper-bounds the resulting chunk size). + -> Int -- ^ Minimal free buffer space for continuing filling + -- the same buffer after a 'flush' or a direct bytestring + -- insertion. This corresponds to the minimal desired + -- chunk size. + -> Int -- ^ Size of the first buffer to be used and copied for + -- larger resulting sequences + -> Put -- ^ Builder to run. + -> L.ByteString -- ^ Lazy bytestring to output after the builder is + -- finished. + -> L.ByteString -- ^ Resulting lazy bytestring +toLazyByteStringWith bufSize minBufSize firstBufSize (Put b) k = + inlinePerformIO $ fillFirstBuffer (b finalStep) + where + finalStep (BR pf _) = return $ Done pf + -- fill a first very small buffer, if we need more space then copy it + -- to the new buffer of size 'minBufSize'. This way we don't pay the + -- allocation cost of the big 'bufSize' buffer, when outputting only + -- small sequences. + fillFirstBuffer !step0 + | minBufSize <= firstBufSize = fillNewBuffer firstBufSize step0 + | otherwise = do + fpbuf <- S.mallocByteString firstBufSize + withForeignPtr fpbuf $ \pf -> do + let !br = BR pf (pf `plusPtr` firstBufSize) + mkbs pf' = S.PS fpbuf 0 (pf' `minusPtr` pf) + {-# INLINE mkbs #-} + next <- step0 br + case next of + Done pf' + | pf' == pf -> return k + | otherwise -> return $ L.Chunk (mkbs pf') k + + BufferFull newSize pf' nextStep -> do + let !l = pf' `minusPtr` pf + fillNewBuffer (max (l + newSize) minBufSize) $ + \(BR pfNew peNew) -> do + copyBytes pfNew pf l + let !brNew = BR (pfNew `plusPtr` l) peNew + nextStep brNew + + ModifyChunks pf' bsk nextStep + | pf' == pf -> + return $ bsk (inlinePerformIO $ fillNewBuffer bufSize nextStep) + | otherwise -> + return $ L.Chunk (mkbs pf') + (bsk (inlinePerformIO $ fillNewBuffer bufSize nextStep)) + + -- allocate and fill a new buffer + fillNewBuffer !size !step0 = do + fpbuf <- S.mallocByteString size + withForeignPtr fpbuf $ fillBuffer fpbuf + where + fillBuffer fpbuf !pbuf = fill pbuf step0 + where + !pe = pbuf `plusPtr` size + fill !pf !step = do + let !br = BR pf pe + next <- step br + let mkbs pf' = S.PS fpbuf (pf `minusPtr` pbuf) (pf' `minusPtr` pf) + {-# INLINE mkbs #-} + case next of + Done pf' + | pf' == pf -> return k + | otherwise -> return $ L.Chunk (mkbs pf') k + + BufferFull newSize pf' nextStep -> + return $ L.Chunk (mkbs pf') + (inlinePerformIO $ + fillNewBuffer (max newSize bufSize) nextStep) + + ModifyChunks pf' bsk nextStep + | pf' == pf -> + return $ bsk (inlinePerformIO $ fill pf' nextStep) + | minBufSize < pe `minusPtr` pf' -> + return $ L.Chunk (mkbs pf') + (bsk (inlinePerformIO $ fill pf' nextStep)) + | otherwise -> + return $ L.Chunk (mkbs pf') + (bsk (inlinePerformIO $ fillNewBuffer bufSize nextStep)) + + +-- | Extract the lazy 'L.ByteString' from the builder by running it with default +-- buffer sizes. Use this function, if you do not have any special +-- considerations with respect to buffer sizes. +-- +-- @ 'toLazyByteString' b = 'toLazyByteStringWith' 'defaultBufferSize' 'defaultMinimalBufferSize' 'defaultFirstBufferSize' b L.empty@ +-- +-- Note that @'toLazyByteString'@ is a 'Monoid' homomorphism. +-- +-- > toLazyByteString mempty == mempty +-- > toLazyByteString (x `mappend` y) == toLazyByteString x `mappend` toLazyByteString y +-- +-- However, in the second equation, the left-hand-side is generally faster to +-- execute. +-- +toLazyByteString :: Put -> L.ByteString +toLazyByteString b = toLazyByteStringWith + defaultBufferSize defaultMinimalBufferSize defaultFirstBufferSize b L.empty +{-# INLINE toLazyByteString #-} + +{- +-- | Pack the chunks of a lazy bytestring into a single strict bytestring. +packChunks :: L.ByteString -> S.ByteString +packChunks lbs = do + S.unsafeCreate (fromIntegral $ L.length lbs) (copyChunks lbs) + where + copyChunks !L.Empty !_pf = return () + copyChunks !(L.Chunk (S.PS fpbuf o l) lbs') !pf = do + withForeignPtr fpbuf $ \pbuf -> + copyBytes pf (pbuf `plusPtr` o) l + copyChunks lbs' (pf `plusPtr` l) + +-- | Run the builder to construct a strict bytestring containing the sequence +-- of bytes denoted by the builder. This is done by first serializing to a lazy bytestring and then packing its +-- chunks to a appropriately sized strict bytestring. +-- +-- > toByteString = packChunks . toLazyByteString +-- +-- Note that @'toByteString'@ is a 'Monoid' homomorphism. +-- +-- > toByteString mempty == mempty +-- > toByteString (x `mappend` y) == toByteString x `mappend` toByteString y +-- +-- However, in the second equation, the left-hand-side is generally faster to +-- execute. +-- +toByteString :: Builder -> S.ByteString +toByteString = packChunks . toLazyByteString + + +-- | @toByteStringIOWith bufSize io b@ runs the builder @b@ with a buffer of +-- at least the size @bufSize@ and executes the 'IO' action @io@ whenever the +-- buffer is full. +-- +-- Compared to 'toLazyByteStringWith' this function requires less allocation, +-- as the output buffer is only allocated once at the start of the +-- serialization and whenever something bigger than the current buffer size has +-- to be copied into the buffer, which should happen very seldomly for the +-- default buffer size of 32kb. Hence, the pressure on the garbage collector is +-- reduced, which can be an advantage when building long sequences of bytes. +-- +toByteStringIOWith :: Int -- ^ Buffer size (upper bounds + -- the number of bytes forced + -- per call to the 'IO' action). + -> (S.ByteString -> IO ()) -- ^ 'IO' action to execute per + -- full buffer, which is + -- referenced by a strict + -- 'S.ByteString'. + -> Builder -- ^ 'Builder' to run. + -> IO () -- ^ Resulting 'IO' action. +toByteStringIOWith bufSize io (Builder b) = + fillNewBuffer bufSize (b finalStep) + where + finalStep pf _ = return $ Done pf + + fillNewBuffer !size !step0 = do + S.mallocByteString size >>= fillBuffer + where + fillBuffer fpbuf = fill step0 + where + -- safe because the constructed ByteString references the foreign + -- pointer AFTER its buffer was filled. + pf = unsafeForeignPtrToPtr fpbuf + fill !step = do + next <- step pf (pf `plusPtr` size) + case next of + Done pf' -> + unless (pf' == pf) (io $ S.PS fpbuf 0 (pf' `minusPtr` pf)) + + BufferFull newSize pf' nextStep -> do + io $ S.PS fpbuf 0 (pf' `minusPtr` pf) + if bufSize < newSize + then fillNewBuffer newSize nextStep + else fill nextStep + + ModifyChunks pf' bsk nextStep -> do + unless (pf' == pf) (io $ S.PS fpbuf 0 (pf' `minusPtr` pf)) + -- was: mapM_ io $ L.toChunks (bsk L.empty) + L.foldrChunks (\bs -> (io bs >>)) (return ()) (bsk L.empty) + fill nextStep + +-- | Run the builder with a 'defaultBufferSize'd buffer and execute the given +-- 'IO' action whenever the buffer is full or gets flushed. +-- +-- @ 'toByteStringIO' = 'toByteStringIOWith' 'defaultBufferSize'@ +-- +-- This is a 'Monoid' homomorphism in the following sense. +-- +-- > toByteStringIO io mempty == return () +-- > toByteStringIO io (x `mappend` y) == toByteStringIO io x >> toByteStringIO io y +-- +toByteStringIO :: (S.ByteString -> IO ()) -> Builder -> IO () +toByteStringIO = toByteStringIOWith defaultBufferSize +{-# INLINE toByteStringIO #-} + +-} diff --git a/benchmarks/FastPut.hs b/benchmarks/FastPut.hs new file mode 100644 --- /dev/null +++ b/benchmarks/FastPut.hs @@ -0,0 +1,643 @@ +{-# LANGUAGE CPP, BangPatterns, Rank2Types #-} +-- | +-- Module : FastPut +-- Copyright : (c) 2010 Simon Meier +-- License : BSD3-style (see LICENSE) +-- +-- Maintainer : Simon Meier +-- Stability : experimental +-- Portability : tested on GHC only +-- +-- Implementation of a 'Put' monad with similar performance characteristics +-- like the 'Builder' monoid. +-- +module FastPut where + +import Foreign +import Data.Monoid +import Control.Monad (unless) +import qualified Data.ByteString as S +import qualified Data.ByteString.Lazy as L + +#ifdef BYTESTRING_IN_BASE +import Data.ByteString.Base (inlinePerformIO) +import qualified Data.ByteString.Base as S +import qualified Data.ByteString.Lazy.Base as L -- FIXME: is this the right module for access to 'Chunks'? +#else +import Data.ByteString.Internal (inlinePerformIO) +import qualified Data.ByteString.Internal as S +import qualified Data.ByteString.Lazy.Internal as L +#endif + +import qualified Blaze.ByteString.Builder.Internal as B +import qualified Blaze.ByteString.Builder.Write as B +import Blaze.ByteString.Builder.Write (Write(..)) +import qualified Blaze.ByteString.Builder.Word as B +import Blaze.ByteString.Builder.Word (writeWord8) + +import Criterion.Main + +------------------------------------------------------------------------------ +-- Benchmarks +------------------------------------------------------------------------------ + +main :: IO () +main = defaultMain $ concat + [ return $ bench "cost of putBuilder" $ whnf + (L.length . toLazyByteString2 . mapM_ (fromBuilder . fromWord8)) + word8s + , benchmark "putBuilder" + (fromBuilder . mconcat . map fromWord8) + (mconcat . map B.fromWord8) + word8s + , benchmark "fromWriteSingleton" + (mapM_ putWord8) + (mconcat . map B.fromWord8) + word8s + , benchmark "fromWrite" + (mapM_ (putWrite . writeWord8)) + (mconcat . map (B.fromWrite . writeWord8)) + word8s + ] + where + benchmark name putF builderF x = + [ bench (name ++ " Put") $ + whnf (L.length . toLazyByteString2 . putF) x + , bench (name ++ " Builder") $ + whnf (L.length . B.toLazyByteString . builderF) x + ] + +word8s :: [Word8] +word8s = take 100000 $ cycle [0..] +{-# NOINLINE word8s #-} + +------------------------------------------------------------------------------ +-- The Put type +------------------------------------------------------------------------------ + +data BufRange = BufRange {-# UNPACK #-} !(Ptr Word8) {-# UNPACK #-} !(Ptr Word8) + +newtype Put a = Put { + unPut :: forall r. (a -> PutStep r) -> PutStep r + } + +data PutSignal a = + Done {-# UNPACK #-} !(Ptr Word8) a + | BufferFull + {-# UNPACK #-} !Int + {-# UNPACK #-} !(Ptr Word8) + !(PutStep a) + | InsertByteString + {-# UNPACK #-} !(Ptr Word8) + !S.ByteString + !(PutStep a) + +type PutStep a = BufRange -> IO (PutSignal a) + +instance Monad Put where + return x = Put $ \k -> k x + {-# INLINE return #-} + m >>= f = Put $ \k -> unPut m (\x -> unPut (f x) k) + {-# INLINE (>>=) #-} + m >> n = Put $ \k -> unPut m (\_ -> unPut n k) + {-# INLINE (>>) #-} + +------------------------------------------------------------------------------ +-- The Builder type with equal signals as the Put type +------------------------------------------------------------------------------ + +newtype Builder = Builder (forall r. PutStep r -> PutStep r) + +instance Monoid Builder where + mempty = Builder id + {-# INLINE mempty #-} + (Builder b1) `mappend` (Builder b2) = Builder $ b1 . b2 + {-# INLINE mappend #-} + mconcat = foldr mappend mempty + {-# INLINE mconcat #-} + +fromBuilder :: Builder -> Put () +fromBuilder (Builder build) = Put $ \k -> build (k ()) + +toBuilder :: Put () -> Builder +toBuilder (Put put) = Builder $ \k -> put (\_ -> k) + +fromWrite :: Write -> Builder +fromWrite (Write size io) = + Builder step + where + step k (BufRange pf pe) + | pf `plusPtr` size <= pe = do + io pf + let !br' = BufRange (pf `plusPtr` size) pe + k br' + | otherwise = return $ BufferFull size pf (step k) +{-# INLINE fromWrite #-} + +fromWriteSingleton :: (a -> Write) -> a -> Builder +fromWriteSingleton write = + mkPut + where + mkPut x = Builder step + where + step k (BufRange pf pe) + | pf `plusPtr` size <= pe = do + io pf + let !br' = BufRange (pf `plusPtr` size) pe + k br' + | otherwise = return $ BufferFull size pf (step k) + where + Write size io = write x +{-# INLINE fromWriteSingleton #-} + +fromWord8 :: Word8 -> Builder +fromWord8 = fromWriteSingleton writeWord8 + + +------------------------------------------------------------------------------ +-- Implementations +------------------------------------------------------------------------------ + +putWord8 :: Word8 -> Put () +putWord8 = putWriteSingleton writeWord8 + +putWrite :: Write -> Put () +putWrite (Write size io) = + Put step + where + step k (BufRange pf pe) + | pf `plusPtr` size <= pe = do + io pf + let !br' = BufRange (pf `plusPtr` size) pe + k () br' + | otherwise = return $ BufferFull size pf (step k) +{-# INLINE putWrite #-} + +putWriteSingleton :: (a -> Write) -> a -> Put () +putWriteSingleton write = + mkPut + where + mkPut x = Put step + where + step k (BufRange pf pe) + | pf `plusPtr` size <= pe = do + io pf + let !br' = BufRange (pf `plusPtr` size) pe + k () br' + | otherwise = return $ BufferFull size pf (step k) + where + Write size io = write x +{-# INLINE putWriteSingleton #-} + +putBuilder :: B.Builder -> Put () +putBuilder (B.Builder b) = + Put step + where + finalStep _ pf = return $ B.Done pf + + step k = go (b finalStep) + where + go buildStep (BufRange pf pe) = do + signal <- buildStep pf pe + case signal of + B.Done pf' -> do + let !br' = BufRange pf' pe + k () br' + B.BufferFull minSize pf' nextBuildStep -> + return $ BufferFull minSize pf' (go nextBuildStep) + B.ModifyChunks _ _ _ -> + error "putBuilder: ModifyChunks not implemented" + +{- + m >>= f = GetC $ \done empty pe -> + runGetC m (\pr' x -> runGetC (f x) done empty pe pr') + (\m' -> empty (m' >>= f)) + pe + + +newtype GetC r a = GetC { + runGetC :: + (Ptr Word8 -> a -> IO r) -> -- done + (GetC r a -> IO r ) -> -- empty buffer + Ptr Word8 -> -- end of buffer + Ptr Word8 -> -- next byte to read + IO r + } + +instance Functor (GetC r) where + fmap f g = GetC $ \done empty -> + runGetC g (\pr' x -> done pr' (f x)) + (\g' -> empty (fmap f g')) + +instance Monad (GetC r) where + return x = GetC $ \done _ _ pr -> done pr x + m >>= f = GetC $ \done empty pe -> + runGetC m (\pr' x -> runGetC (f x) done empty pe pr') + (\m' -> empty (m' >>= f)) + pe + +-} + +------------------------------------------------------------------------------ +-- Internal global constants. +------------------------------------------------------------------------------ + +-- | Default size (~32kb) for the buffer that becomes a chunk of the output +-- stream once it is filled. +-- +defaultBufferSize :: Int +defaultBufferSize = 32 * 1024 - overhead -- Copied from Data.ByteString.Lazy. + where overhead = 2 * sizeOf (undefined :: Int) + +-- | The minimal length (~4kb) a buffer must have before filling it and +-- outputting it as a chunk of the output stream. +-- +-- This size determines when a buffer is spilled after a 'flush' or a direct +-- bytestring insertion. It is also the size of the first chunk generated by +-- 'toLazyByteString'. +defaultMinimalBufferSize :: Int +defaultMinimalBufferSize = 4 * 1024 - overhead + where overhead = 2 * sizeOf (undefined :: Int) + +-- | The default length (64) for the first buffer to be allocated when +-- converting a 'Builder' to a lazy bytestring. +-- +-- See 'toLazyByteStringWith' for further explanation. +defaultFirstBufferSize :: Int +defaultFirstBufferSize = 64 + +-- | The maximal number of bytes for that copying is cheaper than direct +-- insertion into the output stream. This takes into account the fragmentation +-- that may occur in the output buffer due to the early 'flush' implied by the +-- direct bytestring insertion. +-- +-- @'defaultMaximalCopySize' = 2 * 'defaultMinimalBufferSize'@ +-- +defaultMaximalCopySize :: Int +defaultMaximalCopySize = 2 * defaultMinimalBufferSize + +------------------------------------------------------------------------------ +-- Flushing and running a Builder +------------------------------------------------------------------------------ + + +-- | Output all data written in the current buffer and start a new chunk. +-- +-- The use uf this function depends on how the resulting bytestrings are +-- consumed. 'flush' is possibly not very useful in non-interactive scenarios. +-- However, it is kept for compatibility with the builder provided by +-- Data.Binary.Builder. +-- +-- When using 'toLazyByteString' to extract a lazy 'L.ByteString' from a +-- 'Builder', this means that a new chunk will be started in the resulting lazy +-- 'L.ByteString'. The remaining part of the buffer is spilled, if the +-- reamining free space is smaller than the minimal desired buffer size. +-- +{- +flush :: Builder +flush = Builder $ \k pf _ -> return $ ModifyChunks pf id k +-} + +-- | Run a 'Builder' with the given buffer sizes. +-- +-- Use this function for integrating the 'Builder' type with other libraries +-- that generate lazy bytestrings. +-- +-- Note that the builders should guarantee that on average the desired chunk +-- size is attained. Builders may decide to start a new buffer and not +-- completely fill the existing buffer, if this is faster. However, they should +-- not spill too much of the buffer, if they cannot compensate for it. +-- +-- A call @toLazyByteStringWith bufSize minBufSize firstBufSize@ will generate +-- a lazy bytestring according to the following strategy. First, we allocate +-- a buffer of size @firstBufSize@ and start filling it. If it overflows, we +-- allocate a buffer of size @minBufSize@ and copy the first buffer to it in +-- order to avoid generating a too small chunk. Finally, every next buffer will +-- be of size @bufSize@. This, slow startup strategy is required to achieve +-- good speed for short (<200 bytes) resulting bytestrings, as for them the +-- allocation cost is of a large buffer cannot be compensated. Moreover, this +-- strategy also allows us to avoid spilling too much memory for short +-- resulting bytestrings. +-- +-- Note that setting @firstBufSize >= minBufSize@ implies that the first buffer +-- is no longer copied but allocated and filled directly. Hence, setting +-- @firstBufSize = bufSize@ means that all chunks will use an underlying buffer +-- of size @bufSize@. This is recommended, if you know that you always output +-- more than @minBufSize@ bytes. +toLazyByteStringWith + :: Int -- ^ Buffer size (upper-bounds the resulting chunk size). + -> Int -- ^ Minimal free buffer space for continuing filling + -- the same buffer after a 'flush' or a direct bytestring + -- insertion. This corresponds to the minimal desired + -- chunk size. + -> Int -- ^ Size of the first buffer to be used and copied for + -- larger resulting sequences + -> Put a -- ^ Builder to run. + -> L.ByteString -- ^ Lazy bytestring to output after the builder is + -- finished. + -> L.ByteString -- ^ Resulting lazy bytestring +toLazyByteStringWith bufSize minBufSize firstBufSize (Put b) k = + inlinePerformIO $ fillFirstBuffer (b finalStep) + where + finalStep _ (BufRange pf _) = return $ Done pf undefined + -- fill a first very small buffer, if we need more space then copy it + -- to the new buffer of size 'minBufSize'. This way we don't pay the + -- allocation cost of the big 'bufSize' buffer, when outputting only + -- small sequences. + fillFirstBuffer !step0 + | minBufSize <= firstBufSize = fillNewBuffer firstBufSize step0 + | otherwise = do + fpbuf <- S.mallocByteString firstBufSize + withForeignPtr fpbuf $ \pf -> do + let !br = BufRange pf (pf `plusPtr` firstBufSize) + mkbs pf' = S.PS fpbuf 0 (pf' `minusPtr` pf) + {-# INLINE mkbs #-} + next <- step0 br + case next of + Done pf' _ + | pf' == pf -> return k + | otherwise -> return $ L.Chunk (mkbs pf') k + + BufferFull newSize pf' nextStep -> do + let !l = pf' `minusPtr` pf + fillNewBuffer (max (l + newSize) minBufSize) $ + \(BufRange pfNew peNew) -> do + copyBytes pfNew pf l + let !brNew = BufRange (pfNew `plusPtr` l) peNew + nextStep brNew + + InsertByteString _ _ _ -> error "not yet implemented" + {- + ModifyChunks pf' bsk nextStep( + | pf' == pf -> + return $ bsk (inlinePerformIO $ fillNewBuffer bufSize nextStep) + | otherwise -> + return $ L.Chunk (mkbs pf') + (bsk (inlinePerformIO $ fillNewBuffer bufSize nextStep)) + -} + + -- allocate and fill a new buffer + fillNewBuffer !size !step0 = do + fpbuf <- S.mallocByteString size + withForeignPtr fpbuf $ fillBuffer fpbuf + where + fillBuffer fpbuf !pbuf = fill pbuf step0 + where + !pe = pbuf `plusPtr` size + fill !pf !step = do + let !br = BufRange pf pe + next <- step br + let mkbs pf' = S.PS fpbuf (pf `minusPtr` pbuf) (pf' `minusPtr` pf) + {-# INLINE mkbs #-} + case next of + Done pf' _ + | pf' == pf -> return k + | otherwise -> return $ L.Chunk (mkbs pf') k + + BufferFull newSize pf' nextStep -> + return $ L.Chunk (mkbs pf') + (inlinePerformIO $ + fillNewBuffer (max newSize bufSize) nextStep) + + InsertByteString _ _ _ -> error "not yet implemented2" + {- + ModifyChunks pf' bsk nextStep + | pf' == pf -> + return $ bsk (inlinePerformIO $ fill pf' nextStep) + | minBufSize < pe `minusPtr` pf' -> + return $ L.Chunk (mkbs pf') + (bsk (inlinePerformIO $ fill pf' nextStep)) + | otherwise -> + return $ L.Chunk (mkbs pf') + (bsk (inlinePerformIO $ fillNewBuffer bufSize nextStep)) + -} + + +-- | Extract the lazy 'L.ByteString' from the builder by running it with default +-- buffer sizes. Use this function, if you do not have any special +-- considerations with respect to buffer sizes. +-- +-- @ 'toLazyByteString' b = 'toLazyByteStringWith' 'defaultBufferSize' 'defaultMinimalBufferSize' 'defaultFirstBufferSize' b L.empty@ +-- +-- Note that @'toLazyByteString'@ is a 'Monoid' homomorphism. +-- +-- > toLazyByteString mempty == mempty +-- > toLazyByteString (x `mappend` y) == toLazyByteString x `mappend` toLazyByteString y +-- +-- However, in the second equation, the left-hand-side is generally faster to +-- execute. +-- +toLazyByteString :: Put a -> L.ByteString +toLazyByteString b = toLazyByteStringWith + defaultBufferSize defaultMinimalBufferSize defaultFirstBufferSize b L.empty +{-# INLINE toLazyByteString #-} + +------------------------------------------------------------------------------ +-- Builder Enumeration +------------------------------------------------------------------------------ + +data BuildStream a = + BuildChunk S.ByteString (IO (BuildStream a)) + | BuildYield + a + (forall b. Bool -> + Either (Maybe S.ByteString) (Put b -> IO (BuildStream b))) + +enumPut :: Int -> Put a -> IO (BuildStream a) +enumPut bufSize (Put put0) = + fillBuffer bufSize (put0 finalStep) + where + finalStep :: forall b. b -> PutStep b + finalStep x (BufRange op _) = return $ Done op x + + fillBuffer :: forall b. Int -> PutStep b -> IO (BuildStream b) + fillBuffer size step = do + fpbuf <- S.mallocByteString bufSize + let !pbuf = unsafeForeignPtrToPtr fpbuf + -- safe due to later reference of fpbuf + -- BETTER than withForeignPtr, as we lose a tail call otherwise + !br = BufRange pbuf (pbuf `plusPtr` size) + fillStep fpbuf br step + + fillPut :: ForeignPtr Word8 -> BufRange -> + Bool -> Either (Maybe S.ByteString) (Put b -> IO (BuildStream b)) + fillPut !fpbuf !(BufRange op _) False + | pbuf == op = Left Nothing + | otherwise = Left $ Just $ + S.PS fpbuf 0 (op `minusPtr` pbuf) + where + pbuf = unsafeForeignPtrToPtr fpbuf + {-# INLINE pbuf #-} + fillPut !fpbuf !br True = + Right $ \(Put put) -> fillStep fpbuf br (put finalStep) + + fillStep :: forall b. ForeignPtr Word8 -> BufRange -> PutStep b -> IO (BuildStream b) + fillStep !fpbuf !br@(BufRange _ ope) step = do + let pbuf = unsafeForeignPtrToPtr fpbuf + {-# INLINE pbuf #-} + signal <- step br + case signal of + Done op' x -> do -- builder completed, buffer partially filled + let !br' = BufRange op' ope + return $ BuildYield x (fillPut fpbuf br') + + BufferFull minSize op' nextStep + | pbuf == op' -> do -- nothing written, larger buffer required + fillBuffer (max bufSize minSize) nextStep + | otherwise -> do -- some bytes written, new buffer required + return $ BuildChunk + (S.PS fpbuf 0 (op' `minusPtr` pbuf)) + (fillBuffer (max bufSize minSize) nextStep) + + InsertByteString op' bs nextStep + | S.null bs -> do -- empty bytestrings are ignored + let !br' = BufRange op' ope + fillStep fpbuf br' nextStep + | pbuf == op' -> do -- no bytes written: just insert bytestring + return $ BuildChunk bs (fillBuffer bufSize nextStep) + | otherwise -> do -- bytes written, insert buffer and bytestring + return $ BuildChunk (S.PS fpbuf 0 (op' `minusPtr` pbuf)) + (return $ BuildChunk bs (fillBuffer bufSize nextStep)) + + +toLazyByteString' :: Put () -> L.ByteString +toLazyByteString' put = + inlinePerformIO (consume `fmap` enumPut defaultBufferSize put) + where + consume :: BuildStream () -> L.ByteString + consume (BuildYield _ f) = + case f False of + Left Nothing -> L.Empty + Left (Just bs) -> L.Chunk bs L.Empty + Right _ -> error "toLazyByteString': enumPut violated postcondition" + consume (BuildChunk bs ioStream) = + L.Chunk bs $ inlinePerformIO (consume `fmap` ioStream) + + + +{- + BufferFull minSize pf' nextStep -> do + io $ S.PS fpbuf 0 (pf' `minusPtr` pf) + fillBuffer (max bufSize minSize) nextStep + + ModifyChunks pf' bsk nextStep -> do + io $ S.PS fpbuf 0 (pf' `minusPtr` pf) + L.foldrChunks (\bs -> (io bs >>)) (return ()) (bsk L.empty) + fillBuffer bufSize nextStep +-} + +------------------------------------------------------------------------------ +-- More explicit implementation of running builders +------------------------------------------------------------------------------ + + +data Buffer = Buffer {-# UNPACK #-} !(ForeignPtr Word8) -- underlying pinned array + {-# UNPACK #-} !(Ptr Word8) -- beginning of slice + {-# UNPACK #-} !(Ptr Word8) -- next free byte + {-# UNPACK #-} !(Ptr Word8) -- first byte after buffer + +allocBuffer :: Int -> IO Buffer +allocBuffer size = do + fpbuf <- S.mallocByteString size + let !pbuf = unsafeForeignPtrToPtr fpbuf + return $! Buffer fpbuf pbuf pbuf (pbuf `plusPtr` size) + +unsafeFreezeBuffer :: Buffer -> S.ByteString +unsafeFreezeBuffer (Buffer fpbuf p0 op _) = + S.PS fpbuf 0 (op `minusPtr` p0) + +unsafeFreezeNonEmptyBuffer :: Buffer -> Maybe S.ByteString +unsafeFreezeNonEmptyBuffer (Buffer fpbuf p0 op _) + | p0 == op = Nothing + | otherwise = Just $ S.PS fpbuf 0 (op `minusPtr` p0) + +nextSlice :: Int -> Buffer -> Maybe Buffer +nextSlice minSize (Buffer fpbuf _ op ope) + | ope `minusPtr` op <= minSize = Nothing + | otherwise = Just (Buffer fpbuf op op ope) + +runPut :: Monad m + => (IO (PutSignal a) -> m (PutSignal a)) -- lifting of buildsteps + -> (Int -> Buffer -> m Buffer) -- output function for a guaranteedly non-empty buffer, the returned buffer will be filled next + -> (S.ByteString -> m ()) -- output function for guaranteedly non-empty bytestrings, that are inserted directly into the stream + -> Put a -- put to execute + -> Buffer -- initial buffer to be used + -> m (a, Buffer) -- result of put and remaining buffer +runPut liftIO outputBuf outputBS (Put put) = + runStep (put finalStep) + where + finalStep x !(BufRange op _) = return $ Done op x + + runStep step buf@(Buffer fpbuf p0 op ope) = do + let !br = BufRange op ope + signal <- liftIO $ step br + case signal of + Done op' x -> -- put completed, buffer partially runSteped + return (x, Buffer fpbuf p0 op' ope) + + BufferFull minSize op' nextStep -> do + buf' <- outputBuf minSize (Buffer fpbuf p0 op' ope) + runStep nextStep buf' + + InsertByteString op' bs nextStep + | S.null bs -> -- flushing of buffer required + outputBuf 1 (Buffer fpbuf p0 op' ope) >>= runStep nextStep + | p0 == op' -> do -- no bytes written: just insert bytestring + outputBS bs + runStep nextStep buf + | otherwise -> do -- bytes written, insert buffer and bytestring + buf' <- outputBuf 1 (Buffer fpbuf p0 op' ope) + outputBS bs + runStep nextStep buf' +{-# INLINE runPut #-} + +-- | A monad for lazily composing lazy bytestrings using continuations. +newtype LBSM a = LBSM { unLBSM :: (a, L.ByteString -> L.ByteString) } + +instance Monad LBSM where + return x = LBSM (x, id) + (LBSM (x,k)) >>= f = let LBSM (x',k') = f x in LBSM (x', k . k') + (LBSM (_,k)) >> (LBSM (x',k')) = LBSM (x', k . k') + +-- | Execute a put and return the written buffers as the chunks of a lazy +-- bytestring. +toLazyByteString2 :: Put a -> L.ByteString +toLazyByteString2 put = + k (bufToLBSCont (snd result) L.empty) + where + -- initial buffer + buf0 = inlinePerformIO $ allocBuffer defaultBufferSize + -- run put, but don't force result => we're lazy enough + LBSM (result, k) = runPut liftIO outputBuf outputBS put buf0 + -- convert a buffer to a lazy bytestring continuation + bufToLBSCont = maybe id L.Chunk . unsafeFreezeNonEmptyBuffer + -- lifting an io putsignal to a lazy bytestring monad + liftIO io = LBSM (inlinePerformIO io, id) + -- add buffer as a chunk prepare allocation of new one + outputBuf minSize buf = LBSM + ( inlinePerformIO $ allocBuffer (max minSize defaultBufferSize) + , bufToLBSCont buf ) + -- add bytestring directly as a chunk; exploits postcondition of runPut + -- that bytestrings are non-empty + outputBS bs = LBSM ((), L.Chunk bs) + +-- | A Builder that traces a message +traceBuilder :: String -> Builder +traceBuilder msg = Builder $ \k br@(BufRange op ope) -> do + putStrLn $ "traceBuilder " ++ show (op, ope) ++ ": " ++ msg + k br + +flushBuilder :: Builder +flushBuilder = Builder $ \k (BufRange op _) -> do + return $ InsertByteString op S.empty k + +test2 :: Word8 -> [S.ByteString] +test2 x = L.toChunks $ toLazyByteString2 $ fromBuilder $ mconcat + [ traceBuilder "before flush" + , fromWord8 48 + , flushBuilder + , flushBuilder + , traceBuilder "after flush" + , fromWord8 x + ] + diff --git a/benchmarks/LazyByteString.hs b/benchmarks/LazyByteString.hs new file mode 100644 --- /dev/null +++ b/benchmarks/LazyByteString.hs @@ -0,0 +1,410 @@ +{-# LANGUAGE BangPatterns #-} +-- | +-- Module : LazyByteString +-- Copyright : (c) 2010 Simon Meier +-- License : BSD3-style (see LICENSE) +-- +-- Maintainer : Simon Meier +-- Stability : experimental +-- Portability : tested on GHC only +-- +-- Benchmarking of alternative implementations of functions in +-- Data.ByteString.Lazy that construct lazy bytestrings and cannot be +-- implemented with slicing only. +module LazyByteString where -- (main) where + +import Data.Word +import Data.Monoid +import Data.List + +import Criterion.Main + +import Foreign +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.Internal as L + +import Blaze.ByteString.Builder.Internal +import Blaze.ByteString.Builder.Write +import Blaze.ByteString.Builder.Word +import Blaze.ByteString.Builder.ByteString + +------------------------------------------------------------------------------ +-- Benchmarks +------------------------------------------------------------------------------ + +main :: IO () +main = do + let (chunkInfos, benchmarks) = unzip + [ lazyVsBlaze + ( "copy" + , L.copy + , copyBlaze + , (\i -> L.drop 13 $ L.take (fromIntegral i) $ L.fromChunks $ repeat $ S.pack [0..]) + , n) + , lazyVsBlaze + ( "filter ((==0) . (`mod` 3))" + , L.filter ((==0) . (`mod` 3)) + , filterBlaze ((==0) . (`mod` 3)) + , (\i -> L.drop 13 $ L.pack $ take i $ cycle [0..]) + , n) + , lazyVsBlaze + ( "map (+1)" + , L.map (+1) + , mapBlaze (+1) + , (\i -> L.drop 13 $ L.pack $ take i $ cycle [0..]) + , n) + , lazyVsBlaze + ( "concatMap (replicate 10)" + , L.concatMap (L.replicate 10) + , toLazyByteString . concatMapBuilder (fromReplicateWord8 10) + , (\i -> L.pack $ take i $ cycle [0..]) + , n `div` 10 ) + , lazyVsBlaze + ( "unfoldr countToZero" + , L.unfoldr countToZero + , unfoldrBlaze countToZero + , id + , n ) + ] + sequence_ (intersperse (putStrLn "") chunkInfos) + putStrLn "" + defaultMain benchmarks + where + n :: Int + n = 100000 + +lazyVsBlaze :: (String, a -> L.ByteString, a -> L.ByteString, Int -> a, Int) + -> (IO (), Benchmark) +lazyVsBlaze (cmpName, lazy, blaze, prep, n) = + ( do putStrLn $ cmpName ++ ": " ++ checkResults + showChunksize implLazy lazy + showChunksize implBlaze blaze + , bgroup cmpName + [ mkBench implLazy lazy + , mkBench implBlaze blaze + ] + ) + where + implLazy = "bytestring" + implBlaze = "blaze-builder" + x = prep n + + nInfo = "for n = " ++ show n + checkResults + | lazy x == blaze x = "implementations agree " ++ nInfo + | otherwise = unlines [ "ERROR: IMPLEMENTATIONS DISAGREE " ++ nInfo + , implLazy ++ ": " ++ show (lazy x) + , implBlaze ++ ": " ++ show (blaze x) + ] + + showChunksize implName impl = do + let bs = impl x + cs = map S.length $ L.toChunks bs + putStrLn $ " " ++ implName ++ ": " + putStrLn $ " chunks sizes: " ++ show cs + putStrLn $ " avg. chunk size: " ++ + show ((fromIntegral (sum cs) :: Double) / fromIntegral (length cs)) + + mkBench implName impl = bench implName $ whnf (L.length . impl) x + + +------------------------------------------------------------------------------ +-- Alternative implementations +------------------------------------------------------------------------------ + +-- Unfolding +------------ + +{- +-- | /O(n)/ The 'unfoldr' function is analogous to the List \'unfoldr\'. +-- 'unfoldr' builds a ByteString from a seed value. The function takes +-- the element and returns 'Nothing' if it is done producing the +-- ByteString or returns 'Just' @(a,b)@, in which case, @a@ is a +-- prepending to the ByteString and @b@ is used as the next element in a +-- recursive call. +unfoldr :: (a -> Maybe (Word8, a)) -> a -> ByteString +unfoldr f s0 = unfoldChunk 32 s0 + where unfoldChunk n s = + case S.unfoldrN n f s of + (c, Nothing) + | S.null c -> Empty + | otherwise -> Chunk c Empty + (c, Just s') -> Chunk c (unfoldChunk (n*2) s') +-} + +countToZero :: Int -> Maybe (Word8, Int) +countToZero 0 = Nothing +countToZero i = Just (fromIntegral i, i - 1) + +unfoldrBlaze :: (a -> Maybe (Word8, a)) -> a -> L.ByteString +unfoldrBlaze f x = toLazyByteString $ fromWriteUnfoldr writeWord8 f x + +fromWriteUnfoldr :: (b -> Write) -> (a -> Maybe (b, a)) -> a -> Builder +fromWriteUnfoldr write = + makeBuilder + where + makeBuilder f x0 = Builder $ step x0 + where + step x1 !k = fill x1 + where + fill x !pf0 !pe0 = go (f x) pf0 + where + go !Nothing !pf = k pf pe0 + go !(Just (y, x')) !pf + | pf `plusPtr` size <= pe0 = do + io pf + go (f x') (pf `plusPtr` size) + | otherwise = return $ BufferFull size pf $ \pfNew peNew -> do + io pfNew + fill x' (pfNew `plusPtr` size) peNew + where + !(Write size io) = write y +{-# INLINE fromWriteUnfoldr #-} + +-- Filtering and mapping +------------------------ + +test i = + ((L.filter ((==0) . (`mod` 3)) $ x) , + (filterBlaze ((==0) . (`mod` 3)) $ x)) + where + x = L.pack $ take i $ cycle [0..] + +filterBlaze :: (Word8 -> Bool) -> L.ByteString -> L.ByteString +filterBlaze f = toLazyByteString . filterLazyByteString f +{-# INLINE filterBlaze #-} + +mapBlaze :: (Word8 -> Word8) -> L.ByteString -> L.ByteString +mapBlaze f = toLazyByteString . mapLazyByteString f +{-# INLINE mapBlaze #-} + +filterByteString :: (Word8 -> Bool) -> S.ByteString -> Builder +filterByteString p = mapFilterMapByteString id p id +{-# INLINE filterByteString #-} + +filterLazyByteString :: (Word8 -> Bool) -> L.ByteString -> Builder +filterLazyByteString p = mapFilterMapLazyByteString id p id +{-# INLINE filterLazyByteString #-} + +mapByteString :: (Word8 -> Word8) -> S.ByteString -> Builder +mapByteString f = mapFilterMapByteString f (const True) id +{-# INLINE mapByteString #-} + +mapLazyByteString :: (Word8 -> Word8) -> L.ByteString -> Builder +mapLazyByteString f = mapFilterMapLazyByteString f (const True) id +{-# INLINE mapLazyByteString #-} + +mapFilterMapByteString :: (Word8 -> Word8) -> (Word8 -> Bool) -> (Word8 -> Word8) + -> S.ByteString -> Builder +mapFilterMapByteString f p g = + \bs -> Builder $ step bs + where + step (S.PS ifp ioff isize) !k = + goBS (unsafeForeignPtrToPtr ifp `plusPtr` ioff) + where + !ipe = unsafeForeignPtrToPtr ifp `plusPtr` (ioff + isize) + goBS !ip0 !op0 !ope + | ip0 >= ipe = do touchForeignPtr ifp -- input buffer consumed + k op0 ope + | op0 < ope = goPartial (ip0 `plusPtr` min outRemaining inpRemaining) + | otherwise = return $ BufferFull 1 op0 (goBS ip0) + where + outRemaining = ope `minusPtr` op0 + inpRemaining = ipe `minusPtr` ip0 + goPartial !ipeTmp = go ip0 op0 + where + go !ip !op + | ip < ipeTmp = do + w <- peek ip + let w' = g w + if p w' + then poke op (f w') >> go (ip `plusPtr` 1) (op `plusPtr` 1) + else go (ip `plusPtr` 1) op + | otherwise = + goBS ip op ope +{-# INLINE mapFilterMapByteString #-} + +mapFilterMapLazyByteString :: (Word8 -> Word8) -> (Word8 -> Bool) -> (Word8 -> Word8) + -> L.ByteString -> Builder +mapFilterMapLazyByteString f p g = + L.foldrChunks (\c b -> mapFilterMapByteString f p g c `mappend` b) mempty +{-# INLINE mapFilterMapLazyByteString #-} + + +-- Concatenation and replication +-------------------------------- + +{- +-- | Map a function over a 'ByteString' and concatenate the results +concatMap :: (Word8 -> ByteString) -> ByteString -> ByteString +concatMap _ Empty = Empty +concatMap f (Chunk c0 cs0) = to c0 cs0 + where + go :: ByteString -> P.ByteString -> ByteString -> ByteString + go Empty c' cs' = to c' cs' + go (Chunk c cs) c' cs' = Chunk c (go cs c' cs') + + to :: P.ByteString -> ByteString -> ByteString + to c cs | S.null c = case cs of + Empty -> Empty + (Chunk c' cs') -> to c' cs' + | otherwise = go (f (S.unsafeHead c)) (S.unsafeTail c) cs +-} + +fromWriteReplicated :: (a -> Write) -> Int -> a -> Builder +fromWriteReplicated write = + makeBuilder + where + makeBuilder !n0 x = Builder $ step + where + Write size io = write x + step !k = fill n0 + where + fill !n1 !pf0 !pe0 = go n1 pf0 + where + go 0 !pf = k pf pe0 + go n !pf + | pf `plusPtr` size <= pe0 = do + io pf + go (n-1) (pf `plusPtr` size) + | otherwise = return $ BufferFull size pf $ \pfNew peNew -> do + io pfNew + fill (n-1) (pfNew `plusPtr` size) peNew +{-# INLINE fromWriteReplicated #-} + +-- FIXME: Output repeated bytestrings for large replications. +fromReplicateWord8 :: Int -> Word8 -> Builder +fromReplicateWord8 !n0 x = + Builder $ step + where + step !k = fill n0 + where + fill !n !pf !pe + | n <= 0 = k pf pe + | pf' <= pe = do + _ <- S.memset pf x (fromIntegral n) -- FIXME: This conversion looses information for 64 bit systems. + k pf' pe + | otherwise = do + let !l = pe `minusPtr` pf + _ <- S.memset pf x (fromIntegral l) -- FIXME: This conversion looses information for 64 bit systems. + return $ BufferFull 1 pe $ fill (n - l) + where + pf' = pf `plusPtr` n +{-# INLINE fromReplicateWord8 #-} + + +{-# RULES "fromWriteReplicated/writeWord8" + fromWriteReplicated writeWord8 = fromReplicateWord8 + #-} + + +concatMapBuilder :: (Word8 -> Builder) -> L.ByteString -> Builder +concatMapBuilder f = L.foldr (\w b -> f w `mappend` b) mempty +{-# INLINE concatMapBuilder #-} + +concatMapBlaze :: (Word8 -> L.ByteString) -> L.ByteString -> L.ByteString +concatMapBlaze f = toLazyByteString . concatMapBuilder (fromLazyByteString . f) + + +-- Interspersing +---------------- + +-- +-- not sure if it Builder version is needed, as chunks get only bigger. We +-- would need it however, if we used a Builder to ensure latency guarantees; i.e., +-- if we use a builder to ensure a bound on the maximal size of chunks. +-- + +{- +-- | The 'intersperse' function takes a 'Word8' and a 'ByteString' and +-- \`intersperses\' that byte between the elements of the 'ByteString'. +-- It is analogous to the intersperse function on Lists. +intersperse :: Word8 -> ByteString -> ByteString +intersperse _ Empty = Empty +intersperse w (Chunk c cs) = Chunk (S.intersperse w c) + (foldrChunks (Chunk . intersperse') Empty cs) + where intersperse' :: P.ByteString -> P.ByteString + intersperse' (S.PS fp o l) = + S.unsafeCreate (2*l) $ \p' -> withForeignPtr fp $ \p -> do + poke p' w + S.c_intersperse (p' `plusPtr` 1) (p `plusPtr` o) (fromIntegral l) w +-} +{- +intersperseBlaze :: Word8 -- ^ Byte to intersperse. + -> L.ByteString -- ^ Lazy 'L.ByteString' to be "spread". + -> Builder -- ^ Resulting 'Builder'. +intersperseBlaze w lbs0 = + Builder $ step lbs0 + where + step lbs1 k = goChunk lbs1 + where + goChunk L.Empty pf0 pe0 = k pf0 pe0 + goChunk (L.Chunk (S.PS fpi oi li) lbs') pf0 pe0 = do + go + touch + where + go + where + !pf' = pf `plusPtr` + + + goChunk !L.Empty !pf = k pf pe0 + goChunk !lbs@(L.Chunk bs' lbs') !pf + | pf' <= pe0 = do + withForeignPtr fpbuf $ \pbuf -> + copyBytes pf (pbuf `plusPtr` offset) size + go lbs' pf' + + | otherwise = return $ BufferFull size pf (step lbs k) + where + !pf' = pf `plusPtr` + !(fpbuf, offset, size) = S.toForeignPtr bs' +{-# INLINE intersperseBlaze #-} + +-} + + +-- Packing +---------- + +packBlaze :: [Word8] -> L.ByteString +packBlaze = toLazyByteString . fromWrite1List writeWord8 + + +-- Reverse +---------- + + +-- Transpose +------------ + + +-- scanl, scanl1, scanr, scanr1 +------------------------------- + + +-- mapAccumL, mapAccumR +----------------------- + + +-- partition +------------ + +-- unzip +-------- + + +-- copy +------- + +-- FIXME: Implement wrapping +copyBlaze :: L.ByteString -> L.ByteString +copyBlaze = toLazyByteString . copyLazyByteString + + +-- ?? packCString, packCStringLen +--------------------------------- + + diff --git a/benchmarks/StrictIO.hs b/benchmarks/StrictIO.hs new file mode 100644 --- /dev/null +++ b/benchmarks/StrictIO.hs @@ -0,0 +1,28 @@ +{-# LANGUAGE BangPatterns #-} +-- | Demonstrate the problem with IO not allowing for unlifted types. +-- +-- TODO: Not yet finished. +module StrictIO where + + + +loop :: Int -> Int -> IO () +loop !i !c + | i == 1 = print c + | otherwise = do + !i' <- subcases + print i' + loop i' (c+1) + where + subcases + | i `mod` 2 == 0 = do + print "even" + return $ i `div` 2 + | otherwise = do + print "odd" + return $ i + 1 + {-# INLINE subcases #-} + + + + diff --git a/benchmarks/StringAndText.hs b/benchmarks/StringAndText.hs --- a/benchmarks/StringAndText.hs +++ b/benchmarks/StringAndText.hs @@ -42,8 +42,8 @@ , bench "fromStrictTextUnpacked :: StrictText --[Utf8 encoding]--> L.ByteString" $ whnf (L.length . Blaze.toLazyByteString . Blaze.fromText) benchStrictText - , bench "fromStrictTextFolded :: StrictText --[Utf8 encoding]--> L.ByteString" $ whnf - (L.length . Blaze.toLazyByteString . fromStrictTextFolded) benchStrictText + -- , bench "fromStrictTextFolded :: StrictText --[Utf8 encoding]--> L.ByteString" $ whnf + -- (L.length . Blaze.toLazyByteString . fromStrictTextFolded) benchStrictText , bench "TS.encodeUtf8 :: StrictText --[Utf8 encoding]--> S.ByteString" $ whnf (TS.encodeUtf8) benchStrictText @@ -51,8 +51,8 @@ , bench "fromLazyTextUnpacked :: LazyText --[Utf8 encoding]--> L.ByteString" $ whnf (L.length . Blaze.toLazyByteString . Blaze.fromLazyText) benchLazyText - , bench "fromLazyTextFolded :: LazyText --[Utf8 encoding]--> L.ByteString" $ whnf - (L.length . Blaze.toLazyByteString . fromLazyTextFolded) benchLazyText + -- , bench "fromLazyTextFolded :: LazyText --[Utf8 encoding]--> L.ByteString" $ whnf + -- (L.length . Blaze.toLazyByteString . fromLazyTextFolded) benchLazyText , bench "TL.encodeUtf8 :: LazyText --[Utf8 encoding]--> L.ByteString" $ whnf (L.length . TL.encodeUtf8) benchLazyText @@ -83,11 +83,12 @@ benchLazyText = TL.pack benchString {-# NOINLINE benchLazyText #-} +{- -- | Encode the 'TS.Text' as UTF-8 by folding it and filling the raw buffer -- directly. fromStrictTextFolded :: TS.Text -> Blaze.Builder -fromStrictTextFolded t = Blaze.Builder $ \k -> TS.foldr step k t +fromStrictTextFolded t = Blaze.fromBuildStepCont $ \k -> TS.foldr step k t where step c k pf pe | pf' <= pe = do @@ -95,10 +96,10 @@ k pf' pe -- here it would be great, if we wouldn't have to pass -- around pe: requires a more powerful fold for StrictText. | otherwise = - return $ Blaze.BufferFull size pf $ \pfNew peNew -> do - let pfNew' = pfNew `plusPtr` size + return $ Blaze.bufferFull size pf $ \(Blaze.BufRange pfNew peNew) -> do + let !br' = Blaze.BufRange (pfNew `plusPtr` size) peNew io pfNew - k pfNew' peNew + k br' where pf' = pf `plusPtr` size Blaze.Write size io = Blaze.writeChar c @@ -107,7 +108,7 @@ -- | Encode the 'TL.Text' as UTF-8 by folding it and filling the raw buffer -- directly. fromLazyTextFolded :: TL.Text -> Blaze.Builder -fromLazyTextFolded t = Blaze.Builder $ \k -> TL.foldr step k t +fromLazyTextFolded t = Blaze.fromBuildStepContBuilder $ \k -> TL.foldr step k t where step c k pf pe | pf' <= pe = do @@ -115,11 +116,12 @@ k pf' pe -- here it would be great, if we wouldn't have to pass -- around pe: requires a more powerful fold for StrictText. | otherwise = - return $ Blaze.BufferFull size pf $ \pfNew peNew -> do - let pfNew' = pfNew `plusPtr` size + return $ Blaze.bufferFull size pf $ \(Blaze.BufRange pfNew peNew) -> do + let !br' = Blaze.BufRange (pfNew `plusPtr` size) peNew io pfNew - k pfNew' peNew + k br' where pf' = pf `plusPtr` size Blaze.Write size io = Blaze.writeChar c {-# INLINE fromLazyTextFolded #-} +-} diff --git a/benchmarks/UnboxedAppend.hs b/benchmarks/UnboxedAppend.hs new file mode 100644 --- /dev/null +++ b/benchmarks/UnboxedAppend.hs @@ -0,0 +1,254 @@ +{-# LANGUAGE CPP, BangPatterns, Rank2Types, MagicHash #-} +-- | +-- Module : UnboxedAppend +-- Copyright : (c) 2010 Simon Meier +-- License : BSD3-style (see LICENSE) +-- +-- Maintainer : Simon Meier +-- Stability : experimental +-- Portability : tested on GHC only +-- +-- Try using unboxed pointers for the continuation calls to make abstract +-- appends go faster. +-- +module UnboxedAppend where + +import Foreign +import Foreign.UPtr +import Data.Monoid +import qualified Data.ByteString as S +import qualified Data.ByteString.Lazy as L + +#ifdef BYTESTRING_IN_BASE +import Data.ByteString.Base (inlinePerformIO) +import qualified Data.ByteString.Base as S +import qualified Data.ByteString.Lazy.Base as L -- FIXME: is this the right module for access to 'Chunks'? +#else +import Data.ByteString.Internal (inlinePerformIO) +import qualified Data.ByteString.Internal as S +import qualified Data.ByteString.Lazy.Internal as L +#endif + +import qualified Blaze.ByteString.Builder.Internal as B +import Blaze.ByteString.Builder.Write (Write(..)) +import qualified Blaze.ByteString.Builder.Word as B +import Blaze.ByteString.Builder.Word (writeWord8) + +import Criterion.Main + +------------------------------------------------------------------------------ +-- Benchmarks +------------------------------------------------------------------------------ + +main :: IO () +main = defaultMain $ concat + [ benchmark "mconcat . map fromWord8" + myfromWord8s + yourfromWord8s + word8s + ] + where + benchmark name putF builderF x = + [ bench (name ++ " Put") $ + whnf (L.length . toLazyByteString2 . putF) x + , bench (name ++ " Builder") $ + whnf (L.length . B.toLazyByteString . builderF) x + ] + +word8s :: [Word8] +word8s = take 100000 $ cycle [0..] +{-# NOINLINE word8s #-} + +myfromWord8s :: [Word8] -> Put () +myfromWord8s = putBuilder . mconcat . map fromWord8 +{-# NOINLINE myfromWord8s #-} + +yourfromWord8s :: [Word8] -> B.Builder +yourfromWord8s = mconcat . map B.fromWord8 +{-# NOINLINE yourfromWord8s #-} + + +------------------------------------------------------------------------------ +-- The Put type +------------------------------------------------------------------------------ + +data BufRange = BufRange {-# UNPACK #-} !(Ptr Word8) {-# UNPACK #-} !(Ptr Word8) + +newtype Put a = Put { + unPut :: forall r. (a -> PutStep r) -> PutStep r + } + +data PutSignal a = + Done {-# UNPACK #-} !(Ptr Word8) a + | BufferFull + {-# UNPACK #-} !Int + {-# UNPACK #-} !(Ptr Word8) + !(PutStep a) + | InsertByteString + {-# UNPACK #-} !(Ptr Word8) + !S.ByteString + !(PutStep a) + +type PutStep a = UPtr -> UPtr -> IO (PutSignal a) + +instance Monad Put where + return x = Put $ \k -> k x + {-# INLINE return #-} + m >>= f = Put $ \k -> unPut m (\x -> unPut (f x) k) + {-# INLINE (>>=) #-} + m >> n = Put $ \k -> unPut m (\_ -> unPut n k) + {-# INLINE (>>) #-} + +------------------------------------------------------------------------------ +-- The Builder type with equal signals as the Put type +------------------------------------------------------------------------------ + +newtype Builder = Builder (forall r. PutStep r -> PutStep r) + +instance Monoid Builder where + mempty = Builder id + {-# INLINE mempty #-} + (Builder b1) `mappend` (Builder b2) = Builder $ b1 . b2 + {-# INLINE mappend #-} + mconcat = foldr mappend mempty + {-# INLINE mconcat #-} + +putBuilder :: Builder -> Put () +putBuilder (Builder build) = Put $ \k -> build (k ()) + +fromPut :: Put () -> Builder +fromPut (Put put) = Builder $ \k -> put (\_ -> k) + +fromBuildStep :: (forall r. PutStep r -> BufRange -> IO (PutSignal r)) -> Builder +fromBuildStep step = Builder step' + where + step' k op ope = step k (BufRange (uptrToPtr op) (uptrToPtr ope)) +{-# INLINE fromBuildStep #-} + +callBuildStep :: PutStep a -> BufRange -> IO (PutSignal a) +callBuildStep k (BufRange op ope) = k (ptrToUPtr op) (ptrToUPtr ope) +{-# INLINE callBuildStep #-} + +boxBuildStep :: PutStep a -> (BufRange -> IO (PutSignal a)) +boxBuildStep step (BufRange op ope) = step (ptrToUPtr op) (ptrToUPtr ope) +{-# INLINE boxBuildStep #-} + +unboxBuildStep :: (BufRange -> IO (PutSignal a)) -> PutStep a +unboxBuildStep step op ope = step (BufRange (uptrToPtr op) (uptrToPtr ope)) +{-# INLINE unboxBuildStep #-} + +fromWriteSingleton :: (a -> Write) -> a -> Builder +fromWriteSingleton write = + mkBuilder + where + mkBuilder x = fromBuildStep step + where + step k (BufRange pf pe) + | pf `plusPtr` size <= pe = do + io pf + let !br' = BufRange (pf `plusPtr` size) pe + callBuildStep k br' + | otherwise = + return $ BufferFull size pf (unboxBuildStep $ step k) + where + Write size io = write x +{-# INLINE fromWriteSingleton #-} + +fromWord8 :: Word8 -> Builder +fromWord8 = fromWriteSingleton writeWord8 +{-# INLINE fromWord8 #-} + +------------------------------------------------------------------------------ +-- More explicit implementation of running builders +------------------------------------------------------------------------------ + + +data Buffer = Buffer {-# UNPACK #-} !(ForeignPtr Word8) -- underlying pinned array + {-# UNPACK #-} !(Ptr Word8) -- beginning of slice + {-# UNPACK #-} !(Ptr Word8) -- next free byte + {-# UNPACK #-} !(Ptr Word8) -- first byte after buffer + +allocBuffer :: Int -> IO Buffer +allocBuffer size = do + fpbuf <- S.mallocByteString size + let !pbuf = unsafeForeignPtrToPtr fpbuf + return $! Buffer fpbuf pbuf pbuf (pbuf `plusPtr` size) + +unsafeFreezeBuffer :: Buffer -> S.ByteString +unsafeFreezeBuffer (Buffer fpbuf p0 op _) = + S.PS fpbuf 0 (op `minusPtr` p0) + +unsafeFreezeNonEmptyBuffer :: Buffer -> Maybe S.ByteString +unsafeFreezeNonEmptyBuffer (Buffer fpbuf p0 op _) + | p0 == op = Nothing + | otherwise = Just $ S.PS fpbuf 0 (op `minusPtr` p0) + +nextSlice :: Int -> Buffer -> Maybe Buffer +nextSlice minSize (Buffer fpbuf _ op ope) + | ope `minusPtr` op <= minSize = Nothing + | otherwise = Just (Buffer fpbuf op op ope) + +runPut :: Monad m + => (IO (PutSignal a) -> m (PutSignal a)) -- lifting of buildsteps + -> (Int -> Buffer -> m Buffer) -- output function for a guaranteedly non-empty buffer, the returned buffer will be filled next + -> (S.ByteString -> m ()) -- output function for guaranteedly non-empty bytestrings, that are inserted directly into the stream + -> Put a -- put to execute + -> Buffer -- initial buffer to be used + -> m (a, Buffer) -- result of put and remaining buffer +runPut liftIO outputBuf outputBS (Put put) = + runStep (put $ (\x -> unboxBuildStep $ finalStep x)) + where + finalStep x !(BufRange op _) = return $ Done op x + + runStep step buf@(Buffer fpbuf p0 op ope) = do + let !br = BufRange op ope + signal <- liftIO $ callBuildStep step br + case signal of + Done op' x -> -- put completed, buffer partially runSteped + return (x, Buffer fpbuf p0 op' ope) + + BufferFull minSize op' nextStep -> do + buf' <- outputBuf minSize (Buffer fpbuf p0 op' ope) + runStep nextStep buf' + + InsertByteString op' bs nextStep + | S.null bs -> -- flushing of buffer required + outputBuf 1 (Buffer fpbuf p0 op' ope) >>= runStep nextStep + | p0 == op' -> do -- no bytes written: just insert bytestring + outputBS bs + runStep nextStep buf + | otherwise -> do -- bytes written, insert buffer and bytestring + buf' <- outputBuf 1 (Buffer fpbuf p0 op' ope) + outputBS bs + runStep nextStep buf' +{-# INLINE runPut #-} + +-- | A monad for lazily composing lazy bytestrings using continuations. +newtype LBSM a = LBSM { unLBSM :: (a, L.ByteString -> L.ByteString) } + +instance Monad LBSM where + return x = LBSM (x, id) + (LBSM (x,k)) >>= f = let LBSM (x',k') = f x in LBSM (x', k . k') + (LBSM (_,k)) >> (LBSM (x',k')) = LBSM (x', k . k') + +-- | Execute a put and return the written buffers as the chunks of a lazy +-- bytestring. +toLazyByteString2 :: Put a -> L.ByteString +toLazyByteString2 put = + k (bufToLBSCont (snd result) L.empty) + where + -- initial buffer + buf0 = inlinePerformIO $ allocBuffer B.defaultBufferSize + -- run put, but don't force result => we're lazy enough + LBSM (result, k) = runPut liftIO outputBuf outputBS put buf0 + -- convert a buffer to a lazy bytestring continuation + bufToLBSCont = maybe id L.Chunk . unsafeFreezeNonEmptyBuffer + -- lifting an io putsignal to a lazy bytestring monad + liftIO io = LBSM (inlinePerformIO io, id) + -- add buffer as a chunk prepare allocation of new one + outputBuf minSize buf = LBSM + ( inlinePerformIO $ allocBuffer (max minSize B.defaultBufferSize) + , bufToLBSCont buf ) + -- add bytestring directly as a chunk; exploits postcondition of runPut + -- that bytestrings are non-empty + outputBS bs = LBSM ((), L.Chunk bs) diff --git a/blaze-builder.cabal b/blaze-builder.cabal --- a/blaze-builder.cabal +++ b/blaze-builder.cabal @@ -1,6 +1,6 @@ Name: blaze-builder -Version: 0.2.0.3 -Synopsis: Efficient construction of bytestrings. +Version: 0.2.1.0 +Synopsis: Efficient buffered output. Description: This library provides an abstraction of buffered output of @@ -13,13 +13,18 @@ when writing the resulting lazy bytestring to a file or sending it over the network. -Homepage: http://github.com/jaspervdj/blaze-builder -Bug-Reports: http://github.com/jaspervdj/blaze-builder/issues +Author: Jasper Van der Jeugt, Simon Meier +Copyright: 2010 Simon Meier + 2010 Jasper Van der Jeugt +Maintainer: Simon Meier + License: BSD3 License-file: LICENSE -Author: Jasper Van der Jeugt, Simon Meier -Maintainer: jaspervdj@gmail.com, iridcode@gmail.com + +Homepage: http://github.com/meiersi/blaze-builder +Bug-Reports: http://github.com/meiersi/blaze-builder/issues Stability: Experimental + Category: Data Build-type: Simple Cabal-version: >= 1.6 @@ -37,20 +42,29 @@ tests/*.hs +Source-repository head + Type: git + Location: https://github.com/meiersi/blaze-builder.git + Library ghc-options: -Wall exposed-modules: Blaze.ByteString.Builder - Blaze.ByteString.Builder.Write Blaze.ByteString.Builder.Int Blaze.ByteString.Builder.Word Blaze.ByteString.Builder.ByteString Blaze.ByteString.Builder.Char.Utf8 + Blaze.ByteString.Builder.Char8 Blaze.ByteString.Builder.Html.Utf8 + Blaze.ByteString.Builder.HTTP Blaze.ByteString.Builder.Internal + Blaze.ByteString.Builder.Internal.Write + Blaze.ByteString.Builder.Internal.Types + Blaze.ByteString.Builder.Internal.Buffer + + other-modules: Blaze.ByteString.Builder.Internal.UncheckedShifts - -- FIXME: Ensure dependencies are strict enough build-depends: base == 4.* , bytestring == 0.9.* , text >= 0.10 && < 0.12