blaze-builder-0.4.2.3/ 0000755 0000000 0000000 00000000000 07346545000 012570 5 ustar 00 0000000 0000000 blaze-builder-0.4.2.3/Blaze/ByteString/ 0000755 0000000 0000000 00000000000 07346545000 015717 5 ustar 00 0000000 0000000 blaze-builder-0.4.2.3/Blaze/ByteString/Builder.hs 0000644 0000000 0000000 00000025047 07346545000 017651 0 ustar 00 0000000 0000000 {-# LANGUAGE CPP, BangPatterns #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
------------------------------------------------------------------------------
-- |
-- Module: Blaze.ByteString.Builder
-- Copyright: (c) 2013 Leon P Smith
-- License: BSD3
-- Maintainer: https://github.com/blaze-builder
-- Stability: stable
--
-- "Blaze.ByteString.Builder" is the main module, which you should import as a user
-- of the @blaze-builder@ library.
--
-- > import Blaze.ByteString.Builder
--
-- It provides you with a type 'Builder' that allows to efficiently construct
-- lazy bytestrings with a large average chunk size.
--
-- Intuitively, a 'Builder' denotes the construction of a part of a lazy
-- bytestring. Builders can either be created using one of the primitive
-- combinators in "Blaze.ByteString.Builder.Write" or by using one of the predefined
-- combinators for standard Haskell values (see the exposed modules of this
-- package). Concatenation of builders is done using 'mappend' from the
-- 'Monoid' typeclass.
--
-- Here is a small example that serializes a list of strings using the UTF-8
-- encoding.
--
-- @ import "Blaze.ByteString.Builder.Char.Utf8"@
--
-- > strings :: [String]
-- > strings = replicate 10000 "Hello there!"
--
-- The function @'fromString'@ creates a 'Builder' denoting the UTF-8 encoded
-- argument. Hence, UTF-8 encoding and concatenating all @strings@ can be done
-- follows.
--
-- > concatenation :: Builder
-- > concatenation = mconcat $ map fromString strings
--
-- The function 'toLazyByteString' can be used to execute a 'Builder' and
-- obtain the resulting lazy bytestring.
--
-- > result :: L.ByteString
-- > result = toLazyByteString concatenation
--
-- The @result@ is a lazy bytestring containing 10000 repetitions of the string
-- @\"Hello there!\"@ encoded using UTF-8. The corresponding 120000 bytes are
-- distributed among three chunks of 32kb and a last chunk of 6kb.
--
-- /A note on history./ This serialization library was inspired by the
-- @Data.Binary.Builder@ module provided by the @binary@ package. It was
-- originally developed with the specific needs of the @blaze-html@ package in
-- mind. Since then it has been restructured to serve as a drop-in replacement
-- for @Data.Binary.Builder@, which it improves upon both in speed as well as
-- expressivity.
--
------------------------------------------------------------------------------
module Blaze.ByteString.Builder
(
-- * The 'Builder' type
B.Builder
-- * Creating builders
, module Blaze.ByteString.Builder.Int
, module Blaze.ByteString.Builder.Word
, module Blaze.ByteString.Builder.ByteString
, B.flush
-- * Executing builders
, B.toLazyByteString
, toLazyByteStringWith
, toByteString
, toByteStringIO
, toByteStringIOWith
-- * 'Write's
, W.Write
, W.fromWrite
, W.fromWriteSingleton
, W.fromWriteList
, writeToByteString
-- ** Writing 'Storable's
, W.writeStorable
, W.fromStorable
, W.fromStorables
) where
import Control.Monad(unless)
#if __GLASGOW_HASKELL__ >= 702
import Foreign
import qualified Foreign.ForeignPtr.Unsafe as Unsafe
#else
import Foreign as Unsafe
#endif
import qualified Blaze.ByteString.Builder.Internal.Write as W
import Blaze.ByteString.Builder.ByteString
import Blaze.ByteString.Builder.Word
import Blaze.ByteString.Builder.Int
import Data.ByteString.Builder ( Builder )
import qualified Data.ByteString.Builder as B
import qualified Data.ByteString.Builder.Extra as B
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
#if __GLASGOW_HASKELL__ >= 702
import System.IO.Unsafe (unsafeDupablePerformIO)
#else
unsafeDupablePerformIO :: IO a -> a
unsafeDupablePerformIO = unsafePerformIO
#endif
withBS :: S.ByteString -> (ForeignPtr Word8 -> Int -> Int -> a) -> a
#if MIN_VERSION_bytestring(0,11,0)
withBS (S.BS fptr len) f = f fptr 0 len
#else
withBS (S.PS fptr offset len) f = f fptr offset len
#endif
mkBS :: ForeignPtr Word8 -> Int -> S.ByteString
#if MIN_VERSION_bytestring(0,11,0)
mkBS fptr len = S.BS fptr len
#else
mkBS fptr len = S.PS fptr 0 len
#endif
-- | 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 bs lbs') !pf = withBS bs $ \fpbuf o l -> 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 . B.toLazyByteString
-- | 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)
-- | @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.
--
toByteStringIO :: (S.ByteString -> IO ()) -> Builder -> IO ()
toByteStringIO = toByteStringIOWith defaultBufferSize
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 = do
S.mallocByteString bufSize >>= getBuffer (B.runBuilder builder) bufSize
where
getBuffer writer !size fp = do
let !ptr = Unsafe.unsafeForeignPtrToPtr fp
(bytes, next) <- writer ptr size
case next of
B.Done -> io $! mkBS fp bytes
B.More req writer' -> do
io $! mkBS fp bytes
let !size' = max bufSize req
S.mallocByteString size' >>= getBuffer writer' size'
B.Chunk bs' writer' -> do
if bytes > 0
then do
io $! mkBS fp bytes
unless (S.null bs') (io bs')
S.mallocByteString bufSize >>= getBuffer writer' bufSize
else do
unless (S.null bs') (io bs')
getBuffer writer' size fp
-- | 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.
--
-- FIXME: Note that the following paragraphs are not entirely correct as of
-- blaze-builder-0.4:
--
-- 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 -- ^ This parameter is ignored as of blaze-builder-0.4
-> Int -- ^ Size of the first buffer to be used and copied for
-- larger resulting sequences
-> Builder -- ^ Builder to run.
-> L.ByteString -- ^ Lazy bytestring to output after the builder is
-- finished.
-> L.ByteString -- ^ Resulting lazy bytestring
toLazyByteStringWith bufSize _minBufSize firstBufSize builder k =
B.toLazyByteStringWith (B.safeStrategy firstBufSize bufSize) k builder
-- | Run a 'Write' to produce a strict 'S.ByteString'.
-- This is equivalent to @('toByteString' . 'fromWrite')@, but is more
-- efficient because it uses just one appropriately-sized buffer.
writeToByteString :: W.Write -> S.ByteString
writeToByteString !w = unsafeDupablePerformIO $ do
fptr <- S.mallocByteString (W.getBound w)
len <- withForeignPtr fptr $ \ptr -> do
end <- W.runWrite w ptr
return $! end `minusPtr` ptr
return $! S.fromForeignPtr fptr 0 len
{-# INLINE writeToByteString #-}
blaze-builder-0.4.2.3/Blaze/ByteString/Builder/ 0000755 0000000 0000000 00000000000 07346545000 017305 5 ustar 00 0000000 0000000 blaze-builder-0.4.2.3/Blaze/ByteString/Builder/ByteString.hs 0000644 0000000 0000000 00000011160 07346545000 021732 0 ustar 00 0000000 0000000 ------------------------------------------------------------------------------
-- |
-- Module: Blaze.ByteString.Builder.ByteString
-- Copyright: (c) 2013 Leon P Smith
-- License: BSD3
-- Maintainer: https://github.com/blaze-builder
-- Stability: stable
--
-- 'Write's and 'B.Builder's for strict and lazy bytestrings.
--
-- We assume the following qualified imports in order to differentiate between
-- strict and lazy bytestrings in the code examples.
--
-- > import qualified Data.ByteString as S
-- > import qualified Data.ByteString.Lazy as L
--
------------------------------------------------------------------------------
module Blaze.ByteString.Builder.ByteString
(
-- * Strict bytestrings
writeByteString
, fromByteString
, fromByteStringWith
, copyByteString
, insertByteString
-- * Lazy bytestrings
, fromLazyByteString
, fromLazyByteStringWith
, copyLazyByteString
, insertLazyByteString
) where
import Blaze.ByteString.Builder.Internal.Write ( Write, exactWrite )
import Foreign
import qualified Data.ByteString.Builder as B
import qualified Data.ByteString.Builder.Extra as B
import qualified Data.ByteString as S
import qualified Data.ByteString.Internal as S
import qualified Data.ByteString.Lazy as L
-- | Write a strict 'S.ByteString' to a buffer.
writeByteString :: S.ByteString -> Write
writeByteString bs = exactWrite l io
where
(fptr, o, l) = S.toForeignPtr bs
io pf = withForeignPtr fptr $ \p -> copyBytes pf (p `plusPtr` o) l
{-# INLINE writeByteString #-}
-- | Create a 'B.Builder' denoting the same sequence of bytes as a strict
-- 'S.ByteString'.
-- The 'B.Builder' inserts large 'S.ByteString's directly, but copies small ones
-- to ensure that the generated chunks are large on average.
fromByteString :: S.ByteString -> B.Builder
fromByteString = B.byteString
{-# INLINE fromByteString #-}
-- | Construct a 'B.Builder' that copies the strict 'S.ByteString's, if it is
-- smaller than the threshold, and inserts it directly otherwise.
--
-- For example, @fromByteStringWith 1024@ copies strict 'S.ByteString's whose size
-- is less or equal to 1kb, and inserts them directly otherwise. This implies
-- that the average chunk-size of the generated lazy 'L.ByteString' may be as
-- low as 513 bytes, as there could always be just a single byte between the
-- directly inserted 1025 byte, strict 'S.ByteString's.
--
fromByteStringWith :: Int -- ^ Maximal number of bytes to copy.
-> S.ByteString -- ^ Strict 'S.ByteString' to serialize.
-> B.Builder -- ^ Resulting 'B.Builder'.
fromByteStringWith = B.byteStringThreshold
{-# INLINE fromByteStringWith #-}
-- | Construct a 'B.Builder' that copies the strict 'S.ByteString'.
--
-- Use this function to create 'B.Builder's from smallish (@<= 4kb@)
-- 'S.ByteString's or if you need to guarantee that the 'S.ByteString' is not
-- shared with the chunks generated by the 'B.Builder'.
--
copyByteString :: S.ByteString -> B.Builder
copyByteString = B.byteStringCopy
{-# INLINE copyByteString #-}
-- | Construct a 'B.Builder' that always inserts the strict 'S.ByteString'
-- directly as a chunk.
--
-- This implies flushing the output buffer, even if it contains just
-- a single byte. You should therefore use 'insertByteString' only for large
-- (@> 8kb@) 'S.ByteString's. Otherwise, the generated chunks are too
-- fragmented to be processed efficiently afterwards.
--
insertByteString :: S.ByteString -> B.Builder
insertByteString = B.byteStringInsert
{-# INLINE insertByteString #-}
-- | Create a 'B.Builder' denoting the same sequence of bytes as a lazy
-- 'S.ByteString'.
-- The 'B.Builder' inserts large chunks of the lazy 'L.ByteString' directly,
-- but copies small ones to ensure that the generated chunks are large on
-- average.
--
fromLazyByteString :: L.ByteString -> B.Builder
fromLazyByteString = B.lazyByteString
{-# INLINE fromLazyByteString #-}
-- | Construct a 'B.Builder' that uses the thresholding strategy of 'fromByteStringWith'
-- for each chunk of the lazy 'L.ByteString'.
--
fromLazyByteStringWith :: Int -> L.ByteString -> B.Builder
fromLazyByteStringWith = B.lazyByteStringThreshold
{-# INLINE fromLazyByteStringWith #-}
-- | Construct a 'B.Builder' that copies the lazy 'L.ByteString'.
--
copyLazyByteString :: L.ByteString -> B.Builder
copyLazyByteString = B.lazyByteStringCopy
{-# INLINE copyLazyByteString #-}
-- | Construct a 'B.Builder' that inserts all chunks of the lazy 'L.ByteString'
-- directly.
--
insertLazyByteString :: L.ByteString -> B.Builder
insertLazyByteString = B.lazyByteStringInsert
{-# INLINE insertLazyByteString #-}
blaze-builder-0.4.2.3/Blaze/ByteString/Builder/Char/ 0000755 0000000 0000000 00000000000 07346545000 020162 5 ustar 00 0000000 0000000 blaze-builder-0.4.2.3/Blaze/ByteString/Builder/Char/Utf8.hs 0000644 0000000 0000000 00000003740 07346545000 021350 0 ustar 00 0000000 0000000 ------------------------------------------------------------------------------
-- |
-- Module: Blaze.ByteString.Builder.Char.Utf8
-- Copyright: (c) 2013 Leon P Smith
-- License: BSD3
-- Maintainer: https://github.com/blaze-builder
-- Stability: stable
--
-- 'Write's and 'Builder's for serializing Unicode characters using the UTF-8
-- encoding.
--
------------------------------------------------------------------------------
module Blaze.ByteString.Builder.Char.Utf8
(
-- * Writing UTF-8 encoded characters to a buffer
writeChar
-- * Creating Builders from UTF-8 encoded characters
, fromChar
, fromString
, fromShow
, fromText
, fromLazyText
) where
import Blaze.ByteString.Builder.Compat.Write (Write, writePrimBounded)
import Data.ByteString.Builder ( Builder )
import qualified Data.ByteString.Builder as B
import qualified Data.ByteString.Builder.Prim as P
import qualified Data.Text as TS
import qualified Data.Text.Lazy as TL
-- | Write a UTF-8 encoded Unicode character to a buffer.
--
writeChar :: Char -> Write
writeChar = writePrimBounded P.charUtf8
{-# INLINE writeChar #-}
-- | /O(1)/. Serialize a Unicode character using the UTF-8 encoding.
--
fromChar :: Char -> Builder
fromChar = B.charUtf8
{-# INLINE fromChar #-}
-- | /O(n)/. Serialize a Unicode 'String' using the UTF-8 encoding.
--
fromString :: String -> Builder
fromString = B.stringUtf8
{-# INLINE fromString #-}
-- | /O(n)/. Serialize a value by 'Show'ing it and UTF-8 encoding the resulting
-- 'String'.
--
fromShow :: Show a => a -> Builder
fromShow = fromString . show
{-# INLINE fromShow #-}
-- | /O(n)/. Serialize a strict Unicode 'TS.Text' value using the UTF-8 encoding.
--
fromText :: TS.Text -> Builder
fromText = fromString . TS.unpack
{-# INLINE fromText #-}
-- | /O(n)/. Serialize a lazy Unicode 'TL.Text' value using the UTF-8 encoding.
--
fromLazyText :: TL.Text -> Builder
fromLazyText = fromString . TL.unpack
{-# INLINE fromLazyText #-}
blaze-builder-0.4.2.3/Blaze/ByteString/Builder/Char8.hs 0000644 0000000 0000000 00000004416 07346545000 020613 0 ustar 00 0000000 0000000 ------------------------------------------------------------------------------
-- |
-- Module: Blaze.ByteString.Builder.Char8
-- Copyright: (c) 2013 Leon P Smith
-- License: BSD3
-- Maintainer: https://github.com/blaze-builder
-- Stability: stable
--
-- //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 Blaze.ByteString.Builder.Compat.Write ( Write, writePrimFixed )
import Data.ByteString.Builder ( Builder )
import qualified Data.ByteString.Builder as B
import qualified Data.ByteString.Builder.Prim as P
import qualified Data.Text as TS
import qualified Data.Text.Lazy as TL
-- | Write the lower 8-bits of a character to a buffer.
writeChar :: Char -> Write
writeChar = writePrimFixed P.char8
{-# INLINE writeChar #-}
-- | /O(1)/. Serialize the lower 8-bits of a character.
fromChar :: Char -> Builder
fromChar = B.char8
{-# INLINE fromChar #-}
-- | /O(n)/. Serialize the lower 8-bits of all characters of a string
fromString :: String -> Builder
fromString = P.primMapListFixed P.char8
{-# INLINE fromString #-}
-- | /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
{-# INLINE fromShow #-}
-- | /O(n)/. Serialize the lower 8-bits of all characters in the strict text.
fromText :: TS.Text -> Builder
fromText = fromString . TS.unpack
{-# INLINE fromText #-}
-- | /O(n)/. Serialize the lower 8-bits of all characters in the lazy text.
fromLazyText :: TL.Text -> Builder
fromLazyText = fromString . TL.unpack
{-# INLINE fromLazyText #-}
blaze-builder-0.4.2.3/Blaze/ByteString/Builder/Compat/ 0000755 0000000 0000000 00000000000 07346545000 020530 5 ustar 00 0000000 0000000 blaze-builder-0.4.2.3/Blaze/ByteString/Builder/Compat/Write.hs 0000644 0000000 0000000 00000002100 07346545000 022147 0 ustar 00 0000000 0000000 ------------------------------------------------------------------------------
-- |
-- Module: Blaze.ByteString.Builder.Compat.Write
-- Copyright: (c) 2013 Leon P Smith
-- License: BSD3
-- Maintainer: https://github.com/blaze-builder
-- Stability: stable
--
-- Conversions from the new Prims to the old Writes.
--
------------------------------------------------------------------------------
module Blaze.ByteString.Builder.Compat.Write
( Write
, writePrimFixed
, writePrimBounded
) where
import Data.ByteString.Builder.Prim.Internal (BoundedPrim, FixedPrim
, runB, runF, size, sizeBound)
import Blaze.ByteString.Builder.Internal.Write (Poke(..), Write
, boundedWrite, exactWrite)
writePrimFixed :: FixedPrim a -> a -> Write
writePrimFixed fe a = exactWrite (size fe) (runF fe a)
{-# INLINE writePrimFixed #-}
writePrimBounded :: BoundedPrim a -> a -> Write
writePrimBounded be a = boundedWrite (sizeBound be) (Poke (runB be a))
{-# INLINE writePrimBounded #-}
blaze-builder-0.4.2.3/Blaze/ByteString/Builder/HTTP.hs 0000644 0000000 0000000 00000017043 07346545000 020425 0 ustar 00 0000000 0000000 {-# LANGUAGE BangPatterns, CPP, MagicHash, OverloadedStrings #-}
------------------------------------------------------------------------------
-- |
-- Module: Blaze.ByteString.Builder.HTTP
-- Copyright: (c) 2013 Simon Meier
-- License: BSD3
-- Maintainer: https://github.com/blaze-builder
-- Stability: stable
--
-- Support for HTTP response encoding.
--
------------------------------------------------------------------------------
module Blaze.ByteString.Builder.HTTP (
-- * Chunked HTTP transfer encoding
chunkedTransferEncoding
, chunkedTransferTerminator
) where
#if defined(__GLASGOW_HASKELL__) && !defined(__HADDOCK__)
#include "MachDeps.h"
#endif
#if defined(__GLASGOW_HASKELL__) && !defined(__HADDOCK__)
import GHC.Base
import GHC.Word (Word32(..))
#else
import Data.Word
#endif
import Foreign
import qualified Data.ByteString as S
import Data.ByteString.Char8 ()
import Blaze.ByteString.Builder.Internal.Write
import Data.ByteString.Builder
import Data.ByteString.Builder.Internal
import Blaze.ByteString.Builder.ByteString (copyByteString)
import qualified Blaze.ByteString.Builder.Char8 as Char8
#if !MIN_VERSION_base(4,8,0)
import Data.Monoid
#endif
{-# INLINE shiftr_w32 #-}
shiftr_w32 :: Word32 -> Int -> Word32
#if defined(__GLASGOW_HASKELL__) && !defined(__HADDOCK__)
#if MIN_VERSION_ghc_prim(0,8,0)
shiftr_w32 (W32# w) (I# i) = W32# (wordToWord32# ((word32ToWord# w) `uncheckedShiftRL#` i))
#else
shiftr_w32 (W32# w) (I# i) = W32# (w `uncheckedShiftRL#` i)
#endif
#else
shiftr_w32 = shiftR
#endif
-- | 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
_ <- runPoke (getPoke w) op
return ()
------------------------------------------------------------------------------
-- Hex Encoding Infrastructure
------------------------------------------------------------------------------
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) (pokeN len $ pokeWord32HexN len w)
where
len = word32HexLength w
{-# INLINE writeWord32Hex #-}
------------------------------------------------------------------------------
-- Chunked transfer encoding
------------------------------------------------------------------------------
-- | Transform a builder such that it uses chunked HTTP transfer encoding.
chunkedTransferEncoding :: Builder -> Builder
chunkedTransferEncoding innerBuilder =
builder transferEncodingStep
where
transferEncodingStep k =
go (runBuilder innerBuilder)
where
go innerStep !(BufferRange op ope)
-- FIXME: Assert that outRemaining < maxBound :: Word32
| outRemaining < minimalBufferSize =
return $ bufferFull minimalBufferSize op (go innerStep)
| otherwise = do
let !brInner@(BufferRange opInner _) = BufferRange
(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)
-- prepare handlers
doneH opInner' _ = wrapChunk opInner' $ \op' -> do
let !br' = BufferRange op' ope
k br'
fullH opInner' minRequiredSize nextInnerStep =
wrapChunk opInner' $ \op' ->
return $! bufferFull
(minRequiredSize + maxEncodingOverhead)
op'
(go nextInnerStep)
insertChunkH opInner' bs nextInnerStep
| S.null bs = -- flush
wrapChunk opInner' $ \op' ->
return $! insertChunk 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'' <- (`runPoke` op') $ getPoke $
writeWord32Hex (fromIntegral $ S.length bs)
`mappend` writeCRLF
-- insert bytestring and write CRLF in next buildstep
return $! insertChunk
op'' bs
(runBuilderWith (fromWrite writeCRLF) $ go nextInnerStep)
-- execute inner builder with reduced boundaries
fillWithBuildStep innerStep doneH fullH insertChunkH brInner
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 zero-length chunk '0\r\n\r\n' signaling the termination of the data transfer.
chunkedTransferTerminator :: Builder
chunkedTransferTerminator = copyByteString "0\r\n\r\n"
blaze-builder-0.4.2.3/Blaze/ByteString/Builder/Html/ 0000755 0000000 0000000 00000000000 07346545000 020211 5 ustar 00 0000000 0000000 blaze-builder-0.4.2.3/Blaze/ByteString/Builder/Html/Utf8.hs 0000644 0000000 0000000 00000010516 07346545000 021376 0 ustar 00 0000000 0000000 {-# LANGUAGE CPP #-}
#if __GLASGOW_HASKELL__ >= 704
{-# OPTIONS_GHC -fsimpl-tick-factor=40000 #-}
#endif
------------------------------------------------------------------------------
-- |
-- Module: Blaze.ByteString.Builder.Html.Utf8
-- Copyright: (c) 2013 Leon P Smith
-- License: BSD3
-- Maintainer: https://github.com/blaze-builder
-- Stability: stable
--
-- 'Write's and 'Builder's for serializing HTML escaped and UTF-8 encoded
-- characters.
--
-- This module is used by both the 'blaze-html' and the \'hamlet\' HTML
-- templating libraries. If the 'Builder' from 'blaze-builder' replaces the
-- 'Data.Binary.Builder' implementation, this module will most likely keep its
-- place, as it provides a set of very specialized functions.
--
------------------------------------------------------------------------------
module Blaze.ByteString.Builder.Html.Utf8
(
module Blaze.ByteString.Builder.Char.Utf8
-- * Writing HTML escaped and UTF-8 encoded characters to a buffer
, writeHtmlEscapedChar
-- * Creating Builders from HTML escaped and UTF-8 encoded characters
, fromHtmlEscapedChar
, fromHtmlEscapedString
, fromHtmlEscapedShow
, fromHtmlEscapedText
, fromHtmlEscapedLazyText
) where
import Data.ByteString.Char8 () -- for the 'IsString' instance of bytesrings
import qualified Data.Text as TS
import qualified Data.Text.Encoding as TE
import qualified Data.Text.Lazy as TL
import qualified Data.Text.Lazy.Encoding as TLE
import Blaze.ByteString.Builder.Compat.Write ( Write, writePrimBounded )
import qualified Data.ByteString.Builder as B
import Data.ByteString.Builder.Prim ((>*<), (>$<), condB)
import qualified Data.ByteString.Builder.Prim as P
import Blaze.ByteString.Builder.Char.Utf8
import Blaze.ByteString.Builder.Html.Word
-- | Write a HTML escaped and UTF-8 encoded Unicode character to a bufffer.
--
writeHtmlEscapedChar :: Char -> Write
writeHtmlEscapedChar = writePrimBounded charUtf8HtmlEscaped
{-# INLINE writeHtmlEscapedChar #-}
-- | /O(1)./ Serialize a HTML escaped Unicode character using the UTF-8
-- encoding.
fromHtmlEscapedChar :: Char -> B.Builder
fromHtmlEscapedChar = P.primBounded charUtf8HtmlEscaped
{-# INLINE fromHtmlEscapedChar #-}
{-# INLINE charUtf8HtmlEscaped #-}
charUtf8HtmlEscaped :: P.BoundedPrim Char
charUtf8HtmlEscaped =
condB (> '>' ) (condB (== '\DEL') P.emptyB P.charUtf8) $
condB (== '<' ) (fixed4 ('&',('l',('t',';')))) $ -- <
condB (== '>' ) (fixed4 ('&',('g',('t',';')))) $ -- >
condB (== '&' ) (fixed5 ('&',('a',('m',('p',';'))))) $ -- &
condB (== '"' ) (fixed6 ('&',('q',('u',('o',('t',';')))))) $ -- &#quot;
condB (== '\'') (fixed5 ('&',('#',('3',('9',';'))))) $ -- '
condB (\c -> c >= ' ' || c == '\t' || c == '\n' || c == '\r')
(P.liftFixedToBounded P.char7) $
P.emptyB
where
{-# INLINE fixed4 #-}
fixed4 x = P.liftFixedToBounded $ const x >$<
P.char7 >*< P.char7 >*< P.char7 >*< P.char7
{-# INLINE fixed5 #-}
fixed5 x = P.liftFixedToBounded $ const x >$<
P.char7 >*< P.char7 >*< P.char7 >*< P.char7 >*< P.char7
{-# INLINE fixed6 #-}
fixed6 x = P.liftFixedToBounded $ const x >$<
P.char7 >*< P.char7 >*< P.char7 >*< P.char7 >*< P.char7 >*< P.char7
-- | /O(n)/. Serialize a HTML escaped Unicode 'String' using the UTF-8
-- encoding.
--
fromHtmlEscapedString :: String -> B.Builder
fromHtmlEscapedString = P.primMapListBounded charUtf8HtmlEscaped
-- | /O(n)/. Serialize a value by 'Show'ing it and then, HTML escaping and
-- UTF-8 encoding the resulting 'String'.
--
fromHtmlEscapedShow :: Show a => a -> B.Builder
fromHtmlEscapedShow = fromHtmlEscapedString . show
-- | /O(n)/. Serialize a HTML escaped strict Unicode 'TS.Text' value using the
-- UTF-8 encoding.
--
fromHtmlEscapedText :: TS.Text -> B.Builder
#if MIN_VERSION_text(1,1,2) && MIN_VERSION_bytestring(0,10,4)
fromHtmlEscapedText = TE.encodeUtf8BuilderEscaped wordHtmlEscaped
#else
fromHtmlEscapedText = fromHtmlEscapedString . TS.unpack
#endif
-- | /O(n)/. Serialize a HTML escaped Unicode 'TL.Text' using the UTF-8 encoding.
--
fromHtmlEscapedLazyText :: TL.Text -> B.Builder
#if MIN_VERSION_text(1,1,2) && MIN_VERSION_bytestring(0,10,4)
fromHtmlEscapedLazyText = TLE.encodeUtf8BuilderEscaped wordHtmlEscaped
#else
fromHtmlEscapedLazyText = fromHtmlEscapedString . TL.unpack
#endif
blaze-builder-0.4.2.3/Blaze/ByteString/Builder/Html/Word.hs 0000644 0000000 0000000 00000006324 07346545000 021465 0 ustar 00 0000000 0000000 {-# LANGUAGE CPP #-}
#if __GLASGOW_HASKELL__ >= 704
{-# OPTIONS_GHC -fsimpl-tick-factor=40000 #-}
#endif
------------------------------------------------------------------------------
-- |
-- Module: Blaze.ByteString.Builder.Html.Word
-- Copyright: (c) 2016 Dylan Simon
-- License: BSD3
-- Maintainer: https://github.com/blaze-builder
-- Stability: stable
--
-- 'W.Write's and 'B.Builder's for serializing HTML escaped 'Word8' characters
-- and 'BS.ByteString's that have already been appropriately encoded into HTML by
-- escaping basic ASCII character references but leaving other bytes untouched.
--
------------------------------------------------------------------------------
module Blaze.ByteString.Builder.Html.Word
( wordHtmlEscaped
-- * Writing HTML escaped bytes to a buffer
, writeHtmlEscapedWord
-- * Creating Builders from HTML escaped bytes
, fromHtmlEscapedWord
, fromHtmlEscapedWordList
, fromHtmlEscapedByteString
, fromHtmlEscapedLazyByteString
) where
import qualified Blaze.ByteString.Builder.Compat.Write as W
import qualified Data.ByteString as BS
import qualified Data.ByteString.Builder as B
import qualified Data.ByteString.Builder.Prim as P
import Data.ByteString.Internal (c2w)
import qualified Data.ByteString.Lazy as BSL
import Data.Word (Word8)
{-# INLINE wordHtmlEscaped #-}
wordHtmlEscaped :: P.BoundedPrim Word8
wordHtmlEscaped =
P.condB (> c2w '>' ) (P.condB (== c2w '\DEL') P.emptyB $ P.liftFixedToBounded P.word8) $
P.condB (== c2w '<' ) (fixed4 ('&',('l',('t',';')))) $ -- <
P.condB (== c2w '>' ) (fixed4 ('&',('g',('t',';')))) $ -- >
P.condB (== c2w '&' ) (fixed5 ('&',('a',('m',('p',';'))))) $ -- &
P.condB (== c2w '"' ) (fixed6 ('&',('q',('u',('o',('t',';')))))) $ -- "
P.condB (== c2w '\'') (fixed5 ('&',('#',('3',('9',';'))))) $ -- '
P.condB (\c -> c >= c2w ' ' || c == c2w '\t' || c == c2w '\n' || c == c2w '\r')
(P.liftFixedToBounded P.word8) P.emptyB
where
{-# INLINE fixed4 #-}
fixed4 x = P.liftFixedToBounded $ const x P.>$<
P.char8 P.>*< P.char8 P.>*< P.char8 P.>*< P.char8
{-# INLINE fixed5 #-}
fixed5 x = P.liftFixedToBounded $ const x P.>$<
P.char8 P.>*< P.char8 P.>*< P.char8 P.>*< P.char8 P.>*< P.char8
{-# INLINE fixed6 #-}
fixed6 x = P.liftFixedToBounded $ const x P.>$<
P.char8 P.>*< P.char8 P.>*< P.char8 P.>*< P.char8 P.>*< P.char8 P.>*< P.char8
-- | Write a HTML escaped byte to a bufffer.
writeHtmlEscapedWord :: Word8 -> W.Write
writeHtmlEscapedWord = W.writePrimBounded wordHtmlEscaped
-- | /O(1)./ Serialize a HTML escaped byte.
fromHtmlEscapedWord :: Word8 -> B.Builder
fromHtmlEscapedWord = P.primBounded wordHtmlEscaped
-- | /O(n)/. Serialize a HTML escaped list of bytes.
fromHtmlEscapedWordList :: [Word8] -> B.Builder
fromHtmlEscapedWordList = P.primMapListBounded wordHtmlEscaped
-- | /O(n)/. Serialize a HTML escaped 'BS.ByteString'.
fromHtmlEscapedByteString :: BS.ByteString -> B.Builder
fromHtmlEscapedByteString = P.primMapByteStringBounded wordHtmlEscaped
-- | /O(n)/. Serialize a HTML escaped lazy 'BSL.ByteString'.
fromHtmlEscapedLazyByteString :: BSL.ByteString -> B.Builder
fromHtmlEscapedLazyByteString = P.primMapLazyByteStringBounded wordHtmlEscaped
blaze-builder-0.4.2.3/Blaze/ByteString/Builder/Int.hs 0000644 0000000 0000000 00000021042 07346545000 020372 0 ustar 00 0000000 0000000 ------------------------------------------------------------------------------
-- |
-- Module: Blaze.ByteString.Builder.Int
-- Copyright: (c) 2013 Leon P Smith
-- License: BSD3
-- Maintainer: https://github.com/blaze-builder
-- Stability: stable
--
-- 'Write's and 'Builder's for serializing integers.
--
-- See "Blaze.ByteString.Builder.Word" for information about how to best write several
-- integers at once.
--
------------------------------------------------------------------------------
module Blaze.ByteString.Builder.Int
(
-- * Writing integers to a buffer
writeInt8
-- ** Big-endian writes
, writeInt16be -- :: Int16 -> Write
, writeInt32be -- :: Int32 -> Write
, writeInt64be -- :: Int64 -> Write
-- ** Little-endian writes
, writeInt16le -- :: Int16 -> Write
, writeInt32le -- :: Int32 -> Write
, writeInt64le -- :: Int64 -> Write
-- ** Host-endian writes
, writeInthost -- :: Int -> Write
, writeInt16host -- :: Int16 -> Write
, writeInt32host -- :: Int32 -> Write
, writeInt64host -- :: Int64 -> Write
-- * Creating builders from integers
-- | We provide serialization functions both for singleton integers as well as
-- for lists of integers. Using these list serialization functions is /much/ faster
-- than using @mconcat . map fromInt/@, as the list serialization
-- functions use a tighter inner loop.
, fromInt8
, fromInt8s
-- ** Big-endian serialization
, fromInt16be -- :: Int16 -> Builder
, fromInt32be -- :: Int32 -> Builder
, fromInt64be -- :: Int64 -> Builder
, fromInt32sbe -- :: [Int32] -> Builder
, fromInt16sbe -- :: [Int16] -> Builder
, fromInt64sbe -- :: [Int64] -> Builder
-- ** Little-endian serialization
, fromInt16le -- :: Int16 -> Builder
, fromInt32le -- :: Int32 -> Builder
, fromInt64le -- :: Int64 -> Builder
, fromInt16sle -- :: [Int16] -> Builder
, fromInt32sle -- :: [Int32] -> Builder
, fromInt64sle -- :: [Int64] -> Builder
-- ** Host-endian serialization
, fromInthost -- :: Int -> Builder
, fromInt16host -- :: Int16 -> Builder
, fromInt32host -- :: Int32 -> Builder
, fromInt64host -- :: Int64 -> Builder
, fromIntshost -- :: [Int] -> Builder
, fromInt16shost -- :: [Int16] -> Builder
, fromInt32shost -- :: [Int32] -> Builder
, fromInt64shost -- :: [Int64] -> Builder
) where
import Data.Int
import Blaze.ByteString.Builder.Compat.Write ( Write, writePrimFixed )
import Data.ByteString.Builder ( Builder )
import qualified Data.ByteString.Builder as B
import qualified Data.ByteString.Builder.Extra as B
import qualified Data.ByteString.Builder.Prim as P
-- | Write a single signed byte.
--
writeInt8 :: Int8 -> Write
writeInt8 = writePrimFixed P.int8
{-# INLINE writeInt8 #-}
-- | Write an 'Int16' in big endian format.
writeInt16be :: Int16 -> Write
writeInt16be = writePrimFixed P.int16BE
{-# INLINE writeInt16be #-}
-- | Write an 'Int32' in big endian format.
writeInt32be :: Int32 -> Write
writeInt32be = writePrimFixed P.int32BE
{-# INLINE writeInt32be #-}
-- | Write an 'Int64' in big endian format.
writeInt64be :: Int64 -> Write
writeInt64be = writePrimFixed P.int64BE
{-# INLINE writeInt64be #-}
-- | Write an 'Int16' in little endian format.
writeInt16le :: Int16 -> Write
writeInt16le = writePrimFixed P.int16LE
{-# INLINE writeInt16le #-}
-- | Write an 'Int32' in little endian format.
writeInt32le :: Int32 -> Write
writeInt32le = writePrimFixed P.int32LE
{-# INLINE writeInt32le #-}
-- | Write an 'Int64' in little endian format.
writeInt64le :: Int64 -> Write
writeInt64le = writePrimFixed P.int64LE
{-# INLINE writeInt64le #-}
-- | Write a single native machine 'Int'. The 'Int' is written in host order,
-- host endian form, for the machine you're on. On a 64 bit machine the 'Int'
-- is an 8 byte value, on a 32 bit machine, 4 bytes. Values written this way
-- are not portable to different endian or integer sized machines, without
-- conversion.
--
writeInthost :: Int -> Write
writeInthost = writePrimFixed P.intHost
{-# INLINE writeInthost #-}
-- | Write an 'Int16' in native host order and host endianness.
writeInt16host :: Int16 -> Write
writeInt16host = writePrimFixed P.int16Host
{-# INLINE writeInt16host #-}
-- | Write an 'Int32' in native host order and host endianness.
writeInt32host :: Int32 -> Write
writeInt32host = writePrimFixed P.int32Host
{-# INLINE writeInt32host #-}
-- | Write an 'Int64' in native host order and host endianness.
writeInt64host :: Int64 -> Write
writeInt64host = writePrimFixed P.int64Host
{-# INLINE writeInt64host #-}
-- | Serialize a single byte.
fromInt8 :: Int8 -> Builder
fromInt8 = B.int8
{-# INLINE fromInt8 #-}
-- | Serialize a list of bytes.
fromInt8s :: [Int8] -> Builder
fromInt8s = P.primMapListFixed P.int8
{-# INLINE fromInt8s #-}
-- | Serialize an 'Int16' in big endian format.
fromInt16be :: Int16 -> Builder
fromInt16be = B.int16BE
{-# INLINE fromInt16be #-}
-- | Serialize an 'Int32' in big endian format.
fromInt32be :: Int32 -> Builder
fromInt32be = B.int32BE
{-# INLINE fromInt32be #-}
-- | Serialize an 'Int64' in big endian format.
fromInt64be :: Int64 -> Builder
fromInt64be = B.int64BE
{-# INLINE fromInt64be #-}
-- | Serialize a list of 'Int32's in big endian format.
fromInt32sbe :: [Int32] -> Builder
fromInt32sbe = P.primMapListFixed P.int32BE
{-# INLINE fromInt32sbe #-}
-- | Serialize a list of 'Int16's in big endian format.
fromInt16sbe :: [Int16] -> Builder
fromInt16sbe = P.primMapListFixed P.int16BE
{-# INLINE fromInt16sbe #-}
-- | Serialize a list of 'Int64's in big endian format.
fromInt64sbe :: [Int64] -> Builder
fromInt64sbe = P.primMapListFixed P.int64BE
{-# INLINE fromInt64sbe #-}
-- | Serialize an 'Int16' in little endian format.
fromInt16le :: Int16 -> Builder
fromInt16le = B.int16LE
{-# INLINE fromInt16le #-}
-- | Serialize an 'Int32' in little endian format.
fromInt32le :: Int32 -> Builder
fromInt32le = B.int32LE
{-# INLINE fromInt32le #-}
-- | Serialize an 'Int64' in little endian format.
fromInt64le :: Int64 -> Builder
fromInt64le = B.int64LE
{-# INLINE fromInt64le #-}
-- | Serialize a list of 'Int16's in little endian format.
fromInt16sle :: [Int16] -> Builder
fromInt16sle = P.primMapListFixed P.int16LE
{-# INLINE fromInt16sle #-}
-- | Serialize a list of 'Int32's in little endian format.
fromInt32sle :: [Int32] -> Builder
fromInt32sle = P.primMapListFixed P.int32LE
{-# INLINE fromInt32sle #-}
-- | Serialize a list of 'Int64's in little endian format.
fromInt64sle :: [Int64] -> Builder
fromInt64sle = P.primMapListFixed P.int64LE
{-# INLINE fromInt64sle #-}
-- | Serialize a single native machine 'Int'. The 'Int' is serialized in host
-- order, host endian form, for the machine you're on. On a 64 bit machine the
-- 'Int' is an 8 byte value, on a 32 bit machine, 4 bytes. Values written this
-- way are not portable to different endian or integer sized machines, without
-- conversion.
--
fromInthost :: Int -> Builder
fromInthost = B.intHost
{-# INLINE fromInthost #-}
-- | Write an 'Int16' in native host order and host endianness.
fromInt16host :: Int16 -> Builder
fromInt16host = B.int16Host
{-# INLINE fromInt16host #-}
-- | Write an 'Int32' in native host order and host endianness.
fromInt32host :: Int32 -> Builder
fromInt32host = B.int32Host
{-# INLINE fromInt32host #-}
-- | Write an 'Int64' in native host order and host endianness.
fromInt64host :: Int64 -> Builder
fromInt64host = B.int64Host
{-# INLINE fromInt64host #-}
-- | Serialize a list of 'Int's.
-- See 'fromInthost' for usage considerations.
fromIntshost :: [Int] -> Builder
fromIntshost = P.primMapListFixed P.intHost
{-# INLINE fromIntshost #-}
-- | Write a list of 'Int16's in native host order and host endianness.
fromInt16shost :: [Int16] -> Builder
fromInt16shost = P.primMapListFixed P.int16Host
{-# INLINE fromInt16shost #-}
-- | Write a list of 'Int32's in native host order and host endianness.
fromInt32shost :: [Int32] -> Builder
fromInt32shost = P.primMapListFixed P.int32Host
{-# INLINE fromInt32shost #-}
-- | Write a list of 'Int64's in native host order and host endianness.
fromInt64shost :: [Int64] -> Builder
fromInt64shost = P.primMapListFixed P.int64Host
{-# INLINE fromInt64shost #-}
blaze-builder-0.4.2.3/Blaze/ByteString/Builder/Internal/ 0000755 0000000 0000000 00000000000 07346545000 021061 5 ustar 00 0000000 0000000 blaze-builder-0.4.2.3/Blaze/ByteString/Builder/Internal/Write.hs 0000644 0000000 0000000 00000023255 07346545000 022516 0 ustar 00 0000000 0000000 {-# LANGUAGE CPP, BangPatterns #-}
-- |
-- Module : Blaze.ByteString.Builder.Internal.Poke
-- Copyright : (c) 2010 Simon Meier
-- (c) 2010 Jasper van der Jeugt
-- License : BSD3-style (see LICENSE)
--
-- Maintainer : https://github.com/blaze-builder
-- Stability : stable
-- 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.
--
-- FIXME: Improve documentation.
--
module Blaze.ByteString.Builder.Internal.Write (
-- * Poking a buffer
Poke(..)
, pokeN
-- * Writing to abuffer
, Write(..)
, runWrite
, getBound
, getBound'
, getPoke
, exactWrite
, boundedWrite
, writeLiftIO
, writeIf
, writeEq
, writeOrdering
, writeOrd
-- * Constructing builders from writes
, fromWrite
, fromWriteSingleton
, fromWriteList
-- * Writing 'Storable's
, writeStorable
, fromStorable
, fromStorables
) where
import Foreign
import qualified Data.Foldable as F
import Control.Monad
import Data.ByteString.Builder.Internal
#if !MIN_VERSION_base(4,8,0)
import Data.Monoid (Monoid(..))
#endif
import Data.Semigroup (Semigroup(..))
------------------------------------------------------------------------------
-- Poking a buffer and writing to a buffer
------------------------------------------------------------------------------
-- 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 Poke. 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.
--
-- | Changing a sequence of bytes starting from the given pointer. 'Poke's are
-- the most primitive buffer manipulation. In most cases, you don't use the
-- explicitly but as part of a 'Write', which also tells how many bytes will
-- be changed at most.
newtype Poke =
Poke { runPoke :: Ptr Word8 -> IO (Ptr Word8) }
-- | A write of a bounded number of bytes.
--
-- When defining a function @write :: a -> Write@ for some @a@, then it is
-- important to ensure that the bound on the number of bytes written is
-- data-independent. Formally,
--
-- @ forall x y. getBound (write x) = getBound (write y) @
--
-- The idea is that this data-independent bound is specified such that the
-- compiler can optimize the check, if there are enough free bytes in the buffer,
-- to a single subtraction between the pointer to the next free byte and the
-- pointer to the end of the buffer with this constant bound of the maximal
-- number of bytes to be written.
--
data Write = Write {-# UNPACK #-} !Int Poke
-- | Extract the 'Poke' action of a write.
{-# INLINE getPoke #-}
getPoke :: Write -> Poke
getPoke (Write _ wio) = wio
-- | Run the 'Poke' action of a write.
{-# INLINE runWrite #-}
runWrite :: Write -> Ptr Word8 -> IO (Ptr Word8)
runWrite = runPoke . getPoke
-- | Extract the maximal number of bytes that this write could write.
{-# INLINE getBound #-}
getBound :: Write -> Int
getBound (Write bound _) = bound
-- | Extract the maximal number of bytes that this write could write in any
-- case. Assumes that the bound of the write is data-independent.
{-# INLINE getBound' #-}
getBound' :: String -- ^ Name of caller: for debugging purposes.
-> (a -> Write)
-> Int
getBound' msg write =
getBound $ write $ error $
"getBound' called from " ++ msg ++ ": write bound is not data-independent."
instance Semigroup Poke where
{-# INLINE (<>) #-}
(Poke po1) <> (Poke po2) = Poke $ po1 >=> po2
{-# INLINE sconcat #-}
sconcat = F.foldr (<>) mempty
instance Monoid Poke where
{-# INLINE mempty #-}
mempty = Poke $ return
#if !(MIN_VERSION_base(4,11,0))
{-# INLINE mappend #-}
mappend = (<>)
{-# INLINE mconcat #-}
mconcat = F.foldr mappend mempty
#endif
instance Semigroup Write where
{-# INLINE (<>) #-}
(Write bound1 w1) <> (Write bound2 w2) =
Write (bound1 + bound2) (w1 <> w2)
{-# INLINE sconcat #-}
sconcat = F.foldr (<>) mempty
instance Monoid Write where
{-# INLINE mempty #-}
mempty = Write 0 mempty
#if !(MIN_VERSION_base(4,11,0))
{-# INLINE mappend #-}
mappend = (<>)
{-# INLINE mconcat #-}
mconcat = F.foldr mappend mempty
#endif
-- | @pokeN 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!
{-# INLINE pokeN #-}
pokeN :: Int
-> (Ptr Word8 -> IO ()) -> Poke
pokeN size io = Poke $ \op -> io op >> (return $! (op `plusPtr` size))
-- | @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!
{-# INLINE exactWrite #-}
exactWrite :: Int
-> (Ptr Word8 -> IO ())
-> Write
exactWrite size io = Write size (pokeN size io)
-- | @boundedWrite size write@ creates a bounded write from a @write@ that does
-- not write more than @size@ bytes.
{-# INLINE boundedWrite #-}
boundedWrite :: Int -> Poke -> Write
boundedWrite = Write
-- | @writeLiftIO io write@ creates a write executes the @io@ action to compute
-- the value that is then written.
{-# INLINE writeLiftIO #-}
writeLiftIO :: (a -> Write) -> IO a -> Write
writeLiftIO write io =
Write (getBound' "writeLiftIO" write)
(Poke $ \pf -> do x <- io; runWrite (write x) pf)
-- | @writeIf p wTrue wFalse x@ creates a 'Write' with a 'Poke' equal to @wTrue
-- x@, if @p x@ and equal to @wFalse x@ otherwise. The bound of this new
-- 'Write' is the maximum of the bounds for either 'Write'. This yields a data
-- independent bound, if the bound for @wTrue@ and @wFalse@ is already data
-- independent.
{-# INLINE writeIf #-}
writeIf :: (a -> Bool) -> (a -> Write) -> (a -> Write) -> (a -> Write)
writeIf p wTrue wFalse x =
boundedWrite (max (getBound $ wTrue x) (getBound $ wFalse x))
(if p x then getPoke $ wTrue x else getPoke $ wFalse x)
-- | Compare the value to a test value and use the first write action for the
-- equal case and the second write action for the non-equal case.
{-# INLINE writeEq #-}
writeEq :: Eq a => a -> (a -> Write) -> (a -> Write) -> (a -> Write)
writeEq test = writeIf (test ==)
-- | TODO: Test this. It might well be too difficult to use.
-- FIXME: Better name required!
{-# INLINE writeOrdering #-}
writeOrdering :: (a -> Ordering)
-> (a -> Write) -> (a -> Write) -> (a -> Write)
-> (a -> Write)
writeOrdering ord wLT wEQ wGT x =
boundedWrite bound (case ord x of LT -> getPoke $ wLT x;
EQ -> getPoke $ wEQ x;
GT -> getPoke $ wGT x)
where
bound = max (getBound $ wLT x) (max (getBound $ wEQ x) (getBound $ wGT x))
-- | A write combinator useful to build decision trees for deciding what value
-- to write with a constant bound on the maximal number of bytes written.
{-# INLINE writeOrd #-}
writeOrd :: Ord a
=> a
-> (a -> Write) -> (a -> Write) -> (a -> Write)
-> (a -> Write)
writeOrd test = writeOrdering (`compare` test)
-- | Create a builder that execute a single 'Write'.
{-# INLINE fromWrite #-}
fromWrite :: Write -> Builder
fromWrite (Write maxSize wio) =
builder step
where
step k (BufferRange op ope)
| op `plusPtr` maxSize <= ope = do
op' <- runPoke wio op
let !br' = BufferRange op' ope
k br'
| otherwise = return $ bufferFull maxSize op (step k)
{-# INLINE fromWriteSingleton #-}
fromWriteSingleton :: (a -> Write) -> (a -> Builder)
fromWriteSingleton write =
mkBuilder
where
mkBuilder x = builder step
where
step k (BufferRange op ope)
| op `plusPtr` maxSize <= ope = do
op' <- runPoke wio op
let !br' = BufferRange op' ope
k br'
| otherwise = return $ bufferFull maxSize op (step k)
where
Write maxSize wio = write x
-- | Construct a 'Builder' writing a list of data one element at a time.
fromWriteList :: (a -> Write) -> [a] -> Builder
fromWriteList write =
makeBuilder
where
makeBuilder xs0 = builder $ step xs0
where
step xs1 k !(BufferRange op0 ope0) = go xs1 op0
where
go [] !op = do
let !br' = BufferRange op ope0
k br'
go xs@(x':xs') !op
| op `plusPtr` maxSize <= ope0 = do
!op' <- runPoke 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
blaze-builder-0.4.2.3/Blaze/ByteString/Builder/Word.hs 0000644 0000000 0000000 00000022201 07346545000 020551 0 ustar 00 0000000 0000000 ------------------------------------------------------------------------------
-- |
-- Module: Blaze.ByteString.Builder.Word
-- Copyright: (c) 2013 Leon P Smith
-- License: BSD3
-- Maintainer: https://github.com/blaze-builder
-- Stability: stable
--
-- 'Write's and 'Builder's for serializing words.
--
-- Note that for serializing a three tuple @(x,y,z)@ of bytes (or other word
-- values) you should use the expression
--
-- > fromWrite $ writeWord8 x `mappend` writeWord8 y `mappend` writeWord z
--
-- instead of
--
-- > fromWord8 x `mappend` fromWord8 y `mappend` fromWord z
--
-- The first expression will result in a single atomic write of three bytes,
-- while the second expression will check for each byte, if there is free space
-- left in the output buffer. Coalescing these checks can improve performance
-- quite a bit, as long as you use it sensibly.
--
------------------------------------------------------------------------------
module Blaze.ByteString.Builder.Word
(
-- * Writing words to a buffer
writeWord8
-- ** Big-endian writes
, writeWord16be -- :: Word16 -> Write
, writeWord32be -- :: Word32 -> Write
, writeWord64be -- :: Word64 -> Write
-- ** Little-endian writes
, writeWord16le -- :: Word16 -> Write
, writeWord32le -- :: Word32 -> Write
, writeWord64le -- :: Word64 -> Write
-- ** Host-endian writes
, writeWordhost -- :: Word -> Write
, writeWord16host -- :: Word16 -> Write
, writeWord32host -- :: Word32 -> Write
, writeWord64host -- :: Word64 -> Write
-- * Creating builders from words
-- | We provide serialization functions both for singleton words as well as
-- for lists of words. Using these list serialization functions is /much/ faster
-- than using @mconcat . map fromWord/@, as the list serialization
-- functions use a tighter inner loop.
, fromWord8
, fromWord8s
-- ** Big-endian serialization
, fromWord16be -- :: Word16 -> Builder
, fromWord32be -- :: Word32 -> Builder
, fromWord64be -- :: Word64 -> Builder
, fromWord32sbe -- :: [Word32] -> Builder
, fromWord16sbe -- :: [Word16] -> Builder
, fromWord64sbe -- :: [Word64] -> Builder
-- ** Little-endian serialization
, fromWord16le -- :: Word16 -> Builder
, fromWord32le -- :: Word32 -> Builder
, fromWord64le -- :: Word64 -> Builder
, fromWord16sle -- :: [Word16] -> Builder
, fromWord32sle -- :: [Word32] -> Builder
, fromWord64sle -- :: [Word64] -> Builder
-- ** Host-endian serialization
, fromWordhost -- :: Word -> Builder
, fromWord16host -- :: Word16 -> Builder
, fromWord32host -- :: Word32 -> Builder
, fromWord64host -- :: Word64 -> Builder
, fromWordshost -- :: [Word] -> Builder
, fromWord16shost -- :: [Word16] -> Builder
, fromWord32shost -- :: [Word32] -> Builder
, fromWord64shost -- :: [Word64] -> Builder
) where
import Data.Word
import Blaze.ByteString.Builder.Compat.Write ( Write, writePrimFixed )
import Data.ByteString.Builder ( Builder )
import qualified Data.ByteString.Builder as B
import qualified Data.ByteString.Builder.Extra as B
import qualified Data.ByteString.Builder.Prim as P
-- | Write a single byte.
--
writeWord8 :: Word8 -> Write
writeWord8 = writePrimFixed P.word8
{-# INLINE writeWord8 #-}
-- | Write a 'Word16' in big endian format.
writeWord16be :: Word16 -> Write
writeWord16be = writePrimFixed P.word16BE
{-# INLINE writeWord16be #-}
-- | Write a 'Word32' in big endian format.
writeWord32be :: Word32 -> Write
writeWord32be = writePrimFixed P.word32BE
{-# INLINE writeWord32be #-}
-- | Write a 'Word64' in big endian format.
writeWord64be :: Word64 -> Write
writeWord64be = writePrimFixed P.word64BE
{-# INLINE writeWord64be #-}
-- | Write a 'Word16' in little endian format.
writeWord16le :: Word16 -> Write
writeWord16le = writePrimFixed P.word16LE
{-# INLINE writeWord16le #-}
-- | Write a 'Word32' in big endian format.
writeWord32le :: Word32 -> Write
writeWord32le = writePrimFixed P.word32LE
{-# INLINE writeWord32le #-}
-- | Write a 'Word64' in little endian format.
writeWord64le :: Word64 -> Write
writeWord64le = writePrimFixed P.word64LE
{-# INLINE writeWord64le #-}
-- | Write a single native machine 'Word'. The 'Word' is written in host order,
-- host endian form, for the machine you're on. On a 64 bit machine the 'Word'
-- is an 8 byte value, on a 32 bit machine, 4 bytes. Values written this way
-- are not portable to different endian or word sized machines, without
-- conversion.
--
writeWordhost :: Word -> Write
writeWordhost = writePrimFixed P.wordHost
{-# INLINE writeWordhost #-}
-- | Write a 'Word16' in native host order and host endianness.
writeWord16host :: Word16 -> Write
writeWord16host = writePrimFixed P.word16Host
{-# INLINE writeWord16host #-}
-- | Write a 'Word32' in native host order and host endianness.
writeWord32host :: Word32 -> Write
writeWord32host = writePrimFixed P.word32Host
{-# INLINE writeWord32host #-}
-- | Write a 'Word64' in native host order and host endianness.
writeWord64host :: Word64 -> Write
writeWord64host = writePrimFixed P.word64Host
{-# INLINE writeWord64host #-}
-- | Serialize a single byte.
fromWord8 :: Word8 -> Builder
fromWord8 = B.word8
{-# INLINE fromWord8 #-}
-- | Serialize a list of bytes.
fromWord8s :: [Word8] -> Builder
fromWord8s = P.primMapListFixed P.word8
{-# INLINE fromWord8s #-}
-- | Serialize a 'Word16' in big endian format.
fromWord16be :: Word16 -> Builder
fromWord16be = B.word16BE
{-# INLINE fromWord16be #-}
-- | Serialize a 'Word32' in big endian format.
fromWord32be :: Word32 -> Builder
fromWord32be = B.word32BE
{-# INLINE fromWord32be #-}
-- | Serialize a 'Word64' in big endian format.
fromWord64be :: Word64 -> Builder
fromWord64be = B.word64BE
{-# INLINE fromWord64be #-}
-- | Serialize a list of 'Word32's in big endian format.
fromWord32sbe :: [Word32] -> Builder
fromWord32sbe = P.primMapListFixed P.word32BE
{-# INLINE fromWord32sbe #-}
-- | Serialize a list of 'Word16's in big endian format.
fromWord16sbe :: [Word16] -> Builder
fromWord16sbe = P.primMapListFixed P.word16BE
{-# INLINE fromWord16sbe #-}
-- | Serialize a list of 'Word64's in big endian format.
fromWord64sbe :: [Word64] -> Builder
fromWord64sbe = P.primMapListFixed P.word64BE
{-# INLINE fromWord64sbe #-}
-- | Serialize a 'Word16' in little endian format.
fromWord16le :: Word16 -> Builder
fromWord16le = B.word16LE
{-# INLINE fromWord16le #-}
-- | Serialize a list of 'Word32's in little endian format.
fromWord32le :: Word32 -> Builder
fromWord32le = B.word32LE
{-# INLINE fromWord32le #-}
-- | Serialize a 'Word64' in little endian format.
fromWord64le :: Word64 -> Builder
fromWord64le = B.word64LE
{-# INLINE fromWord64le #-}
-- | Serialize a list of 'Word16's in little endian format.
fromWord16sle :: [Word16] -> Builder
fromWord16sle = P.primMapListFixed P.word16LE
{-# INLINE fromWord16sle #-}
-- | Serialize a list of 'Word32's in little endian format.
fromWord32sle :: [Word32] -> Builder
fromWord32sle = P.primMapListFixed P.word32LE
{-# INLINE fromWord32sle #-}
-- | Serialize a list of 'Word64's in little endian format.
fromWord64sle :: [Word64] -> Builder
fromWord64sle = P.primMapListFixed P.word64LE
{-# INLINE fromWord64sle #-}
-- | Serialize a single native machine 'Word'. The 'Word' is serialized in host
-- order, host endian form, for the machine you're on. On a 64 bit machine the
-- 'Word' is an 8 byte value, on a 32 bit machine, 4 bytes. Values written this
-- way are not portable to different endian or word sized machines, without
-- conversion.
fromWordhost :: Word -> Builder
fromWordhost = B.wordHost
{-# INLINE fromWordhost #-}
-- | Write a 'Word16' in native host order and host endianness.
fromWord16host :: Word16 -> Builder
fromWord16host = B.word16Host
{-# INLINE fromWord16host #-}
-- | Write a 'Word32' in native host order and host endianness.
fromWord32host :: Word32 -> Builder
fromWord32host = B.word32Host
{-# INLINE fromWord32host #-}
-- | Write a 'Word64' in native host order and host endianness.
fromWord64host :: Word64 -> Builder
fromWord64host = B.word64Host
{-# INLINE fromWord64host #-}
-- | Serialize a list of 'Word's.
-- See 'fromWordhost' for usage considerations.
fromWordshost :: [Word] -> Builder
fromWordshost = P.primMapListFixed P.wordHost
{-# INLINE fromWordshost #-}
-- | Write a list of 'Word16's in native host order and host endianness.
fromWord16shost :: [Word16] -> Builder
fromWord16shost = P.primMapListFixed P.word16Host
{-# INLINE fromWord16shost #-}
-- | Write a list of 'Word32's in native host order and host endianness.
fromWord32shost :: [Word32] -> Builder
fromWord32shost = P.primMapListFixed P.word32Host
{-# INLINE fromWord32shost #-}
-- | Write a 'Word64' in native host order and host endianness.
fromWord64shost :: [Word64] -> Builder
fromWord64shost = P.primMapListFixed P.word64Host
{-# INLINE fromWord64shost #-}
blaze-builder-0.4.2.3/CHANGES 0000644 0000000 0000000 00000013337 07346545000 013572 0 ustar 00 0000000 0000000 * 0.4.2.3 2023-08-27
- Fix compilation warnings concerning non-canonical mappend
- Support bytestring-0.12
- Support text-2.1
- Tested with GHC 7.0.4 to 9.8.1 alpha3
* 0.4.2.2
- Support GHC 9.2
* 0.4.2.1
- Bump cabal file to Cabal >= 1.10
* 0.4.2.0
- Make semigroup instances unconditional
- Support bytestring-0.11
- Support semigroups-0.19
* 0.4.1.0
- Gain compatibility with the Semigroup/Monoid proposal
- Add Word8 HTML escaping builders
- Speed up `fromHtmlEscapedText` and `fromHtmlEscapedLazyText`
* 0.4.0.2
- Fixed warnings on GHC 7.10, courtesy of Mikhail Glushenkov.
* 0.4.0.1
- Tightened the version constraints on the bytestring package for GHC 7.8
* 0.4.0.0
- This is now a compatibility shim for the new bytestring builder. Most
of the old internal modules are gone. See this blog post for more
information:
- The 'Blaze.ByteString.Builder.Html.Utf8.fromHtmlEscaped*' functions now
strip out any ASCII control characters present in their inputs. See
for more
information.
* 0.3.3.0
- exposed the 'Buffer' constructor to enable keeping around a pool of
buffers.
* 0.3.2.0
- added 'writeToByteString' to construct a strict bytestring in a single
step. We can actually view 'Write's as strict-bytestring builders.
* 0.3.1.1
- Changed imports of Foreign.Unsafe to make it GHC 7.8 compatible
- -Wall clean on GHC 7.0 - 7.6
* 0.3.1.0
- Widened dependencies on text and bytestring
* 0.3.0.1
- Fix build warning in Blaze.ByteString.Builder.Word
(contributed by Greg Weber)
* 0.3.0.1
- Remove comparison to the 'text' library encoding functions of
'Blaze.Builder.Char.Utf8.fromText' and
'Blaze.Builder.Char.Utf8.fromLazyText'. Bryan O'Sullivan reported that on
his 64-bit system with GHC 7.0.3 the 'text' library is 5x faster than the
'blaze-builder' library.
* 0.3.0.0
- Renamings in internal modules: WriteIO -> Poke and associated functions.
* 0.2.1.4
- Fixed bug: appending to 'chunkedTransferEncoding somebuilder' also encoded
the appended builder, which is obviously wrong.
* 0.2.1.3
- Fixed bug: 'chunkedTransferTerminator' is now correctly set to "0\r\n\r\n".
* 0.2.1.2
- Add 'MonoPatBinds' language extension to all relevant files to solve the
issues caused by GHC bug http://hackage.haskell.org/trac/ghc/ticket/4498
* 0.2.1.1
- Reexport 'Write' datatype and 'fromWriteList', 'fromWriteSingleton',
'fromWrite' functions together with writes and builders for storables.
- Add 'MonoPatBinds' language extension to (hopefully) solve the issues
caused by GHC bug http://hackage.haskell.org/trac/ghc/ticket/4498
* 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'
* 0.2.0.2
Fixed bug: use ' instead of ' for HTML escaping '
* 0.2.0.1
Added a missing benchmark file.
* blaze-builder-0.2.0.0
Heavily restructured 'blaze-builder' such that 'Blaze.ByteString.Builder' serves as
a drop-in replacement of 'binary:Data.Binary.Builder' which it improves upon
with respect to both speed as well as expressivity. See the documentation and
the benchmarks for details on improvements and new functionality.
Changed module structure:
Blaze.ByteString.Builder.Core -> Blaze.ByteString.Builder
Blaze.ByteString.Builder.Utf8 -> Blaze.ByteString.Builder.Char.Utf8
Blaze.ByteString.Builder.Html -> Blaze.ByteString.Builder.Html.Utf8
Changed function names:
writeByte -> writeWord8
fromByte -> fromWord8
fromWriteList -> fromWrite1List
Possibly performance sensitive implementation changes:
- 'fromByteString' and 'fromLazyByteString' check now if a direct insertion
of the bytestring(s) would be cheaper than copying it. See their
documentation on how to recover the old behaviour.
Deprecated functions:
'empty' : use 'mempty' instead
'singleton': use 'fromWord8' instead
'append' : use 'mappend' instead
* blaze-builder-0.1
This is the first version of 'blaze-builder'. It is explicitely targeted at
fast generation of UTF-8 encoded HTML documents in the 'blaze-html' and the
'hamlet' HTML templating libraries.
blaze-builder-0.4.2.3/LICENSE 0000644 0000000 0000000 00000003026 07346545000 013576 0 ustar 00 0000000 0000000 Copyright Jasper Van der Jeugt 2010, Simon Meier 2010 & 2011
All rights reserved.
Redistribution and use in source and binary forms, with or without
modification, are permitted provided that the following conditions are met:
* Redistributions of source code must retain the above copyright
notice, this list of conditions and the following disclaimer.
* Redistributions in binary form must reproduce the above
copyright notice, this list of conditions and the following
disclaimer in the documentation and/or other materials provided
with the distribution.
* Neither the name of Jasper Van der Jeugt nor the names of other
contributors may be used to endorse or promote products derived
from this software without specific prior written permission.
THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT
OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT
LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
blaze-builder-0.4.2.3/Makefile 0000644 0000000 0000000 00000013512 07346545000 014232 0 ustar 00 0000000 0000000
##############################################################################
## Benchmarks
##############################################################################
## Config
#########
GHC = ghc
GHCI = ghci
## All benchmarks
#################
bench-all: bench-compression bench-string-and-text bench-throughput bench-chunked-write
clean-bench-all:
rm -f benchmarks/*.o benchmarks/*.hi
rm -f benchmarks/Throughput/*.o benchmarks/Throughput/*.hi
rm -f Blaze/ByteString/Builder.o Blaze/ByteString/Builder.hi
rm -f Blaze/ByteString/Builder/*.o Blaze/ByteString/Builder/*.hi
rm -f Blaze/ByteString/Builder/Internal/*.o Blaze/ByteString/Builder/Internal/*.hi
rm -f Blaze/ByteString/Builder/Char/*.o Blaze/ByteString/Builder/Char/*.hi
rm -f Blaze/ByteString/Builder/Html/*.o Blaze/ByteString/Builder/Html/*.hi
rm -f Blaze/ByteString/Builder/Core/*.o Blaze/ByteString/Builder/Core/*.hi
rm -f benchmarks/Compression benchmarks/StringAndText benchmarks/BenchThroughput benchmarks/ChunkedWrite benchmarks/BlazeVsBinary
rm -f Criterion/*.o Criterion/*.hi
rm -f Criterion/ScalingBenchmark
## Individual benchmarks
########################
# utf8 writing to a file
utf8-io:
$(GHC) --make -O2 -fforce-recomp -main-is Utf8IO benchmarks/Utf8IO.hs
time ./benchmarks/Utf8IO via-text 100000000 /dev/null
time ./benchmarks/Utf8IO text 100000000 /dev/null
time ./benchmarks/Utf8IO blaze 100000000 /dev/null
time ./benchmarks/Utf8IO base 100000000 /dev/null
time ./benchmarks/Utf8IO utf8-light 100000000 /dev/null
time ./benchmarks/Utf8IO utf8-string 100000000 /dev/null
# 'blaze-builder' vs. 'binary' comparision
bench-blaze-vs-binary:
$(GHC) --make -O2 -fforce-recomp -main-is BlazeVsBinary benchmarks/BlazeVsBinary.hs
./benchmarks/BlazeVsBinary --resamples 10000
# throughput benchmarks: interactive development
ghci-throughput: benchmarks/Throughput/CBenchmark.o
$(GHCI) -O2 -fforce-recomp -ibenchmarks -main-is BenchThroughput benchmarks/Throughput/CBenchmark.o benchmarks/BenchThroughput.hs
bench-throughput: benchmarks/Throughput/CBenchmark.o
$(GHC) --make -O2 -fforce-recomp -fliberate-case-threshold=1000 -ibenchmarks -main-is BenchThroughput benchmarks/Throughput/CBenchmark.o benchmarks/BenchThroughput.hs
./benchmarks/BenchThroughput 100
benchmarks/Throughput/CBenchmark.o: benchmarks/Throughput/CBenchmark.c
gcc -O3 -c $< -o $@
# Benchmark benefit of serializing several list elements at once
bench-chunked-write:
$(GHC) --make -O2 -fforce-recomp -main-is ChunkedWrite benchmarks/ChunkedWrite.hs
./benchmarks/ChunkedWrite --resamples 10000
core-chunked-write:
ghc-core -- --make -O2 -fforce-recomp -main-is ChunkedWrite benchmarks/ChunkedWrite.hs
# Benchmark best serialization techniques for 'String' and 'Text'
bench-string-and-text:
$(GHC) --make -O2 -fforce-recomp -ibenchmarks -main-is StringAndText StringAndText
echo $(GHC)
./benchmarks/StringAndText --resamples 10000
# Benchmark benefit of compaction before compression
bench-compression:
$(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
core-lazy-bytestring:
ghc-core -- --make -O2 -fforce-recomp -ibenchmarks -main-is LazyByteString LazyByteString
# 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
##############################################################################
plot-all:
$(GHC) --make -O2 -fforce-recomp -main-is Criterion.ScalingBenchmark Criterion.ScalingBenchmark
./Criterion/ScalingBenchmark --resamples 10000
##############################################################################
## Tests
##############################################################################
test:
$(GHC) --make -fforce-recomp -O2 -itests -main-is Tests Tests
./tests/Tests
clean-tests:
rm -f tests/Tests tests/*.o tests/*.hi
ghci-llvm-segfault:
$(GHCI) -itests -main-is LlvmSegfault tests/LlvmSegfault
test-llvm-segfault:
ghc-7.0.0.20100924 --make -fllvm -itests -main-is LlvmSegfault tests/LlvmSegfault
./tests/LlvmSegfault
##############################################################################
## All inclusive targets
##############################################################################
clean: clean-tests clean-bench-all
blaze-builder-0.4.2.3/README.markdown 0000644 0000000 0000000 00000003774 07346545000 015304 0 ustar 00 0000000 0000000 [](http://hackage.haskell.org/package/blaze-builder)
[](https://stackage.org/nightly/package/blaze-builder)
[](https://www.stackage.org/package/blaze-builder)
[](https://github.com/blaze-builder/blaze-builder/actions)
blaze-builder
=============
This library allows to efficiently serialize Haskell values to lazy bytestrings
with a large average chunk size. The large average chunk size allows to make
good use of cache prefetching in later processing steps (e.g. compression) and
reduces the system call overhead when writing the resulting lazy bytestring to a
file or sending it over the network.
This library was inspired by the module `Data.Binary.Builder` provided by the
`binary` package. It was originally developed with the specific needs of the
`blaze-html` package in mind. Since then it has been restructured to serve as a
drop-in replacement for `Data.Binary.Builder`, which it improves upon both in
speed as well as expressivity.
To see the improvements in speed, run the throughput benchmark, which measures
serialization speeds for writing `Word8`, `Word16`, `Word32` and `Word64` in different
endian formats and different chunk sizes, using the command
```
make bench-throughput
```
or run the list serialization comparison benchmark
```
make bench-blaze-vs-binary
```
Checkout the combinators in the module `Blaze.ByteString.Builder.Write` to see
the improvements in expressivity. This module allows to incorporate efficient
primitive buffer manipulations as parts of a builder. We use this facility
in the `blaze-html` HTML templating library to allow for the efficient
serialization of HTML escaped and UTF-8 encoded characters.
blaze-builder-0.4.2.3/Setup.hs 0000644 0000000 0000000 00000000056 07346545000 014225 0 ustar 00 0000000 0000000 import Distribution.Simple
main = defaultMain
blaze-builder-0.4.2.3/TODO 0000644 0000000 0000000 00000006653 07346545000 013272 0 ustar 00 0000000 0000000
!! UPDATE TODO !!
!! UPDATE BENCHMARKS !!
* custom serialization functions for lists of 'WordX's
- benchmark chunk size speedup for more complicated computations of list
elements => to be expected that we get no speedup anymore or even a
slowdown => adapt Blaze.ByteString.Builder.Word accordingly.
* fast serialization for 'Text' values (currently unpacking to 'String' is
the fastest :-/)
* implementation
- further encodings for 'Char'
- think about end-of-buffer wrapping when copying bytestrings
- toByteStringIO with accumulator capability => provide 'toByteStringIO_'
- allow buildr/foldr deforestation to happen for input to 'fromWriteList'
(or whatever stream fusion framework is in place for lists)
- implement 'toByteString' with an amortized O(n) runtime using the
exponentional scaling trick. If the start size is chosen wisely this
may even be faster than 'S.pack', as the one copy per element is
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
* benchmarks
- understand why the declarative blaze-builder version is the fastest
serializer for Word64 little-endian and big-endian
- check the cost of using `mappend` on builders instead of writes.
- show that using toByteStringIO has an advantage over toLazyByteString
- check performance of toByteStringIO
- compare speed of 'L.pack' to speed of 'toLazyByteString . fromWord8s'
* documentation
- sort out formultion: "serialization" vs. "encoding"
* check portability to Hugs
* performance:
- check if reordering 'pe' and 'pf' change performance; it seems that 'pe'
is only a reader argument while 'pf' is a state argument.
- perhaps we could improve performance by taking page size, page
alignment, and memory access alignment into account.
- detect machine endianness and use host order writes for the supported
endianness.
- introduce a type 'BoundedWrite' that encapsulates a 'Write' generator
with a bound on the number of bytes maximally written by the write.
This way we can achieve data independence for the size check by
sacrificing just a little bit of buffer space at buffer ends.
- investigate where we would profit from static bounds on number of bytes
written (e.g. to make the control flow more linear)
* testing
- port tests from 'Data.Binary.Builder' to ensure that the word writes
and builders are working correctly. I may have missed some pitfalls
about word types in Haskell during porting the functions from
'Data.Binary.Builder'.
* portability
- port to Hugs
- test lower versions of GHC
* deployment
- add source repository to 'blaze-html' and 'blaze-builder' cabal files
blaze-builder-0.4.2.3/benchmarks/ 0000755 0000000 0000000 00000000000 07346545000 014705 5 ustar 00 0000000 0000000 blaze-builder-0.4.2.3/benchmarks/BenchThroughput.hs 0000644 0000000 0000000 00000016400 07346545000 020353 0 ustar 00 0000000 0000000 -----------------------------------------------------------------------------
-- |
-- Module : BenchThroughput
-- Copyright : Simon Meier
-- License : BSD3-style (see LICENSE)
--
-- Maintainer : https://github.com/blaze-builder
-- Stability : stable
-- Portability : GHC
--
-- This benchmark is based on 'tests/Benchmark.hs' from the 'binary-0.5.0.2'
-- package.
--
-- Benchmark the throughput of 'blaze-builder' and 'binary' for serializing
-- sequences of 'Word8' .. 'Word64' values in little-endian, big-endian, and
-- "host-endian" formats.
--
-- The results on a Core2 Duo T7500 with Linux 2.6.32-24 i686 and GHC 6.12.3
-- are as follows:
--
-- Using the Blaze.Builder directly (i.e. not encapsulated in a writer monad
-- as Put is doing it) gives the best scalability. Up to 'Word32', it holds
-- that the bigger the chunk size, the bigger the relative speedup of using
-- the Blaze.Builder. For 'Word64', the speedup is not as impressive.
-- Probably due to the more expensive writes.
--
-----------------------------------------------------------------------------
module BenchThroughput (main) where
import qualified Throughput.BinaryBuilder as BinaryBuilder
import qualified Throughput.BinaryPut as BinaryPut
import qualified Throughput.BinaryBuilderDeclarative as BinaryBuilderDecl
import qualified Throughput.BlazeBuilder as BlazeBuilder
import qualified Throughput.BlazePut as BlazePut
import qualified Throughput.BlazeBuilderDeclarative as BlazeBuilderDecl
import Throughput.Utils
import Throughput.Memory
import qualified Data.ByteString.Lazy as L
import Debug.Trace
import Data.Binary
import Data.Binary.Put
import Data.Binary.Get
import Control.Exception
import Control.Monad
import System.CPUTime
import Numeric
import Text.Printf
import System.Environment
import System.IO
import Data.Maybe
import Data.Accessor
import Data.Colour
import Data.Colour.Names
import Graphics.Rendering.Chart
import Graphics.Rendering.Chart.Gtk
-- The different serialization functions
----------------------------------------
supportAllSizes f wS cS e i = return $ f wS cS e i
blazeLineStyle = solidLine 1 . opaque
binaryLineStyle = dashedLine 1 [5, 5] . opaque
blazeBuilder =
( "BlazeBuilder"
, blazeLineStyle green
, supportAllSizes $ BlazeBuilder.serialize)
blazeBuilderDecl =
( "BlazeBuilderDecl"
, blazeLineStyle blue
, supportAllSizes $ BlazeBuilderDecl.serialize)
blazePut =
( "BlazePut"
, blazeLineStyle red
, supportAllSizes $ BlazePut.serialize)
binaryBuilder =
( "BinaryBuilder"
, binaryLineStyle green
, supportAllSizes $ BinaryBuilder.serialize)
binaryBuilderDecl =
( "BinaryBuilderDecl"
, binaryLineStyle blue
, BinaryBuilderDecl.serialize)
binaryPut =
( "BinaryPut"
, binaryLineStyle red
, supportAllSizes $ BinaryPut.serialize)
main :: IO ()
main = do
mb <- getArgs >>= readIO . head
-- memBench (mb*10)
putStrLn ""
putStrLn "Binary serialisation benchmarks:"
-- do bytewise
-- sequence_
-- [ test wordSize chunkSize Host mb
-- | wordSize <- [1]
-- , chunkSize <- [1,2,4,8,16]
-- ]
-- now Word16 .. Word64
let lift f wS cS e i = return $ f wS cS e i
serializers =
[ blazeBuilder , blazeBuilderDecl , blazePut
, binaryBuilder, binaryBuilderDecl, binaryPut
]
wordSizes = [1,2,4,8]
chunkSizes = [1,2,4,8,16]
endians = [Host,Big,Little]
let compares =
[ compareResults serialize wordSize chunkSize end mb
| wordSize <- wordSizes
, chunkSize <- chunkSizes
, end <- endians
, serialize <- serializers
, wordSize /= 1 || end == Host -- no endianess for Word8
]
-- putStrLn "checking equality of serialization results:"
-- sequence_ compares
let serializes =
[ [ ( serialize
, [ (chunkSize, test serialize wordSize chunkSize end mb)
| chunkSize <- [1,2,4,8,16]
]
)
| serialize <- serializers
]
| wordSize <- [1,2,4,8]
, end <- [Host,Big,Little]
, wordSize /= 1 || end == Host -- no endianess for Word8
]
putStrLn "\n\nbenchmarking serialization speed:"
results <- mapM mkChart serializes
print results
mkChart :: [((String,CairoLineStyle,a), [(Int, IO (Maybe Double))])] -> IO ()
mkChart task = do
lines <- catMaybes `liftM` mapM measureSerializer task
let plottedLines = flip map lines $ \ ((name,lineStyle,_), points) ->
plot_lines_title ^= name $
plot_lines_style ^= lineStyle $
plot_lines_values ^= [points] $
defaultPlotLines
let layout =
defaultLayout1
{ layout1_plots_ = map (Right . toPlot) plottedLines }
return ()
-- renderableToWindow (toRenderable layout) 640 480
measureSerializer :: (a, [(Int, IO (Maybe Double))]) -> IO (Maybe (a, [(Int,Double)]))
measureSerializer (info, tests) = do
optPoints <- forM tests $ \ (x, test) -> do
optY <- test
case optY of
Nothing -> return Nothing
Just y -> return $ Just (x, y)
case catMaybes optPoints of
[] -> return Nothing
points -> return $ Just (info, points)
------------------------------------------------------------------------
time :: IO a -> IO Double
time action = do
start <- getCPUTime
action
end <- getCPUTime
return $! (fromIntegral (end - start)) / (10^12)
------------------------------------------------------------------------
test :: (String, a, Int -> Int -> Endian -> Int -> Maybe L.ByteString)
-> Int -> Int -> Endian -> Int -> IO (Maybe Double)
test (serializeName, _, serialize) wordSize chunkSize end mb = do
let bytes :: Int
bytes = mb * 2^20
iterations = bytes `div` wordSize
case serialize wordSize chunkSize end iterations of
Nothing -> return Nothing
Just bs -> do
_ <- printf "%17s: %dMB of Word%-2d in chunks of %2d (%6s endian):"
serializeName (mb :: Int) (8 * wordSize :: Int) (chunkSize :: Int) (show end)
putSeconds <- time $ evaluate (L.length bs)
-- getSeconds <- time $ evaluate sum
-- print (L.length bs, sum)
let putThroughput = fromIntegral mb / putSeconds
-- getThroughput = fromIntegral mb / getSeconds
_ <- printf "%6.1f MB/s write\n"
putThroughput
-- getThroughput
-- (getThroughput/putThroughput)
hFlush stdout
return $ Just putThroughput
------------------------------------------------------------------------
compareResults :: (String, a, Int -> Int -> Endian -> Int -> Maybe L.ByteString)
-> Int -> Int -> Endian -> Int -> IO ()
compareResults (serializeName, _, serialize) wordSize chunkSize end mb0 = do
let mb :: Int
mb = max 1 (mb0 `div` 100)
bytes :: Int
bytes = mb * 2^20
iterations = bytes `div` wordSize
bs0 = BinaryBuilder.serialize wordSize chunkSize end iterations
case serialize wordSize chunkSize end iterations of
Nothing -> return ()
Just bs1 -> do
_ <- printf "%17s: %dMB of Word%-2d in chunks of %2d (%6s endian):"
serializeName (mb :: Int) (8 * wordSize :: Int) (chunkSize :: Int) (show end)
if (bs0 == bs1)
then putStrLn " Ok"
else putStrLn " Failed"
hFlush stdout
blaze-builder-0.4.2.3/benchmarks/BenchmarkServer.hs 0000644 0000000 0000000 00000006270 07346545000 020327 0 ustar 00 0000000 0000000 {- Benchmark server based upon Jasper van der Jeugt's 'BenchmarkServer.lhs'
from blaze-html. Modified for network-2.3 by Simon Meier
-}
{-# LANGUAGE OverloadedStrings #-}
module BenchmarkServer where
import Prelude hiding (putStrLn)
import Data.Char (ord)
import Data.Monoid
import Data.ByteString.Char8 () -- IsString instance only
import qualified Data.ByteString as S
import qualified Data.ByteString.Lazy as L
import qualified Data.ByteString.Lazy.Internal as L
import Control.Concurrent (forkIO, putMVar, takeMVar, newEmptyMVar)
import Control.Exception (bracket)
import Control.Monad
import Network.Socket (Socket, accept, sClose)
import Network (listenOn, PortID (PortNumber))
import Network.Socket.ByteString as S
import Network.Socket.ByteString.Lazy as L
import System (getArgs)
import Blaze.ByteString.Builder
import Blaze.ByteString.Builder.Internal (defaultBufferSize, defaultMinimalBufferSize)
import Blaze.ByteString.Builder.Char.Utf8
import Criterion.Main
httpOkHeader :: S.ByteString
httpOkHeader = S.concat
[ "HTTP/1.1 200 OK\r\n"
, "Content-Type: text/html; charset=UTF-8\r\n"
, "\r\n" ]
response :: Int -> Builder
response n =
fromByteString httpOkHeader `mappend`
fromString (take n $ cycle "hello λ-world! ")
sendVectoredBuilderLBS :: Socket -> Builder -> IO ()
sendVectoredBuilderLBS s = L.sendAll s . toLazyByteString
{-# NOINLINE sendVectoredBuilderLBS #-}
sendBuilderLBS :: Socket -> Builder -> IO ()
sendBuilderLBS s =
-- mapM_ (S.sendAll s) . L.toChunks . toLazyByteString
L.foldrChunks (\c -> (S.sendAll s c >>)) (return ()). toLazyByteString
{-# NOINLINE sendBuilderLBS #-}
sendBuilderBSIO :: Socket -> Builder -> IO ()
sendBuilderBSIO s = toByteStringIO $ S.sendAll s
{-# NOINLINE sendBuilderBSIO #-}
-- criterion benchmark determining the speed of response
main2 = defaultMain
[ bench ("response " ++ show n) $ whnf
(L.length . toLazyByteString . response) n
]
where
n :: Int
n = 1000000
main :: IO ()
main = do
[port, nChars] <- map read `liftM` getArgs
killSignal <- newEmptyMVar
bracket (listenOn . PortNumber . fromIntegral $ port) sClose
(\socket -> do
_ <- forkIO $ loop (putMVar killSignal ()) nChars socket
takeMVar killSignal)
where
loop killServer nChars socket = forever $ do
(s, _) <- accept socket
forkIO (respond s nChars)
where
respond s n = do
input <- S.recv s 1024
let requestUrl = (S.split (fromIntegral $ ord ' ') input) !! 1
case tail (S.split (fromIntegral $ ord '/') requestUrl) of
["lbs"] -> sendBuilderLBS s $ response n
["lbs-vec"] -> sendVectoredBuilderLBS s $ response n
["bs-io"] -> sendBuilderBSIO s $ response n
["kill"] -> notFound s >> killServer
_ -> notFound s
sClose s
notFound s = do
_ <- S.sendAll s $ "HTTP/1.1 404 Not Found\r\n"
`mappend` "Content-Type: text/html; charset=UTF-8\r\n"
`mappend` "\r\n"
`mappend` "Page not found
"
return ()
blaze-builder-0.4.2.3/benchmarks/BlazeVsBinary.hs 0000644 0000000 0000000 00000005110 07346545000 017751 0 ustar 00 0000000 0000000 {-# LANGUAGE OverloadedStrings #-}
-- |
-- Module : BlazeVsBinary
-- Copyright : (c) 2010 Jasper Van der Jeught & Simon Meier
-- License : BSD3-style (see LICENSE)
--
-- Maintainer : https://github.com/blaze-builder
-- Stability : stable
-- Portability : tested on GHC only
--
-- A comparison between 'blaze-builder' and the Data.Binary.Builder from
-- 'binary'. The goal is to measure the performance on serializing dynamic
-- data referenced by a list.
--
-- Note that some of the benchmarks are a bit unfair with respect to
-- blaze-builder, as it does more than 'binary':
--
-- 1. It encodes chars as utf-8 strings and does not just truncate character
-- value to one byte.
--
-- 2. It copies the contents of the lazy bytestring chunks if they are
-- shorter than 4kb. This ensures efficient processing of the resulting
-- lazy bytestring. 'binary' just inserts the chunks directly in the
-- resulting output stream.
--
module BlazeVsBinary where
import Data.Char (ord)
import Data.Monoid (mconcat)
import Data.Word (Word8)
import qualified Data.Binary.Builder as Binary
import Criterion.Main
import qualified Data.ByteString.Lazy as L
import qualified Data.ByteString as S
import Data.Text (Text)
import Data.Text.Encoding (encodeUtf8)
import qualified Blaze.ByteString.Builder as Blaze
import qualified Blaze.ByteString.Builder.Char.Utf8 as Blaze
main :: IO ()
main = defaultMain $ concat
[ benchmark "[String]"
(mconcat . map (mconcat . (map $ Binary.singleton . fromIntegral . ord)))
(mconcat . map Blaze.fromString)
strings
, benchmark "L.ByteString"
(Binary.fromLazyByteString)
(Blaze.fromLazyByteString)
byteStrings
, benchmark "[Text]"
(mconcat . map (Binary.fromByteString . encodeUtf8))
(mconcat . map Blaze.fromText)
texts
, benchmark "[Word8]"
(mconcat . map Binary.singleton)
(Blaze.fromWord8s)
word8s
]
where
benchmark name binaryF blazeF x =
[ bench (name ++ " (Data.Binary builder)") $
whnf (L.length . Binary.toLazyByteString . binaryF) x
, bench (name ++ " (blaze builder)") $
whnf (L.length . Blaze.toLazyByteString . blazeF) x
]
strings :: [String]
strings = replicate 10000 "![]()
"
{-# NOINLINE strings #-}
byteStrings :: L.ByteString
byteStrings = L.fromChunks $ replicate 10000 "![]()
"
{-# NOINLINE byteStrings #-}
texts :: [Text]
texts = replicate 10000 "![]()
"
{-# NOINLINE texts #-}
word8s :: [Word8]
word8s = replicate 10000 $ fromIntegral $ ord 'a'
{-# NOINLINE word8s #-}
blaze-builder-0.4.2.3/benchmarks/BoundedWrite.hs 0000644 0000000 0000000 00000020507 07346545000 017640 0 ustar 00 0000000 0000000 {-# LANGUAGE CPP, BangPatterns #-}
-- |
-- Module : BoundedWrite
-- Copyright : (c) 2010 Simon Meier
-- License : BSD3-style (see LICENSE)
--
-- Maintainer : https://github.com/blaze-builder
-- Stability : stable
-- 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 #-}
blaze-builder-0.4.2.3/benchmarks/BuilderBufferRange.hs 0000644 0000000 0000000 00000043232 07346545000 020742 0 ustar 00 0000000 0000000 {-# LANGUAGE CPP, BangPatterns #-}
-- |
-- Module : BuilderBufferRange
-- Copyright : (c) 2010 Simon Meier
-- License : BSD3-style (see LICENSE)
--
-- Maintainer : https://github.com/blaze-builder
-- Stability : stable
-- 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 #-}
-}
blaze-builder-0.4.2.3/benchmarks/ChunkedWrite.hs 0000644 0000000 0000000 00000013006 07346545000 017635 0 ustar 00 0000000 0000000 {-# LANGUAGE OverloadedStrings #-}
-- |
-- Module : ChunkedWrite
-- Copyright : (c) 2010 Simon Meier
-- License : BSD3-style (see LICENSE)
--
-- Maintainer : https://github.com/blaze-builder
-- Stability : stable
-- Portability : tested on GHC only
--
-- Test different strategies for writing lists of simple values:
--
-- 1. Using 'mconcat . map from'
--
-- 2. Using the specialized 'fromWriteList' function where 'n' denotes
-- the number of elements to write at the same time. Writing chunks of
-- elements reduces the overhead from the buffer overflow test that has
-- to be done before every write.
--
module ChunkedWrite where
import Data.Char (chr)
import Data.Int (Int64)
import Data.Word (Word8, Word32)
import Data.Monoid
import Criterion.Main
import qualified Data.ByteString.Lazy as L
import qualified Data.ByteString as S
import qualified Blaze.ByteString.Builder as BB
import qualified Blaze.ByteString.Builder.Char.Utf8 as BB
main :: IO ()
main = defaultMain
[ bench "S.pack: [Word8] -> S.ByteString" $
whnf (S.pack) word8s
, bench "toByteString . fromWord8s: [Word8] -> Builder -> S.ByteString" $
whnf (BB.toByteString . BB.fromWord8s) word8s
, bench "L.pack: [Word8] -> L.ByteString" $
whnf (L.length . L.pack) word8s
, bench "mconcat . map fromByte: [Word8] -> Builder -> L.ByteString" $
whnf benchMConcatWord8s word8s
, bench "fromWrite1List: [Word8] -> Builder -> L.ByteString" $
whnf bench1Word8s word8s
, bench "fromWrite2List: [Word8] -> Builder -> L.ByteString" $
whnf bench2Word8s word8s
, bench "fromWrite4List: [Word8] -> Builder -> L.ByteString" $
whnf bench4Word8s word8s
, bench "fromWrite8List: [Word8] -> Builder -> L.ByteString" $
whnf bench8Word8s word8s
, bench "fromWrite16List: [Word8] -> Builder -> L.ByteString" $
whnf bench16Word8s word8s
, bench "mconcat . map fromByte: [Char] -> Builder -> L.ByteString" $
whnf benchMConcatChars chars
, bench "fromWrite1List: [Char] -> Builder -> L.ByteString" $
whnf bench1Chars chars
, bench "fromWrite2List: [Char] -> Builder -> L.ByteString" $
whnf bench2Chars chars
, bench "fromWrite4List: [Char] -> Builder -> L.ByteString" $
whnf bench4Chars chars
, bench "fromWrite8List: [Char] -> Builder -> L.ByteString" $
whnf bench8Chars chars
, bench "fromWrite16List: [Char] -> Builder -> L.ByteString" $
whnf bench16Chars chars
, bench "mconcat . map fromWord32host: [Word32] -> Builder -> L.ByteString" $
whnf benchMConcatWord32s word32s
, bench "fromWrite1List: [Word32] -> Builder -> L.ByteString" $
whnf bench1Word32s word32s
, bench "fromWrite2List: [Word32] -> Builder -> L.ByteString" $
whnf bench2Word32s word32s
, bench "fromWrite4List: [Word32] -> Builder -> L.ByteString" $
whnf bench4Word32s word32s
, bench "fromWrite8List: [Word32] -> Builder -> L.ByteString" $
whnf bench8Word32s word32s
, bench "fromWrite16List: [Word32] -> Builder -> L.ByteString" $
whnf bench16Word32s word32s
]
where
n = 100000
word8s :: [Word8]
word8s = take n $ map fromIntegral $ [(1::Int)..]
{-# NOINLINE word8s #-}
word32s :: [Word32]
word32s = take n $ [1..]
{-# NOINLINE word32s #-}
chars :: String
chars = take n $ map (chr . fromIntegral) $ word8s
{-# NOINLINE chars #-}
-- Char
benchMConcatChars :: [Char] -> Int64
benchMConcatChars = L.length . BB.toLazyByteString . mconcat . map BB.fromChar
bench1Chars :: [Char] -> Int64
bench1Chars = L.length . BB.toLazyByteString . BB.fromWrite1List BB.writeChar
bench2Chars :: [Char] -> Int64
bench2Chars = L.length . BB.toLazyByteString . BB.fromWrite2List BB.writeChar
bench4Chars :: [Char] -> Int64
bench4Chars = L.length . BB.toLazyByteString . BB.fromWrite4List BB.writeChar
bench8Chars :: [Char] -> Int64
bench8Chars = L.length . BB.toLazyByteString . BB.fromWrite8List BB.writeChar
bench16Chars :: [Char] -> Int64
bench16Chars = L.length . BB.toLazyByteString . BB.fromWrite16List BB.writeChar
-- Word8
benchMConcatWord8s :: [Word8] -> Int64
benchMConcatWord8s = L.length . BB.toLazyByteString . mconcat . map BB.fromWord8
bench1Word8s :: [Word8] -> Int64
bench1Word8s = L.length . BB.toLazyByteString . BB.fromWrite1List BB.writeWord8
bench2Word8s :: [Word8] -> Int64
bench2Word8s = L.length . BB.toLazyByteString . BB.fromWrite2List BB.writeWord8
bench4Word8s :: [Word8] -> Int64
bench4Word8s = L.length . BB.toLazyByteString . BB.fromWrite4List BB.writeWord8
bench8Word8s :: [Word8] -> Int64
bench8Word8s = L.length . BB.toLazyByteString . BB.fromWrite8List BB.writeWord8
bench16Word8s :: [Word8] -> Int64
bench16Word8s = L.length . BB.toLazyByteString . BB.fromWrite16List BB.writeWord8
-- Word32
benchMConcatWord32s :: [Word32] -> Int64
benchMConcatWord32s = L.length . BB.toLazyByteString . mconcat . map BB.fromWord32host
bench1Word32s :: [Word32] -> Int64
bench1Word32s = L.length . BB.toLazyByteString . BB.fromWrite1List BB.writeWord32host
bench2Word32s :: [Word32] -> Int64
bench2Word32s = L.length . BB.toLazyByteString . BB.fromWrite2List BB.writeWord32host
bench4Word32s :: [Word32] -> Int64
bench4Word32s = L.length . BB.toLazyByteString . BB.fromWrite4List BB.writeWord32host
bench8Word32s :: [Word32] -> Int64
bench8Word32s = L.length . BB.toLazyByteString . BB.fromWrite8List BB.writeWord32host
bench16Word32s :: [Word32] -> Int64
bench16Word32s = L.length . BB.toLazyByteString . BB.fromWrite16List BB.writeWord32host
blaze-builder-0.4.2.3/benchmarks/Compression.hs 0000644 0000000 0000000 00000003344 07346545000 017546 0 ustar 00 0000000 0000000 -- |
-- Module : Compression
-- Copyright : (c) 2010 Simon Meier
-- License : BSD3-style (see LICENSE)
--
-- Maintainer : https://github.com/blaze-builder
-- Stability : stable
-- Portability : tested on GHC only
--
-- Benchmark the effect of first compacting the input stream for the 'zlib'
-- compression package.
--
-- On a Core2 Duo T7500 with Linux 2.6.32-24 i686 and GHC 6.12.3 compacting
-- first is worth its price up to chunks of 2kb size. Hence, in most
-- serialization scenarios it is better to first use a builder and only then
-- compress the output.
--
module Compression where
import Data.Int
import Data.Monoid (mconcat, mappend)
import Criterion.Main
import qualified Data.ByteString.Lazy as L
import qualified Data.ByteString.Char8 as S
import qualified Blaze.ByteString.Builder as B
import Codec.Compression.GZip
main = defaultMain
[ bench "compress directly (chunksize 10)" $
whnf benchCompressDirectly byteString10
, bench "compress compacted (chunksize 10)" $
whnf benchCompressCompacted byteString10
, bench "compress directly (chunksize 2kb)" $
whnf benchCompressDirectly byteString2kb
, bench "compress compacted (chunksize 2kb)" $
whnf benchCompressCompacted byteString2kb
]
where
n = 100000
byteString10 = L.fromChunks $ replicate n $ S.pack $ take 10 ['\x0'..]
{-# NOINLINE byteString10 #-}
byteString2kb = L.fromChunks $ replicate (n `div` 200) $ S.pack $ take 2048 ['\x0'..]
{-# NOINLINE byteString2kb #-}
benchCompressDirectly :: L.ByteString -> Int64
benchCompressDirectly = L.length . compress
benchCompressCompacted :: L.ByteString -> Int64
benchCompressCompacted =
L.length . compress . B.toLazyByteString . B.fromLazyByteString
blaze-builder-0.4.2.3/benchmarks/FastPut.hs 0000644 0000000 0000000 00000060506 07346545000 016636 0 ustar 00 0000000 0000000 {-# LANGUAGE CPP, BangPatterns, Rank2Types #-}
-- |
-- Module : FastPut
-- Copyright : (c) 2010 Simon Meier
-- License : BSD3-style (see LICENSE)
--
-- Maintainer : https://github.com/blaze-builder
-- Stability : stable
-- 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
-- remaining 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
]
blaze-builder-0.4.2.3/benchmarks/LazyByteString.hs 0000644 0000000 0000000 00000066124 07346545000 020204 0 ustar 00 0000000 0000000 {-# LANGUAGE BangPatterns, OverloadedStrings #-}
-- |
-- Module : LazyByteString
-- Copyright : (c) 2010 Simon Meier
-- License : BSD3-style (see LICENSE)
--
-- Maintainer : https://github.com/blaze-builder
-- Stability : stable
-- 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.Char
import Data.Word
import Data.Monoid
import Data.List
import Control.Monad
import Control.Arrow (second)
import Criterion.Main
import Foreign
import qualified Data.ByteString as S
import qualified Data.ByteString.Unsafe 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 Data.ByteString.Base64
import Blaze.ByteString.Builder.Internal
import Blaze.ByteString.Builder.Word
import Blaze.ByteString.Builder.ByteString
------------------------------------------------------------------------------
-- Benchmarks
------------------------------------------------------------------------------
main :: IO ()
main = do
let (chunkInfos, benchmarks) = unzip
{-
[ lazyVsBlaze
( "partitionLazy"
, (uncurry mappend) . L.partition ((0 <) . sin . fromIntegral)
, (uncurry mappend) . partitionLazy ((0 <) . sin . fromIntegral)
, (\i -> L.drop 13 $ L.pack $ take i $ cycle [0..])
, n)
-}
{-
[ lazyVsBlaze
( "base64mime"
, L.fromChunks . return . joinWith "\r\n" 76 . encode
, toLazyByteString . encodeBase64MIME
, (\i -> S.drop 13 $ S.pack $ take i $ cycle [0..])
, n)
-}
{-
[ lazyVsBlaze
( "joinWith"
, L.fromChunks . return . joinWith "\r\n" 76
, toLazyByteString . intersperseBlocks 76 "\r\n"
, (\i -> S.drop 13 $ S.pack $ take i $ cycle [0..])
, n)
-}
[ lazyVsBlaze
( "base64"
, L.fromChunks . return . encode
, toLazyByteString . encodeBase64
, (\i -> S.drop 13 $ S.pack $ take i $ cycle [0..])
, n)
{-
, 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 implBlaze blaze
, mkBench implLazy lazy
]
)
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 = fromBuildStepCont $ step x0
where
step x1 !k = fill x1
where
fill x !(BufRange pf0 pe0) = go (f x) pf0
where
go !Nothing !pf = do
let !br' = BufRange pf pe0
k br'
go !(Just (y, x')) !pf
| pf `plusPtr` bound <= pe0 = do
!pf' <- runWrite (write y) pf
go (f x') pf'
| otherwise = return $ bufferFull bound pf $
\(BufRange pfNew peNew) -> do
!pfNew' <- runWrite (write y) pfNew
fill x' (BufRange pfNew' peNew)
where
bound = getBound $ write y
{-# INLINE fromWriteUnfoldr #-}
-- Filtering and mapping
------------------------
test :: Int -> (L.ByteString, L.ByteString)
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 -> fromBuildStepCont $ step bs
where
step (S.PS ifp ioff isize) !k =
goBS (unsafeForeignPtrToPtr ifp `plusPtr` ioff)
where
!ipe = unsafeForeignPtrToPtr ifp `plusPtr` (ioff + isize)
goBS !ip0 !br@(BufRange op0 ope)
| ip0 >= ipe = do touchForeignPtr ifp -- input buffer consumed
k br
| 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 (BufRange 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 = fromBuildStepCont $ step
where
bound = getBound $ write x
step !k = fill n0
where
fill !n1 !(BufRange pf0 pe0) = go n1 pf0
where
go 0 !pf = do
let !br' = BufRange pf pe0
k br'
go n !pf
| pf `plusPtr` bound <= pe0 = do
pf' <- runWrite (write x) pf
go (n-1) pf'
| otherwise = return $ bufferFull bound pf $
\(BufRange pfNew peNew) -> do
pfNew' <- runWrite (write x) pfNew
fill (n-1) (BufRange pfNew' peNew)
{-# INLINE fromWriteReplicated #-}
-- FIXME: Output repeated bytestrings for large replications.
fromReplicateWord8 :: Int -> Word8 -> Builder
fromReplicateWord8 !n0 x =
fromBuildStepCont $ step
where
step !k = fill n0
where
fill !n !br@(BufRange pf pe)
| n <= 0 = k br
| pf' <= pe = do
_ <- S.memset pf x (fromIntegral n) -- FIXME: This conversion looses information for 64 bit systems.
let !br' = BufRange pf' pe
k br'
| 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 . fromWriteList writeWord8
-- Reverse
----------
-- Transpose
------------
-- scanl, scanl1, scanr, scanr1
-------------------------------
-- mapAccumL, mapAccumR
-----------------------
-- partition
------------
-- unzip
--------
-- copy
-------
copyBlaze :: L.ByteString -> L.ByteString
copyBlaze = toLazyByteString . copyLazyByteString
-- ?? packCString, packCStringLen
---------------------------------
-- joinWith
--------------------------------------------
intersperseBlocks :: Int -> S.ByteString -> S.ByteString -> Builder
intersperseBlocks blockSize sep (S.PS ifp ioff isize) =
fromPut $ do
lastBS <- go (ip0 `plusPtr` ioff)
unless (S.null lastBS) (putBuilder $ fromByteString lastBS)
where
ip0 = unsafeForeignPtrToPtr ifp
ipe = ip0 `plusPtr` (ioff + isize)
go !ip
| ip `plusPtr` blockSize >= ipe =
return $ S.PS ifp (ip `minusPtr` ip0) (ipe `minusPtr` ip)
| otherwise = do
putBuilder $ fromByteString (S.PS ifp (ip `minusPtr` ip0) blockSize)
`mappend` fromByteString sep
go (ip `plusPtr` blockSize)
intersperseLazyBlocks :: Int -> Builder -> L.ByteString -> Builder
intersperseLazyBlocks blockSize sep bs =
go (splitLazyAt blockSize bs)
where
go (pre, suf)
| L.null suf = fromLazyByteString pre
| otherwise = fromLazyByteString pre `mappend` sep `mappend`
go (splitLazyAt blockSize suf)
encodeBase64MIME :: S.ByteString -> Builder
encodeBase64MIME =
intersperseLazyBlocks 76 (fromByteString "\r\n") . toLazyByteString . encodeBase64
-- test blockwise mapping on base64 encoding
--------------------------------------------
-- | Encode a bytestring using Base64 encoding according to the specification
-- in RFC 4648, .
--
-- Note that you need to insert additional linebreaks every 76 bytes using the
-- function @joinWith "\r\n" 76@ in order to achieve the MIME Base64
-- Content-Transfer-Encoding .
--
-- TODO implement encoding of lazy bytestrings, implement joinWith
-- functionality, and convencience function for MIME base-64 encoding.
encodeBase64 :: S.ByteString -> Builder
encodeBase64 = encodeLazyBase64 . L.fromChunks . return
encodeLazyBase64 :: L.ByteString -> Builder
encodeLazyBase64 =
mkBuilder
where
mkBuilder bs = fromPut $ do
remainder <- putWriteLazyBlocks 3 writeBase64 bs
putBuilder $ complete remainder
{-# INLINE writeBase64 #-}
writeBase64 ip =
exactWrite 4 $ \op -> do
b0 <- peekByte 0
b1 <- peekByte 1
b2 <- peekByte 2
let w = (b0 `shiftL` 16) .|. (b1 `shiftL` 8) .|. b2
poke (castPtr $ op ) =<< enc (w `shiftR` 12)
poke (castPtr $ op `plusPtr` 2) =<< enc (w .&. 0xfff)
where
peekByte :: Int -> IO Word32
peekByte off = fmap fromIntegral (peekByteOff ip off :: IO Word8)
enc = peekElemOff (unsafeForeignPtrToPtr encodeTable) . fromIntegral
{-# INLINE complete #-}
complete bs
| S.null bs = mempty
| otherwise = fromWrite $
exactWrite 4 $ \op -> do
let poke6Base64 off sh = pokeByteOff op off
(alphabet `S.unsafeIndex` fromIntegral (w `shiftR` sh .&. 63))
pad off = pokeByteOff op off (fromIntegral $ ord '=' :: Word8)
poke6Base64 0 18
poke6Base64 1 12
if S.length bs == 1 then pad 2
else poke6Base64 2 8
pad 3
where
getByte :: Int -> Int -> Word32
getByte i sh = fromIntegral (bs `S.unsafeIndex` i) `shiftL` sh
w = getByte 0 16 .|. (if S.length bs == 1 then 0 else getByte 1 8)
-- Lookup table trick from Data.ByteString.Base64 by Bryan O'Sullivan
{-# NOINLINE alphabet #-}
alphabet :: S.ByteString
alphabet = S.pack $ [65..90] ++ [97..122] ++ [48..57] ++ [43,47]
-- FIXME: Check that the implementation of the lookup table aslo works on
-- big-endian systems.
{-# NOINLINE encodeTable #-}
encodeTable :: ForeignPtr Word16
encodeTable = unsafePerformIO $ do
fp <- mallocForeignPtrArray 4096
let ix = fromIntegral . S.index alphabet
withForeignPtr fp $ \p ->
sequence_ [ pokeElemOff p (j*64+k) ((ix k `shiftL` 8) .|. ix j)
| j <- [0..63], k <- [0..63] ]
return fp
-- | Process a bytestring block-wise using a 'Write' action to produce the
-- output per block.
--
-- TODO: Compare speed with 'mapFilterMapByteString'.
{-# INLINE putWriteBlocks #-}
putWriteBlocks :: Int -- ^ Block size.
-> (Ptr Word8 -> Write) -- ^ 'Write' given a pointer to the
-- beginning of the block.
-> S.ByteString -- ^ 'S.ByteString' to consume blockwise.
-> Put S.ByteString -- ^ 'Put' returning the remaining
-- bytes, which are guaranteed to be
-- fewer than the block size.
putWriteBlocks blockSize write =
\bs -> putBuildStepCont $ step bs
where
step (S.PS ifp ioff isize) !k =
goBS (unsafeForeignPtrToPtr ifp `plusPtr` ioff)
where
!ipe = unsafeForeignPtrToPtr ifp `plusPtr` (ioff + isize)
goBS !ip0 !br@(BufRange op0 ope)
| ip0 `plusPtr` blockSize > ipe = do
touchForeignPtr ifp -- input buffer consumed
let !bs' = S.PS ifp (ip0 `minusPtr` unsafeForeignPtrToPtr ifp)
(ipe `minusPtr` ip0)
k bs' br
| op0 `plusPtr` writeBound < ope =
goPartial (ip0 `plusPtr` (blockSize * min outRemaining inpRemaining))
| otherwise = return $ bufferFull writeBound op0 (goBS ip0)
where
writeBound = getBound' "putWriteBlocks" write
outRemaining = (ope `minusPtr` op0) `div` writeBound
inpRemaining = (ipe `minusPtr` ip0) `div` blockSize
goPartial !ipeTmp = go ip0 op0
where
go !ip !op
| ip < ipeTmp = do
op' <- runWrite (write ip) op
go (ip `plusPtr` blockSize) op'
| otherwise =
goBS ip (BufRange op ope)
{-# INLINE putWriteLazyBlocks #-}
putWriteLazyBlocks :: Int -- ^ Block size.
-> (Ptr Word8 -> Write) -- ^ 'Write' given a pointer to the
-- beginning of the block.
-> L.ByteString -- ^ 'L.ByteString' to consume blockwise.
-> Put S.ByteString -- ^ 'Put' returning the remaining
-- bytes, which are guaranteed to be
-- fewer than the block size.
putWriteLazyBlocks blockSize write =
go
where
go L.Empty = return S.empty
go (L.Chunk bs lbs) = do
bsRem <- putWriteBlocks blockSize write bs
case S.length bsRem of
lRem
| lRem <= 0 -> go lbs
| otherwise -> do
let (lbsPre, lbsSuf) =
L.splitAt (fromIntegral $ blockSize - lRem) lbs
case S.concat $ bsRem : L.toChunks lbsPre of
block@(S.PS bfp boff bsize)
| bsize < blockSize -> return block
| otherwise -> do
putBuilder $ fromWrite $
write (unsafeForeignPtrToPtr bfp `plusPtr` boff)
putLiftIO $ touchForeignPtr bfp
go lbsSuf
------------------------------------------------------------------------------
-- Testing code
------------------------------------------------------------------------------
chunks3 :: [Word8] -> [Word32]
chunks3 (b0 : b1 : b2 : bs) =
((fromIntegral b0 `shiftL` 16) .|.
(fromIntegral b1 `shiftL` 8) .|.
(fromIntegral b2 )
) : chunks3 bs
chunks3 _ = []
cmpWriteToLib :: [Word8] -> (L.ByteString, L.ByteString)
cmpWriteToLib bs =
-- ( toLazyByteString $ fromWriteList write24bitsBase64 $ chunks3 bs
( toLazyByteString $ encodeBase64 $ S.pack bs
, (`L.Chunk` L.empty) $ encode $ S.pack bs )
test3 :: Bool
test3 = uncurry (==) $ cmpWriteToLib $ [0..]
test2 :: L.ByteString
test2 = toLazyByteString $ encodeBase64 $ S.pack [0..]
{- OLD code
{-# INLINE poke8 #-}
poke8 :: Word8 -> Ptr Word8 -> IO ()
poke8 = flip poke
-- | @writeBase64 w@ writes the lower @24@ bits as four times 6 bit in
-- little-endian order encoded using the standard alphabeth of Base 64 encoding
-- as defined in .
--
{-# INLINE write6bitsBase64 #-}
write6bitsBase64 :: Word32 -> Write
write6bitsBase64 = exactWrite 1 . poke6bitsBase64
{-# INLINE poke6bitsBase64 #-}
poke6bitsBase64 :: Word32 -> Ptr Word8 -> IO ()
poke6bitsBase64 w = poke8 (alphabet `S.unsafeIndex` fromIntegral (w .&. 63))
{-
| i < 26 = withOffsets 0 'A'
| i < 52 = withOffsets 26 'a'
| i < 62 = withOffsets 52 '0'
| i == 62 = poke8 $ fromIntegral $ ord '+'
| otherwise = poke8 $ fromIntegral $ ord '/'
where
i :: Int
i = fromIntegral (w .&. 63)
{-# INLINE withOffsets #-}
withOffsets neg pos = poke8 $ fromIntegral (i + ord pos - neg)
-}
{-# INLINE writePaddedBitsBase64 #-}
writePaddedBitsBase64 :: Bool -- ^ Only 8 bits have to be output.
-> Word32 -- ^ Input whose lower 8 or 16 bits need to be output.
-> Write
writePaddedBitsBase64 only8 w =
write6bitsBase64 (w `shiftr_w32` 18) `mappend`
write6bitsBase64 (w `shiftr_w32` 12) `mappend`
writeIf (const only8) (const $ C8.writeChar '=')
(write6bitsBase64 . (`shiftr_w32` 6))
w `mappend`
C8.writeChar '='
{-# INLINE write24bitsBase64 #-}
write24bitsBase64 :: Word32 -> Write
write24bitsBase64 w = write6bitsBase64 (w `shiftr_w32` 18) `mappend`
write6bitsBase64 (w `shiftr_w32` 12) `mappend`
write6bitsBase64 (w `shiftr_w32` 6) `mappend`
write6bitsBase64 (w )
-- ASSUMES bits 25 - 31 are zero.
{-# INLINE write24bitsBase64' #-}
write24bitsBase64' :: Word32 -> Write
write24bitsBase64' w =
exactWrite 4 $ \p -> do
poke (castPtr p ) =<< enc (w `shiftR` 12)
poke (castPtr $ p `plusPtr` 2) =<< enc (w .&. 0xfff)
where
{-# INLINE enc #-}
enc = peekElemOff (unsafeForeignPtrToPtr encodeTable) . fromIntegral
-}
-------------------------------------------------------------------------------
-- A faster split for lazy bytestrings
-------------------------------------------------------------------------------
-- | /O(n\/c)/ 'splitAt' @n xs@ is equivalent to @('take' n xs, 'drop' n xs)@.
splitLazyAt :: Int -> L.ByteString -> (L.ByteString, L.ByteString)
splitLazyAt n cs0
| n <= 0 = (L.Empty, cs0)
| otherwise = split cs0
where
split L.Empty = (L.Empty, L.Empty)
split (L.Chunk c cs)
| n < len = case S.splitAt n c of
(pre, suf) -> (L.Chunk pre L.Empty, L.Chunk suf cs)
| otherwise = case splitLazyAt (n - len) cs of
(pre, suf) -> (L.Chunk c pre , suf )
where
len = S.length c
-------------------------------------------------------------------------------
-- A faster partition for strict and lazy bytestrings
-------------------------------------------------------------------------------
{-# INLINE partitionStrict #-}
partitionStrict :: (Word8 -> Bool) -> S.ByteString -> (S.ByteString, S.ByteString)
partitionStrict f (S.PS ifp ioff ilen) =
second S.reverse $ S.inlinePerformIO $ do
ofp <- S.mallocByteString ilen
withForeignPtr ifp $ wrapper ofp
where
wrapper !ofp !ip0 =
go (ip0 `plusPtr` ioff) op0 (op0 `plusPtr` ilen)
where
op0 = unsafeForeignPtrToPtr ofp
go !ip !opl !oph
| oph == opl = return (S.PS ofp 0 olen, S.PS ofp olen (ilen - olen))
| otherwise = do
x <- peek ip
if f x
then do poke opl x
go (ip `plusPtr` 1) (opl `plusPtr` 1) oph
else do let oph' = oph `plusPtr` (-1)
poke oph' x
go (ip `plusPtr` 1) opl oph'
where
olen = opl `minusPtr` op0
{-# INLINE partitionLazy #-}
partitionLazy :: (Word8 -> Bool) -> L.ByteString -> (L.ByteString, L.ByteString)
partitionLazy f =
L.foldrChunks partitionOne (L.empty, L.empty)
where
partitionOne bs (ls, rs) =
(L.Chunk l ls, L.Chunk r rs)
where
(l, r) = partitionStrict f bs
blaze-builder-0.4.2.3/benchmarks/PlotTest.hs 0000644 0000000 0000000 00000013613 07346545000 017023 0 ustar 00 0000000 0000000 -----------------------------------------------------------------------------
-- |
-- Module : PlotTest
-- Copyright : Simon Meier
-- License : BSD3-style (see LICENSE)
--
-- Maintainer : https://github.com/blaze-builder
-- Stability : stable
-- Portability : GHC
--
-- Test plotting for the benchmarks.
-- package.
--
-----------------------------------------------------------------------------
module PlotTest where
import Prelude hiding (lines)
import Data.List (unfoldr)
import Data.Word (Word8)
import Data.Maybe
import Data.Accessor
import Data.Colour
import Data.Colour.Names
import Graphics.Rendering.Chart
import Graphics.Rendering.Chart.Grid
import Graphics.Rendering.Chart.Gtk
import Criterion
import Criterion.Environment
import Criterion.Monad
import Criterion.Types
import Criterion.Config
import Control.Monad
import Control.Monad.Trans
import Control.Monad.Trans.Reader
import Statistics.Types
import qualified System.Random as R
-- Plots to be generated
------------------------
{-
Compression:
1 plot (title "compressing MB of random data using 'zlib')
3 lines (direct, compacted using a Builder, compaction time) [chunk size/ms]
ChunkedWrite:
1 plot (title "serializing a list of elements")
1 line per type of element [chunk size/ms]
Throughput:
5 x 3 plots (word type x endianness) (title " MB of ()")
1 line per type of Word [chunk size/ MB/s]
-}
-- | A pseudo-random stream of 'Word8' always started from the same initial
-- seed.
randomWord8s :: [Word8]
randomWord8s = map fromIntegral $ unfoldr (Just . R.next) (R.mkStdGen 666)
-- Main function
----------------
main :: IO ()
main = undefined
-- Benchmarking Infrastructure
------------------------------
type MyCriterion a = ReaderT Environment Criterion a
-- | Run a list of benchmarks; flattening benchmark groups to a path of strings.
runFlattenedBenchmarks :: [Benchmark] -> MyCriterion [([String],Sample)]
runFlattenedBenchmarks =
(concat `liftM`) . mapM (go id)
where
go path (Benchmark name b) = do
env <- ask
sample <- lift $ runBenchmark env b
return [(path [name], sample)]
go path (BenchGroup name bs) =
concat `liftM` mapM (go (path . (name:))) bs
-- | Run a benchmark for a series of data points; e.g. to measure scalability
-- properties.
runSeriesBenchmark :: (a -> Benchmark) -> [a] -> MyCriterion [(a,Sample)]
runSeriesBenchmark mkBench xs =
(zip xs . map snd) `liftM` runFlattenedBenchmarks (map mkBench xs)
-- | Use the given config to measure the environment and then run the embedded
-- criterion operation with this information about the environment.
runMyCriterion :: Config -> MyCriterion a -> IO a
runMyCriterion config criterion = do
env <- withConfig config measureEnvironment
withConfig config (runReaderT criterion env)
-- Plotting Infrastructure
--------------------------
colorPalette :: [Colour Double]
colorPalette = [blue, green, red, yellow, magenta, cyan]
lineStylePalette :: [CairoLineStyle]
lineStylePalette =
map (solidLine 1 . opaque) colorPalette ++
map (dashedLine 1 [5, 5] . opaque) colorPalette
-- | > ((title, xName, yName), [(lineName,[(x,y)])])
type PlotData = ((String, String, String), [(String, [(Int, Double)])])
layoutPlot :: PlotData -> Layout1 Int Double
layoutPlot ((title, xName, yName), lines) =
layout1_plots ^= map (Right . toPlot) plots $
layout1_title ^= title $
layout1_bottom_axis ^= mkLinearAxis xName $
layout1_right_axis ^= mkLogAxis yName $
defaultLayout1
where
(linesName, linesData) = unzip lines
plots = zipWith3 plotLine linesName (cycle lineStylePalette) linesData
-- | Plot a single named line using the given line style.
plotLine :: String -> CairoLineStyle -> [(Int,Double)] -> PlotLines Int Double
plotLine name style points =
plot_lines_title ^= name $
plot_lines_style ^= style $
plot_lines_values ^= [points] $
defaultPlotLines
mkLinearAxis :: String -> LayoutAxis Int
mkLinearAxis name = laxis_title ^= name $ defaultLayoutAxis
mkLogAxis :: String -> LayoutAxis Double
mkLogAxis name =
laxis_title ^= name $
laxis_generate ^= autoScaledLogAxis defaultLogAxis $
defaultLayoutAxis
{-
-- Plot Experiments
-------------------
testData :: [(Int,Double)]
testData = zip xs (map (fromIntegral . (^2)) xs)
where xs = [1,2,4,8,16,32]
blazeLineStyle = solidLine 1 . opaque
binaryLineStyle = dashedLine 1 [5, 5] . opaque
plots :: [PlotLines Int Double]
plots = [ plotLine [c] style testData
| (c, style) <- zip ['a'..] (cycle lineStylePalette) ]
mkLayout xname yname title p =
layout1_plots ^= [Right p] $
layout1_title ^= title $
layout1_bottom_axis ^= mkLinearAxis xname $
layout1_right_axis ^= mkLogAxis yname $
defaultLayout1
layouts = zipWith (mkLayout "chunksize" "MB/s") (map return ['A'..]) (map toPlot plots)
testGrid = aboveN $ map (besideN . map (flip tspan (1,1) . toRenderable)) [l1,l2]
where
(l1,l2) = splitAt 3 layouts
testIt = renderableToWindow (gridToRenderable testGrid) 640 480
-}
{-
mkChart :: [((String,CairoLineStyle,a), [(Int, IO (Maybe Double))])] -> IO ()
mkChart task = do
lines <- catMaybes `liftM` mapM measureSerializer task
let plottedLines = flip map lines $ \ ((name,lineStyle,_), points) ->
plot_lines_title ^= name $
plot_lines_style ^= lineStyle $
plot_lines_values ^= [points] $
defaultPlotLines
let layout =
defaultLayout1
{ layout1_plots_ = map (Right . toPlot) plottedLines }
renderableToWindow (toRenderable layout) 640 480
measureSerializer :: (a, [(Int, IO (Maybe Double))]) -> IO (Maybe (a, [(Int,Double)]))
measureSerializer (info, tests) = do
optPoints <- forM tests $ \ (x, test) -> do
optY <- test
case optY of
Nothing -> return Nothing
Just y -> return $ Just (x, y)
case catMaybes optPoints of
[] -> return Nothing
points -> return $ Just (info, points)
-}
blaze-builder-0.4.2.3/benchmarks/StrictIO.hs 0000644 0000000 0000000 00000001004 07346545000 016734 0 ustar 00 0000000 0000000 {-# 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 #-}
blaze-builder-0.4.2.3/benchmarks/StringAndText.hs 0000644 0000000 0000000 00000011176 07346545000 020005 0 ustar 00 0000000 0000000 {-# LANGUAGE OverloadedStrings #-}
-- |
-- Module : StringAndText
-- Copyright : (c) 2010 Simon Meier
-- License : BSD3-style (see LICENSE)
--
-- Maintainer : https://github.com/blaze-builder
-- Stability : stable
-- Portability : tested on GHC only
--
-- Benchmarking of String and Text serialization.
module StringAndText (main) where
import Data.Char (ord)
import Data.Monoid
import Criterion.Main
import Foreign (plusPtr)
import qualified Data.ByteString as S
import qualified Data.ByteString.Lazy as L
import qualified Data.Text as TS
import qualified Data.Text.Encoding as TS
import qualified Data.Text.Lazy as TL
import qualified Data.Text.Lazy.Encoding as TL
import qualified Blaze.ByteString.Builder as Blaze
import qualified Data.ByteString.Builder.Internal as Blaze
import qualified Blaze.ByteString.Builder.Char.Utf8 as Blaze
import qualified Blaze.ByteString.Builder.Html.Utf8 as Blaze
main :: IO ()
main = defaultMain
[ bench "TL.unpack :: LazyText -> String" $ nf
TL.unpack benchLazyText
, bench "TL.foldr :: LazyText -> String" $ nf
(TL.foldr (:) []) benchLazyText
, bench "fromString :: String --[Utf8 encoding]--> L.ByteString" $ whnf
(L.length . Blaze.toLazyByteString . Blaze.fromString) benchString
, 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 "TS.encodeUtf8 :: StrictText --[Utf8 encoding]--> S.ByteString" $ whnf
(TS.encodeUtf8) benchStrictText
, 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 "TL.encodeUtf8 :: LazyText --[Utf8 encoding]--> L.ByteString" $ whnf
(L.length . TL.encodeUtf8) benchLazyText
, bench "fromHtmlEscapedString :: String --[Html esc. & Utf8 encoding]--> L.ByteString" $ whnf
(L.length . Blaze.toLazyByteString . Blaze.fromHtmlEscapedString) benchString
, bench "fromHtmlEscapedStrictTextUnpacked :: StrictText --[HTML esc. & Utf8 encoding]--> L.ByteString" $ whnf
(L.length . Blaze.toLazyByteString . Blaze.fromHtmlEscapedText) benchStrictText
, bench "fromHtmlEscapedLazyTextUnpacked :: LazyText --[HTML esc. & Utf8 encoding]--> L.ByteString" $ whnf
(L.length . Blaze.toLazyByteString . Blaze.fromHtmlEscapedLazyText) benchLazyText
]
n :: Int
n = 100000
benchString :: String
benchString = take n $ concatMap show [(1::Int)..]
{-# NOINLINE benchString #-}
benchStrictText :: TS.Text
benchStrictText = TS.pack benchString
{-# NOINLINE benchStrictText #-}
benchLazyText :: TL.Text
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.fromBuildStepCont $ \k -> TS.foldr step k t
where
step c k pf pe
| pf' <= pe = do
io pf
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 $ \(Blaze.BufRange pfNew peNew) -> do
let !br' = Blaze.BufRange (pfNew `plusPtr` size) peNew
io pfNew
k br'
where
pf' = pf `plusPtr` size
Blaze.Write size io = Blaze.writeChar c
{-# INLINE fromStrictTextFolded #-}
-- | Encode the 'TL.Text' as UTF-8 by folding it and filling the raw buffer
-- directly.
fromLazyTextFolded :: TL.Text -> Blaze.Builder
fromLazyTextFolded t = Blaze.fromBuildStepContBuilder $ \k -> TL.foldr step k t
where
step c k pf pe
| pf' <= pe = do
io pf
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 $ \(Blaze.BufRange pfNew peNew) -> do
let !br' = Blaze.BufRange (pfNew `plusPtr` size) peNew
io pfNew
k br'
where
pf' = pf `plusPtr` size
Blaze.Write size io = Blaze.writeChar c
{-# INLINE fromLazyTextFolded #-}
-}
blaze-builder-0.4.2.3/benchmarks/Throughput/ 0000755 0000000 0000000 00000000000 07346545000 017056 5 ustar 00 0000000 0000000 blaze-builder-0.4.2.3/benchmarks/Throughput/BinaryBuilder.hs 0000644 0000000 0000000 00000055020 07346545000 022147 0 ustar 00 0000000 0000000 {-# LANGUAGE BangPatterns #-}
module Throughput.BinaryBuilder (serialize) where
import Data.Monoid
import qualified Data.ByteString.Lazy as L
import Data.Binary.Builder
import Throughput.Utils
serialize :: Int -> Int -> Endian -> Int -> L.ByteString
serialize wordSize chunkSize end = toLazyByteString .
case (wordSize, chunkSize, end) of
(1, 1,_) -> writeByteN1
(1, 2,_) -> writeByteN2
(1, 4,_) -> writeByteN4
(1, 8,_) -> writeByteN8
(1, 16, _) -> writeByteN16
(2, 1, Big) -> writeWord16N1Big
(2, 2, Big) -> writeWord16N2Big
(2, 4, Big) -> writeWord16N4Big
(2, 8, Big) -> writeWord16N8Big
(2, 16, Big) -> writeWord16N16Big
(2, 1, Little) -> writeWord16N1Little
(2, 2, Little) -> writeWord16N2Little
(2, 4, Little) -> writeWord16N4Little
(2, 8, Little) -> writeWord16N8Little
(2, 16, Little) -> writeWord16N16Little
(2, 1, Host) -> writeWord16N1Host
(2, 2, Host) -> writeWord16N2Host
(2, 4, Host) -> writeWord16N4Host
(2, 8, Host) -> writeWord16N8Host
(2, 16, Host) -> writeWord16N16Host
(4, 1, Big) -> writeWord32N1Big
(4, 2, Big) -> writeWord32N2Big
(4, 4, Big) -> writeWord32N4Big
(4, 8, Big) -> writeWord32N8Big
(4, 16, Big) -> writeWord32N16Big
(4, 1, Little) -> writeWord32N1Little
(4, 2, Little) -> writeWord32N2Little
(4, 4, Little) -> writeWord32N4Little
(4, 8, Little) -> writeWord32N8Little
(4, 16, Little) -> writeWord32N16Little
(4, 1, Host) -> writeWord32N1Host
(4, 2, Host) -> writeWord32N2Host
(4, 4, Host) -> writeWord32N4Host
(4, 8, Host) -> writeWord32N8Host
(4, 16, Host) -> writeWord32N16Host
(8, 1, Host) -> writeWord64N1Host
(8, 2, Host) -> writeWord64N2Host
(8, 4, Host) -> writeWord64N4Host
(8, 8, Host) -> writeWord64N8Host
(8, 16, Host) -> writeWord64N16Host
(8, 1, Big) -> writeWord64N1Big
(8, 2, Big) -> writeWord64N2Big
(8, 4, Big) -> writeWord64N4Big
(8, 8, Big) -> writeWord64N8Big
(8, 16, Big) -> writeWord64N16Big
(8, 1, Little) -> writeWord64N1Little
(8, 2, Little) -> writeWord64N2Little
(8, 4, Little) -> writeWord64N4Little
(8, 8, Little) -> writeWord64N8Little
(8, 16, Little) -> writeWord64N16Little
------------------------------------------------------------------------
writeByteN1 bytes = loop 0 0
where loop !s !n | n == bytes = mempty
| otherwise = singleton s `mappend`
loop (s+1) (n+1)
writeByteN2 = loop 0
where loop s n | s `seq` n `seq` False = undefined
loop _ 0 = mempty
loop s n = (
singleton (s+0) `mappend`
singleton (s+1)) `mappend`
loop (s+2) (n-2)
writeByteN4 = loop 0
where loop s n | s `seq` n `seq` False = undefined
loop _ 0 = mempty
loop s n = (
singleton (s+0) `mappend`
singleton (s+1) `mappend`
singleton (s+2) `mappend`
singleton (s+3)) `mappend`
loop (s+4) (n-4)
writeByteN8 = loop 0
where loop s n | s `seq` n `seq` False = undefined
loop _ 0 = mempty
loop s n = (
singleton (s+0) `mappend`
singleton (s+1) `mappend`
singleton (s+2) `mappend`
singleton (s+3) `mappend`
singleton (s+4) `mappend`
singleton (s+5) `mappend`
singleton (s+6) `mappend`
singleton (s+7)) `mappend`
loop (s+8) (n-8)
writeByteN16 = loop 0
where loop s n | s `seq` n `seq` False = undefined
loop _ 0 = mempty
loop s n = (
singleton (s+0) `mappend`
singleton (s+1) `mappend`
singleton (s+2) `mappend`
singleton (s+3) `mappend`
singleton (s+4) `mappend`
singleton (s+5) `mappend`
singleton (s+6) `mappend`
singleton (s+7) `mappend`
singleton (s+8) `mappend`
singleton (s+9) `mappend`
singleton (s+10) `mappend`
singleton (s+11) `mappend`
singleton (s+12) `mappend`
singleton (s+13) `mappend`
singleton (s+14) `mappend`
singleton (s+15)) `mappend`
loop (s+16) (n-16)
------------------------------------------------------------------------
-- Big endian, word16 writes
writeWord16N1Big = loop 0
where loop s n | s `seq` n `seq` False = undefined
loop _ 0 = mempty
loop s n = (
putWord16be (s+0)) `mappend`
loop (s+1) (n-1)
writeWord16N2Big = loop 0
where loop s n | s `seq` n `seq` False = undefined
loop _ 0 = mempty
loop s n = (
putWord16be (s+0) `mappend`
putWord16be (s+1)) `mappend`
loop (s+2) (n-2)
writeWord16N4Big = loop 0
where loop s n | s `seq` n `seq` False = undefined
loop _ 0 = mempty
loop s n = (
putWord16be (s+0) `mappend`
putWord16be (s+1) `mappend`
putWord16be (s+2) `mappend`
putWord16be (s+3)) `mappend`
loop (s+4) (n-4)
writeWord16N8Big = loop 0
where loop s n | s `seq` n `seq` False = undefined
loop _ 0 = mempty
loop s n = (
putWord16be (s+0) `mappend`
putWord16be (s+1) `mappend`
putWord16be (s+2) `mappend`
putWord16be (s+3) `mappend`
putWord16be (s+4) `mappend`
putWord16be (s+5) `mappend`
putWord16be (s+6) `mappend`
putWord16be (s+7)) `mappend`
loop (s+8) (n-8)
writeWord16N16Big = loop 0
where loop s n | s `seq` n `seq` False = undefined
loop _ 0 = mempty
loop s n = (
putWord16be (s+0) `mappend`
putWord16be (s+1) `mappend`
putWord16be (s+2) `mappend`
putWord16be (s+3) `mappend`
putWord16be (s+4) `mappend`
putWord16be (s+5) `mappend`
putWord16be (s+6) `mappend`
putWord16be (s+7) `mappend`
putWord16be (s+8) `mappend`
putWord16be (s+9) `mappend`
putWord16be (s+10) `mappend`
putWord16be (s+11) `mappend`
putWord16be (s+12) `mappend`
putWord16be (s+13) `mappend`
putWord16be (s+14) `mappend`
putWord16be (s+15)) `mappend`
loop (s+16) (n-16)
------------------------------------------------------------------------
-- Little endian, word16 writes
writeWord16N1Little = loop 0
where loop s n | s `seq` n `seq` False = undefined
loop _ 0 = mempty
loop s n =
(putWord16le (s+0)) `mappend`
loop (s+1) (n-1)
writeWord16N2Little = loop 0
where loop s n | s `seq` n `seq` False = undefined
loop _ 0 = mempty
loop s n = (
putWord16le (s+0) `mappend`
putWord16le (s+1)) `mappend`
loop (s+2) (n-2)
writeWord16N4Little = loop 0
where loop s n | s `seq` n `seq` False = undefined
loop _ 0 = mempty
loop s n = (
putWord16le (s+0) `mappend`
putWord16le (s+1) `mappend`
putWord16le (s+2) `mappend`
putWord16le (s+3)) `mappend`
loop (s+4) (n-4)
writeWord16N8Little = loop 0
where loop s n | s `seq` n `seq` False = undefined
loop _ 0 = mempty
loop s n = (
putWord16le (s+0) `mappend`
putWord16le (s+1) `mappend`
putWord16le (s+2) `mappend`
putWord16le (s+3) `mappend`
putWord16le (s+4) `mappend`
putWord16le (s+5) `mappend`
putWord16le (s+6) `mappend`
putWord16le (s+7)) `mappend`
loop (s+8) (n-8)
writeWord16N16Little = loop 0
where loop s n | s `seq` n `seq` False = undefined
loop _ 0 = mempty
loop s n = (
putWord16le (s+0) `mappend`
putWord16le (s+1) `mappend`
putWord16le (s+2) `mappend`
putWord16le (s+3) `mappend`
putWord16le (s+4) `mappend`
putWord16le (s+5) `mappend`
putWord16le (s+6) `mappend`
putWord16le (s+7) `mappend`
putWord16le (s+8) `mappend`
putWord16le (s+9) `mappend`
putWord16le (s+10) `mappend`
putWord16le (s+11) `mappend`
putWord16le (s+12) `mappend`
putWord16le (s+13) `mappend`
putWord16le (s+14) `mappend`
putWord16le (s+15)) `mappend`
loop (s+16) (n-16)
------------------------------------------------------------------------
-- Host endian, unaligned, word16 writes
writeWord16N1Host = loop 0
where loop s n | s `seq` n `seq` False = undefined
loop _ 0 = mempty
loop s n = (
putWord16host (s+0)) `mappend`
loop (s+1) (n-1)
writeWord16N2Host = loop 0
where loop s n | s `seq` n `seq` False = undefined
loop _ 0 = mempty
loop s n = (
putWord16host (s+0) `mappend`
putWord16host (s+1)) `mappend`
loop (s+2) (n-2)
writeWord16N4Host = loop 0
where loop s n | s `seq` n `seq` False = undefined
loop _ 0 = mempty
loop s n = (
putWord16host (s+0) `mappend`
putWord16host (s+1) `mappend`
putWord16host (s+2) `mappend`
putWord16host (s+3)) `mappend`
loop (s+4) (n-4)
writeWord16N8Host = loop 0
where loop s n | s `seq` n `seq` False = undefined
loop _ 0 = mempty
loop s n = (
putWord16host (s+0) `mappend`
putWord16host (s+1) `mappend`
putWord16host (s+2) `mappend`
putWord16host (s+3) `mappend`
putWord16host (s+4) `mappend`
putWord16host (s+5) `mappend`
putWord16host (s+6) `mappend`
putWord16host (s+7)) `mappend`
loop (s+8) (n-8)
writeWord16N16Host = loop 0
where loop s n | s `seq` n `seq` False = undefined
loop _ 0 = mempty
loop s n = (
putWord16host (s+0) `mappend`
putWord16host (s+1) `mappend`
putWord16host (s+2) `mappend`
putWord16host (s+3) `mappend`
putWord16host (s+4) `mappend`
putWord16host (s+5) `mappend`
putWord16host (s+6) `mappend`
putWord16host (s+7) `mappend`
putWord16host (s+8) `mappend`
putWord16host (s+9) `mappend`
putWord16host (s+10) `mappend`
putWord16host (s+11) `mappend`
putWord16host (s+12) `mappend`
putWord16host (s+13) `mappend`
putWord16host (s+14) `mappend`
putWord16host (s+15)) `mappend`
loop (s+16) (n-16)
------------------------------------------------------------------------
writeWord32N1Big = loop 0
where loop s n | s `seq` n `seq` False = undefined
loop _ 0 = mempty
loop s n = (
putWord32be (s+0)) `mappend`
loop (s+1) (n-1)
writeWord32N2Big = loop 0
where loop s n | s `seq` n `seq` False = undefined
loop _ 0 = mempty
loop s n = (
putWord32be (s+0) `mappend`
putWord32be (s+1)) `mappend`
loop (s+2) (n-2)
writeWord32N4Big = loop 0
where loop s n | s `seq` n `seq` False = undefined
loop _ 0 = mempty
loop s n = (
putWord32be (s+0) `mappend`
putWord32be (s+1) `mappend`
putWord32be (s+2) `mappend`
putWord32be (s+3)) `mappend`
loop (s+4) (n-4)
writeWord32N8Big = loop 0
where loop s n | s `seq` n `seq` False = undefined
loop _ 0 = mempty
loop s n = (
putWord32be (s+0) `mappend`
putWord32be (s+1) `mappend`
putWord32be (s+2) `mappend`
putWord32be (s+3) `mappend`
putWord32be (s+4) `mappend`
putWord32be (s+5) `mappend`
putWord32be (s+6) `mappend`
putWord32be (s+7)) `mappend`
loop (s+8) (n-8)
writeWord32N16Big = loop 0
where loop s n | s `seq` n `seq` False = undefined
loop _ 0 = mempty
loop s n = (
putWord32be (s+0) `mappend`
putWord32be (s+1) `mappend`
putWord32be (s+2) `mappend`
putWord32be (s+3) `mappend`
putWord32be (s+4) `mappend`
putWord32be (s+5) `mappend`
putWord32be (s+6) `mappend`
putWord32be (s+7) `mappend`
putWord32be (s+8) `mappend`
putWord32be (s+9) `mappend`
putWord32be (s+10) `mappend`
putWord32be (s+11) `mappend`
putWord32be (s+12) `mappend`
putWord32be (s+13) `mappend`
putWord32be (s+14) `mappend`
putWord32be (s+15)) `mappend`
loop (s+16) (n-16)
------------------------------------------------------------------------
writeWord32N1Little = loop 0
where loop s n | s `seq` n `seq` False = undefined
loop _ 0 = mempty
loop s n = (
putWord32le (s+0)) `mappend`
loop (s+1) (n-1)
writeWord32N2Little = loop 0
where loop s n | s `seq` n `seq` False = undefined
loop _ 0 = mempty
loop s n = (
putWord32le (s+0) `mappend`
putWord32le (s+1)) `mappend`
loop (s+2) (n-2)
writeWord32N4Little = loop 0
where loop s n | s `seq` n `seq` False = undefined
loop _ 0 = mempty
loop s n = (
putWord32le (s+0) `mappend`
putWord32le (s+1) `mappend`
putWord32le (s+2) `mappend`
putWord32le (s+3)) `mappend`
loop (s+4) (n-4)
writeWord32N8Little = loop 0
where loop s n | s `seq` n `seq` False = undefined
loop _ 0 = mempty
loop s n = (
putWord32le (s+0) `mappend`
putWord32le (s+1) `mappend`
putWord32le (s+2) `mappend`
putWord32le (s+3) `mappend`
putWord32le (s+4) `mappend`
putWord32le (s+5) `mappend`
putWord32le (s+6) `mappend`
putWord32le (s+7)) `mappend`
loop (s+8) (n-8)
writeWord32N16Little = loop 0
where loop s n | s `seq` n `seq` False = undefined
loop _ 0 = mempty
loop s n = (
putWord32le (s+0) `mappend`
putWord32le (s+1) `mappend`
putWord32le (s+2) `mappend`
putWord32le (s+3) `mappend`
putWord32le (s+4) `mappend`
putWord32le (s+5) `mappend`
putWord32le (s+6) `mappend`
putWord32le (s+7) `mappend`
putWord32le (s+8) `mappend`
putWord32le (s+9) `mappend`
putWord32le (s+10) `mappend`
putWord32le (s+11) `mappend`
putWord32le (s+12) `mappend`
putWord32le (s+13) `mappend`
putWord32le (s+14) `mappend`
putWord32le (s+15)) `mappend`
loop (s+16) (n-16)
------------------------------------------------------------------------
writeWord32N1Host = loop 0
where loop s n | s `seq` n `seq` False = undefined
loop _ 0 = mempty
loop s n = (
putWord32host (s+0)) `mappend`
loop (s+1) (n-1)
writeWord32N2Host = loop 0
where loop s n | s `seq` n `seq` False = undefined
loop _ 0 = mempty
loop s n = (
putWord32host (s+0) `mappend`
putWord32host (s+1)) `mappend`
loop (s+2) (n-2)
writeWord32N4Host = loop 0
where loop s n | s `seq` n `seq` False = undefined
loop _ 0 = mempty
loop s n = (
putWord32host (s+0) `mappend`
putWord32host (s+1) `mappend`
putWord32host (s+2) `mappend`
putWord32host (s+3)) `mappend`
loop (s+4) (n-4)
writeWord32N8Host = loop 0
where loop s n | s `seq` n `seq` False = undefined
loop _ 0 = mempty
loop s n = (
putWord32host (s+0) `mappend`
putWord32host (s+1) `mappend`
putWord32host (s+2) `mappend`
putWord32host (s+3) `mappend`
putWord32host (s+4) `mappend`
putWord32host (s+5) `mappend`
putWord32host (s+6) `mappend`
putWord32host (s+7)) `mappend`
loop (s+8) (n-8)
writeWord32N16Host = loop 0
where loop s n | s `seq` n `seq` False = undefined
loop _ 0 = mempty
loop s n = (
putWord32host (s+0) `mappend`
putWord32host (s+1) `mappend`
putWord32host (s+2) `mappend`
putWord32host (s+3) `mappend`
putWord32host (s+4) `mappend`
putWord32host (s+5) `mappend`
putWord32host (s+6) `mappend`
putWord32host (s+7) `mappend`
putWord32host (s+8) `mappend`
putWord32host (s+9) `mappend`
putWord32host (s+10) `mappend`
putWord32host (s+11) `mappend`
putWord32host (s+12) `mappend`
putWord32host (s+13) `mappend`
putWord32host (s+14) `mappend`
putWord32host (s+15)) `mappend`
loop (s+16) (n-16)
------------------------------------------------------------------------
writeWord64N1Big = loop 0
where loop s n | s `seq` n `seq` False = undefined
loop _ 0 = mempty
loop s n = (
putWord64be (s+0)) `mappend`
loop (s+1) (n-1)
writeWord64N2Big = loop 0
where loop s n | s `seq` n `seq` False = undefined
loop _ 0 = mempty
loop s n = (
putWord64be (s+0) `mappend`
putWord64be (s+1)) `mappend`
loop (s+2) (n-2)
writeWord64N4Big = loop 0
where loop s n | s `seq` n `seq` False = undefined
loop _ 0 = mempty
loop s n = (
putWord64be (s+0) `mappend`
putWord64be (s+1) `mappend`
putWord64be (s+2) `mappend`
putWord64be (s+3)) `mappend`
loop (s+4) (n-4)
writeWord64N8Big = loop 0
where loop s n | s `seq` n `seq` False = undefined
loop _ 0 = mempty
loop s n = (
putWord64be (s+0) `mappend`
putWord64be (s+1) `mappend`
putWord64be (s+2) `mappend`
putWord64be (s+3) `mappend`
putWord64be (s+4) `mappend`
putWord64be (s+5) `mappend`
putWord64be (s+6) `mappend`
putWord64be (s+7)) `mappend`
loop (s+8) (n-8)
writeWord64N16Big = loop 0
where loop s n | s `seq` n `seq` False = undefined
loop _ 0 = mempty
loop s n = (
putWord64be (s+0) `mappend`
putWord64be (s+1) `mappend`
putWord64be (s+2) `mappend`
putWord64be (s+3) `mappend`
putWord64be (s+4) `mappend`
putWord64be (s+5) `mappend`
putWord64be (s+6) `mappend`
putWord64be (s+7) `mappend`
putWord64be (s+8) `mappend`
putWord64be (s+9) `mappend`
putWord64be (s+10) `mappend`
putWord64be (s+11) `mappend`
putWord64be (s+12) `mappend`
putWord64be (s+13) `mappend`
putWord64be (s+14) `mappend`
putWord64be (s+15)) `mappend`
loop (s+16) (n-16)
------------------------------------------------------------------------
writeWord64N1Little = loop 0
where loop s n | s `seq` n `seq` False = undefined
loop _ 0 = mempty
loop s n = (
putWord64le (s+0)) `mappend`
loop (s+1) (n-1)
writeWord64N2Little = loop 0
where loop s n | s `seq` n `seq` False = undefined
loop _ 0 = mempty
loop s n = (
putWord64le (s+0) `mappend`
putWord64le (s+1)) `mappend`
loop (s+2) (n-2)
writeWord64N4Little = loop 0
where loop s n | s `seq` n `seq` False = undefined
loop _ 0 = mempty
loop s n = (
putWord64le (s+0) `mappend`
putWord64le (s+1) `mappend`
putWord64le (s+2) `mappend`
putWord64le (s+3)) `mappend`
loop (s+4) (n-4)
writeWord64N8Little = loop 0
where loop s n | s `seq` n `seq` False = undefined
loop _ 0 = mempty
loop s n = (
putWord64le (s+0) `mappend`
putWord64le (s+1) `mappend`
putWord64le (s+2) `mappend`
putWord64le (s+3) `mappend`
putWord64le (s+4) `mappend`
putWord64le (s+5) `mappend`
putWord64le (s+6) `mappend`
putWord64le (s+7)) `mappend`
loop (s+8) (n-8)
writeWord64N16Little = loop 0
where loop s n | s `seq` n `seq` False = undefined
loop _ 0 = mempty
loop s n = (
putWord64le (s+0) `mappend`
putWord64le (s+1) `mappend`
putWord64le (s+2) `mappend`
putWord64le (s+3) `mappend`
putWord64le (s+4) `mappend`
putWord64le (s+5) `mappend`
putWord64le (s+6) `mappend`
putWord64le (s+7) `mappend`
putWord64le (s+8) `mappend`
putWord64le (s+9) `mappend`
putWord64le (s+10) `mappend`
putWord64le (s+11) `mappend`
putWord64le (s+12) `mappend`
putWord64le (s+13) `mappend`
putWord64le (s+14) `mappend`
putWord64le (s+15)) `mappend`
loop (s+16) (n-16)
------------------------------------------------------------------------
writeWord64N1Host = loop 0
where loop s n | s `seq` n `seq` False = undefined
loop _ 0 = mempty
loop s n = (
putWord64host (s+0)) `mappend`
loop (s+1) (n-1)
writeWord64N2Host = loop 0
where loop s n | s `seq` n `seq` False = undefined
loop _ 0 = mempty
loop s n = (
putWord64host (s+0) `mappend`
putWord64host (s+1)) `mappend`
loop (s+2) (n-2)
writeWord64N4Host = loop 0
where loop s n | s `seq` n `seq` False = undefined
loop _ 0 = mempty
loop s n = (
putWord64host (s+0) `mappend`
putWord64host (s+1) `mappend`
putWord64host (s+2) `mappend`
putWord64host (s+3)) `mappend`
loop (s+4) (n-4)
writeWord64N8Host = loop 0
where loop s n | s `seq` n `seq` False = undefined
loop _ 0 = mempty
loop s n = (
putWord64host (s+0) `mappend`
putWord64host (s+1) `mappend`
putWord64host (s+2) `mappend`
putWord64host (s+3) `mappend`
putWord64host (s+4) `mappend`
putWord64host (s+5) `mappend`
putWord64host (s+6) `mappend`
putWord64host (s+7)) `mappend`
loop (s+8) (n-8)
writeWord64N16Host = loop 0
where loop s n | s `seq` n `seq` False = undefined
loop _ 0 = mempty
loop s n = (
putWord64host (s+0) `mappend`
putWord64host (s+1) `mappend`
putWord64host (s+2) `mappend`
putWord64host (s+3) `mappend`
putWord64host (s+4) `mappend`
putWord64host (s+5) `mappend`
putWord64host (s+6) `mappend`
putWord64host (s+7) `mappend`
putWord64host (s+8) `mappend`
putWord64host (s+9) `mappend`
putWord64host (s+10) `mappend`
putWord64host (s+11) `mappend`
putWord64host (s+12) `mappend`
putWord64host (s+13) `mappend`
putWord64host (s+14) `mappend`
putWord64host (s+15)) `mappend`
loop (s+16) (n-16)
blaze-builder-0.4.2.3/benchmarks/Throughput/BinaryBuilderDeclarative.hs 0000644 0000000 0000000 00000006727 07346545000 024325 0 ustar 00 0000000 0000000 module Throughput.BinaryBuilderDeclarative (
serialize
) where
import Data.Monoid
import Data.Word
import qualified Data.ByteString.Lazy as L
import Data.Binary.Builder
import Control.Monad
import Throughput.Utils
serialize :: Int -> Int -> Endian -> Int -> Maybe L.ByteString
serialize wordSize chunkSize end iters = fmap toLazyByteString $
case (wordSize, chunkSize, end) of
(1, 1,_) -> return $ writeByteN1 iters
(2, 1, Big) -> return $ writeWord16N1Big iters
(2, 1, Little) -> return $ writeWord16N1Little iters
(2, 1, Host) -> return $ writeWord16N1Host iters
(4, 1, Big) -> return $ writeWord32N1Big iters
(4, 1, Little) -> return $ writeWord32N1Little iters
(4, 1, Host) -> return $ writeWord32N1Host iters
(8, 1, Host) -> return $ writeWord64N1Host iters
(8, 1, Big) -> return $ writeWord64N1Big iters
(8, 1, Little) -> return $ writeWord64N1Little iters
_ -> mzero
------------------------------------------------------------------------
-- Word8
------------------------------------------------------------------------
word8List :: Int -> [Word8]
word8List n = take n $ cycle $ [0..]
------------------------------------------------------------------------
writeByteN1 = mconcat . map singleton . word8List
------------------------------------------------------------------------
-- Word16
------------------------------------------------------------------------
word16List :: Int -> [Word16]
word16List n = take n $ cycle $ [0..]
------------------------------------------------------------------------
-- Big endian, word16 writes
writeWord16N1Big = mconcat . map putWord16be . word16List
------------------------------------------------------------------------
-- Little endian, word16 writes
writeWord16N1Little = mconcat . map putWord16le . word16List
------------------------------------------------------------------------
-- Host endian, unaligned, word16 writes
writeWord16N1Host = mconcat . map putWord16host . word16List
------------------------------------------------------------------------
-- Word32
------------------------------------------------------------------------
word32List :: Int -> [Word32]
word32List n = [0..fromIntegral (n-1)]
------------------------------------------------------------------------
-- Big endian, word16 writes
writeWord32N1Big = mconcat . map putWord32be . word32List
------------------------------------------------------------------------
-- Little endian, word32 writes
writeWord32N1Little = mconcat . map putWord32le . word32List
------------------------------------------------------------------------
-- Host endian, unaligned, word32 writes
writeWord32N1Host = mconcat . map putWord32host . word32List
------------------------------------------------------------------------
-- Word64
------------------------------------------------------------------------
word64List :: Int -> [Word64]
word64List n = [0..fromIntegral (n-1)]
------------------------------------------------------------------------
-- Big endian, word16 writes
writeWord64N1Big = mconcat . map putWord64be . word64List
------------------------------------------------------------------------
-- Little endian, word64 writes
writeWord64N1Little = mconcat . map putWord64le . word64List
------------------------------------------------------------------------
-- Host endian, unaligned, word64 writes
writeWord64N1Host = mconcat . map putWord64host . word64List
blaze-builder-0.4.2.3/benchmarks/Throughput/BinaryPut.hs 0000644 0000000 0000000 00000046616 07346545000 021344 0 ustar 00 0000000 0000000 {-# LANGUAGE BangPatterns #-}
module Throughput.BinaryPut (serialize) where
import qualified Data.ByteString.Lazy as L
import Data.Binary.Put
import Throughput.Utils
serialize :: Int -> Int -> Endian -> Int -> L.ByteString
serialize wordSize chunkSize end = runPut .
case (wordSize, chunkSize, end) of
(1, 1,_) -> putWord8N1
(1, 2,_) -> putWord8N2
(1, 4,_) -> putWord8N4
(1, 8,_) -> putWord8N8
(1, 16, _) -> putWord8N16
(2, 1, Big) -> putWord16N1Big
(2, 2, Big) -> putWord16N2Big
(2, 4, Big) -> putWord16N4Big
(2, 8, Big) -> putWord16N8Big
(2, 16, Big) -> putWord16N16Big
(2, 1, Little) -> putWord16N1Little
(2, 2, Little) -> putWord16N2Little
(2, 4, Little) -> putWord16N4Little
(2, 8, Little) -> putWord16N8Little
(2, 16, Little) -> putWord16N16Little
(2, 1, Host) -> putWord16N1Host
(2, 2, Host) -> putWord16N2Host
(2, 4, Host) -> putWord16N4Host
(2, 8, Host) -> putWord16N8Host
(2, 16, Host) -> putWord16N16Host
(4, 1, Big) -> putWord32N1Big
(4, 2, Big) -> putWord32N2Big
(4, 4, Big) -> putWord32N4Big
(4, 8, Big) -> putWord32N8Big
(4, 16, Big) -> putWord32N16Big
(4, 1, Little) -> putWord32N1Little
(4, 2, Little) -> putWord32N2Little
(4, 4, Little) -> putWord32N4Little
(4, 8, Little) -> putWord32N8Little
(4, 16, Little) -> putWord32N16Little
(4, 1, Host) -> putWord32N1Host
(4, 2, Host) -> putWord32N2Host
(4, 4, Host) -> putWord32N4Host
(4, 8, Host) -> putWord32N8Host
(4, 16, Host) -> putWord32N16Host
(8, 1, Host) -> putWord64N1Host
(8, 2, Host) -> putWord64N2Host
(8, 4, Host) -> putWord64N4Host
(8, 8, Host) -> putWord64N8Host
(8, 16, Host) -> putWord64N16Host
(8, 1, Big) -> putWord64N1Big
(8, 2, Big) -> putWord64N2Big
(8, 4, Big) -> putWord64N4Big
(8, 8, Big) -> putWord64N8Big
(8, 16, Big) -> putWord64N16Big
(8, 1, Little) -> putWord64N1Little
(8, 2, Little) -> putWord64N2Little
(8, 4, Little) -> putWord64N4Little
(8, 8, Little) -> putWord64N8Little
(8, 16, Little) -> putWord64N16Little
------------------------------------------------------------------------
putWord8N1 bytes = loop 0 0
where loop !s !n | n == bytes = return ()
| otherwise = do putWord8 s
loop (s+1) (n+1)
putWord8N2 = loop 0
where loop s n | s `seq` n `seq` False = undefined
loop _ 0 = return ()
loop s n = do
putWord8 (s+0)
putWord8 (s+1)
loop (s+2) (n-2)
putWord8N4 = loop 0
where loop s n | s `seq` n `seq` False = undefined
loop _ 0 = return ()
loop s n = do
putWord8 (s+0)
putWord8 (s+1)
putWord8 (s+2)
putWord8 (s+3)
loop (s+4) (n-4)
putWord8N8 = loop 0
where loop s n | s `seq` n `seq` False = undefined
loop _ 0 = return ()
loop s n = do
putWord8 (s+0)
putWord8 (s+1)
putWord8 (s+2)
putWord8 (s+3)
putWord8 (s+4)
putWord8 (s+5)
putWord8 (s+6)
putWord8 (s+7)
loop (s+8) (n-8)
putWord8N16 = loop 0
where loop s n | s `seq` n `seq` False = undefined
loop _ 0 = return ()
loop s n = do
putWord8 (s+0)
putWord8 (s+1)
putWord8 (s+2)
putWord8 (s+3)
putWord8 (s+4)
putWord8 (s+5)
putWord8 (s+6)
putWord8 (s+7)
putWord8 (s+8)
putWord8 (s+9)
putWord8 (s+10)
putWord8 (s+11)
putWord8 (s+12)
putWord8 (s+13)
putWord8 (s+14)
putWord8 (s+15)
loop (s+16) (n-16)
------------------------------------------------------------------------
-- Big endian, word16 writes
putWord16N1Big = loop 0
where loop s n | s `seq` n `seq` False = undefined
loop _ 0 = return ()
loop s n = do
putWord16be (s+0)
loop (s+1) (n-1)
putWord16N2Big = loop 0
where loop s n | s `seq` n `seq` False = undefined
loop _ 0 = return ()
loop s n = do
putWord16be (s+0)
putWord16be (s+1)
loop (s+2) (n-2)
putWord16N4Big = loop 0
where loop s n | s `seq` n `seq` False = undefined
loop _ 0 = return ()
loop s n = do
putWord16be (s+0)
putWord16be (s+1)
putWord16be (s+2)
putWord16be (s+3)
loop (s+4) (n-4)
putWord16N8Big = loop 0
where loop s n | s `seq` n `seq` False = undefined
loop _ 0 = return ()
loop s n = do
putWord16be (s+0)
putWord16be (s+1)
putWord16be (s+2)
putWord16be (s+3)
putWord16be (s+4)
putWord16be (s+5)
putWord16be (s+6)
putWord16be (s+7)
loop (s+8) (n-8)
putWord16N16Big = loop 0
where loop s n | s `seq` n `seq` False = undefined
loop _ 0 = return ()
loop s n = do
putWord16be (s+0)
putWord16be (s+1)
putWord16be (s+2)
putWord16be (s+3)
putWord16be (s+4)
putWord16be (s+5)
putWord16be (s+6)
putWord16be (s+7)
putWord16be (s+8)
putWord16be (s+9)
putWord16be (s+10)
putWord16be (s+11)
putWord16be (s+12)
putWord16be (s+13)
putWord16be (s+14)
putWord16be (s+15)
loop (s+16) (n-16)
------------------------------------------------------------------------
-- Little endian, word16 writes
putWord16N1Little = loop 0
where loop s n | s `seq` n `seq` False = undefined
loop _ 0 = return ()
loop s n = do
putWord16le (s+0)
loop (s+1) (n-1)
putWord16N2Little = loop 0
where loop s n | s `seq` n `seq` False = undefined
loop _ 0 = return ()
loop s n = do
putWord16le (s+0)
putWord16le (s+1)
loop (s+2) (n-2)
putWord16N4Little = loop 0
where loop s n | s `seq` n `seq` False = undefined
loop _ 0 = return ()
loop s n = do
putWord16le (s+0)
putWord16le (s+1)
putWord16le (s+2)
putWord16le (s+3)
loop (s+4) (n-4)
putWord16N8Little = loop 0
where loop s n | s `seq` n `seq` False = undefined
loop _ 0 = return ()
loop s n = do
putWord16le (s+0)
putWord16le (s+1)
putWord16le (s+2)
putWord16le (s+3)
putWord16le (s+4)
putWord16le (s+5)
putWord16le (s+6)
putWord16le (s+7)
loop (s+8) (n-8)
putWord16N16Little = loop 0
where loop s n | s `seq` n `seq` False = undefined
loop _ 0 = return ()
loop s n = do
putWord16le (s+0)
putWord16le (s+1)
putWord16le (s+2)
putWord16le (s+3)
putWord16le (s+4)
putWord16le (s+5)
putWord16le (s+6)
putWord16le (s+7)
putWord16le (s+8)
putWord16le (s+9)
putWord16le (s+10)
putWord16le (s+11)
putWord16le (s+12)
putWord16le (s+13)
putWord16le (s+14)
putWord16le (s+15)
loop (s+16) (n-16)
------------------------------------------------------------------------
-- Host endian, unaligned, word16 writes
putWord16N1Host = loop 0
where loop s n | s `seq` n `seq` False = undefined
loop _ 0 = return ()
loop s n = do
putWord16host (s+0)
loop (s+1) (n-1)
putWord16N2Host = loop 0
where loop s n | s `seq` n `seq` False = undefined
loop _ 0 = return ()
loop s n = do
putWord16host (s+0)
putWord16host (s+1)
loop (s+2) (n-2)
putWord16N4Host = loop 0
where loop s n | s `seq` n `seq` False = undefined
loop _ 0 = return ()
loop s n = do
putWord16host (s+0)
putWord16host (s+1)
putWord16host (s+2)
putWord16host (s+3)
loop (s+4) (n-4)
putWord16N8Host = loop 0
where loop s n | s `seq` n `seq` False = undefined
loop _ 0 = return ()
loop s n = do
putWord16host (s+0)
putWord16host (s+1)
putWord16host (s+2)
putWord16host (s+3)
putWord16host (s+4)
putWord16host (s+5)
putWord16host (s+6)
putWord16host (s+7)
loop (s+8) (n-8)
putWord16N16Host = loop 0
where loop s n | s `seq` n `seq` False = undefined
loop _ 0 = return ()
loop s n = do
putWord16host (s+0)
putWord16host (s+1)
putWord16host (s+2)
putWord16host (s+3)
putWord16host (s+4)
putWord16host (s+5)
putWord16host (s+6)
putWord16host (s+7)
putWord16host (s+8)
putWord16host (s+9)
putWord16host (s+10)
putWord16host (s+11)
putWord16host (s+12)
putWord16host (s+13)
putWord16host (s+14)
putWord16host (s+15)
loop (s+16) (n-16)
------------------------------------------------------------------------
putWord32N1Big = loop 0
where loop s n | s `seq` n `seq` False = undefined
loop _ 0 = return ()
loop s n = do
putWord32be (s+0)
loop (s+1) (n-1)
putWord32N2Big = loop 0
where loop s n | s `seq` n `seq` False = undefined
loop _ 0 = return ()
loop s n = do
putWord32be (s+0)
putWord32be (s+1)
loop (s+2) (n-2)
putWord32N4Big = loop 0
where loop s n | s `seq` n `seq` False = undefined
loop _ 0 = return ()
loop s n = do
putWord32be (s+0)
putWord32be (s+1)
putWord32be (s+2)
putWord32be (s+3)
loop (s+4) (n-4)
putWord32N8Big = loop 0
where loop s n | s `seq` n `seq` False = undefined
loop _ 0 = return ()
loop s n = do
putWord32be (s+0)
putWord32be (s+1)
putWord32be (s+2)
putWord32be (s+3)
putWord32be (s+4)
putWord32be (s+5)
putWord32be (s+6)
putWord32be (s+7)
loop (s+8) (n-8)
putWord32N16Big = loop 0
where loop s n | s `seq` n `seq` False = undefined
loop _ 0 = return ()
loop s n = do
putWord32be (s+0)
putWord32be (s+1)
putWord32be (s+2)
putWord32be (s+3)
putWord32be (s+4)
putWord32be (s+5)
putWord32be (s+6)
putWord32be (s+7)
putWord32be (s+8)
putWord32be (s+9)
putWord32be (s+10)
putWord32be (s+11)
putWord32be (s+12)
putWord32be (s+13)
putWord32be (s+14)
putWord32be (s+15)
loop (s+16) (n-16)
------------------------------------------------------------------------
putWord32N1Little = loop 0
where loop s n | s `seq` n `seq` False = undefined
loop _ 0 = return ()
loop s n = do
putWord32le (s+0)
loop (s+1) (n-1)
putWord32N2Little = loop 0
where loop s n | s `seq` n `seq` False = undefined
loop _ 0 = return ()
loop s n = do
putWord32le (s+0)
putWord32le (s+1)
loop (s+2) (n-2)
putWord32N4Little = loop 0
where loop s n | s `seq` n `seq` False = undefined
loop _ 0 = return ()
loop s n = do
putWord32le (s+0)
putWord32le (s+1)
putWord32le (s+2)
putWord32le (s+3)
loop (s+4) (n-4)
putWord32N8Little = loop 0
where loop s n | s `seq` n `seq` False = undefined
loop _ 0 = return ()
loop s n = do
putWord32le (s+0)
putWord32le (s+1)
putWord32le (s+2)
putWord32le (s+3)
putWord32le (s+4)
putWord32le (s+5)
putWord32le (s+6)
putWord32le (s+7)
loop (s+8) (n-8)
putWord32N16Little = loop 0
where loop s n | s `seq` n `seq` False = undefined
loop _ 0 = return ()
loop s n = do
putWord32le (s+0)
putWord32le (s+1)
putWord32le (s+2)
putWord32le (s+3)
putWord32le (s+4)
putWord32le (s+5)
putWord32le (s+6)
putWord32le (s+7)
putWord32le (s+8)
putWord32le (s+9)
putWord32le (s+10)
putWord32le (s+11)
putWord32le (s+12)
putWord32le (s+13)
putWord32le (s+14)
putWord32le (s+15)
loop (s+16) (n-16)
------------------------------------------------------------------------
putWord32N1Host = loop 0
where loop s n | s `seq` n `seq` False = undefined
loop _ 0 = return ()
loop s n = do
putWord32host (s+0)
loop (s+1) (n-1)
putWord32N2Host = loop 0
where loop s n | s `seq` n `seq` False = undefined
loop _ 0 = return ()
loop s n = do
putWord32host (s+0)
putWord32host (s+1)
loop (s+2) (n-2)
putWord32N4Host = loop 0
where loop s n | s `seq` n `seq` False = undefined
loop _ 0 = return ()
loop s n = do
putWord32host (s+0)
putWord32host (s+1)
putWord32host (s+2)
putWord32host (s+3)
loop (s+4) (n-4)
putWord32N8Host = loop 0
where loop s n | s `seq` n `seq` False = undefined
loop _ 0 = return ()
loop s n = do
putWord32host (s+0)
putWord32host (s+1)
putWord32host (s+2)
putWord32host (s+3)
putWord32host (s+4)
putWord32host (s+5)
putWord32host (s+6)
putWord32host (s+7)
loop (s+8) (n-8)
putWord32N16Host = loop 0
where loop s n | s `seq` n `seq` False = undefined
loop _ 0 = return ()
loop s n = do
putWord32host (s+0)
putWord32host (s+1)
putWord32host (s+2)
putWord32host (s+3)
putWord32host (s+4)
putWord32host (s+5)
putWord32host (s+6)
putWord32host (s+7)
putWord32host (s+8)
putWord32host (s+9)
putWord32host (s+10)
putWord32host (s+11)
putWord32host (s+12)
putWord32host (s+13)
putWord32host (s+14)
putWord32host (s+15)
loop (s+16) (n-16)
------------------------------------------------------------------------
putWord64N1Big = loop 0
where loop s n | s `seq` n `seq` False = undefined
loop _ 0 = return ()
loop s n = do
putWord64be (s+0)
loop (s+1) (n-1)
putWord64N2Big = loop 0
where loop s n | s `seq` n `seq` False = undefined
loop _ 0 = return ()
loop s n = do
putWord64be (s+0)
putWord64be (s+1)
loop (s+2) (n-2)
putWord64N4Big = loop 0
where loop s n | s `seq` n `seq` False = undefined
loop _ 0 = return ()
loop s n = do
putWord64be (s+0)
putWord64be (s+1)
putWord64be (s+2)
putWord64be (s+3)
loop (s+4) (n-4)
putWord64N8Big = loop 0
where loop s n | s `seq` n `seq` False = undefined
loop _ 0 = return ()
loop s n = do
putWord64be (s+0)
putWord64be (s+1)
putWord64be (s+2)
putWord64be (s+3)
putWord64be (s+4)
putWord64be (s+5)
putWord64be (s+6)
putWord64be (s+7)
loop (s+8) (n-8)
putWord64N16Big = loop 0
where loop s n | s `seq` n `seq` False = undefined
loop _ 0 = return ()
loop s n = do
putWord64be (s+0)
putWord64be (s+1)
putWord64be (s+2)
putWord64be (s+3)
putWord64be (s+4)
putWord64be (s+5)
putWord64be (s+6)
putWord64be (s+7)
putWord64be (s+8)
putWord64be (s+9)
putWord64be (s+10)
putWord64be (s+11)
putWord64be (s+12)
putWord64be (s+13)
putWord64be (s+14)
putWord64be (s+15)
loop (s+16) (n-16)
------------------------------------------------------------------------
putWord64N1Little = loop 0
where loop s n | s `seq` n `seq` False = undefined
loop _ 0 = return ()
loop s n = do
putWord64le (s+0)
loop (s+1) (n-1)
putWord64N2Little = loop 0
where loop s n | s `seq` n `seq` False = undefined
loop _ 0 = return ()
loop s n = do
putWord64le (s+0)
putWord64le (s+1)
loop (s+2) (n-2)
putWord64N4Little = loop 0
where loop s n | s `seq` n `seq` False = undefined
loop _ 0 = return ()
loop s n = do
putWord64le (s+0)
putWord64le (s+1)
putWord64le (s+2)
putWord64le (s+3)
loop (s+4) (n-4)
putWord64N8Little = loop 0
where loop s n | s `seq` n `seq` False = undefined
loop _ 0 = return ()
loop s n = do
putWord64le (s+0)
putWord64le (s+1)
putWord64le (s+2)
putWord64le (s+3)
putWord64le (s+4)
putWord64le (s+5)
putWord64le (s+6)
putWord64le (s+7)
loop (s+8) (n-8)
putWord64N16Little = loop 0
where loop s n | s `seq` n `seq` False = undefined
loop _ 0 = return ()
loop s n = do
putWord64le (s+0)
putWord64le (s+1)
putWord64le (s+2)
putWord64le (s+3)
putWord64le (s+4)
putWord64le (s+5)
putWord64le (s+6)
putWord64le (s+7)
putWord64le (s+8)
putWord64le (s+9)
putWord64le (s+10)
putWord64le (s+11)
putWord64le (s+12)
putWord64le (s+13)
putWord64le (s+14)
putWord64le (s+15)
loop (s+16) (n-16)
------------------------------------------------------------------------
putWord64N1Host = loop 0
where loop s n | s `seq` n `seq` False = undefined
loop _ 0 = return ()
loop s n = do
putWord64host (s+0)
loop (s+1) (n-1)
putWord64N2Host = loop 0
where loop s n | s `seq` n `seq` False = undefined
loop _ 0 = return ()
loop s n = do
putWord64host (s+0)
putWord64host (s+1)
loop (s+2) (n-2)
putWord64N4Host = loop 0
where loop s n | s `seq` n `seq` False = undefined
loop _ 0 = return ()
loop s n = do
putWord64host (s+0)
putWord64host (s+1)
putWord64host (s+2)
putWord64host (s+3)
loop (s+4) (n-4)
putWord64N8Host = loop 0
where loop s n | s `seq` n `seq` False = undefined
loop _ 0 = return ()
loop s n = do
putWord64host (s+0)
putWord64host (s+1)
putWord64host (s+2)
putWord64host (s+3)
putWord64host (s+4)
putWord64host (s+5)
putWord64host (s+6)
putWord64host (s+7)
loop (s+8) (n-8)
putWord64N16Host = loop 0
where loop s n | s `seq` n `seq` False = undefined
loop _ 0 = return ()
loop s n = do
putWord64host (s+0)
putWord64host (s+1)
putWord64host (s+2)
putWord64host (s+3)
putWord64host (s+4)
putWord64host (s+5)
putWord64host (s+6)
putWord64host (s+7)
putWord64host (s+8)
putWord64host (s+9)
putWord64host (s+10)
putWord64host (s+11)
putWord64host (s+12)
putWord64host (s+13)
putWord64host (s+14)
putWord64host (s+15)
loop (s+16) (n-16)
blaze-builder-0.4.2.3/benchmarks/Throughput/BlazeBuilder.hs 0000644 0000000 0000000 00000057232 07346545000 021767 0 ustar 00 0000000 0000000 {-# LANGUAGE BangPatterns #-}
module Throughput.BlazeBuilder (
serialize
) where
import Data.Monoid
import qualified Data.ByteString.Lazy as L
import Blaze.ByteString.Builder
import Throughput.Utils
serialize :: Int -> Int -> Endian -> Int -> L.ByteString
serialize wordSize chunkSize end = toLazyByteString .
case (wordSize, chunkSize, end) of
(1, 1,_) -> writeByteN1
(1, 2,_) -> writeByteN2
(1, 4,_) -> writeByteN4
(1, 8,_) -> writeByteN8
(1, 16, _) -> writeByteN16
(2, 1, Big) -> writeWord16N1Big
(2, 2, Big) -> writeWord16N2Big
(2, 4, Big) -> writeWord16N4Big
(2, 8, Big) -> writeWord16N8Big
(2, 16, Big) -> writeWord16N16Big
(2, 1, Little) -> writeWord16N1Little
(2, 2, Little) -> writeWord16N2Little
(2, 4, Little) -> writeWord16N4Little
(2, 8, Little) -> writeWord16N8Little
(2, 16, Little) -> writeWord16N16Little
(2, 1, Host) -> writeWord16N1Host
(2, 2, Host) -> writeWord16N2Host
(2, 4, Host) -> writeWord16N4Host
(2, 8, Host) -> writeWord16N8Host
(2, 16, Host) -> writeWord16N16Host
(4, 1, Big) -> writeWord32N1Big
(4, 2, Big) -> writeWord32N2Big
(4, 4, Big) -> writeWord32N4Big
(4, 8, Big) -> writeWord32N8Big
(4, 16, Big) -> writeWord32N16Big
(4, 1, Little) -> writeWord32N1Little
(4, 2, Little) -> writeWord32N2Little
(4, 4, Little) -> writeWord32N4Little
(4, 8, Little) -> writeWord32N8Little
(4, 16, Little) -> writeWord32N16Little
(4, 1, Host) -> writeWord32N1Host
(4, 2, Host) -> writeWord32N2Host
(4, 4, Host) -> writeWord32N4Host
(4, 8, Host) -> writeWord32N8Host
(4, 16, Host) -> writeWord32N16Host
(8, 1, Host) -> writeWord64N1Host
(8, 2, Host) -> writeWord64N2Host
(8, 4, Host) -> writeWord64N4Host
(8, 8, Host) -> writeWord64N8Host
(8, 16, Host) -> writeWord64N16Host
(8, 1, Big) -> writeWord64N1Big
(8, 2, Big) -> writeWord64N2Big
(8, 4, Big) -> writeWord64N4Big
(8, 8, Big) -> writeWord64N8Big
(8, 16, Big) -> writeWord64N16Big
(8, 1, Little) -> writeWord64N1Little
(8, 2, Little) -> writeWord64N2Little
(8, 4, Little) -> writeWord64N4Little
(8, 8, Little) -> writeWord64N8Little
(8, 16, Little) -> writeWord64N16Little
------------------------------------------------------------------------
------------------------------------------------------------------------
writeByteN1 bytes = loop 0 0
where loop !s !n | n == bytes = mempty
| otherwise = fromWord8 s `mappend`
loop (s+1) (n+1)
writeByteN2 = loop 0
where loop s n | s `seq` n `seq` False = undefined
loop _ 0 = mempty
loop s n = fromWrite (
writeWord8 (s+0) `mappend`
writeWord8 (s+1)) `mappend`
loop (s+2) (n-2)
writeByteN4 = loop 0
where loop s n | s `seq` n `seq` False = undefined
loop _ 0 = mempty
loop s n = fromWrite (
writeWord8 (s+0) `mappend`
writeWord8 (s+1) `mappend`
writeWord8 (s+2) `mappend`
writeWord8 (s+3)) `mappend`
loop (s+4) (n-4)
writeByteN8 = loop 0
where loop s n | s `seq` n `seq` False = undefined
loop _ 0 = mempty
loop s n = fromWrite (
writeWord8 (s+0) `mappend`
writeWord8 (s+1) `mappend`
writeWord8 (s+2) `mappend`
writeWord8 (s+3) `mappend`
writeWord8 (s+4) `mappend`
writeWord8 (s+5) `mappend`
writeWord8 (s+6) `mappend`
writeWord8 (s+7)) `mappend`
loop (s+8) (n-8)
writeByteN16 = loop 0
where loop s n | s `seq` n `seq` False = undefined
loop _ 0 = mempty
loop s n = fromWrite (
writeWord8 (s+0) `mappend`
writeWord8 (s+1) `mappend`
writeWord8 (s+2) `mappend`
writeWord8 (s+3) `mappend`
writeWord8 (s+4) `mappend`
writeWord8 (s+5) `mappend`
writeWord8 (s+6) `mappend`
writeWord8 (s+7) `mappend`
writeWord8 (s+8) `mappend`
writeWord8 (s+9) `mappend`
writeWord8 (s+10) `mappend`
writeWord8 (s+11) `mappend`
writeWord8 (s+12) `mappend`
writeWord8 (s+13) `mappend`
writeWord8 (s+14) `mappend`
writeWord8 (s+15)) `mappend`
loop (s+16) (n-16)
------------------------------------------------------------------------
-- Big endian, word16 writes
writeWord16N1Big = loop 0
where loop s n | s `seq` n `seq` False = undefined
loop _ 0 = mempty
loop s n = fromWrite (
writeWord16be (s+0)) `mappend`
loop (s+1) (n-1)
writeWord16N2Big = loop 0
where loop s n | s `seq` n `seq` False = undefined
loop _ 0 = mempty
loop s n = fromWrite (
writeWord16be (s+0) `mappend`
writeWord16be (s+1)) `mappend`
loop (s+2) (n-2)
writeWord16N4Big = loop 0
where loop s n | s `seq` n `seq` False = undefined
loop _ 0 = mempty
loop s n = fromWrite (
writeWord16be (s+0) `mappend`
writeWord16be (s+1) `mappend`
writeWord16be (s+2) `mappend`
writeWord16be (s+3)) `mappend`
loop (s+4) (n-4)
writeWord16N8Big = loop 0
where loop s n | s `seq` n `seq` False = undefined
loop _ 0 = mempty
loop s n = fromWrite (
writeWord16be (s+0) `mappend`
writeWord16be (s+1) `mappend`
writeWord16be (s+2) `mappend`
writeWord16be (s+3) `mappend`
writeWord16be (s+4) `mappend`
writeWord16be (s+5) `mappend`
writeWord16be (s+6) `mappend`
writeWord16be (s+7)) `mappend`
loop (s+8) (n-8)
writeWord16N16Big = loop 0
where loop s n | s `seq` n `seq` False = undefined
loop _ 0 = mempty
loop s n = fromWrite (
writeWord16be (s+0) `mappend`
writeWord16be (s+1) `mappend`
writeWord16be (s+2) `mappend`
writeWord16be (s+3) `mappend`
writeWord16be (s+4) `mappend`
writeWord16be (s+5) `mappend`
writeWord16be (s+6) `mappend`
writeWord16be (s+7) `mappend`
writeWord16be (s+8) `mappend`
writeWord16be (s+9) `mappend`
writeWord16be (s+10) `mappend`
writeWord16be (s+11) `mappend`
writeWord16be (s+12) `mappend`
writeWord16be (s+13) `mappend`
writeWord16be (s+14) `mappend`
writeWord16be (s+15)) `mappend`
loop (s+16) (n-16)
------------------------------------------------------------------------
-- Little endian, word16 writes
writeWord16N1Little = loop 0
where loop s n | s `seq` n `seq` False = undefined
loop _ 0 = mempty
loop s n =
fromWrite (writeWord16le (s+0)) `mappend`
loop (s+1) (n-1)
writeWord16N2Little = loop 0
where loop s n | s `seq` n `seq` False = undefined
loop _ 0 = mempty
loop s n = fromWrite (
writeWord16le (s+0) `mappend`
writeWord16le (s+1)) `mappend`
loop (s+2) (n-2)
writeWord16N4Little = loop 0
where loop s n | s `seq` n `seq` False = undefined
loop _ 0 = mempty
loop s n = fromWrite (
writeWord16le (s+0) `mappend`
writeWord16le (s+1) `mappend`
writeWord16le (s+2) `mappend`
writeWord16le (s+3)) `mappend`
loop (s+4) (n-4)
writeWord16N8Little = loop 0
where loop s n | s `seq` n `seq` False = undefined
loop _ 0 = mempty
loop s n = fromWrite (
writeWord16le (s+0) `mappend`
writeWord16le (s+1) `mappend`
writeWord16le (s+2) `mappend`
writeWord16le (s+3) `mappend`
writeWord16le (s+4) `mappend`
writeWord16le (s+5) `mappend`
writeWord16le (s+6) `mappend`
writeWord16le (s+7)) `mappend`
loop (s+8) (n-8)
writeWord16N16Little = loop 0
where loop s n | s `seq` n `seq` False = undefined
loop _ 0 = mempty
loop s n = fromWrite (
writeWord16le (s+0) `mappend`
writeWord16le (s+1) `mappend`
writeWord16le (s+2) `mappend`
writeWord16le (s+3) `mappend`
writeWord16le (s+4) `mappend`
writeWord16le (s+5) `mappend`
writeWord16le (s+6) `mappend`
writeWord16le (s+7) `mappend`
writeWord16le (s+8) `mappend`
writeWord16le (s+9) `mappend`
writeWord16le (s+10) `mappend`
writeWord16le (s+11) `mappend`
writeWord16le (s+12) `mappend`
writeWord16le (s+13) `mappend`
writeWord16le (s+14) `mappend`
writeWord16le (s+15)) `mappend`
loop (s+16) (n-16)
------------------------------------------------------------------------
-- Host endian, unaligned, word16 writes
writeWord16N1Host = loop 0
where loop s n | s `seq` n `seq` False = undefined
loop _ 0 = mempty
loop s n = fromWrite (
writeWord16host (s+0)) `mappend`
loop (s+1) (n-1)
writeWord16N2Host = loop 0
where loop s n | s `seq` n `seq` False = undefined
loop _ 0 = mempty
loop s n = fromWrite (
writeWord16host (s+0) `mappend`
writeWord16host (s+1)) `mappend`
loop (s+2) (n-2)
writeWord16N4Host = loop 0
where loop s n | s `seq` n `seq` False = undefined
loop _ 0 = mempty
loop s n = fromWrite (
writeWord16host (s+0) `mappend`
writeWord16host (s+1) `mappend`
writeWord16host (s+2) `mappend`
writeWord16host (s+3)) `mappend`
loop (s+4) (n-4)
writeWord16N8Host = loop 0
where loop s n | s `seq` n `seq` False = undefined
loop _ 0 = mempty
loop s n = fromWrite (
writeWord16host (s+0) `mappend`
writeWord16host (s+1) `mappend`
writeWord16host (s+2) `mappend`
writeWord16host (s+3) `mappend`
writeWord16host (s+4) `mappend`
writeWord16host (s+5) `mappend`
writeWord16host (s+6) `mappend`
writeWord16host (s+7)) `mappend`
loop (s+8) (n-8)
writeWord16N16Host = loop 0
where loop s n | s `seq` n `seq` False = undefined
loop _ 0 = mempty
loop s n = fromWrite (
writeWord16host (s+0) `mappend`
writeWord16host (s+1) `mappend`
writeWord16host (s+2) `mappend`
writeWord16host (s+3) `mappend`
writeWord16host (s+4) `mappend`
writeWord16host (s+5) `mappend`
writeWord16host (s+6) `mappend`
writeWord16host (s+7) `mappend`
writeWord16host (s+8) `mappend`
writeWord16host (s+9) `mappend`
writeWord16host (s+10) `mappend`
writeWord16host (s+11) `mappend`
writeWord16host (s+12) `mappend`
writeWord16host (s+13) `mappend`
writeWord16host (s+14) `mappend`
writeWord16host (s+15)) `mappend`
loop (s+16) (n-16)
------------------------------------------------------------------------
writeWord32N1Big = loop 0
where loop s n | s `seq` n `seq` False = undefined
loop _ 0 = mempty
loop s n = fromWrite (
writeWord32be (s+0)) `mappend`
loop (s+1) (n-1)
writeWord32N2Big = loop 0
where loop s n | s `seq` n `seq` False = undefined
loop _ 0 = mempty
loop s n = fromWrite (
writeWord32be (s+0) `mappend`
writeWord32be (s+1)) `mappend`
loop (s+2) (n-2)
writeWord32N4Big = loop 0
where loop s n | s `seq` n `seq` False = undefined
loop _ 0 = mempty
loop s n = fromWrite (
writeWord32be (s+0) `mappend`
writeWord32be (s+1) `mappend`
writeWord32be (s+2) `mappend`
writeWord32be (s+3)) `mappend`
loop (s+4) (n-4)
writeWord32N8Big = loop 0
where loop s n | s `seq` n `seq` False = undefined
loop _ 0 = mempty
loop s n = fromWrite (
writeWord32be (s+0) `mappend`
writeWord32be (s+1) `mappend`
writeWord32be (s+2) `mappend`
writeWord32be (s+3) `mappend`
writeWord32be (s+4) `mappend`
writeWord32be (s+5) `mappend`
writeWord32be (s+6) `mappend`
writeWord32be (s+7)) `mappend`
loop (s+8) (n-8)
writeWord32N16Big = loop 0
where loop s n | s `seq` n `seq` False = undefined
loop _ 0 = mempty
loop s n = fromWrite (
writeWord32be (s+0) `mappend`
writeWord32be (s+1) `mappend`
writeWord32be (s+2) `mappend`
writeWord32be (s+3) `mappend`
writeWord32be (s+4) `mappend`
writeWord32be (s+5) `mappend`
writeWord32be (s+6) `mappend`
writeWord32be (s+7) `mappend`
writeWord32be (s+8) `mappend`
writeWord32be (s+9) `mappend`
writeWord32be (s+10) `mappend`
writeWord32be (s+11) `mappend`
writeWord32be (s+12) `mappend`
writeWord32be (s+13) `mappend`
writeWord32be (s+14) `mappend`
writeWord32be (s+15)) `mappend`
loop (s+16) (n-16)
------------------------------------------------------------------------
writeWord32N1Little = loop 0
where loop s n | s `seq` n `seq` False = undefined
loop _ 0 = mempty
loop s n = fromWrite (
writeWord32le (s+0)) `mappend`
loop (s+1) (n-1)
writeWord32N2Little = loop 0
where loop s n | s `seq` n `seq` False = undefined
loop _ 0 = mempty
loop s n = fromWrite (
writeWord32le (s+0) `mappend`
writeWord32le (s+1)) `mappend`
loop (s+2) (n-2)
writeWord32N4Little = loop 0
where loop s n | s `seq` n `seq` False = undefined
loop _ 0 = mempty
loop s n = fromWrite (
writeWord32le (s+0) `mappend`
writeWord32le (s+1) `mappend`
writeWord32le (s+2) `mappend`
writeWord32le (s+3)) `mappend`
loop (s+4) (n-4)
writeWord32N8Little = loop 0
where loop s n | s `seq` n `seq` False = undefined
loop _ 0 = mempty
loop s n = fromWrite (
writeWord32le (s+0) `mappend`
writeWord32le (s+1) `mappend`
writeWord32le (s+2) `mappend`
writeWord32le (s+3) `mappend`
writeWord32le (s+4) `mappend`
writeWord32le (s+5) `mappend`
writeWord32le (s+6) `mappend`
writeWord32le (s+7)) `mappend`
loop (s+8) (n-8)
writeWord32N16Little = loop 0
where loop s n | s `seq` n `seq` False = undefined
loop _ 0 = mempty
loop s n = fromWrite (
writeWord32le (s+0) `mappend`
writeWord32le (s+1) `mappend`
writeWord32le (s+2) `mappend`
writeWord32le (s+3) `mappend`
writeWord32le (s+4) `mappend`
writeWord32le (s+5) `mappend`
writeWord32le (s+6) `mappend`
writeWord32le (s+7) `mappend`
writeWord32le (s+8) `mappend`
writeWord32le (s+9) `mappend`
writeWord32le (s+10) `mappend`
writeWord32le (s+11) `mappend`
writeWord32le (s+12) `mappend`
writeWord32le (s+13) `mappend`
writeWord32le (s+14) `mappend`
writeWord32le (s+15)) `mappend`
loop (s+16) (n-16)
------------------------------------------------------------------------
writeWord32N1Host = loop 0
where loop s n | s `seq` n `seq` False = undefined
loop _ 0 = mempty
loop s n = fromWrite (
writeWord32host (s+0)) `mappend`
loop (s+1) (n-1)
writeWord32N2Host = loop 0
where loop s n | s `seq` n `seq` False = undefined
loop _ 0 = mempty
loop s n = fromWrite (
writeWord32host (s+0) `mappend`
writeWord32host (s+1)) `mappend`
loop (s+2) (n-2)
writeWord32N4Host = loop 0
where loop s n | s `seq` n `seq` False = undefined
loop _ 0 = mempty
loop s n = fromWrite (
writeWord32host (s+0) `mappend`
writeWord32host (s+1) `mappend`
writeWord32host (s+2) `mappend`
writeWord32host (s+3)) `mappend`
loop (s+4) (n-4)
writeWord32N8Host = loop 0
where loop s n | s `seq` n `seq` False = undefined
loop _ 0 = mempty
loop s n = fromWrite (
writeWord32host (s+0) `mappend`
writeWord32host (s+1) `mappend`
writeWord32host (s+2) `mappend`
writeWord32host (s+3) `mappend`
writeWord32host (s+4) `mappend`
writeWord32host (s+5) `mappend`
writeWord32host (s+6) `mappend`
writeWord32host (s+7)) `mappend`
loop (s+8) (n-8)
writeWord32N16Host = loop 0
where loop s n | s `seq` n `seq` False = undefined
loop _ 0 = mempty
loop s n = fromWrite (
writeWord32host (s+0) `mappend`
writeWord32host (s+1) `mappend`
writeWord32host (s+2) `mappend`
writeWord32host (s+3) `mappend`
writeWord32host (s+4) `mappend`
writeWord32host (s+5) `mappend`
writeWord32host (s+6) `mappend`
writeWord32host (s+7) `mappend`
writeWord32host (s+8) `mappend`
writeWord32host (s+9) `mappend`
writeWord32host (s+10) `mappend`
writeWord32host (s+11) `mappend`
writeWord32host (s+12) `mappend`
writeWord32host (s+13) `mappend`
writeWord32host (s+14) `mappend`
writeWord32host (s+15)) `mappend`
loop (s+16) (n-16)
------------------------------------------------------------------------
writeWord64N1Big = loop 0
where loop s n | s `seq` n `seq` False = undefined
loop _ 0 = mempty
loop s n = fromWrite (
writeWord64be (s+0)) `mappend`
loop (s+1) (n-1)
writeWord64N2Big = loop 0
where loop s n | s `seq` n `seq` False = undefined
loop _ 0 = mempty
loop s n = fromWrite (
writeWord64be (s+0) `mappend`
writeWord64be (s+1)) `mappend`
loop (s+2) (n-2)
writeWord64N4Big = loop 0
where loop s n | s `seq` n `seq` False = undefined
loop _ 0 = mempty
loop s n = fromWrite (
writeWord64be (s+0) `mappend`
writeWord64be (s+1) `mappend`
writeWord64be (s+2) `mappend`
writeWord64be (s+3)) `mappend`
loop (s+4) (n-4)
writeWord64N8Big = loop 0
where loop s n | s `seq` n `seq` False = undefined
loop _ 0 = mempty
loop s n = fromWrite (
writeWord64be (s+0) `mappend`
writeWord64be (s+1) `mappend`
writeWord64be (s+2) `mappend`
writeWord64be (s+3) `mappend`
writeWord64be (s+4) `mappend`
writeWord64be (s+5) `mappend`
writeWord64be (s+6) `mappend`
writeWord64be (s+7)) `mappend`
loop (s+8) (n-8)
writeWord64N16Big = loop 0
where loop s n | s `seq` n `seq` False = undefined
loop _ 0 = mempty
loop s n = fromWrite (
writeWord64be (s+0) `mappend`
writeWord64be (s+1) `mappend`
writeWord64be (s+2) `mappend`
writeWord64be (s+3) `mappend`
writeWord64be (s+4) `mappend`
writeWord64be (s+5) `mappend`
writeWord64be (s+6) `mappend`
writeWord64be (s+7) `mappend`
writeWord64be (s+8) `mappend`
writeWord64be (s+9) `mappend`
writeWord64be (s+10) `mappend`
writeWord64be (s+11) `mappend`
writeWord64be (s+12) `mappend`
writeWord64be (s+13) `mappend`
writeWord64be (s+14) `mappend`
writeWord64be (s+15)) `mappend`
loop (s+16) (n-16)
------------------------------------------------------------------------
writeWord64N1Little = loop 0
where loop s n | s `seq` n `seq` False = undefined
loop _ 0 = mempty
loop s n = fromWrite (
writeWord64le (s+0)) `mappend`
loop (s+1) (n-1)
writeWord64N2Little = loop 0
where loop s n | s `seq` n `seq` False = undefined
loop _ 0 = mempty
loop s n = fromWrite (
writeWord64le (s+0) `mappend`
writeWord64le (s+1)) `mappend`
loop (s+2) (n-2)
writeWord64N4Little = loop 0
where loop s n | s `seq` n `seq` False = undefined
loop _ 0 = mempty
loop s n = fromWrite (
writeWord64le (s+0) `mappend`
writeWord64le (s+1) `mappend`
writeWord64le (s+2) `mappend`
writeWord64le (s+3)) `mappend`
loop (s+4) (n-4)
writeWord64N8Little = loop 0
where loop s n | s `seq` n `seq` False = undefined
loop _ 0 = mempty
loop s n = fromWrite (
writeWord64le (s+0) `mappend`
writeWord64le (s+1) `mappend`
writeWord64le (s+2) `mappend`
writeWord64le (s+3) `mappend`
writeWord64le (s+4) `mappend`
writeWord64le (s+5) `mappend`
writeWord64le (s+6) `mappend`
writeWord64le (s+7)) `mappend`
loop (s+8) (n-8)
writeWord64N16Little = loop 0
where loop s n | s `seq` n `seq` False = undefined
loop _ 0 = mempty
loop s n = fromWrite (
writeWord64le (s+0) `mappend`
writeWord64le (s+1) `mappend`
writeWord64le (s+2) `mappend`
writeWord64le (s+3) `mappend`
writeWord64le (s+4) `mappend`
writeWord64le (s+5) `mappend`
writeWord64le (s+6) `mappend`
writeWord64le (s+7) `mappend`
writeWord64le (s+8) `mappend`
writeWord64le (s+9) `mappend`
writeWord64le (s+10) `mappend`
writeWord64le (s+11) `mappend`
writeWord64le (s+12) `mappend`
writeWord64le (s+13) `mappend`
writeWord64le (s+14) `mappend`
writeWord64le (s+15)) `mappend`
loop (s+16) (n-16)
------------------------------------------------------------------------
writeWord64N1Host = loop 0
where loop s n | s `seq` n `seq` False = undefined
loop _ 0 = mempty
loop s n = fromWrite (
writeWord64host (s+0)) `mappend`
loop (s+1) (n-1)
writeWord64N2Host = loop 0
where loop s n | s `seq` n `seq` False = undefined
loop _ 0 = mempty
loop s n = fromWrite (
writeWord64host (s+0) `mappend`
writeWord64host (s+1)) `mappend`
loop (s+2) (n-2)
writeWord64N4Host = loop 0
where loop s n | s `seq` n `seq` False = undefined
loop _ 0 = mempty
loop s n = fromWrite (
writeWord64host (s+0) `mappend`
writeWord64host (s+1) `mappend`
writeWord64host (s+2) `mappend`
writeWord64host (s+3)) `mappend`
loop (s+4) (n-4)
writeWord64N8Host = loop 0
where loop s n | s `seq` n `seq` False = undefined
loop _ 0 = mempty
loop s n = fromWrite (
writeWord64host (s+0) `mappend`
writeWord64host (s+1) `mappend`
writeWord64host (s+2) `mappend`
writeWord64host (s+3) `mappend`
writeWord64host (s+4) `mappend`
writeWord64host (s+5) `mappend`
writeWord64host (s+6) `mappend`
writeWord64host (s+7)) `mappend`
loop (s+8) (n-8)
writeWord64N16Host = loop 0
where loop s n | s `seq` n `seq` False = undefined
loop _ 0 = mempty
loop s n = fromWrite (
writeWord64host (s+0) `mappend`
writeWord64host (s+1) `mappend`
writeWord64host (s+2) `mappend`
writeWord64host (s+3) `mappend`
writeWord64host (s+4) `mappend`
writeWord64host (s+5) `mappend`
writeWord64host (s+6) `mappend`
writeWord64host (s+7) `mappend`
writeWord64host (s+8) `mappend`
writeWord64host (s+9) `mappend`
writeWord64host (s+10) `mappend`
writeWord64host (s+11) `mappend`
writeWord64host (s+12) `mappend`
writeWord64host (s+13) `mappend`
writeWord64host (s+14) `mappend`
writeWord64host (s+15)) `mappend`
loop (s+16) (n-16)
blaze-builder-0.4.2.3/benchmarks/Throughput/BlazeBuilderDeclarative.hs 0000644 0000000 0000000 00000016734 07346545000 024135 0 ustar 00 0000000 0000000 {-# LANGUAGE BangPatterns #-}
module Throughput.BlazeBuilderDeclarative (
serialize
) where
import Data.Monoid
import Data.Word
import qualified Data.ByteString.Lazy as L
import Blaze.ByteString.Builder
import Throughput.Utils
serialize :: Int -> Int -> Endian -> Int -> L.ByteString
serialize wordSize chunkSize end = toLazyByteString .
case (wordSize, chunkSize, end) of
(1, 1,_) -> writeByteN1
(1, 2,_) -> writeByteN2
(1, 4,_) -> writeByteN4
(1, 8,_) -> writeByteN8
(1, 16, _) -> writeByteN16
(2, 1, Big) -> writeWord16N1Big
(2, 2, Big) -> writeWord16N2Big
(2, 4, Big) -> writeWord16N4Big
(2, 8, Big) -> writeWord16N8Big
(2, 16, Big) -> writeWord16N16Big
(2, 1, Little) -> writeWord16N1Little
(2, 2, Little) -> writeWord16N2Little
(2, 4, Little) -> writeWord16N4Little
(2, 8, Little) -> writeWord16N8Little
(2, 16, Little) -> writeWord16N16Little
(2, 1, Host) -> writeWord16N1Host
(2, 2, Host) -> writeWord16N2Host
(2, 4, Host) -> writeWord16N4Host
(2, 8, Host) -> writeWord16N8Host
(2, 16, Host) -> writeWord16N16Host
(4, 1, Big) -> writeWord32N1Big
(4, 2, Big) -> writeWord32N2Big
(4, 4, Big) -> writeWord32N4Big
(4, 8, Big) -> writeWord32N8Big
(4, 16, Big) -> writeWord32N16Big
(4, 1, Little) -> writeWord32N1Little
(4, 2, Little) -> writeWord32N2Little
(4, 4, Little) -> writeWord32N4Little
(4, 8, Little) -> writeWord32N8Little
(4, 16, Little) -> writeWord32N16Little
(4, 1, Host) -> writeWord32N1Host
(4, 2, Host) -> writeWord32N2Host
(4, 4, Host) -> writeWord32N4Host
(4, 8, Host) -> writeWord32N8Host
(4, 16, Host) -> writeWord32N16Host
(8, 1, Host) -> writeWord64N1Host
(8, 2, Host) -> writeWord64N2Host
(8, 4, Host) -> writeWord64N4Host
(8, 8, Host) -> writeWord64N8Host
(8, 16, Host) -> writeWord64N16Host
(8, 1, Big) -> writeWord64N1Big
(8, 2, Big) -> writeWord64N2Big
(8, 4, Big) -> writeWord64N4Big
(8, 8, Big) -> writeWord64N8Big
(8, 16, Big) -> writeWord64N16Big
(8, 1, Little) -> writeWord64N1Little
(8, 2, Little) -> writeWord64N2Little
(8, 4, Little) -> writeWord64N4Little
(8, 8, Little) -> writeWord64N8Little
(8, 16, Little) -> writeWord64N16Little
------------------------------------------------------------------------
-- Word8
------------------------------------------------------------------------
word8List :: Int -> [Word8]
word8List n = take n $ cycle $ [0..]
------------------------------------------------------------------------
writeByteN1 = fromWrite1List writeWord8 . word8List
writeByteN2 = fromWrite2List writeWord8 . word8List
writeByteN4 = fromWrite4List writeWord8 . word8List
writeByteN8 = fromWrite8List writeWord8 . word8List
writeByteN16 = fromWrite16List writeWord8 . word8List
------------------------------------------------------------------------
-- Word16
------------------------------------------------------------------------
word16List :: Int -> [Word16]
word16List n = take n $ cycle $ [0..]
------------------------------------------------------------------------
-- Big endian, word16 writes
writeWord16N1Big = fromWrite1List writeWord16be . word16List
writeWord16N2Big = fromWrite2List writeWord16be . word16List
writeWord16N4Big = fromWrite4List writeWord16be . word16List
writeWord16N8Big = fromWrite8List writeWord16be . word16List
writeWord16N16Big = fromWrite16List writeWord16be . word16List
------------------------------------------------------------------------
-- Little endian, word16 writes
writeWord16N1Little = fromWrite1List writeWord16le . word16List
writeWord16N2Little = fromWrite2List writeWord16le . word16List
writeWord16N4Little = fromWrite4List writeWord16le . word16List
writeWord16N8Little = fromWrite8List writeWord16le . word16List
writeWord16N16Little = fromWrite16List writeWord16le . word16List
------------------------------------------------------------------------
-- Host endian, unaligned, word16 writes
writeWord16N1Host = fromWrite1List writeWord16host . word16List
writeWord16N2Host = fromWrite2List writeWord16host . word16List
writeWord16N4Host = fromWrite4List writeWord16host . word16List
writeWord16N8Host = fromWrite8List writeWord16host . word16List
writeWord16N16Host = fromWrite16List writeWord16host . word16List
------------------------------------------------------------------------
-- Word32
------------------------------------------------------------------------
word32List :: Int -> [Word32]
word32List n = [0..fromIntegral (n-1)]
------------------------------------------------------------------------
-- Big endian, word16 writes
writeWord32N1Big = fromWrite1List writeWord32be . word32List
writeWord32N2Big = fromWrite2List writeWord32be . word32List
writeWord32N4Big = fromWrite4List writeWord32be . word32List
writeWord32N8Big = fromWrite8List writeWord32be . word32List
writeWord32N16Big = fromWrite16List writeWord32be . word32List
------------------------------------------------------------------------
-- Little endian, word32 writes
writeWord32N1Little = fromWrite1List writeWord32le . word32List
writeWord32N2Little = fromWrite2List writeWord32le . word32List
writeWord32N4Little = fromWrite4List writeWord32le . word32List
writeWord32N8Little = fromWrite8List writeWord32le . word32List
writeWord32N16Little = fromWrite16List writeWord32le . word32List
------------------------------------------------------------------------
-- Host endian, unaligned, word32 writes
writeWord32N1Host = fromWrite1List writeWord32host . word32List
writeWord32N2Host = fromWrite2List writeWord32host . word32List
writeWord32N4Host = fromWrite4List writeWord32host . word32List
writeWord32N8Host = fromWrite8List writeWord32host . word32List
writeWord32N16Host = fromWrite16List writeWord32host . word32List
------------------------------------------------------------------------
-- Word64
------------------------------------------------------------------------
word64List :: Int -> [Word64]
word64List n = [0..fromIntegral (n-1)]
------------------------------------------------------------------------
-- Big endian, word16 writes
writeWord64N1Big = fromWrite1List writeWord64be . word64List
writeWord64N2Big = fromWrite2List writeWord64be . word64List
writeWord64N4Big = fromWrite4List writeWord64be . word64List
writeWord64N8Big = fromWrite8List writeWord64be . word64List
writeWord64N16Big = fromWrite16List writeWord64be . word64List
------------------------------------------------------------------------
-- Little endian, word64 writes
writeWord64N1Little = fromWrite1List writeWord64le . word64List
writeWord64N2Little = fromWrite2List writeWord64le . word64List
writeWord64N4Little = fromWrite4List writeWord64le . word64List
writeWord64N8Little = fromWrite8List writeWord64le . word64List
writeWord64N16Little = fromWrite16List writeWord64le . word64List
------------------------------------------------------------------------
-- Host endian, unaligned, word64 writes
writeWord64N1Host = fromWrite1List writeWord64host . word64List
writeWord64N2Host = fromWrite2List writeWord64host . word64List
writeWord64N4Host = fromWrite4List writeWord64host . word64List
writeWord64N8Host = fromWrite8List writeWord64host . word64List
writeWord64N16Host = fromWrite16List writeWord64host . word64List
blaze-builder-0.4.2.3/benchmarks/Throughput/BlazePut.hs 0000644 0000000 0000000 00000061102 07346545000 021140 0 ustar 00 0000000 0000000 {-# LANGUAGE BangPatterns #-}
module Throughput.BlazePut (serialize) where
import qualified Data.ByteString.Lazy as L
import Blaze.ByteString.Builder
import Throughput.BlazePutMonad as Put
import Data.Monoid
import Throughput.Utils
------------------------------------------------------------------------
serialize :: Int -> Int -> Endian -> Int -> L.ByteString
serialize wordSize chunkSize end = runPut .
case (wordSize, chunkSize, end) of
(1, 1,_) -> writeByteN1
(1, 2,_) -> writeByteN2
(1, 4,_) -> writeByteN4
(1, 8,_) -> writeByteN8
(1, 16, _) -> writeByteN16
(2, 1, Big) -> writeWord16N1Big
(2, 2, Big) -> writeWord16N2Big
(2, 4, Big) -> writeWord16N4Big
(2, 8, Big) -> writeWord16N8Big
(2, 16, Big) -> writeWord16N16Big
(2, 1, Little) -> writeWord16N1Little
(2, 2, Little) -> writeWord16N2Little
(2, 4, Little) -> writeWord16N4Little
(2, 8, Little) -> writeWord16N8Little
(2, 16, Little) -> writeWord16N16Little
(2, 1, Host) -> writeWord16N1Host
(2, 2, Host) -> writeWord16N2Host
(2, 4, Host) -> writeWord16N4Host
(2, 8, Host) -> writeWord16N8Host
(2, 16, Host) -> writeWord16N16Host
(4, 1, Big) -> writeWord32N1Big
(4, 2, Big) -> writeWord32N2Big
(4, 4, Big) -> writeWord32N4Big
(4, 8, Big) -> writeWord32N8Big
(4, 16, Big) -> writeWord32N16Big
(4, 1, Little) -> writeWord32N1Little
(4, 2, Little) -> writeWord32N2Little
(4, 4, Little) -> writeWord32N4Little
(4, 8, Little) -> writeWord32N8Little
(4, 16, Little) -> writeWord32N16Little
(4, 1, Host) -> writeWord32N1Host
(4, 2, Host) -> writeWord32N2Host
(4, 4, Host) -> writeWord32N4Host
(4, 8, Host) -> writeWord32N8Host
(4, 16, Host) -> writeWord32N16Host
(8, 1, Host) -> writeWord64N1Host
(8, 2, Host) -> writeWord64N2Host
(8, 4, Host) -> writeWord64N4Host
(8, 8, Host) -> writeWord64N8Host
(8, 16, Host) -> writeWord64N16Host
(8, 1, Big) -> writeWord64N1Big
(8, 2, Big) -> writeWord64N2Big
(8, 4, Big) -> writeWord64N4Big
(8, 8, Big) -> writeWord64N8Big
(8, 16, Big) -> writeWord64N16Big
(8, 1, Little) -> writeWord64N1Little
(8, 2, Little) -> writeWord64N2Little
(8, 4, Little) -> writeWord64N4Little
(8, 8, Little) -> writeWord64N8Little
(8, 16, Little) -> writeWord64N16Little
------------------------------------------------------------------------
writeByteN1 bytes = loop 0 0
where loop !s !n | n == bytes = return ()
| otherwise = do
Put.putWrite ( writeWord8 s)
loop (s+1) (n+1)
writeByteN2 = loop 0
where loop s n | s `seq` n `seq` False = undefined
loop _ 0 = return ()
loop s n = do
do Put.putWrite (
writeWord8 (s+0) `mappend`
writeWord8 (s+1))
loop (s+2) (n-2)
writeByteN4 = loop 0
where loop s n | s `seq` n `seq` False = undefined
loop _ 0 = return ()
loop s n = do
Put.putWrite (
writeWord8 (s+0) `mappend`
writeWord8 (s+1) `mappend`
writeWord8 (s+2) `mappend`
writeWord8 (s+3))
loop (s+4) (n-4)
writeByteN8 = loop 0
where loop s n | s `seq` n `seq` False = undefined
loop _ 0 = return ()
loop s n = do
Put.putWrite (
writeWord8 (s+0) `mappend`
writeWord8 (s+1) `mappend`
writeWord8 (s+2) `mappend`
writeWord8 (s+3) `mappend`
writeWord8 (s+4) `mappend`
writeWord8 (s+5) `mappend`
writeWord8 (s+6) `mappend`
writeWord8 (s+7))
loop (s+8) (n-8)
writeByteN16 = loop 0
where loop s n | s `seq` n `seq` False = undefined
loop _ 0 = return ()
loop s n = do
Put.putWrite (
writeWord8 (s+0) `mappend`
writeWord8 (s+1) `mappend`
writeWord8 (s+2) `mappend`
writeWord8 (s+3) `mappend`
writeWord8 (s+4) `mappend`
writeWord8 (s+5) `mappend`
writeWord8 (s+6) `mappend`
writeWord8 (s+7) `mappend`
writeWord8 (s+8) `mappend`
writeWord8 (s+9) `mappend`
writeWord8 (s+10) `mappend`
writeWord8 (s+11) `mappend`
writeWord8 (s+12) `mappend`
writeWord8 (s+13) `mappend`
writeWord8 (s+14) `mappend`
writeWord8 (s+15))
loop (s+16) (n-16)
------------------------------------------------------------------------
-- Big endian, word16 writes
writeWord16N1Big = loop 0
where loop s n | s `seq` n `seq` False = undefined
loop _ 0 = return ()
loop s n = do
Put.putWord16be (s+0)
loop (s+1) (n-1)
writeWord16N2Big = loop 0
where loop s n | s `seq` n `seq` False = undefined
loop _ 0 = return ()
loop s n = do
Put.putWrite (
writeWord16be (s+0) `mappend`
writeWord16be (s+1))
loop (s+2) (n-2)
writeWord16N4Big = loop 0
where loop s n | s `seq` n `seq` False = undefined
loop _ 0 = return ()
loop s n = do
Put.putWrite (
writeWord16be (s+0) `mappend`
writeWord16be (s+1) `mappend`
writeWord16be (s+2) `mappend`
writeWord16be (s+3))
loop (s+4) (n-4)
writeWord16N8Big = loop 0
where loop s n | s `seq` n `seq` False = undefined
loop _ 0 = return ()
loop s n = do
Put.putWrite (
writeWord16be (s+0) `mappend`
writeWord16be (s+1) `mappend`
writeWord16be (s+2) `mappend`
writeWord16be (s+3) `mappend`
writeWord16be (s+4) `mappend`
writeWord16be (s+5) `mappend`
writeWord16be (s+6) `mappend`
writeWord16be (s+7))
loop (s+8) (n-8)
writeWord16N16Big = loop 0
where loop s n | s `seq` n `seq` False = undefined
loop _ 0 = return ()
loop s n = do
Put.putWrite (
writeWord16be (s+0) `mappend`
writeWord16be (s+1) `mappend`
writeWord16be (s+2) `mappend`
writeWord16be (s+3) `mappend`
writeWord16be (s+4) `mappend`
writeWord16be (s+5) `mappend`
writeWord16be (s+6) `mappend`
writeWord16be (s+7) `mappend`
writeWord16be (s+8) `mappend`
writeWord16be (s+9) `mappend`
writeWord16be (s+10) `mappend`
writeWord16be (s+11) `mappend`
writeWord16be (s+12) `mappend`
writeWord16be (s+13) `mappend`
writeWord16be (s+14) `mappend`
writeWord16be (s+15))
loop (s+16) (n-16)
------------------------------------------------------------------------
-- Little endian, word16 writes
writeWord16N1Little = loop 0
where loop s n | s `seq` n `seq` False = undefined
loop _ 0 = return ()
loop s n =
do Put.putWord16le (s+0)
loop (s+1) (n-1)
writeWord16N2Little = loop 0
where loop s n | s `seq` n `seq` False = undefined
loop _ 0 = return ()
loop s n = do
Put.putWrite (
writeWord16le (s+0) `mappend`
writeWord16le (s+1))
loop (s+2) (n-2)
writeWord16N4Little = loop 0
where loop s n | s `seq` n `seq` False = undefined
loop _ 0 = return ()
loop s n = do
Put.putWrite (
writeWord16le (s+0) `mappend`
writeWord16le (s+1) `mappend`
writeWord16le (s+2) `mappend`
writeWord16le (s+3))
loop (s+4) (n-4)
writeWord16N8Little = loop 0
where loop s n | s `seq` n `seq` False = undefined
loop _ 0 = return ()
loop s n = do
Put.putWrite (
writeWord16le (s+0) `mappend`
writeWord16le (s+1) `mappend`
writeWord16le (s+2) `mappend`
writeWord16le (s+3) `mappend`
writeWord16le (s+4) `mappend`
writeWord16le (s+5) `mappend`
writeWord16le (s+6) `mappend`
writeWord16le (s+7))
loop (s+8) (n-8)
writeWord16N16Little = loop 0
where loop s n | s `seq` n `seq` False = undefined
loop _ 0 = return ()
loop s n = do
Put.putWrite (
writeWord16le (s+0) `mappend`
writeWord16le (s+1) `mappend`
writeWord16le (s+2) `mappend`
writeWord16le (s+3) `mappend`
writeWord16le (s+4) `mappend`
writeWord16le (s+5) `mappend`
writeWord16le (s+6) `mappend`
writeWord16le (s+7) `mappend`
writeWord16le (s+8) `mappend`
writeWord16le (s+9) `mappend`
writeWord16le (s+10) `mappend`
writeWord16le (s+11) `mappend`
writeWord16le (s+12) `mappend`
writeWord16le (s+13) `mappend`
writeWord16le (s+14) `mappend`
writeWord16le (s+15))
loop (s+16) (n-16)
------------------------------------------------------------------------
-- Host endian, unaligned, word16 writes
writeWord16N1Host = loop 0
where loop s n | s `seq` n `seq` False = undefined
loop _ 0 = return ()
loop s n = do
Put.putWord16host (s+0)
loop (s+1) (n-1)
writeWord16N2Host = loop 0
where loop s n | s `seq` n `seq` False = undefined
loop _ 0 = return ()
loop s n = do
Put.putWrite (
writeWord16host (s+0) `mappend`
writeWord16host (s+1))
loop (s+2) (n-2)
writeWord16N4Host = loop 0
where loop s n | s `seq` n `seq` False = undefined
loop _ 0 = return ()
loop s n = do
Put.putWrite (
writeWord16host (s+0) `mappend`
writeWord16host (s+1) `mappend`
writeWord16host (s+2) `mappend`
writeWord16host (s+3))
loop (s+4) (n-4)
writeWord16N8Host = loop 0
where loop s n | s `seq` n `seq` False = undefined
loop _ 0 = return ()
loop s n = do
Put.putWrite (
writeWord16host (s+0) `mappend`
writeWord16host (s+1) `mappend`
writeWord16host (s+2) `mappend`
writeWord16host (s+3) `mappend`
writeWord16host (s+4) `mappend`
writeWord16host (s+5) `mappend`
writeWord16host (s+6) `mappend`
writeWord16host (s+7))
loop (s+8) (n-8)
writeWord16N16Host = loop 0
where loop s n | s `seq` n `seq` False = undefined
loop _ 0 = return ()
loop s n = do
Put.putWrite (
writeWord16host (s+0) `mappend`
writeWord16host (s+1) `mappend`
writeWord16host (s+2) `mappend`
writeWord16host (s+3) `mappend`
writeWord16host (s+4) `mappend`
writeWord16host (s+5) `mappend`
writeWord16host (s+6) `mappend`
writeWord16host (s+7) `mappend`
writeWord16host (s+8) `mappend`
writeWord16host (s+9) `mappend`
writeWord16host (s+10) `mappend`
writeWord16host (s+11) `mappend`
writeWord16host (s+12) `mappend`
writeWord16host (s+13) `mappend`
writeWord16host (s+14) `mappend`
writeWord16host (s+15))
loop (s+16) (n-16)
------------------------------------------------------------------------
writeWord32N1Big = loop 0
where loop s n | s `seq` n `seq` False = undefined
loop _ 0 = return ()
loop s n = do
Put.putWord32be (s+0)
loop (s+1) (n-1)
writeWord32N2Big = loop 0
where loop s n | s `seq` n `seq` False = undefined
loop _ 0 = return ()
loop s n = do
Put.putWrite (
writeWord32be (s+0) `mappend`
writeWord32be (s+1))
loop (s+2) (n-2)
writeWord32N4Big = loop 0
where loop s n | s `seq` n `seq` False = undefined
loop _ 0 = return ()
loop s n = do
Put.putWrite (
writeWord32be (s+0) `mappend`
writeWord32be (s+1) `mappend`
writeWord32be (s+2) `mappend`
writeWord32be (s+3))
loop (s+4) (n-4)
writeWord32N8Big = loop 0
where loop s n | s `seq` n `seq` False = undefined
loop _ 0 = return ()
loop s n = do
Put.putWrite (
writeWord32be (s+0) `mappend`
writeWord32be (s+1) `mappend`
writeWord32be (s+2) `mappend`
writeWord32be (s+3) `mappend`
writeWord32be (s+4) `mappend`
writeWord32be (s+5) `mappend`
writeWord32be (s+6) `mappend`
writeWord32be (s+7))
loop (s+8) (n-8)
writeWord32N16Big = loop 0
where loop s n | s `seq` n `seq` False = undefined
loop _ 0 = return ()
loop s n = do
Put.putWrite (
writeWord32be (s+0) `mappend`
writeWord32be (s+1) `mappend`
writeWord32be (s+2) `mappend`
writeWord32be (s+3) `mappend`
writeWord32be (s+4) `mappend`
writeWord32be (s+5) `mappend`
writeWord32be (s+6) `mappend`
writeWord32be (s+7) `mappend`
writeWord32be (s+8) `mappend`
writeWord32be (s+9) `mappend`
writeWord32be (s+10) `mappend`
writeWord32be (s+11) `mappend`
writeWord32be (s+12) `mappend`
writeWord32be (s+13) `mappend`
writeWord32be (s+14) `mappend`
writeWord32be (s+15))
loop (s+16) (n-16)
------------------------------------------------------------------------
writeWord32N1Little = loop 0
where loop s n | s `seq` n `seq` False = undefined
loop _ 0 = return ()
loop s n = do
Put.putWord32le (s+0)
loop (s+1) (n-1)
writeWord32N2Little = loop 0
where loop s n | s `seq` n `seq` False = undefined
loop _ 0 = return ()
loop s n = do
Put.putWrite (
writeWord32le (s+0) `mappend`
writeWord32le (s+1))
loop (s+2) (n-2)
writeWord32N4Little = loop 0
where loop s n | s `seq` n `seq` False = undefined
loop _ 0 = return ()
loop s n = do
Put.putWrite (
writeWord32le (s+0) `mappend`
writeWord32le (s+1) `mappend`
writeWord32le (s+2) `mappend`
writeWord32le (s+3))
loop (s+4) (n-4)
writeWord32N8Little = loop 0
where loop s n | s `seq` n `seq` False = undefined
loop _ 0 = return ()
loop s n = do
Put.putWrite (
writeWord32le (s+0) `mappend`
writeWord32le (s+1) `mappend`
writeWord32le (s+2) `mappend`
writeWord32le (s+3) `mappend`
writeWord32le (s+4) `mappend`
writeWord32le (s+5) `mappend`
writeWord32le (s+6) `mappend`
writeWord32le (s+7))
loop (s+8) (n-8)
writeWord32N16Little = loop 0
where loop s n | s `seq` n `seq` False = undefined
loop _ 0 = return ()
loop s n = do
Put.putWrite (
writeWord32le (s+0) `mappend`
writeWord32le (s+1) `mappend`
writeWord32le (s+2) `mappend`
writeWord32le (s+3) `mappend`
writeWord32le (s+4) `mappend`
writeWord32le (s+5) `mappend`
writeWord32le (s+6) `mappend`
writeWord32le (s+7) `mappend`
writeWord32le (s+8) `mappend`
writeWord32le (s+9) `mappend`
writeWord32le (s+10) `mappend`
writeWord32le (s+11) `mappend`
writeWord32le (s+12) `mappend`
writeWord32le (s+13) `mappend`
writeWord32le (s+14) `mappend`
writeWord32le (s+15))
loop (s+16) (n-16)
------------------------------------------------------------------------
writeWord32N1Host = loop 0
where loop s n | s `seq` n `seq` False = undefined
loop _ 0 = return ()
loop s n = do
Put.putWord32host (s+0)
loop (s+1) (n-1)
writeWord32N2Host = loop 0
where loop s n | s `seq` n `seq` False = undefined
loop _ 0 = return ()
loop s n = do
Put.putWrite (
writeWord32host (s+0) `mappend`
writeWord32host (s+1))
loop (s+2) (n-2)
writeWord32N4Host = loop 0
where loop s n | s `seq` n `seq` False = undefined
loop _ 0 = return ()
loop s n = do
Put.putWrite (
writeWord32host (s+0) `mappend`
writeWord32host (s+1) `mappend`
writeWord32host (s+2) `mappend`
writeWord32host (s+3))
loop (s+4) (n-4)
writeWord32N8Host = loop 0
where loop s n | s `seq` n `seq` False = undefined
loop _ 0 = return ()
loop s n = do
Put.putWrite (
writeWord32host (s+0) `mappend`
writeWord32host (s+1) `mappend`
writeWord32host (s+2) `mappend`
writeWord32host (s+3) `mappend`
writeWord32host (s+4) `mappend`
writeWord32host (s+5) `mappend`
writeWord32host (s+6) `mappend`
writeWord32host (s+7))
loop (s+8) (n-8)
writeWord32N16Host = loop 0
where loop s n | s `seq` n `seq` False = undefined
loop _ 0 = return ()
loop s n = do
Put.putWrite (
writeWord32host (s+0) `mappend`
writeWord32host (s+1) `mappend`
writeWord32host (s+2) `mappend`
writeWord32host (s+3) `mappend`
writeWord32host (s+4) `mappend`
writeWord32host (s+5) `mappend`
writeWord32host (s+6) `mappend`
writeWord32host (s+7) `mappend`
writeWord32host (s+8) `mappend`
writeWord32host (s+9) `mappend`
writeWord32host (s+10) `mappend`
writeWord32host (s+11) `mappend`
writeWord32host (s+12) `mappend`
writeWord32host (s+13) `mappend`
writeWord32host (s+14) `mappend`
writeWord32host (s+15))
loop (s+16) (n-16)
------------------------------------------------------------------------
writeWord64N1Big = loop 0
where loop s n | s `seq` n `seq` False = undefined
loop _ 0 = return ()
loop s n = do
Put.putWord64be (s+0)
loop (s+1) (n-1)
writeWord64N2Big = loop 0
where loop s n | s `seq` n `seq` False = undefined
loop _ 0 = return ()
loop s n = do
Put.putWrite (
writeWord64be (s+0) `mappend`
writeWord64be (s+1))
loop (s+2) (n-2)
writeWord64N4Big = loop 0
where loop s n | s `seq` n `seq` False = undefined
loop _ 0 = return ()
loop s n = do
Put.putWrite (
writeWord64be (s+0) `mappend`
writeWord64be (s+1) `mappend`
writeWord64be (s+2) `mappend`
writeWord64be (s+3))
loop (s+4) (n-4)
writeWord64N8Big = loop 0
where loop s n | s `seq` n `seq` False = undefined
loop _ 0 = return ()
loop s n = do
Put.putWrite (
writeWord64be (s+0) `mappend`
writeWord64be (s+1) `mappend`
writeWord64be (s+2) `mappend`
writeWord64be (s+3) `mappend`
writeWord64be (s+4) `mappend`
writeWord64be (s+5) `mappend`
writeWord64be (s+6) `mappend`
writeWord64be (s+7))
loop (s+8) (n-8)
writeWord64N16Big = loop 0
where loop s n | s `seq` n `seq` False = undefined
loop _ 0 = return ()
loop s n = do
Put.putWrite (
writeWord64be (s+0) `mappend`
writeWord64be (s+1) `mappend`
writeWord64be (s+2) `mappend`
writeWord64be (s+3) `mappend`
writeWord64be (s+4) `mappend`
writeWord64be (s+5) `mappend`
writeWord64be (s+6) `mappend`
writeWord64be (s+7) `mappend`
writeWord64be (s+8) `mappend`
writeWord64be (s+9) `mappend`
writeWord64be (s+10) `mappend`
writeWord64be (s+11) `mappend`
writeWord64be (s+12) `mappend`
writeWord64be (s+13) `mappend`
writeWord64be (s+14) `mappend`
writeWord64be (s+15))
loop (s+16) (n-16)
------------------------------------------------------------------------
writeWord64N1Little = loop 0
where loop s n | s `seq` n `seq` False = undefined
loop _ 0 = return ()
loop s n = do
Put.putWord64le (s+0)
loop (s+1) (n-1)
writeWord64N2Little = loop 0
where loop s n | s `seq` n `seq` False = undefined
loop _ 0 = return ()
loop s n = do
Put.putWrite (
writeWord64le (s+0) `mappend`
writeWord64le (s+1))
loop (s+2) (n-2)
writeWord64N4Little = loop 0
where loop s n | s `seq` n `seq` False = undefined
loop _ 0 = return ()
loop s n = do
Put.putWrite (
writeWord64le (s+0) `mappend`
writeWord64le (s+1) `mappend`
writeWord64le (s+2) `mappend`
writeWord64le (s+3))
loop (s+4) (n-4)
writeWord64N8Little = loop 0
where loop s n | s `seq` n `seq` False = undefined
loop _ 0 = return ()
loop s n = do
Put.putWrite (
writeWord64le (s+0) `mappend`
writeWord64le (s+1) `mappend`
writeWord64le (s+2) `mappend`
writeWord64le (s+3) `mappend`
writeWord64le (s+4) `mappend`
writeWord64le (s+5) `mappend`
writeWord64le (s+6) `mappend`
writeWord64le (s+7))
loop (s+8) (n-8)
writeWord64N16Little = loop 0
where loop s n | s `seq` n `seq` False = undefined
loop _ 0 = return ()
loop s n = do
Put.putWrite (
writeWord64le (s+0) `mappend`
writeWord64le (s+1) `mappend`
writeWord64le (s+2) `mappend`
writeWord64le (s+3) `mappend`
writeWord64le (s+4) `mappend`
writeWord64le (s+5) `mappend`
writeWord64le (s+6) `mappend`
writeWord64le (s+7) `mappend`
writeWord64le (s+8) `mappend`
writeWord64le (s+9) `mappend`
writeWord64le (s+10) `mappend`
writeWord64le (s+11) `mappend`
writeWord64le (s+12) `mappend`
writeWord64le (s+13) `mappend`
writeWord64le (s+14) `mappend`
writeWord64le (s+15))
loop (s+16) (n-16)
------------------------------------------------------------------------
writeWord64N1Host = loop 0
where loop s n | s `seq` n `seq` False = undefined
loop _ 0 = return ()
loop s n = do
Put.putWord64host (s+0)
loop (s+1) (n-1)
writeWord64N2Host = loop 0
where loop s n | s `seq` n `seq` False = undefined
loop _ 0 = return ()
loop s n = do
Put.putWrite (
writeWord64host (s+0) `mappend`
writeWord64host (s+1))
loop (s+2) (n-2)
writeWord64N4Host = loop 0
where loop s n | s `seq` n `seq` False = undefined
loop _ 0 = return ()
loop s n = do
Put.putWrite (
writeWord64host (s+0) `mappend`
writeWord64host (s+1) `mappend`
writeWord64host (s+2) `mappend`
writeWord64host (s+3))
loop (s+4) (n-4)
writeWord64N8Host = loop 0
where loop s n | s `seq` n `seq` False = undefined
loop _ 0 = return ()
loop s n = do
Put.putWrite (
writeWord64host (s+0) `mappend`
writeWord64host (s+1) `mappend`
writeWord64host (s+2) `mappend`
writeWord64host (s+3) `mappend`
writeWord64host (s+4) `mappend`
writeWord64host (s+5) `mappend`
writeWord64host (s+6) `mappend`
writeWord64host (s+7))
loop (s+8) (n-8)
writeWord64N16Host = loop 0
where loop s n | s `seq` n `seq` False = undefined
loop _ 0 = return ()
loop s n = do
Put.putWrite (
writeWord64host (s+0) `mappend`
writeWord64host (s+1) `mappend`
writeWord64host (s+2) `mappend`
writeWord64host (s+3) `mappend`
writeWord64host (s+4) `mappend`
writeWord64host (s+5) `mappend`
writeWord64host (s+6) `mappend`
writeWord64host (s+7) `mappend`
writeWord64host (s+8) `mappend`
writeWord64host (s+9) `mappend`
writeWord64host (s+10) `mappend`
writeWord64host (s+11) `mappend`
writeWord64host (s+12) `mappend`
writeWord64host (s+13) `mappend`
writeWord64host (s+14) `mappend`
writeWord64host (s+15))
loop (s+16) (n-16)
blaze-builder-0.4.2.3/benchmarks/Throughput/BlazePutMonad.hs 0000644 0000000 0000000 00000014510 07346545000 022120 0 ustar 00 0000000 0000000 {-# LANGUAGE CPP #-}
-----------------------------------------------------------------------------
-- |
-- Module : Data.Binary.Put
-- Copyright : Lennart Kolmodin
-- License : BSD3-style (see LICENSE)
--
-- Maintainer : Lennart Kolmodin
-- Stability : stable
-- Portability : Portable to Hugs and GHC. Requires MPTCs
--
-- The Put monad. A monad for efficiently constructing lazy bytestrings using
-- the Builder developed for blaze-html.
--
-----------------------------------------------------------------------------
module Throughput.BlazePutMonad (
-- * The Put type
Put
, PutM(..)
, runPut
, runPutM
, putBuilder
, execPut
-- * Flushing the implicit parse state
, flush
-- * Primitives
, putWrite
, putWord8
, putByteString
, putLazyByteString
-- * Big-endian primitives
, putWord16be
, putWord32be
, putWord64be
-- * Little-endian primitives
, putWord16le
, putWord32le
, putWord64le
-- * Host-endian, unaligned writes
, putWordhost -- :: Word -> Put
, putWord16host -- :: Word16 -> Put
, putWord32host -- :: Word32 -> Put
, putWord64host -- :: Word64 -> Put
) where
import Data.Monoid
import Blaze.ByteString.Builder (Builder, toLazyByteString)
import qualified Blaze.ByteString.Builder as B
import Data.Word
import qualified Data.ByteString as S
import qualified Data.ByteString.Lazy as L
import Control.Applicative
------------------------------------------------------------------------
-- XXX Strict in buffer only.
data PairS a = PairS a {-# UNPACK #-}!Builder
sndS :: PairS a -> Builder
sndS (PairS _ b) = b
-- | The PutM type. A Writer monad over the efficient Builder monoid.
newtype PutM a = Put { unPut :: PairS a }
-- | Put merely lifts Builder into a Writer monad, applied to ().
type Put = PutM ()
instance Functor PutM where
fmap f m = Put $ let PairS a w = unPut m in PairS (f a) w
{-# INLINE fmap #-}
instance Applicative PutM where
pure = return
m <*> k = Put $
let PairS f w = unPut m
PairS x w' = unPut k
in PairS (f x) (w `mappend` w')
-- Standard Writer monad, with aggressive inlining
instance Monad PutM where
return a = Put $ PairS a mempty
{-# INLINE return #-}
m >>= k = Put $
let PairS a w = unPut m
PairS b w' = unPut (k a)
in PairS b (w `mappend` w')
{-# INLINE (>>=) #-}
m >> k = Put $
let PairS _ w = unPut m
PairS b w' = unPut k
in PairS b (w `mappend` w')
{-# INLINE (>>) #-}
tell :: Builder -> Put
tell b = Put $ PairS () b
{-# INLINE tell #-}
putBuilder :: Builder -> Put
putBuilder = tell
{-# INLINE putBuilder #-}
-- | Run the 'Put' monad
execPut :: PutM a -> Builder
execPut = sndS . unPut
{-# INLINE execPut #-}
-- | Run the 'Put' monad with a serialiser
runPut :: Put -> L.ByteString
runPut = toLazyByteString . sndS . unPut
{-# INLINE runPut #-}
-- | Run the 'Put' monad with a serialiser and get its result
runPutM :: PutM a -> (a, L.ByteString)
runPutM (Put (PairS f s)) = (f, toLazyByteString s)
{-# INLINE runPutM #-}
------------------------------------------------------------------------
-- | Pop the ByteString we have constructed so far, if any, yielding a
-- new chunk in the result ByteString.
flush :: Put
flush = tell B.flush
{-# INLINE flush #-}
-- | Efficiently write a byte into the output buffer
putWord8 :: Word8 -> Put
putWord8 = tell . B.fromWord8
{-# INLINE putWord8 #-}
-- | Execute a write on the output buffer.
putWrite :: B.Write -> Put
putWrite = tell . B.fromWrite
-- | An efficient primitive to write a strict ByteString into the output buffer.
-- It flushes the current buffer, and writes the argument into a new chunk.
putByteString :: S.ByteString -> Put
putByteString = tell . B.fromByteString
{-# INLINE putByteString #-}
-- | Write a lazy ByteString efficiently, simply appending the lazy
-- ByteString chunks to the output buffer
putLazyByteString :: L.ByteString -> Put
putLazyByteString = tell . B.fromLazyByteString
{-# INLINE putLazyByteString #-}
-- | Write a Word16 in big endian format
putWord16be :: Word16 -> Put
putWord16be = tell . B.fromWord16be
{-# INLINE putWord16be #-}
-- | Write a Word16 in little endian format
putWord16le :: Word16 -> Put
putWord16le = tell . B.fromWord16le
{-# INLINE putWord16le #-}
-- | Write a Word32 in big endian format
putWord32be :: Word32 -> Put
putWord32be = tell . B.fromWord32be
{-# INLINE putWord32be #-}
-- | Write a Word32 in little endian format
putWord32le :: Word32 -> Put
putWord32le = tell . B.fromWord32le
{-# INLINE putWord32le #-}
-- | Write a Word64 in big endian format
putWord64be :: Word64 -> Put
putWord64be = tell . B.fromWord64be
{-# INLINE putWord64be #-}
-- | Write a Word64 in little endian format
putWord64le :: Word64 -> Put
putWord64le = tell . B.fromWord64le
{-# INLINE putWord64le #-}
------------------------------------------------------------------------
-- | /O(1)./ Write a single native machine word. The word is
-- written in host order, host endian form, for the machine you're on.
-- On a 64 bit machine the Word is an 8 byte value, on a 32 bit machine,
-- 4 bytes. Values written this way are not portable to
-- different endian or word sized machines, without conversion.
--
putWordhost :: Word -> Put
putWordhost = tell . B.fromWordhost
{-# INLINE putWordhost #-}
-- | /O(1)./ Write a Word16 in native host order and host endianness.
-- For portability issues see @putWordhost@.
putWord16host :: Word16 -> Put
putWord16host = tell . B.fromWord16host
{-# INLINE putWord16host #-}
-- | /O(1)./ Write a Word32 in native host order and host endianness.
-- For portability issues see @putWordhost@.
putWord32host :: Word32 -> Put
putWord32host = tell . B.fromWord32host
{-# INLINE putWord32host #-}
-- | /O(1)./ Write a Word64 in native host order
-- On a 32 bit machine we write two host order Word32s, in big endian form.
-- For portability issues see @putWordhost@.
putWord64host :: Word64 -> Put
putWord64host = tell . B.fromWord64host
{-# INLINE putWord64host #-}
blaze-builder-0.4.2.3/benchmarks/Throughput/CBenchmark.c 0000644 0000000 0000000 00000001356 07346545000 021224 0 ustar 00 0000000 0000000 #include "CBenchmark.h"
void bytewrite(unsigned char *a, int bytes) {
unsigned char n = 0;
int i = 0;
int iterations = bytes;
while (i < iterations) {
a[i++] = n++;
}
}
unsigned char byteread(unsigned char *a, int bytes) {
unsigned char n = 0;
int i = 0;
int iterations = bytes;
while (i < iterations) {
n += a[i++];
}
return n;
}
void wordwrite(unsigned long *a, int bytes) {
unsigned long n = 0;
int i = 0;
int iterations = bytes / sizeof(unsigned long) ;
while (i < iterations) {
a[i++] = n++;
}
}
unsigned int wordread(unsigned long *a, int bytes) {
unsigned long n = 0;
int i = 0;
int iterations = bytes / sizeof(unsigned long);
while (i < iterations) {
n += a[i++];
}
return n;
}
blaze-builder-0.4.2.3/benchmarks/Throughput/CBenchmark.h 0000644 0000000 0000000 00000000303 07346545000 021220 0 ustar 00 0000000 0000000 void bytewrite(unsigned char *a, int bytes);
unsigned char byteread(unsigned char *a, int bytes);
void wordwrite(unsigned long *a, int bytes);
unsigned int wordread(unsigned long *a, int bytes);
blaze-builder-0.4.2.3/benchmarks/Throughput/Memory.hs 0000644 0000000 0000000 00000007172 07346545000 020671 0 ustar 00 0000000 0000000 {-# LANGUAGE ForeignFunctionInterface, BangPatterns #-}
module Throughput.Memory (memBench) where
import Foreign
import Foreign.C
import Control.Exception
import System.CPUTime
import Numeric
memBench :: Int -> IO ()
memBench mb = do
let bytes = mb * 2^20
allocaBytes bytes $ \ptr -> do
let bench label test = do
seconds <- time $ test (castPtr ptr) (fromIntegral bytes)
let throughput = fromIntegral mb / seconds
putStrLn $ show mb ++ "MB of " ++ label
++ " in " ++ showFFloat (Just 3) seconds "s, at: "
++ showFFloat (Just 1) throughput "MB/s"
bench "setup " c_wordwrite
putStrLn ""
putStrLn "C memory throughput benchmarks:"
bench "bytes written " c_bytewrite
bench "bytes read " c_byteread
bench "words written " c_wordwrite
bench "words read " c_wordread
putStrLn ""
putStrLn "Haskell memory throughput benchmarks:"
bench "bytes written " hs_bytewrite
bench "bytes written (loop unrolled once)" hs_bytewrite2
bench "bytes read " hs_byteread
bench "words written " hs_wordwrite
bench "words read " hs_wordread
hs_bytewrite :: Ptr CUChar -> Int -> IO ()
hs_bytewrite !ptr bytes = loop 0 0
where iterations = bytes
loop :: Int -> CUChar -> IO ()
loop !i !n | i == iterations = return ()
| otherwise = do pokeByteOff ptr i n
loop (i+1) (n+1)
hs_bytewrite2 :: Ptr CUChar -> Int -> IO ()
hs_bytewrite2 !start bytes = loop start 0
where end = start `plusPtr` bytes
loop :: Ptr CUChar -> CUChar -> IO ()
loop !ptr !n | ptr `plusPtr` 2 < end = do
poke ptr n
poke (ptr `plusPtr` 1) (n+1)
loop (ptr `plusPtr` 2) (n+2)
| ptr `plusPtr` 1 < end =
poke ptr n
| otherwise = return ()
hs_byteread :: Ptr CUChar -> Int -> IO CUChar
hs_byteread !ptr bytes = loop 0 0
where iterations = bytes
loop :: Int -> CUChar -> IO CUChar
loop !i !n | i == iterations = return n
| otherwise = do x <- peekByteOff ptr i
loop (i+1) (n+x)
hs_wordwrite :: Ptr CULong -> Int -> IO ()
hs_wordwrite !ptr bytes = loop 0 0
where iterations = bytes `div` sizeOf (undefined :: CULong)
loop :: Int -> CULong -> IO ()
loop !i !n | i == iterations = return ()
| otherwise = do pokeByteOff ptr i n
loop (i+1) (n+1)
hs_wordread :: Ptr CULong -> Int -> IO CULong
hs_wordread !ptr bytes = loop 0 0
where iterations = bytes `div` sizeOf (undefined :: CULong)
loop :: Int -> CULong -> IO CULong
loop !i !n | i == iterations = return n
| otherwise = do x <- peekByteOff ptr i
loop (i+1) (n+x)
foreign import ccall unsafe "CBenchmark.h byteread"
c_byteread :: Ptr CUChar -> CInt -> IO ()
foreign import ccall unsafe "CBenchmark.h bytewrite"
c_bytewrite :: Ptr CUChar -> CInt -> IO ()
foreign import ccall unsafe "CBenchmark.h wordread"
c_wordread :: Ptr CUInt -> CInt -> IO ()
foreign import ccall unsafe "CBenchmark.h wordwrite"
c_wordwrite :: Ptr CUInt -> CInt -> IO ()
time :: IO a -> IO Double
time action = do
start <- getCPUTime
action
end <- getCPUTime
return $! (fromIntegral (end - start)) / (10^12)
blaze-builder-0.4.2.3/benchmarks/Throughput/Utils.hs 0000644 0000000 0000000 00000000176 07346545000 020516 0 ustar 00 0000000 0000000 module Throughput.Utils (
Endian(..)
) where
data Endian
= Big
| Little
| Host
deriving (Eq,Ord,Show)
blaze-builder-0.4.2.3/benchmarks/UnboxedAppend.hs 0000644 0000000 0000000 00000022107 07346545000 017777 0 ustar 00 0000000 0000000 {-# LANGUAGE CPP, BangPatterns, Rank2Types, MagicHash #-}
-- |
-- Module : UnboxedAppend
-- Copyright : (c) 2010 Simon Meier
-- License : BSD3-style (see LICENSE)
--
-- Maintainer : https://github.com/blaze-builder
-- Stability : stable
-- 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)
blaze-builder-0.4.2.3/benchmarks/Utf8IO.hs 0000644 0000000 0000000 00000007305 07346545000 016324 0 ustar 00 0000000 0000000 {-# LANGUAGE OverloadedStrings #-}
-- |
-- Copyright : (c) 2011 Simon Meier
-- License : BSD3-style (see LICENSE)
--
-- Maintainer : https://github.com/blaze-builder
-- Stability : stable
-- Portability : tested on GHC only
--
-- Benchmarking IO output speed of writing a string in Utf8 encoding to a file.
module Utf8IO (main) where
import Control.Monad
import Control.Exception (evaluate)
import qualified Codec.Binary.UTF8.Light as Utf8Light
import Data.Char (chr)
import Data.Time.Clock
import qualified Data.ByteString.Lazy as L
import qualified Data.ByteString.Lazy.UTF8 as Utf8String
import qualified Data.Text.Lazy as TL
import qualified Data.Text.Lazy.Encoding as TL
import System.IO
import System.Environment
import Blaze.ByteString.Builder
import Blaze.ByteString.Builder.Internal (defaultBufferSize)
import qualified Blaze.ByteString.Builder.Char.Utf8 as Blaze
-- | Write using the standard text utf8 encoding function built into 'base'.
writeUtf8_base :: String -> FilePath -> IO ()
writeUtf8_base cs file =
withFile file WriteMode $ \h -> do
hSetEncoding h utf8
hPutStr h cs
-- | Write using utf8 encoding as provided by the 'blaze-builder' library.
writeUtf8_blaze :: String -> FilePath -> IO ()
writeUtf8_blaze cs file = L.writeFile file $ toLazyByteString $ Blaze.fromString cs
-- | Write using utf8 encoding as provided by the 'text' library.
writeUtf8_text :: TL.Text -> FilePath -> IO ()
writeUtf8_text tx file = L.writeFile file $ TL.encodeUtf8 tx
-- | Write using utf8 encoding as provided by the 'utf8-string' library.
writeUtf8_string :: String -> FilePath -> IO ()
writeUtf8_string cs file = L.writeFile file $ Utf8String.fromString cs
-- | Write using utf8 encoding as provided by the 'utf8-light' library. Note
-- that this library only allows encoding the whole string as a strict
-- bytestring. That might make it unusable in some circumstances.
{-# NOINLINE writeUtf8_light #-}
writeUtf8_light :: String -> FilePath -> IO ()
writeUtf8_light cs file = Utf8Light.writeUTF8File file cs
main :: IO ()
main = do
[how, len, file] <- getArgs
let blocksize = 32000
block = map chr [0..blocksize]
n = read len
cs = take n $ cycle $ block
tx = TL.pack cs
writer <- case how of
"base" -> return $ writeUtf8_base cs
"blaze" -> return $ writeUtf8_blaze cs
"utf8-string" -> return $ writeUtf8_string cs
-- utf8-light is missing support for lazy bytestrings => test 100 times
-- writing a 100 times smaller string to avoid out-of-memory errors.
"utf8-light" -> return $ \f -> sequence_ $ replicate 100 $
writeUtf8_light (take (n `div` 100) cs) f
"via-text" -> do return $ writeUtf8_text tx
-- Here, we ensure that the text tx is already packed before timing.
"text" -> do _ <- evaluate (TL.length tx)
return $ writeUtf8_text tx
_ -> error $ "unknown writer '" ++ how ++ "'"
t <- timed_ $ writer file
putStrLn $ how ++ ": " ++ show t
------------------------------------------------------------------------------
-- Timing
------------------------------------------------------------------------------
-- | Execute an IO action and return its result plus the time it took to execute it.
timed :: IO a -> IO (a, NominalDiffTime)
timed io = do
t0 <- getCurrentTime
x <- io
t1 <- getCurrentTime
return (x, diffUTCTime t1 t0)
-- | Execute an IO action and return the time it took to execute it.
timed_ :: IO a -> IO NominalDiffTime
timed_ = (snd `liftM`) . timed
blaze-builder-0.4.2.3/blaze-builder.cabal 0000644 0000000 0000000 00000007225 07346545000 016303 0 ustar 00 0000000 0000000 Name: blaze-builder
Version: 0.4.2.3
Synopsis: Efficient buffered output.
Description:
This library allows to efficiently serialize Haskell values to lazy bytestrings
with a large average chunk size. The large average chunk size allows to make
good use of cache prefetching in later processing steps (e.g. compression) and
reduces the system call overhead when writing the resulting lazy bytestring to a
file or sending it over the network.
.
This library was inspired by the module Data.Binary.Builder provided by the
binary package. It was originally developed with the specific needs of the
blaze-html package in mind. Since then it has been restructured to serve as a
drop-in replacement for Data.Binary.Builder, which it improves upon both in
speed as well as expressivity.
Author: Jasper Van der Jeugt, Simon Meier, Leon P Smith
Copyright: (c) 2010-2014 Simon Meier
(c) 2010 Jasper Van der Jeugt
(c) 2013-2015 Leon P Smith
Maintainer: https://github.com/blaze-builder
License: BSD3
License-file: LICENSE
Homepage: https://github.com/blaze-builder/blaze-builder
Bug-Reports: https://github.com/blaze-builder/blaze-builder/issues
Stability: Stable
Category: Data
Build-type: Simple
Cabal-version: >= 1.10
Tested-with:
GHC == 9.8.0
GHC == 9.6.2
GHC == 9.4.7
GHC == 9.2.8
GHC == 9.0.2
GHC == 8.10.7
GHC == 8.8.4
GHC == 8.6.5
GHC == 8.4.4
GHC == 8.2.2
GHC == 8.0.2
GHC == 7.10.3
GHC == 7.8.4
GHC == 7.6.3
GHC == 7.4.2
GHC == 7.0.4
Extra-source-files:
Makefile
README.markdown
TODO
CHANGES
benchmarks/*.hs
benchmarks/Throughput/*.hs
benchmarks/Throughput/*.h
benchmarks/Throughput/*.c
tests/*.hs
Source-repository head
Type: git
Location: https://github.com/blaze-builder/blaze-builder.git
Library
default-language: Haskell98
exposed-modules: Blaze.ByteString.Builder
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.Html.Word
Blaze.ByteString.Builder.HTTP
Blaze.ByteString.Builder.Compat.Write
Blaze.ByteString.Builder.Internal.Write
build-depends:
base >= 4.3 && < 5
, bytestring >= 0.9 && < 1
, deepseq
, ghc-prim
, text >= 0.10 && < 3
if impl(ghc < 7.8)
build-depends: bytestring-builder
else
build-depends: bytestring >= 0.10.4
if impl(ghc < 8.0)
build-depends: semigroups >= 0.16 && < 0.20
ghc-options: -Wall
if impl(ghc >= 8.0)
ghc-options: -Wcompat
test-suite test
type: exitcode-stdio-1.0
hs-source-dirs: tests
main-is: Tests.hs
default-language: Haskell98
ghc-options: -Wall -fno-warn-orphans
if impl(ghc >= 8.0)
ghc-options: -Wcompat
build-depends: base
, blaze-builder
, bytestring
, HUnit
, QuickCheck
, test-framework
, test-framework-hunit
, test-framework-quickcheck2
, text
, utf8-string
blaze-builder-0.4.2.3/tests/ 0000755 0000000 0000000 00000000000 07346545000 013732 5 ustar 00 0000000 0000000 blaze-builder-0.4.2.3/tests/LlvmSegfault.hs 0000644 0000000 0000000 00000001411 07346545000 016670 0 ustar 00 0000000 0000000 -- Author: Simon Meier , 10/06/2010
--
-- Attempt to find a small test-case for the segfaults that happen when
-- compiling the benchmarks with LLVM and GHC-7.0.1
--
module LlvmSegfault where
import Data.Word
import Data.Monoid
import qualified Data.ByteString.Lazy as L
import Foreign
import Blaze.ByteString.Builder.Internal
fromWord8 :: Word8 -> Builder
fromWord8 w =
Builder step
where
step k pf pe
| pf < pe = do
poke pf w
let pf' = pf `plusPtr` 1
pf' `seq` k pf' pe
| otherwise = return $ BufferFull 1 pf (step k)
word8s :: Builder
word8s = map (fromWord8 . fromIntegral) $ [(1::Int)..1000]
main :: IO ()
main =
print $ toLazyByteStringWith 10 10 (mconcat word8s) L.empty
blaze-builder-0.4.2.3/tests/Tests.hs 0000644 0000000 0000000 00000007537 07346545000 015404 0 ustar 00 0000000 0000000 {-# LANGUAGE CPP, OverloadedStrings #-}
#if __GLASGOW_HASKELL__ >= 704
{-# OPTIONS_GHC -fsimpl-tick-factor=40000 #-}
#endif
-- | Tests for the Blaze builder
--
module Main where
#if !MIN_VERSION_base(4,8,0)
import Control.Applicative ((<$>))
import Data.Monoid (mempty, mappend, mconcat)
#endif
import qualified Data.Text as T
import qualified Data.ByteString.Lazy as LB
import Test.Framework
import Test.Framework.Providers.QuickCheck2
import Test.Framework.Providers.HUnit
import Test.QuickCheck
import Test.HUnit hiding (Test)
import Codec.Binary.UTF8.String (decode)
import Blaze.ByteString.Builder
import Blaze.ByteString.Builder.Char.Utf8
import Blaze.ByteString.Builder.Html.Utf8
main :: IO ()
main = defaultMain $ return $ testGroup "Tests" tests
tests :: [Test]
tests =
[ testProperty "left identity Monoid law" monoidLeftIdentity
, testProperty "right identity Monoid law" monoidRightIdentity
, testProperty "associativity Monoid law" monoidAssociativity
, testProperty "mconcat Monoid law" monoidConcat
, testProperty "string → builder → string" fromStringToString
, testProperty "string and text" stringAndText
, testProperty "lazy bytestring identity" identityLazyByteString
, testProperty "flushing identity" identityFlushing
, testProperty "writeToByteString" writeToByteStringProp
, testCase "escaping case 1" escaping1
, testCase "escaping case 2" escaping2
, testCase "escaping case 3" escaping3
]
monoidLeftIdentity :: Builder -> Bool
monoidLeftIdentity b = mappend mempty b == b
monoidRightIdentity :: Builder -> Bool
monoidRightIdentity b = mappend b mempty == b
monoidAssociativity :: Builder -> Builder -> Builder -> Bool
monoidAssociativity x y z = mappend x (mappend y z) == mappend (mappend x y) z
monoidConcat :: [Builder] -> Bool
monoidConcat xs = mconcat xs == foldr mappend mempty xs
fromStringToString :: String -> Bool
fromStringToString string = string == convert string
where
convert = decode . LB.unpack . toLazyByteString . fromString
stringAndText :: String -> Bool
stringAndText string = fromString string == fromText (T.pack string)
identityLazyByteString :: LB.ByteString -> Bool
identityLazyByteString lbs = lbs == toLazyByteString (fromLazyByteString lbs)
identityFlushing :: String -> String -> Bool
identityFlushing s1 s2 =
let b1 = fromString s1
b2 = fromString s2
in b1 `mappend` b2 == b1 `mappend` flush `mappend` b2
writeToByteStringProp :: Write -> Bool
writeToByteStringProp w = toByteString (fromWrite w) == writeToByteString w
escaping1 :: Assertion
escaping1 = fromString "<hello>" @?= fromHtmlEscapedString ""
escaping2 :: Assertion
escaping2 = fromString "f &&& g" @?= fromHtmlEscapedString "f &&& g"
escaping3 :: Assertion
escaping3 = fromString ""'" @?= fromHtmlEscapedString "\"'"
#if !MIN_VERSION_bytestring(0,11,1)
instance Show Builder where
show = show . toLazyByteString
#endif
instance Show Write where
show = show . fromWrite
instance Eq Builder where
b1 == b2 =
-- different and small buffer sizses for testing wrapping behaviour
toLazyByteStringWith 1024 1024 256 b1 mempty ==
toLazyByteStringWith 2001 511 256 b2 mempty
-- | Artificially scale up size to ensures that buffer wrapping behaviour is
-- also tested.
numRepetitions :: Int
numRepetitions = 250
instance Arbitrary Builder where
arbitrary = (mconcat . replicate numRepetitions . fromString) <$> arbitrary
instance Arbitrary Write where
arbitrary = mconcat . map singleWrite <$> arbitrary
where
singleWrite (Left bs) = writeByteString (mconcat (LB.toChunks bs))
singleWrite (Right w) = writeWord8 w
instance Arbitrary LB.ByteString where
arbitrary = (LB.concat . replicate numRepetitions . LB.pack) <$> arbitrary