blaze-builder 0.2.0.3 → 0.2.1.0

raw patch · 27 files changed

+3429/−909 lines, 27 filesPVP: major bump suggested

API removals or changes: PVP suggests a major version bump

API changes (from Hackage documentation)

Files

• Blaze/ByteString/Builder.hs +0/−122
• Blaze/ByteString/Builder/ByteString.hs +41/−52
• Blaze/ByteString/Builder/Char/Utf8.hs +14/−33
• Blaze/ByteString/Builder/Char8.hs +78/−0
• Blaze/ByteString/Builder/HTTP.hs +210/−0
• Blaze/ByteString/Builder/Html/Utf8.hs +12/−7
• Blaze/ByteString/Builder/Int.hs +16/−27
• Blaze/ByteString/Builder/Internal.hs +158/−188
• Blaze/ByteString/Builder/Internal/Buffer.hs +214/−0
• Blaze/ByteString/Builder/Internal/Types.hs +137/−0
• Blaze/ByteString/Builder/Internal/UncheckedShifts.hs +73/−0
• Blaze/ByteString/Builder/Internal/Write.hs +187/−0
• Blaze/ByteString/Builder/Word.hs +29/−72
• Blaze/ByteString/Builder/Write.hs +0/−384
• CHANGES +29/−0
• Makefile +48/−3
• TODO +10/−0
• benchmarks/BenchmarkServer.hs +97/−0
• benchmarks/BlazeVsBinary.hs +1/−1
• benchmarks/BoundedWrite.hs +241/−0
• benchmarks/BuilderBufferRange.hs +463/−0
• benchmarks/FastPut.hs +643/−0
• benchmarks/LazyByteString.hs +410/−0
• benchmarks/StrictIO.hs +28/−0
• benchmarks/StringAndText.hs +14/−12
• benchmarks/UnboxedAppend.hs +254/−0
• blaze-builder.cabal +22/−8

@@ -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<n><endian>' 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." #-} 

@@ -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 #-} 

@@ -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

@@ -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 <iridcode@gmail.com>+-- 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

@@ -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+

@@ -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 "&lt;"-writeHtmlEscapedChar '>'  = writeByteString "&gt;"-writeHtmlEscapedChar '&'  = writeByteString "&amp;"-writeHtmlEscapedChar '"'  = writeByteString "&quot;"-writeHtmlEscapedChar '\'' = writeByteString "&#39;"-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 "&lt;"+    io '>'  = runWrite $ writeByteString "&gt;"+    io '&'  = runWrite $ writeByteString "&amp;"+    io '"'  = runWrite $ writeByteString "&quot;"+    io '\'' = runWrite $ writeByteString "&#39;"+    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'.

@@ -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/<n/>@, 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 #-}

@@ -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+  ]++-}++-}

@@ -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 <iridcode@gmail.com>+-- 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'

@@ -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 <iridcode@gmail.com>+-- 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)++

@@ -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 <iridcode@gmail.com>+-- 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+

@@ -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 <iridcode@gmail.com>+-- 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

@@ -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/<n/>@, 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 #-}

@@ -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 <iridcode@gmail.com>--- 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 #-}--

@@ -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'

@@ -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:

@@ -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 

@@ -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 <iridcode@gmail.com>+-}++{-# 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` "<h1>Page not found</h1>"+        return ()

@@ -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"

@@ -0,0 +1,241 @@+{-# LANGUAGE CPP, BangPatterns #-}+-- |+-- Module      : BoundedWrite+-- Copyright   : (c) 2010 Simon Meier+-- License     : BSD3-style (see LICENSE)+-- +-- Maintainer  : Simon Meier <iridcode@gmail.com>+-- 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 #-}+

@@ -0,0 +1,463 @@+{-# LANGUAGE CPP, BangPatterns #-}+-- |+-- Module      : BuilderBufferRange+-- Copyright   : (c) 2010 Simon Meier+-- License     : BSD3-style (see LICENSE)+-- +-- Maintainer  : Simon Meier <iridcode@gmail.com>+-- 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 #-}++-}

@@ -0,0 +1,643 @@+{-# LANGUAGE CPP, BangPatterns, Rank2Types #-}+-- |+-- Module      : FastPut+-- Copyright   : (c) 2010 Simon Meier+-- License     : BSD3-style (see LICENSE)+-- +-- Maintainer  : Simon Meier <iridcode@gmail.com>+-- 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+  ]+

@@ -0,0 +1,410 @@+{-# LANGUAGE BangPatterns #-}+-- |+-- Module      : LazyByteString+-- Copyright   : (c) 2010 Simon Meier+-- License     : BSD3-style (see LICENSE)+-- +-- Maintainer  : Simon Meier <iridcode@gmail.com>+-- 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+---------------------------------++

@@ -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 #-}+++  +

@@ -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 #-}+-}

@@ -0,0 +1,254 @@+{-# LANGUAGE CPP, BangPatterns, Rank2Types, MagicHash #-}+-- |+-- Module      : UnboxedAppend+-- Copyright   : (c) 2010 Simon Meier+-- License     : BSD3-style (see LICENSE)+-- +-- Maintainer  : Simon Meier <iridcode@gmail.com>+-- 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)

@@ -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 <iridcode@gmail.com>+ 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