diff --git a/Blaze/ByteString/Builder.hs b/Blaze/ByteString/Builder.hs new file mode 100644 --- /dev/null +++ b/Blaze/ByteString/Builder.hs @@ -0,0 +1,205 @@ +----------------------------------------------------------------------------- +-- | +-- Module : Blaze.ByteString.Builder +-- Copyright : (c) 2010 Jasper Van der Jeugt & Simon Meier +-- License : BSD3-style (see LICENSE) +-- +-- Maintainer : Simon Meier +-- Stability : experimental +-- Portability : tested on GHC only +-- +-- "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 + Builder + + -- * Creating builders + , module Blaze.ByteString.Builder.Write + , module Blaze.ByteString.Builder.Int + , module Blaze.ByteString.Builder.Word + , module Blaze.ByteString.Builder.ByteString + , flush + + -- * Executing builders + , toLazyByteString + , toLazyByteStringWith + , toByteString + , toByteStringIO + , toByteStringIOWith + + + -- * Compatibility to Data.Binary.Builder from the binary package + -- + -- | The following functions ensure that @"Blaze.ByteString.Builder"@ is a + -- drop-in replacement for @Data.Binary.Builder@ from the @binary@ + -- package. Note that these functions are deprecated and may be removed + -- in future versions of the @blaze-builder@ package. + -- + , empty -- DEPRECATED: use 'mempty' instead + , singleton -- DEPRECATED: use 'fromByte' instead + , append -- DEPRECATED: use 'mappend' instead + + , putWord16be -- DEPRECATED: use 'fromWord' instead + , putWord32be -- + , putWord64be -- + , putWord16le -- + , putWord32le -- + , putWord64le -- for all these functions + , putWordhost -- + , putWord16host -- + , putWord32host -- + , putWord64host -- + ) where + +import Blaze.ByteString.Builder.Internal +import Blaze.ByteString.Builder.Write +import Blaze.ByteString.Builder.Int +import Blaze.ByteString.Builder.Word +import Blaze.ByteString.Builder.ByteString + +import Data.Monoid +import Data.Word + +------------------------------------------------------------------------------ +-- API Compatibility to Data.Binary.Builder from 'binary' +------------------------------------------------------------------------------ + +-- | /O(1)/. An empty builder. +-- +-- /Deprecated:/ use 'mempty' instead. +empty :: Builder +empty = mempty +{-# DEPRECATED empty "Use 'mempty' instead." #-} + +-- | /O(1)/. Append two builders. +-- +-- /Deprecated:/ use 'mappend' instead. +append :: Builder -> Builder -> Builder +append = mappend +{-# DEPRECATED append "Use 'mappend' instead." #-} + +-- | /O(1)/. Serialize a single byte. +-- +-- /Deprecated:/ use 'fromWord8' instead. +singleton :: Word8 -> Builder +singleton = fromWriteSingleton writeWord8 +{-# DEPRECATED singleton "Use 'fromWord8' instead." #-} + +-- | /O(1)/. Serialize a 'Word16' in big endian format. +-- +-- /Deprecated:/ use 'fromWord16be' instead. +putWord16be :: Word16 -> Builder +putWord16be = fromWord16be +{-# DEPRECATED putWord16be "Use 'fromWord16be' instead." #-} + +-- | /O(1)/. Serialize a 'Word32' in big endian format. +-- +-- /Deprecated:/ use 'fromWord32be' instead. +putWord32be :: Word32 -> Builder +putWord32be = fromWord32be +{-# DEPRECATED putWord32be "Use 'fromWord32be' instead." #-} + +-- | /O(1)/. Serialize a 'Word64' in big endian format. +-- +-- /Deprecated:/ use 'fromWord64be' instead. +putWord64be :: Word64 -> Builder +putWord64be = fromWord64be +{-# DEPRECATED putWord64be "Use 'fromWord64be' instead." #-} + +-- | /O(1)/. Serialize a 'Word16' in little endian format. +-- +-- /Deprecated:/ use 'fromWord16le' instead. +putWord16le :: Word16 -> Builder +putWord16le = fromWord16le +{-# DEPRECATED putWord16le "Use 'fromWord16le' instead." #-} + +-- | /O(1)/. Serialize a 'Word32' in little endian format. +-- +-- /Deprecated:/ use 'fromWord32le' instead. +putWord32le :: Word32 -> Builder +putWord32le = fromWord32le +{-# DEPRECATED putWord32le "Use 'fromWord32le' instead." #-} + +-- | /O(1)/. Serialize a 'Word64' in little endian format. +-- +-- /Deprecated:/ use 'fromWord64le' instead. +putWord64le :: Word64 -> Builder +putWord64le = fromWord64le +{-# DEPRECATED putWord64le "Use 'fromWord64le' instead." #-} + +-- | /O(1)/. Serialize a 'Word' in host endian format. +-- +-- /Deprecated:/ use 'fromWordhost' instead. +putWordhost :: Word -> Builder +putWordhost = fromWordhost +{-# DEPRECATED putWordhost "Use 'fromWordhost' instead." #-} + +-- | /O(1)/. Serialize a 'Word16' in host endian format. +-- +-- /Deprecated:/ use 'fromWord16host' instead. +putWord16host :: Word16 -> Builder +putWord16host = fromWord16host +{-# DEPRECATED putWord16host "Use 'fromWord16host' instead." #-} + +-- | /O(1)/. Serialize a 'Word32' in host endian format. +-- +-- /Deprecated:/ use 'fromWord32host' instead. +putWord32host :: Word32 -> Builder +putWord32host = fromWord32host +{-# DEPRECATED putWord32host "Use 'fromWord32host' instead." #-} + +-- | /O(1)/. Serialize a 'Word64' in host endian format. +-- +-- /Deprecated:/ use 'fromWord64host' instead. +putWord64host :: Word64 -> Builder +putWord64host = fromWord64host +{-# DEPRECATED putWord64host "Use 'fromWord64host' instead." #-} + diff --git a/Blaze/ByteString/Builder/ByteString.hs b/Blaze/ByteString/Builder/ByteString.hs new file mode 100644 --- /dev/null +++ b/Blaze/ByteString/Builder/ByteString.hs @@ -0,0 +1,229 @@ +{-# LANGUAGE CPP, BangPatterns, OverloadedStrings #-} + +-- | +-- Module : Blaze.ByteString.Builder.ByteString +-- Copyright : (c) 2010 Jasper Van der Jeugt & Simon Meier +-- License : BSD3-style (see LICENSE) +-- +-- Maintainer : Simon Meier +-- Stability : experimental +-- Portability : tested on GHC only +-- +-- 'Write's and '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.Write +import Blaze.ByteString.Builder.Internal + +import Foreign +import Data.Monoid + +import qualified Data.ByteString as S +import qualified Data.ByteString.Lazy as L + +#ifdef BYTESTRING_IN_BASE +import qualified Data.ByteString.Base as S +import qualified Data.ByteString.Lazy.Base as L -- FIXME: check if this is the right module +#else +import qualified Data.ByteString.Internal as S +import qualified Data.ByteString.Lazy.Internal as L +#endif + + +------------------------------------------------------------------------------ +-- Strict ByteStrings +------------------------------------------------------------------------------ + +-- | Write a strict 'S.ByteString' to a buffer. +-- +writeByteString :: S.ByteString -> Write +writeByteString bs = Write l io + where + (fptr, o, l) = S.toForeignPtr bs + io pf = withForeignPtr fptr $ \p -> copyBytes pf (p `plusPtr` o) l +{-# INLINE writeByteString #-} + +-- | Smart serialization of a strict bytestring. +-- +-- @'fromByteString' = 'fromByteStringWith' 'defaultMaximalCopySize'@ +-- +-- Use this function to serialize strict bytestrings. It guarantees an +-- average chunk size of 4kb, which has been shown to be a reasonable size in +-- benchmarks. Note that the check whether to copy or to insert is (almost) +-- free as the builder performance is mostly memory-bound. +-- +-- If you statically know that copying or inserting the strict bytestring is +-- always the best choice, then you can use the 'copyByteString' or +-- 'insertByteString' functions. +-- +fromByteString :: S.ByteString -> Builder +fromByteString = fromByteStringWith defaultMaximalCopySize +{-# INLINE fromByteString #-} + + +-- | @fromByteStringWith maximalCopySize bs@ serializes the strict bytestring +-- @bs@ according to the following rules. +-- +-- [@S.length bs <= maximalCopySize@:] @bs@ is copied to the output buffer. +-- +-- [@S.length bs > maximalCopySize@:] @bs@ the output buffer is flushed and +-- @bs@ is inserted directly as separate chunk in the output stream. +-- +-- These rules guarantee that average chunk size in the output stream is at +-- least half the @maximalCopySize@. +-- +fromByteStringWith :: Int -- ^ Maximal number of bytes to copy. + -> S.ByteString -- ^ Strict 'S.ByteString' to serialize. + -> Builder -- ^ Resulting 'Builder'. +fromByteStringWith maximalCopySize bs = Builder step + where + step k pf pe + | maximalCopySize < size = + return $ ModifyChunks pf (L.Chunk bs) k + | pf `plusPtr` size <= pe = do + withForeignPtr fpbuf $ \pbuf -> + copyBytes pf (pbuf `plusPtr` offset) size + let pf' = pf `plusPtr` size + pf' `seq` k pf' pe + | otherwise = return $ BufferFull size pf (step k) + where + (fpbuf, offset, size) = S.toForeignPtr bs +{-# INLINE fromByteStringWith #-} + + +-- | @copyByteString bs@ serialize the strict bytestring @bs@ by copying it to +-- the output buffer. +-- +-- Use this function to serialize strict bytestrings that are statically known +-- to be smallish (@<= 4kb@). +-- +copyByteString :: S.ByteString -> Builder +copyByteString = fromWriteSingleton writeByteString +{-# INLINE copyByteString #-} + +-- | @insertByteString bs@ serializes the strict bytestring @bs@ by inserting +-- it directly as a chunk of the output stream. +-- +-- Note that this implies flushing the output buffer; even if it contains just +-- a single byte. Hence, you should use this operation only for large (@> 8kb@) +-- bytestrings, as otherwise the resulting output stream may be too fragmented +-- to be processed efficiently. +-- +insertByteString :: S.ByteString -> Builder +insertByteString bs = Builder $ \ k pf _ -> + return $ ModifyChunks pf (L.Chunk bs) k +{-# INLINE insertByteString #-} + + +-- Lazy bytestrings +------------------------------------------------------------------------------ + +-- | /O(n)/. Smart serialization of a lazy bytestring. +-- +-- @'fromLazyByteString' = 'fromLazyByteStringWith' 'defaultMaximalCopySize'@ +-- +-- Use this function to serialize lazy bytestrings. It guarantees an average +-- chunk size of 4kb, which has been shown to be a reasonable size in +-- benchmarks. Note that the check whether to copy or to insert is (almost) +-- free as the builder performance is mostly memory-bound. +-- +-- If you statically know that copying or inserting /all/ chunks of the lazy +-- bytestring is always the best choice, then you can use the +-- 'copyLazyByteString' or 'insertLazyByteString' functions. +-- +fromLazyByteString :: L.ByteString -> Builder +fromLazyByteString = fromLazyByteStringWith defaultMaximalCopySize +{-# INLINE fromLazyByteString #-} + +-- | /O(n)/. Serialize a lazy bytestring chunk-wise according to the same rules +-- as in 'fromByteStringWith'. +-- +-- Semantically, it holds that +-- +-- > fromLazyByteStringWith maxCopySize +-- > = mconcat . map (fromByteStringWith maxCopySize) . L.toChunks +-- +-- However, the left-hand-side is much more efficient, as it moves the +-- end-of-buffer pointer out of the inner loop and provides the compiler with +-- more strictness information. +-- +fromLazyByteStringWith :: Int -- ^ Maximal number of bytes to copy. + -> L.ByteString -- ^ Lazy 'L.ByteString' to serialize. + -> Builder -- ^ Resulting 'Builder'. +fromLazyByteStringWith maximalCopySize = + makeBuilder + where + -- FIXME: Justify this first case split. Can we justify it at all? I seem + -- to remember that its idea was to enable a partial inlining; i.e. sharing + -- of 'step' between different calls to 'fromLazyByteStringWith'. + makeBuilder L.Empty = mempty + makeBuilder lbs0 = Builder $ step lbs0 + where + step lbs1 k pf0 pe0 = go lbs1 pf0 + where + go L.Empty !pf = k pf pe0 + go lbs@(L.Chunk bs' lbs') !pf + | maximalCopySize < size = + return $ ModifyChunks pf (L.Chunk bs') (step lbs' k) + + | pf' <= pe0 = do + withForeignPtr fpbuf $ \pbuf -> + copyBytes pf (pbuf `plusPtr` offset) size + go lbs' pf' + + | otherwise = return $ BufferFull size pf (step lbs k) + where + pf' = pf `plusPtr` size + (fpbuf, offset, size) = S.toForeignPtr bs' +{-# INLINE fromLazyByteStringWith #-} + + +-- | /O(n)/. Serialize a lazy bytestring by copying /all/ chunks sequentially +-- to the output buffer. +-- +-- See 'copyByteString' for usage considerations. +-- + +-- FIXME: Implement fused L.toChunks and fromWrite1List +copyLazyByteString :: L.ByteString -> Builder +copyLazyByteString = fromWrite1List writeByteString . L.toChunks +{-# INLINE copyLazyByteString #-} + +-- | /O(n)/. Serialize a lazy bytestring by inserting /all/ its chunks directly +-- into the output stream. +-- +-- See 'insertByteString' for usage considerations. +-- +-- For library developers, see the 'ModifyChunks' build signal, if you +-- need an /O(1)/ lazy bytestring insert based on difference lists. +-- +insertLazyByteString :: L.ByteString -> Builder +insertLazyByteString lbs = Builder step + where + step k pf _ = + return $ ModifyChunks pf (\lbs' -> L.foldrChunks L.Chunk lbs' lbs) k + +{-# INLINE insertLazyByteString #-} + diff --git a/Blaze/ByteString/Builder/Char/Utf8.hs b/Blaze/ByteString/Builder/Char/Utf8.hs new file mode 100644 --- /dev/null +++ b/Blaze/ByteString/Builder/Char/Utf8.hs @@ -0,0 +1,149 @@ +{-# OPTIONS_GHC -fno-warn-unused-imports #-} +-- ignore warning from 'import Data.Text.Encoding' + +-- | +-- Module : Blaze.ByteString.Builder.Char.Utf8 +-- Copyright : (c) 2010 Jasper Van der Jeugt & Simon Meier +-- License : BSD3-style (see LICENSE) +-- +-- Maintainer : Simon Meier +-- Stability : experimental +-- Portability : tested on GHC only +-- +-- '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 Foreign +import Data.Char (ord) + +import qualified Data.Text as TS +import qualified Data.Text.Encoding as TS -- imported for documentation links +import qualified Data.Text.Lazy as TL +import qualified Data.Text.Lazy.Encoding as TS -- imported for documentation links + +import Blaze.ByteString.Builder.Internal +import Blaze.ByteString.Builder.Write + +-- | Write a UTF-8 encoded Unicode character to a buffer. +-- +-- Note that the control flow of 'writeChar' is more complicated than the one +-- of 'writeWord8', as the size of the write depends on the 'Char' written. +-- Therefore, +-- +-- > fromWrite $ writeChar a `mappend` writeChar b +-- +-- must not always be faster than +-- +-- > fromChar a `mappend` fromChar b +-- +-- Use benchmarking to make informed decisions. +-- + +-- FIXME: Use a Write that always checks if 4 bytes are available and only take +-- care of the precise pointer advance once the data has been written. Either +-- formulate it using continuation passing or returning the increment using the +-- IO action. The latter is probably simpler and better understandable. +-- +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 #-} + +-- | /O(1)/. Serialize a Unicode character using the UTF-8 encoding. +-- +fromChar :: Char -> Builder +fromChar = fromWriteSingleton writeChar + +-- | /O(n)/. Serialize a Unicode 'String' using the UTF-8 encoding. +-- +fromString :: String -> Builder +fromString = fromWrite1List writeChar +-- Performance note: ^^^ +-- +-- fromWrite2List made things slightly worse for the blaze-html benchmarks +-- despite being better when serializing only a list. Probably, the cache is +-- already occupied enough with dealing with the data from Html rendering. +-- + + +-- | /O(n)/. Serialize a value by 'Show'ing it and UTF-8 encoding the resulting +-- 'String'. +-- +fromShow :: Show a => a -> Builder +fromShow = fromString . show + +-- | /O(n)/. Serialize a strict Unicode 'TS.Text' value using the UTF-8 encoding. +-- +-- Note that this function is currently faster than 'TS.encodeUtf8' provided by +-- "Data.Text.Encoding". Moreover, 'fromText' is also lazy, while 'TL.encodeUtf8' +-- is strict. +-- +fromText :: TS.Text -> Builder +fromText = fromString . TS.unpack +{-# INLINE fromText #-} + + +-- | /O(n)/. Serialize a lazy Unicode 'TL.Text' value using the UTF-8 encoding. +-- +-- Note that this function is currently faster than 'TL.encodeUtf8' provided by +-- "Data.Text.Lazy.Encoding". +-- +fromLazyText :: TL.Text -> Builder +fromLazyText = fromString . TL.unpack +{-# INLINE fromLazyText #-} diff --git a/Blaze/ByteString/Builder/Html/Utf8.hs b/Blaze/ByteString/Builder/Html/Utf8.hs new file mode 100644 --- /dev/null +++ b/Blaze/ByteString/Builder/Html/Utf8.hs @@ -0,0 +1,81 @@ +{-# LANGUAGE OverloadedStrings #-} +-- | +-- Module : Blaze.ByteString.Builder.Html.Utf8 +-- Copyright : (c) 2010 Jasper Van der Jeugt & Simon Meier +-- License : BSD3-style (see LICENSE) +-- +-- Maintainer : Simon Meier +-- Stability : experimental +-- Portability : tested on GHC only +-- +-- '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.Lazy as TL + +import Blaze.ByteString.Builder +import Blaze.ByteString.Builder.Char.Utf8 + +-- | Write a HTML escaped and UTF-8 encoded Unicode character to a bufffer. +-- +writeHtmlEscapedChar :: Char -> Write +writeHtmlEscapedChar '<' = writeByteString "<" +writeHtmlEscapedChar '>' = writeByteString ">" +writeHtmlEscapedChar '&' = writeByteString "&" +writeHtmlEscapedChar '"' = writeByteString """ +writeHtmlEscapedChar '\'' = writeByteString "'" +writeHtmlEscapedChar c = writeChar c +{-# INLINE writeHtmlEscapedChar #-} + +-- | /O(1)./ Serialize a HTML escaped Unicode character using the UTF-8 +-- encoding. +-- +fromHtmlEscapedChar :: Char -> Builder +fromHtmlEscapedChar = fromWriteSingleton writeHtmlEscapedChar + +-- | /O(n)/. Serialize a HTML escaped Unicode 'String' using the UTF-8 +-- encoding. +-- +fromHtmlEscapedString :: String -> Builder +fromHtmlEscapedString = fromWrite1List writeHtmlEscapedChar + +-- | /O(n)/. Serialize a value by 'Show'ing it and then, HTML escaping and +-- UTF-8 encoding the resulting 'String'. +-- +fromHtmlEscapedShow :: Show a => a -> Builder +fromHtmlEscapedShow = fromHtmlEscapedString . show + + +-- | /O(n)/. Serialize a HTML escaped strict Unicode 'TS.Text' value using the +-- UTF-8 encoding. +-- +fromHtmlEscapedText :: TS.Text -> Builder +fromHtmlEscapedText = fromHtmlEscapedString . TS.unpack + +-- | /O(n)/. Serialize a HTML escaped Unicode 'TL.Text' using the UTF-8 encoding. +-- +fromHtmlEscapedLazyText :: TL.Text -> Builder +fromHtmlEscapedLazyText = fromHtmlEscapedString . TL.unpack + diff --git a/Blaze/ByteString/Builder/Int.hs b/Blaze/ByteString/Builder/Int.hs new file mode 100644 --- /dev/null +++ b/Blaze/ByteString/Builder/Int.hs @@ -0,0 +1,301 @@ +{-# LANGUAGE CPP #-} +-- | +-- Module : Blaze.ByteString.Builder.Int +-- Copyright : (c) 2010 Simon Meier +-- +-- License : BSD3-style (see LICENSE) +-- +-- Maintainer : Simon Meier +-- Stability : experimental +-- Portability : tested on GHC only +-- +-- 'Write's and 'Builder's for serializing integers. +-- +-- See "Blaze.ByteString.Builder.Word" for information about how to best write several +-- integers at once. +-- +#if defined(__GLASGOW_HASKELL__) && !defined(__HADDOCK__) +#include "MachDeps.h" +#endif + +module Blaze.ByteString.Builder.Int + ( + -- * Writing integers to a buffer + + 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 and a chunked write like it is + -- provided by functions such as 'fromWrite2List'. + + , 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 Blaze.ByteString.Builder.Internal +import Blaze.ByteString.Builder.Write +import Blaze.ByteString.Builder.Word + +import Foreign + +------------------------------------------------------------------------------ +-- Int writes +-------------- +-- +-- we rely on 'fromIntegral' to do a loss-less conversion to the corresponding +-- 'Word' type +-- +------------------------------------------------------------------------------ + + +-- | Write a single signed byte. +-- +writeInt8 :: Int8 -> Write +writeInt8 = writeWord8 . fromIntegral +{-# INLINE writeInt8 #-} + +-- | Write an 'Int16' in big endian format. +writeInt16be :: Int16 -> Write +writeInt16be = writeWord16be . fromIntegral +{-# INLINE writeInt16be #-} + +-- | Write an 'Int16' in little endian format. +writeInt16le :: Int16 -> Write +writeInt16le = writeWord16le . fromIntegral +{-# INLINE writeInt16le #-} + +-- | Write an 'Int32' in big endian format. +writeInt32be :: Int32 -> Write +writeInt32be = writeWord32be . fromIntegral +{-# INLINE writeInt32be #-} + +-- | Write an 'Int32' in little endian format. +writeInt32le :: Int32 -> Write +writeInt32le = writeWord32le . fromIntegral +{-# INLINE writeInt32le #-} + +-- | Write an 'Int64' in big endian format. +writeInt64be :: Int64 -> Write +writeInt64be = writeWord64be . fromIntegral +{-# INLINE writeInt64be #-} + +-- | Write an 'Int64' in little endian format. +writeInt64le :: Int64 -> Write +writeInt64le = writeWord64le . fromIntegral +{-# INLINE writeInt64le #-} + + +------------------------------------------------------------------------ +-- Unaligned, integer size ops + +-- | 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 w = + Write (sizeOf (undefined :: Int)) (\p -> poke (castPtr p) w) +{-# INLINE writeInthost #-} + +-- | Write an 'Int16' in native host order and host endianness. +writeInt16host :: Int16 -> Write +writeInt16host w16 = + Write (sizeOf (undefined :: Int16)) (\p -> poke (castPtr p) w16) +{-# INLINE writeInt16host #-} + +-- | Write an 'Int32' in native host order and host endianness. +writeInt32host :: Int32 -> Write +writeInt32host w32 = + Write (sizeOf (undefined :: Int32)) (\p -> poke (castPtr p) w32) +{-# INLINE writeInt32host #-} + +-- | Write an 'Int64' in native host order and host endianness. +writeInt64host :: Int64 -> Write +writeInt64host w = + Write (sizeOf (undefined :: Int64)) (\p -> poke (castPtr p) w) +{-# INLINE writeInt64host #-} + + +------------------------------------------------------------------------------ +-- Builders corresponding to the integer writes +------------------------------------------------------------------------------ + +-- Single bytes +------------------------------------------------------------------------------ + +-- | Serialize a single byte. +-- +fromInt8 :: Int8 -> Builder +fromInt8 = fromWriteSingleton writeInt8 + +-- | Serialize a list of bytes. +-- +fromInt8s :: [Int8] -> Builder +fromInt8s = fromWrite8List writeInt8 + + +-- Int16 +------------------------------------------------------------------------------ + +-- | Serialize an 'Int16' in big endian format. +fromInt16be :: Int16 -> Builder +fromInt16be = fromWriteSingleton writeInt16be +{-# INLINE fromInt16be #-} + +-- | Serialize a list of 'Int16's in big endian format. +fromInt16sbe :: [Int16] -> Builder +fromInt16sbe = fromWrite4List writeInt16be +{-# INLINE fromInt16sbe #-} + +-- | Serialize an 'Int16' in little endian format. +fromInt16le :: Int16 -> Builder +fromInt16le = fromWriteSingleton writeInt16le +{-# INLINE fromInt16le #-} + +-- | Serialize a list of 'Int16's in little endian format. +fromInt16sle :: [Int16] -> Builder +fromInt16sle = fromWrite4List writeInt16le +{-# INLINE fromInt16sle #-} + + +-- Int32 +----------------------------------------------------------------------------- + +-- | Serialize an 'Int32' in big endian format. +fromInt32be :: Int32 -> Builder +fromInt32be = fromWriteSingleton writeInt32be +{-# INLINE fromInt32be #-} + +-- | Serialize a list of 'Int32's in big endian format. +fromInt32sbe :: [Int32] -> Builder +fromInt32sbe = fromWrite2List writeInt32be +{-# INLINE fromInt32sbe #-} + +-- | Serialize an 'Int32' in little endian format. +fromInt32le :: Int32 -> Builder +fromInt32le = fromWriteSingleton writeInt32le +{-# INLINE fromInt32le #-} + +-- | Serialize a list of 'Int32's in little endian format. +fromInt32sle :: [Int32] -> Builder +fromInt32sle = fromWrite2List writeInt32le +{-# INLINE fromInt32sle #-} + +-- | Serialize an 'Int64' in big endian format. +fromInt64be :: Int64 -> Builder +fromInt64be = fromWriteSingleton writeInt64be +{-# INLINE fromInt64be #-} + +-- | Serialize a list of 'Int64's in big endian format. +fromInt64sbe :: [Int64] -> Builder +fromInt64sbe = fromWrite1List writeInt64be +{-# INLINE fromInt64sbe #-} + +-- | Serialize an 'Int64' in little endian format. +fromInt64le :: Int64 -> Builder +fromInt64le = fromWriteSingleton writeInt64le +{-# INLINE fromInt64le #-} + +-- | Serialize a list of 'Int64's in little endian format. +fromInt64sle :: [Int64] -> Builder +fromInt64sle = fromWrite1List writeInt64le +{-# INLINE fromInt64sle #-} + + +------------------------------------------------------------------------ +-- Unaligned, integer size ops + +-- | 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 = fromWriteSingleton writeInthost +{-# INLINE fromInthost #-} + +-- | Serialize a list of 'Int's. +-- See 'fromInthost' for usage considerations. +fromIntshost :: [Int] -> Builder +fromIntshost = fromWrite2List writeInthost +{-# INLINE fromIntshost #-} + +-- | Write an 'Int16' in native host order and host endianness. +fromInt16host :: Int16 -> Builder +fromInt16host = fromWriteSingleton writeInt16host +{-# INLINE fromInt16host #-} + +-- | Write a list of 'Int16's in native host order and host endianness. +fromInt16shost :: [Int16] -> Builder +fromInt16shost = fromWrite4List writeInt16host +{-# INLINE fromInt16shost #-} + +-- | Write an 'Int32' in native host order and host endianness. +fromInt32host :: Int32 -> Builder +fromInt32host = fromWriteSingleton writeInt32host +{-# INLINE fromInt32host #-} + +-- | Write a list of 'Int32's in native host order and host endianness. +fromInt32shost :: [Int32] -> Builder +fromInt32shost = fromWrite2List writeInt32host +{-# INLINE fromInt32shost #-} + +-- | Write an 'Int64' in native host order and host endianness. +fromInt64host :: Int64 -> Builder +fromInt64host = fromWriteSingleton writeInt64host +{-# INLINE fromInt64host #-} + +-- | Write a list of 'Int64's in native host order and host endianness. +fromInt64shost :: [Int64] -> Builder +fromInt64shost = fromWrite1List writeInt64host +{-# INLINE fromInt64shost #-} diff --git a/Blaze/ByteString/Builder/Internal.hs b/Blaze/ByteString/Builder/Internal.hs new file mode 100644 --- /dev/null +++ b/Blaze/ByteString/Builder/Internal.hs @@ -0,0 +1,441 @@ +{-# LANGUAGE CPP, BangPatterns #-} +-- | +-- Module : Blaze.ByteString.Builder.Internal +-- Copyright : (c) 2010 Simon Meier +-- License : BSD3-style (see LICENSE) +-- +-- Maintainer : Simon Meier +-- Stability : experimental +-- Portability : tested on GHC only +-- +-- Implementation of the 'Builder' monoid. +-- +-- A standard library user must never import this module directly. Instead, he +-- should import "Blaze.ByteString.Builder", which re-exports the 'Builder' type and +-- its associated public functions defined in this module. +-- +-- Developers of other libraries may import this module to gain access to the +-- internal representation of builders. For example, in some cases, creating a +-- 'Builder' with a custom low-level 'BuildStep' may improve performance +-- considerably compared to the creating it using the public 'Builder' +-- combinators (e.g., @'fromWrite1List'@ in "Blaze.ByteString.Builder.Write"). +-- Another example, is the use of 'ModifyChunks' to efficiently wire the +-- 'Builder' type with another library that generates lazy bytestrings. +-- +-- In any case, whenever you import this module you /must/ reference the full +-- version of the 'blaze-builder' package in your cabal file, as the +-- implementation and the guarantees given in this file may change in any +-- version! The release notes will tell, if this was the case. +-- +module Blaze.ByteString.Builder.Internal + ( + -- * The @Builder@ type + Builder(..) + , BuildStep + , BuildSignal(..) + + -- * Flushing the buffer + , flush + + -- * Executing builders + , toLazyByteStringWith + , toLazyByteString + , toByteString + , toByteStringIOWith + , toByteStringIO + + -- * Default sizes + , defaultBufferSize + , defaultMinimalBufferSize + , defaultMaximalCopySize + ) 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 + + +------------------------------------------------------------------------------ +-- The Builder type +------------------------------------------------------------------------------ + +-- | Intuitively, a builder denotes the construction of a lazy bytestring. +-- +-- Builders can be created from primitive buffer manipulations using the +-- @'Write'@ abstraction provided by in "Blaze.ByteString.Builder.Write". However for +-- many Haskell values, there exist predefined functions doing that already. +-- For example, UTF-8 encoding 'Char' and 'String' values is provided by the +-- functions in "Blaze.ByteString.Builder.Char.Utf8". Concatenating builders is done +-- using their 'Monoid' instance. +-- +-- Semantically, builders are nothing special. They just denote a sequence of +-- bytes. However, their representation is chosen such that this sequence of +-- bytes can be efficiently (in terms of CPU cycles) computed in an +-- incremental, chunk-wise fashion such that the average chunk-size is large. +-- Note that the large average chunk size allows to make good use of cache +-- prefetching in later processing steps (e.g. compression) or to reduce the +-- sytem call overhead when writing the resulting lazy bytestring to a file or +-- sending it over the network. +-- +-- For precisely understanding the performance of a specific 'Builder', +-- benchmarking is unavoidable. Moreover, it also helps to understand the +-- implementation of builders and the predefined combinators. This should be +-- amenable to the average Haskell programmer by reading the source code of +-- "Blaze.ByteString.Builder.Internal" and the other modules of this library. +-- +-- The guiding implementation principle was to reduce the abstraction cost per +-- output byte. We use continuation passing to achieve a constant time append. +-- The output buffer is filled by the individual builders as long as possible. +-- They call each other directly when they are done and control is returned to +-- the driver (e.g., 'toLazyByteString') only when the buffer is full, a +-- bytestring needs to be inserted directly, or no more bytes can be written. +-- We also try to take the pressure off the cache by moving variables as far +-- out of loops as possible. This leads to some duplication of code, but +-- results in sometimes dramatic increases in performance. For example, see the +-- @'fromWord8s'@ function in "Blaze.ByteString.Builder.Word". +-- +newtype Builder = Builder (BuildStep -> BuildStep) + +-- | A 'BuildSignal' signals to the driver of the 'Builder' execution the next +-- step to be taken. +-- +data BuildSignal = + -- | @Done pf@ signals that the 'BuildStep' is finished and data has been + -- written up to the next free byte @pf@. + Done {-# UNPACK #-} !(Ptr Word8) + -- | @BufferFull newSize pf nextStep@ signals that the buffer is full and + -- data has been written up to the next free byte @pf@. Moreover, the next + -- build step to be executed @nextStep@ requires a buffer of at least size + -- @newSize@ to execute successfully. + -- + -- A driver /must/ guarantee that the buffer used to call @nextStep@ is at + -- least of size @newSize@. + | BufferFull + {-# UNPACK #-} !Int + {-# UNPACK #-} !(Ptr Word8) + !BuildStep + -- | @ModifyChunks pf fbs nextStep@ signals that the data written up to the + -- next free byte @pf@ must be output and the remaining lazy bytestring that + -- is produced by executing @nextStep@ must be modified using the function + -- @fbs@. + -- + -- This signal is used to insert bytestrings directly into the output stream. + -- It can also be used to efficiently hand over control to another library + -- for generating streams of strict bytestrings. + | ModifyChunks + {-# UNPACK #-} !(Ptr Word8) + !(L.ByteString -> L.ByteString) + !BuildStep + +-- | A 'BuildStep' fills a buffer from the given start pointer as long as +-- possible and returns control to the caller using a 'BuildSignal', once it is +-- required. +-- +type BuildStep = Ptr Word8 -- ^ Pointer to the next free byte in the + -- buffer. A 'BuildStep' must start writing + -- its data from this address. + -> Ptr Word8 -- ^ Pointer to the first byte /after/ the + -- buffer. A 'BuildStep' must never write + -- data at or after this address. + -> IO BuildSignal -- ^ Signal to the driver about the next step + -- to be taken. + +instance Monoid Builder where + mempty = Builder id + {-# INLINE mempty #-} + mappend (Builder f) (Builder g) = Builder $ f . g + {-# INLINE mappend #-} + mconcat = foldr mappend mempty + {-# INLINE mconcat #-} + +------------------------------------------------------------------------------ +-- 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 + -> 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 b) k = + inlinePerformIO $ fillFirstBuffer (b finalStep) + where + finalStep 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 !pe = pf `plusPtr` firstBufSize + mkbs pf' = S.PS fpbuf 0 (pf' `minusPtr` pf) + {-# INLINE mkbs #-} + next <- step0 pf pe + 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) $ + \pfNew peNew -> do + copyBytes pfNew pf l + nextStep (pfNew `plusPtr` l) peNew + + 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 + next <- step pf pe + 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 :: Builder -> L.ByteString +toLazyByteString b = toLazyByteStringWith + defaultBufferSize defaultMinimalBufferSize defaultFirstBufferSize b L.empty +{-# INLINE toLazyByteString #-} + +-- | Pack the chunks of a lazy bytestring into a single strict bytestring. +packChunks :: L.ByteString -> S.ByteString +packChunks lbs = do + S.unsafeCreate (fromIntegral $ L.length lbs) (copyChunks lbs) + where + copyChunks !L.Empty !_pf = return () + copyChunks !(L.Chunk (S.PS fpbuf o l) lbs') !pf = do + withForeignPtr fpbuf $ \pbuf -> + copyBytes pf (pbuf `plusPtr` o) l + copyChunks lbs' (pf `plusPtr` l) + +-- | Run the builder to construct a strict bytestring containing the sequence +-- of bytes denoted by the builder. This is done by first serializing to a lazy bytestring and then packing its +-- chunks to a appropriately sized strict bytestring. +-- +-- > toByteString = packChunks . toLazyByteString +-- +-- Note that @'toByteString'@ is a 'Monoid' homomorphism. +-- +-- > toByteString mempty == mempty +-- > toByteString (x `mappend` y) == toByteString x `mappend` toByteString y +-- +-- However, in the second equation, the left-hand-side is generally faster to +-- execute. +-- +toByteString :: Builder -> S.ByteString +toByteString = packChunks . toLazyByteString + + +-- | @toByteStringIOWith bufSize io b@ runs the builder @b@ with a buffer of +-- at least the size @bufSize@ and executes the 'IO' action @io@ whenever the +-- buffer is full. +-- +-- Compared to 'toLazyByteStringWith' this function requires less allocation, +-- as the output buffer is only allocated once at the start of the +-- serialization and whenever something bigger than the current buffer size has +-- to be copied into the buffer, which should happen very seldomly for the +-- default buffer size of 32kb. Hence, the pressure on the garbage collector is +-- reduced, which can be an advantage when building long sequences of bytes. +-- +toByteStringIOWith :: Int -- ^ Buffer size (upper bounds + -- the number of bytes forced + -- per call to the 'IO' action). + -> (S.ByteString -> IO ()) -- ^ 'IO' action to execute per + -- full buffer, which is + -- referenced by a strict + -- 'S.ByteString'. + -> Builder -- ^ 'Builder' to run. + -> IO () -- ^ Resulting 'IO' action. +toByteStringIOWith bufSize io (Builder b) = + fillNewBuffer bufSize (b finalStep) + where + finalStep pf _ = return $ Done pf + + fillNewBuffer !size !step0 = do + S.mallocByteString size >>= fillBuffer + where + fillBuffer fpbuf = fill step0 + where + -- safe because the constructed ByteString references the foreign + -- pointer AFTER its buffer was filled. + pf = unsafeForeignPtrToPtr fpbuf + fill !step = do + next <- step pf (pf `plusPtr` size) + case next of + Done pf' -> + unless (pf' == pf) (io $ S.PS fpbuf 0 (pf' `minusPtr` pf)) + + BufferFull newSize pf' nextStep -> do + io $ S.PS fpbuf 0 (pf' `minusPtr` pf) + if bufSize < newSize + then fillNewBuffer newSize nextStep + else fill nextStep + + ModifyChunks pf' bsk nextStep -> do + unless (pf' == pf) (io $ S.PS fpbuf 0 (pf' `minusPtr` pf)) + -- was: mapM_ io $ L.toChunks (bsk L.empty) + L.foldrChunks (\bs -> (io bs >>)) (return ()) (bsk L.empty) + fill nextStep + +-- | Run the builder with a 'defaultBufferSize'd buffer and execute the given +-- 'IO' action whenever the buffer is full or gets flushed. +-- +-- @ 'toByteStringIO' = 'toByteStringIOWith' 'defaultBufferSize'@ +-- +-- This is a 'Monoid' homomorphism in the following sense. +-- +-- > toByteStringIO io mempty == return () +-- > toByteStringIO io (x `mappend` y) == toByteStringIO io x >> toByteStringIO io y +-- +toByteStringIO :: (S.ByteString -> IO ()) -> Builder -> IO () +toByteStringIO = toByteStringIOWith defaultBufferSize +{-# INLINE toByteStringIO #-} + diff --git a/Blaze/ByteString/Builder/Word.hs b/Blaze/ByteString/Builder/Word.hs new file mode 100644 --- /dev/null +++ b/Blaze/ByteString/Builder/Word.hs @@ -0,0 +1,436 @@ +{-# OPTIONS_GHC -fglasgow-exts #-} +-- for unboxed shifts + +{-# LANGUAGE CPP #-} +-- | +-- Module : Blaze.ByteString.Builder.Word +-- Copyright : (c) 2010 Jasper Van der Jeugt & Simon Meier +-- +-- Original serialization code from 'Data.Binary.Builder': +-- (c) Lennart Kolmodin, Ross Patterson +-- +-- License : BSD3-style (see LICENSE) +-- +-- Maintainer : Simon Meier +-- Stability : experimental +-- Portability : tested on GHC only +-- +-- '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. +-- +#if defined(__GLASGOW_HASKELL__) && !defined(__HADDOCK__) +#include "MachDeps.h" +#endif + +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 and a chunked write like it is + -- provided by functions such as 'fromWrite2List'. + + , 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 Blaze.ByteString.Builder.Internal +import Blaze.ByteString.Builder.Write + +import Foreign + +#if defined(__GLASGOW_HASKELL__) && !defined(__HADDOCK__) +import GHC.Base +import GHC.Word (Word32(..),Word16(..),Word64(..)) + +#if WORD_SIZE_IN_BITS < 64 && __GLASGOW_HASKELL__ >= 608 +import GHC.Word (uncheckedShiftRL64#) +#endif +#else +import Data.Word +#endif + +------------------------------------------------------------------------------ +-- Word writes +-------------- +-- +-- Based upon the 'putWordX' functions from "Data.Binary.Builder" from the +-- 'binary' package. +-- +------------------------------------------------------------------------------ + + +-- | Write a single byte. +-- +writeWord8 :: Word8 -> Write +writeWord8 x = Write 1 (\pf -> poke pf x) +{-# INLINE writeWord8 #-} + +-- +-- We rely on the fromIntegral to do the right masking for us. +-- The inlining here is critical, and can be worth 4x performance +-- + +-- | Write a 'Word16' in big endian format. +writeWord16be :: Word16 -> Write +writeWord16be w = Write 2 $ \p -> do + poke p (fromIntegral (shiftr_w16 w 8) :: Word8) + poke (p `plusPtr` 1) (fromIntegral (w) :: Word8) +{-# INLINE writeWord16be #-} + +-- | Write a 'Word16' in little endian format. +writeWord16le :: Word16 -> Write +writeWord16le w = Write 2 $ \p -> do + poke p (fromIntegral (w) :: Word8) + poke (p `plusPtr` 1) (fromIntegral (shiftr_w16 w 8) :: Word8) +{-# INLINE writeWord16le #-} + +-- writeWord16le w16 = Write 2 (\p -> poke (castPtr p) w16) + +-- | Write a 'Word32' in big endian format. +writeWord32be :: Word32 -> Write +writeWord32be w = Write 4 $ \p -> do + poke p (fromIntegral (shiftr_w32 w 24) :: Word8) + poke (p `plusPtr` 1) (fromIntegral (shiftr_w32 w 16) :: Word8) + poke (p `plusPtr` 2) (fromIntegral (shiftr_w32 w 8) :: Word8) + poke (p `plusPtr` 3) (fromIntegral (w) :: Word8) +{-# INLINE writeWord32be #-} + +-- | Write a 'Word32' in little endian format. +writeWord32le :: Word32 -> Write +writeWord32le w = Write 4 $ \p -> do + poke p (fromIntegral (w) :: Word8) + poke (p `plusPtr` 1) (fromIntegral (shiftr_w32 w 8) :: Word8) + poke (p `plusPtr` 2) (fromIntegral (shiftr_w32 w 16) :: Word8) + poke (p `plusPtr` 3) (fromIntegral (shiftr_w32 w 24) :: Word8) +{-# INLINE writeWord32le #-} + +-- on a little endian machine: +-- writeWord32le w32 = Write 4 (\p -> poke (castPtr p) w32) + +-- | Write a 'Word64' in big endian format. +writeWord64be :: Word64 -> Write +#if WORD_SIZE_IN_BITS < 64 +-- +-- To avoid expensive 64 bit shifts on 32 bit machines, we cast to +-- Word32, and write that +-- +writeWord64be w = + let a = fromIntegral (shiftr_w64 w 32) :: Word32 + b = fromIntegral w :: Word32 + in Write 8 $ \p -> do + poke p (fromIntegral (shiftr_w32 a 24) :: Word8) + poke (p `plusPtr` 1) (fromIntegral (shiftr_w32 a 16) :: Word8) + poke (p `plusPtr` 2) (fromIntegral (shiftr_w32 a 8) :: Word8) + poke (p `plusPtr` 3) (fromIntegral (a) :: Word8) + poke (p `plusPtr` 4) (fromIntegral (shiftr_w32 b 24) :: Word8) + poke (p `plusPtr` 5) (fromIntegral (shiftr_w32 b 16) :: Word8) + poke (p `plusPtr` 6) (fromIntegral (shiftr_w32 b 8) :: Word8) + poke (p `plusPtr` 7) (fromIntegral (b) :: Word8) +#else +writeWord64be w = Write 8 $ \p -> do + poke p (fromIntegral (shiftr_w64 w 56) :: Word8) + poke (p `plusPtr` 1) (fromIntegral (shiftr_w64 w 48) :: Word8) + poke (p `plusPtr` 2) (fromIntegral (shiftr_w64 w 40) :: Word8) + poke (p `plusPtr` 3) (fromIntegral (shiftr_w64 w 32) :: Word8) + poke (p `plusPtr` 4) (fromIntegral (shiftr_w64 w 24) :: Word8) + poke (p `plusPtr` 5) (fromIntegral (shiftr_w64 w 16) :: Word8) + poke (p `plusPtr` 6) (fromIntegral (shiftr_w64 w 8) :: Word8) + poke (p `plusPtr` 7) (fromIntegral (w) :: Word8) +#endif +{-# INLINE writeWord64be #-} + +-- | Write a 'Word64' in little endian format. +writeWord64le :: Word64 -> Write + +#if WORD_SIZE_IN_BITS < 64 +writeWord64le w = + let b = fromIntegral (shiftr_w64 w 32) :: Word32 + a = fromIntegral w :: Word32 + in Write 8 $ \p -> do + poke (p) (fromIntegral (a) :: Word8) + poke (p `plusPtr` 1) (fromIntegral (shiftr_w32 a 8) :: Word8) + poke (p `plusPtr` 2) (fromIntegral (shiftr_w32 a 16) :: Word8) + poke (p `plusPtr` 3) (fromIntegral (shiftr_w32 a 24) :: Word8) + poke (p `plusPtr` 4) (fromIntegral (b) :: Word8) + poke (p `plusPtr` 5) (fromIntegral (shiftr_w32 b 8) :: Word8) + poke (p `plusPtr` 6) (fromIntegral (shiftr_w32 b 16) :: Word8) + poke (p `plusPtr` 7) (fromIntegral (shiftr_w32 b 24) :: Word8) +#else +writeWord64le w = Write 8 $ \p -> do + poke p (fromIntegral (w) :: Word8) + poke (p `plusPtr` 1) (fromIntegral (shiftr_w64 w 8) :: Word8) + poke (p `plusPtr` 2) (fromIntegral (shiftr_w64 w 16) :: Word8) + poke (p `plusPtr` 3) (fromIntegral (shiftr_w64 w 24) :: Word8) + poke (p `plusPtr` 4) (fromIntegral (shiftr_w64 w 32) :: Word8) + poke (p `plusPtr` 5) (fromIntegral (shiftr_w64 w 40) :: Word8) + poke (p `plusPtr` 6) (fromIntegral (shiftr_w64 w 48) :: Word8) + poke (p `plusPtr` 7) (fromIntegral (shiftr_w64 w 56) :: Word8) +#endif +{-# INLINE writeWord64le #-} + +-- on a little endian machine: +-- writeWord64le w64 = Write 8 (\p -> poke (castPtr p) w64) + +------------------------------------------------------------------------ +-- Unaligned, word size ops + +-- | 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 w = + Write (sizeOf (undefined :: Word)) (\p -> poke (castPtr p) w) +{-# INLINE writeWordhost #-} + +-- | Write a 'Word16' in native host order and host endianness. +writeWord16host :: Word16 -> Write +writeWord16host w16 = + Write (sizeOf (undefined :: Word16)) (\p -> poke (castPtr p) w16) +{-# INLINE writeWord16host #-} + +-- | Write a 'Word32' in native host order and host endianness. +writeWord32host :: Word32 -> Write +writeWord32host w32 = + Write (sizeOf (undefined :: Word32)) (\p -> poke (castPtr p) w32) +{-# INLINE writeWord32host #-} + +-- | Write a 'Word64' in native host order and host endianness. +writeWord64host :: Word64 -> Write +writeWord64host w = + Write (sizeOf (undefined :: Word64)) (\p -> poke (castPtr p) w) +{-# INLINE writeWord64host #-} + +------------------------------------------------------------------------ +-- Unchecked shifts + +{-# INLINE shiftr_w16 #-} +shiftr_w16 :: Word16 -> Int -> Word16 +{-# INLINE shiftr_w32 #-} +shiftr_w32 :: Word32 -> Int -> Word32 +{-# INLINE shiftr_w64 #-} +shiftr_w64 :: Word64 -> Int -> Word64 + +#if defined(__GLASGOW_HASKELL__) && !defined(__HADDOCK__) +shiftr_w16 (W16# w) (I# i) = W16# (w `uncheckedShiftRL#` i) +shiftr_w32 (W32# w) (I# i) = W32# (w `uncheckedShiftRL#` i) + +#if WORD_SIZE_IN_BITS < 64 +shiftr_w64 (W64# w) (I# i) = W64# (w `uncheckedShiftRL64#` i) + +#if __GLASGOW_HASKELL__ <= 606 +-- Exported by GHC.Word in GHC 6.8 and higher +foreign import ccall unsafe "stg_uncheckedShiftRL64" + uncheckedShiftRL64# :: Word64# -> Int# -> Word64# +#endif + +#else +shiftr_w64 (W64# w) (I# i) = W64# (w `uncheckedShiftRL#` i) +#endif + +#else +shiftr_w16 = shiftR +shiftr_w32 = shiftR +shiftr_w64 = shiftR +#endif + + +------------------------------------------------------------------------------ +-- Builders corresponding to the word writes +------------------------------------------------------------------------------ + +-- Single bytes +------------------------------------------------------------------------------ + +-- | Serialize a single byte. +-- +fromWord8 :: Word8 -> Builder +fromWord8 = fromWriteSingleton writeWord8 + +-- | Serialize a list of bytes. +-- +fromWord8s :: [Word8] -> Builder +fromWord8s = fromWrite8List writeWord8 + + +-- Word16 +------------------------------------------------------------------------------ + +-- | Serialize a 'Word16' in big endian format. +fromWord16be :: Word16 -> Builder +fromWord16be = fromWriteSingleton writeWord16be +{-# INLINE fromWord16be #-} + +-- | Serialize a list of 'Word16's in big endian format. +fromWord16sbe :: [Word16] -> Builder +fromWord16sbe = fromWrite4List writeWord16be +{-# INLINE fromWord16sbe #-} + +-- | Serialize a 'Word16' in little endian format. +fromWord16le :: Word16 -> Builder +fromWord16le = fromWriteSingleton writeWord16le +{-# INLINE fromWord16le #-} + +-- | Serialize a list of 'Word16's in little endian format. +fromWord16sle :: [Word16] -> Builder +fromWord16sle = fromWrite4List writeWord16le +{-# INLINE fromWord16sle #-} + + +-- Word32 +----------------------------------------------------------------------------- + +-- | Serialize a 'Word32' in big endian format. +fromWord32be :: Word32 -> Builder +fromWord32be = fromWriteSingleton writeWord32be +{-# INLINE fromWord32be #-} + +-- | Serialize a list of 'Word32's in big endian format. +fromWord32sbe :: [Word32] -> Builder +fromWord32sbe = fromWrite2List writeWord32be +{-# INLINE fromWord32sbe #-} + +-- | Serialize a 'Word32' in little endian format. +fromWord32le :: Word32 -> Builder +fromWord32le = fromWriteSingleton writeWord32le +{-# INLINE fromWord32le #-} + +-- | Serialize a list of 'Word32's in little endian format. +fromWord32sle :: [Word32] -> Builder +fromWord32sle = fromWrite2List writeWord32le +{-# INLINE fromWord32sle #-} + +-- | Serialize a 'Word64' in big endian format. +fromWord64be :: Word64 -> Builder +fromWord64be = fromWriteSingleton writeWord64be +{-# INLINE fromWord64be #-} + +-- | Serialize a list of 'Word64's in big endian format. +fromWord64sbe :: [Word64] -> Builder +fromWord64sbe = fromWrite1List writeWord64be +{-# INLINE fromWord64sbe #-} + +-- | Serialize a 'Word64' in little endian format. +fromWord64le :: Word64 -> Builder +fromWord64le = fromWriteSingleton writeWord64le +{-# INLINE fromWord64le #-} + +-- | Serialize a list of 'Word64's in little endian format. +fromWord64sle :: [Word64] -> Builder +fromWord64sle = fromWrite1List writeWord64le +{-# INLINE fromWord64sle #-} + + +------------------------------------------------------------------------ +-- Unaligned, word size ops + +-- | 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 = fromWriteSingleton writeWordhost +{-# INLINE fromWordhost #-} + +-- | Serialize a list of 'Word's. +-- See 'fromWordhost' for usage considerations. +fromWordshost :: [Word] -> Builder +fromWordshost = fromWrite2List writeWordhost +{-# INLINE fromWordshost #-} + +-- | Write a 'Word16' in native host order and host endianness. +fromWord16host :: Word16 -> Builder +fromWord16host = fromWriteSingleton writeWord16host +{-# INLINE fromWord16host #-} + +-- | Write a list of 'Word16's in native host order and host endianness. +fromWord16shost :: [Word16] -> Builder +fromWord16shost = fromWrite4List writeWord16host +{-# INLINE fromWord16shost #-} + +-- | Write a 'Word32' in native host order and host endianness. +fromWord32host :: Word32 -> Builder +fromWord32host = fromWriteSingleton writeWord32host +{-# INLINE fromWord32host #-} + +-- | Write a list of 'Word32's in native host order and host endianness. +fromWord32shost :: [Word32] -> Builder +fromWord32shost = fromWrite2List writeWord32host +{-# INLINE fromWord32shost #-} + +-- | Write a 'Word64' in native host order and host endianness. +fromWord64host :: Word64 -> Builder +fromWord64host = fromWriteSingleton writeWord64host +{-# INLINE fromWord64host #-} + +-- | Write a list of 'Word64's in native host order and host endianness. +fromWord64shost :: [Word64] -> Builder +fromWord64shost = fromWrite1List writeWord64host +{-# INLINE fromWord64shost #-} diff --git a/Blaze/ByteString/Builder/Write.hs b/Blaze/ByteString/Builder/Write.hs new file mode 100644 --- /dev/null +++ b/Blaze/ByteString/Builder/Write.hs @@ -0,0 +1,384 @@ +{-# LANGUAGE CPP, BangPatterns #-} + +-- | +-- Module : Blaze.ByteString.Builder.Write +-- Copyright : (c) 2010 Jasper Van der Jeugt & Simon Meier +-- License : BSD3-style (see LICENSE) +-- +-- Maintainer : Simon Meier +-- Stability : experimental +-- Portability : tested on GHC only +-- +-- This module provides the 'Write' type, which abstracts direct writes to a +-- buffer. 'Write's form the public interface for lifting direct buffer +-- manipulations to 'Builder's. +-- +module Blaze.ByteString.Builder.Write + ( + -- * Atomic writes to a buffer + Write (..) + + -- * Creating builders from 'Write' abstractions + , fromWrite + , fromWriteSingleton + , fromWrite1List + , fromWrite2List + , fromWrite4List + , fromWrite8List + , fromWrite16List + + ) where + +import Blaze.ByteString.Builder.Internal + +import Foreign +import Data.Monoid + + +------------------------------------------------------------------------------ +-- Atomic writes to a buffer +------------------------------------------------------------------------------ + +-- | A value @Write n io@ denotes the write of @n@ bytes to a buffer. The +-- actual write is executed by calling @io@ with a pointer @pf@ to the first +-- free byte that the write should start with. Note that the caller of @io pf@ +-- must ensure that @n@ bytes are free starting from @pf@. +-- +-- For example, the function @'writeWord8'@ provided by +-- "Blaze.ByteString.Builder.Word" creates a 'Write' that writes a single fixed byte +-- to a buffer. +-- +-- > writeWord8 :: Word8 -> Write +-- > writeWord8 x = Write 1 (\pf -> poke pf x) +-- +-- The benefit of writes is that they abstract low-level manipulations (e.g. +-- 'poke' and 'copyBytes') of sequences of bytes in a form that that can be +-- completely optimized away in many cases. +-- +-- For example, the 'Monoid' instance of 'Write' allows to formulate writing a +-- three-tuple of bytes as follows. +-- +-- > writeThreeWord8 :: (Word8, Word8, Word8) -> Write +-- > writeThreeWord8 (x,y,z) = +-- > writeWord8 x `mappend` writeWord8 y `mappend` writeWord8 z +-- +-- This expression will be optimized by the compiler to the following efficient +-- 'Write'. +-- +-- > writeThreeWord8 (x, y, z) = Write 3 $ \pf -> do +-- > poke pf x +-- > poke (pf `plusPtr` 1) y +-- > poke (pf `plusPtr` 2) z +-- +-- Writes are /atomic/. This means that the written data cannot be wrapped +-- over buffer boundaries as it can be done for builders. For writes it holds +-- that either the buffer has enough free space and the write can proceed or a +-- new buffer with a size larger or equal to the number of bytes to write has +-- to be allocated. +-- +-- Moreover, for a 'Write', the size of the data to be written must be known +-- before the data can be written. Hence, if this size is data-dependent, the +-- control flow becomes complicated: first, all data must be forced and stored, +-- then the size check happens, and only afterwards the stored data can be +-- written. Therefore, because of cache misses, composing writes with +-- data-dependent size computations may actually be slower than combining the +-- resulting builders. Use benchmarking to make informed decisions. +-- +data Write = Write + {-# UNPACK #-} !Int -- Number of bytes that will be written. + (Ptr Word8 -> IO ()) -- Function to write the bytes starting from the given + -- pointer + +-- A monoid interface for the 'Write' actions. +instance Monoid Write where + mempty = Write 0 (const $ return ()) + {-# INLINE mempty #-} + + mappend (Write l1 f1) (Write l2 f2) = Write (l1 + l2) $ \ptr -> do + f1 ptr + f2 (ptr `plusPtr` l1) + {-# INLINE mappend #-} + + +-- Lifting Writes to Builders +----------------------------- + +-- | Create a 'Builder' from a single write @w@. For good performance, @w@ must +-- feature an outermost 'Write' constructor such that the pattern match can be +-- eliminated during compilation. +-- +-- Semantically, it holds that +-- +-- > fromWrite . write = fromWriteSingleton write +-- +-- However, performance-wise the right-hand side is more efficient due to +-- currently unknown reasons. Use the second form, when +-- defining functions for creating builders from writes of Haskell values. +-- +-- (Use the standard benchmark in the @blaze-html@ package when investigating +-- this phenomenon.) +fromWrite :: Write -> Builder +fromWrite (Write size io) = + Builder step + where + step k pf pe + | pf `plusPtr` size <= pe = do + io pf + let pf' = pf `plusPtr` size + pf' `seq` k pf' pe + | otherwise = return $ BufferFull size pf (step k) +{-# INLINE fromWrite #-} + +-- | Create a 'Builder' constructor from a single 'Write' constructor. +-- +fromWriteSingleton :: (a -> Write) -> a -> Builder +fromWriteSingleton write = makeBuilder + where + makeBuilder x = Builder step + where + step k pf pe + | pf `plusPtr` size <= pe = do + io pf + let pf' = pf `plusPtr` size + pf' `seq` k pf' pe + | otherwise = return $ BufferFull size pf (step k) + where + Write size io = write x +{-# INLINE fromWriteSingleton #-} + +-- | Construct a 'Builder' writing a list of data one element at a time from a 'Write' abstraction. +-- +fromWrite1List :: (a -> Write) -> [a] -> Builder +fromWrite1List write = makeBuilder + where + makeBuilder [] = mempty + makeBuilder xs0 = Builder $ step xs0 + where + step xs1 k pf0 pe0 = go xs1 pf0 + where + go [] !pf = k pf pe0 + go xs@(x':xs') !pf + | pf `plusPtr` size <= pe0 = do + io pf + go xs' (pf `plusPtr` size) + | otherwise = do return $ BufferFull size pf (step xs k) + where + Write size io = write x' +{-# INLINE fromWrite1List #-} + +-- | Construct a 'Builder' writing a list of data two elements at a time from a +-- 'Write' abstraction. +-- +fromWrite2List :: (a -> Write) -> [a] -> Builder +fromWrite2List write = makeBuilder + where + makeBuilder [] = mempty + makeBuilder xs0 = Builder $ step xs0 + where + step xs1 k pf0 pe0 = go xs1 pf0 + where + go [] !pf = k pf pe0 + + go xs@[x'1] !pf + | pf' <= pe0 = do + io pf + k pf' pe0 + | otherwise = do return $ BufferFull size pf (step xs k) + where + Write size io = write x'1 + pf' = pf `plusPtr` size + + go xs@(x'1:x'2:xs') !pf + | pf' <= pe0 = do + io pf + go xs' pf' + | otherwise = do return $ BufferFull size pf (step xs k) + where + Write size io = write x'1 `mappend` write x'2 + pf' = pf `plusPtr` size +{-# INLINE fromWrite2List #-} + +-- | Construct a 'Builder' writing a list of data four elements at a time from a +-- 'Write' abstraction. +-- +fromWrite4List :: (a -> Write) -> [a] -> Builder +fromWrite4List write = makeBuilder + where + makeBuilder [] = mempty + makeBuilder xs0 = Builder $ step xs0 + where + step xs1 k pf0 pe0 = go xs1 pf0 + where + go xs@(x'1:x'2:x'3:x'4:xs') !pf + | pf' <= pe0 = do + io pf + go xs' pf' + | otherwise = do return $ BufferFull size pf (step xs k) + where + Write size io = write x'1 `mappend` write x'2 + `mappend` write x'3 + `mappend` write x'4 + pf' = pf `plusPtr` size + + go xs@(x'1:x'2:xs') !pf + | pf' <= pe0 = do + io pf + go xs' pf' + | otherwise = do return $ BufferFull size pf (step xs k) + where + Write size io = write x'1 `mappend` write x'2 + pf' = pf `plusPtr` size + + go xs@[x'1] !pf + | pf' <= pe0 = do + io pf + k pf' pe0 + | otherwise = do return $ BufferFull size pf (step xs k) + where + Write size io = write x'1 + pf' = pf `plusPtr` size + + go [] !pf = k pf pe0 +{-# INLINE fromWrite4List #-} + +-- | Construct a 'Builder' writing a list of data eight elements at a time from a +-- 'Write' abstraction. +-- +fromWrite8List :: (a -> Write) -> [a] -> Builder +fromWrite8List write = makeBuilder + where + makeBuilder [] = mempty + makeBuilder xs0 = Builder $ step xs0 + where + step xs1 k pf0 pe0 = go xs1 pf0 + where + go xs@(x'1:x'2:x'3:x'4:x'5:x'6:x'7:x'8:xs') !pf + | pf' <= pe0 = do + io pf + go xs' pf' + | otherwise = do return $ BufferFull size pf (step xs k) + where + Write size io = write x'1 `mappend` write x'2 + `mappend` write x'3 + `mappend` write x'4 + `mappend` write x'5 + `mappend` write x'6 + `mappend` write x'7 + `mappend` write x'8 + pf' = pf `plusPtr` size + + go xs@(x'1:x'2:x'3:x'4:xs') !pf + | pf' <= pe0 = do + io pf + go xs' pf' + | otherwise = do return $ BufferFull size pf (step xs k) + where + Write size io = write x'1 `mappend` write x'2 + `mappend` write x'3 + `mappend` write x'4 + pf' = pf `plusPtr` size + + go xs@(x'1:x'2:xs') !pf + | pf' <= pe0 = do + io pf + go xs' pf' + | otherwise = do return $ BufferFull size pf (step xs k) + where + Write size io = write x'1 `mappend` write x'2 + pf' = pf `plusPtr` size + + go xs@[x'1] !pf + | pf' <= pe0 = do + io pf + k pf' pe0 + | otherwise = do return $ BufferFull size pf (step xs k) + where + Write size io = write x'1 + pf' = pf `plusPtr` size + + go [] !pf = k pf pe0 +{-# INLINE fromWrite8List #-} + +-- | Construct a 'Builder' writing a list of data 16 elements at a time from a +-- 'Write' abstraction. +-- +fromWrite16List :: (a -> Write) -> [a] -> Builder +fromWrite16List write = makeBuilder + where + makeBuilder [] = mempty + makeBuilder xs0 = Builder $ step xs0 + where + step xs1 k pf0 pe0 = go xs1 pf0 + where + go xs@(x'1:x'2:x'3:x'4:x'5:x'6:x'7:x'8:x'9:x'10:x'11:x'12:x'13:x'14:x'15:x'16:xs') !pf + | pf' <= pe0 = do + io pf + go xs' pf' + | otherwise = do return $ BufferFull size pf (step xs k) + where + Write size io = write x'1 `mappend` write x'2 + `mappend` write x'3 + `mappend` write x'4 + `mappend` write x'5 + `mappend` write x'6 + `mappend` write x'7 + `mappend` write x'8 + `mappend` write x'9 + `mappend` write x'10 + `mappend` write x'11 + `mappend` write x'12 + `mappend` write x'13 + `mappend` write x'14 + `mappend` write x'15 + `mappend` write x'16 + pf' = pf `plusPtr` size + + go xs@(x'1:x'2:x'3:x'4:x'5:x'6:x'7:x'8:xs') !pf + | pf' <= pe0 = do + io pf + go xs' pf' + | otherwise = do return $ BufferFull size pf (step xs k) + where + Write size io = write x'1 `mappend` write x'2 + `mappend` write x'3 + `mappend` write x'4 + `mappend` write x'5 + `mappend` write x'6 + `mappend` write x'7 + `mappend` write x'8 + pf' = pf `plusPtr` size + + + go xs@(x'1:x'2:x'3:x'4:xs') !pf + | pf' <= pe0 = do + io pf + go xs' pf' + | otherwise = do return $ BufferFull size pf (step xs k) + where + Write size io = write x'1 `mappend` write x'2 + `mappend` write x'3 + `mappend` write x'4 + pf' = pf `plusPtr` size + + go xs@(x'1:x'2:xs') !pf + | pf' <= pe0 = do + io pf + go xs' pf' + | otherwise = do return $ BufferFull size pf (step xs k) + where + Write size io = write x'1 `mappend` write x'2 + pf' = pf `plusPtr` size + + go xs@[x'1] !pf + | pf' <= pe0 = do + io pf + k pf' pe0 + | otherwise = do return $ BufferFull size pf (step xs k) + where + Write size io = write x'1 + pf' = pf `plusPtr` size + + go [] !pf = k pf pe0 +{-# INLINE fromWrite16List #-} + + diff --git a/CHANGES b/CHANGES new file mode 100644 --- /dev/null +++ b/CHANGES @@ -0,0 +1,34 @@ + +* 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. diff --git a/Makefile b/Makefile new file mode 100644 --- /dev/null +++ b/Makefile @@ -0,0 +1,101 @@ + +############################################################################## +## Benchmarks +############################################################################## + +## Config +######### + +GHC = ghc-6.12.3 +# GHC = ghc-7.0.0.20100924 + +GHCI = ghci-6.12.3 + + +## 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 Text/Blaze/Builder.o Text/Blaze/Builder.hi + rm -f Text/Blaze/Builder/*.o Text/Blaze/Builder/*.hi + rm -f Text/Blaze/Builder/Char/*.o Text/Blaze/Builder/Char/*.hi + rm -f Text/Blaze/Builder/Html/*.o Text/Blaze/Builder/Html/*.hi + rm -f Text/Blaze/Builder/Core/*.o Text/Blaze/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 +######################## + +# '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 + +############################################################################## +## Plots +############################################################################## + +plot-all: + $(GHC) --make -O2 -fforce-recomp -main-is Criterion.ScalingBenchmark Criterion.ScalingBenchmark + ./Criterion/ScalingBenchmark --resamples 10000 + + +############################################################################## +## Tests +############################################################################## + +test: + $(GHC) --make -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 diff --git a/README.markdown b/README.markdown new file mode 100644 --- /dev/null +++ b/README.markdown @@ -0,0 +1,30 @@ +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 sytem 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. diff --git a/TODO b/TODO new file mode 100644 --- /dev/null +++ b/TODO @@ -0,0 +1,63 @@ + + * 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. + + * 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 diff --git a/Text/Blaze/Builder/Core.hs b/Text/Blaze/Builder/Core.hs deleted file mode 100644 --- a/Text/Blaze/Builder/Core.hs +++ /dev/null @@ -1,219 +0,0 @@ --- | The builder monoid from BlazeHtml. --- --- Usage is fairly straightforward. Builders can be constructed from many --- values, including 'String' and 'Text' values. --- --- > strings :: [String] --- > strings = replicate 10000 "Hello there!" --- --- Concatenation should happen through the 'Monoid' interface. --- --- > concatenation :: Builder --- > concatenation = mconcat $ map fromString strings --- --- There is only one way to efficiently obtain the result: to convert the --- 'Builder' to a lazy 'L.ByteString' using 'toLazyByteString'. --- --- > result :: L.ByteString --- > result = toLazyByteString concatenation --- -{-# LANGUAGE BangPatterns, OverloadedStrings #-} -module Text.Blaze.Builder.Core - ( - -- * Main builder type - Builder - - -- * Custom writes to the builder - , Write (..) - , writeByte - , writeByteString - , writeSingleton - , writeList - - -- * Creating builders - , singleton - , fromByteString - - -- * Extracting the result from a builder - , toLazyByteString - ) where - -import Foreign -import Data.Monoid (Monoid, mempty, mappend, mconcat) -import qualified Data.ByteString.Char8 () -import qualified Data.ByteString as S -import qualified Data.ByteString.Internal as S -import qualified Data.ByteString.Lazy as L - --- | Main builder type. It simply contains a function to extract the actual --- data. --- -newtype Builder = Builder (BuildStep -> BuildStep) - --- | A buildsignal is a signal returned from a write to the builder, it tells us --- what should happen next. --- -data BuildSignal - -- | Signal the completion of the write process. - = Done {-# UNPACK #-} !(Ptr Word8) -- ^ Pointer to the next free byte - -- | Signal that the buffer is full and a new one needs to be allocated. - -- It contains the minimal size required for the next buffer, a pointer to the - -- next free byte, and a continuation. - | BufferFull - {-# UNPACK #-} !Int - {-# UNPACK #-} !(Ptr Word8) - {-# UNPACK #-} !BuildStep - --- | Type for a single build step. Every build step checks that --- --- > free + bytes-written <= last --- -type BuildStep = Ptr Word8 -- ^ Ptr to the next free byte in the buffer - -> Ptr Word8 -- ^ Ptr to the first byte AFTER the buffer - -> IO BuildSignal -- ^ Signal the next step to be taken - -instance Monoid Builder where - mempty = Builder id - {-# INLINE mempty #-} - mappend (Builder f) (Builder g) = Builder $ f . g - {-# INLINE mappend #-} - mconcat = foldr mappend mempty - {-# INLINE mconcat #-} - --- | Write abstraction so we can avoid some gory and bloody details. A write --- abstration holds the exact size of the write in bytes, and a function to --- carry out the write operation. --- -data Write = Write - {-# UNPACK #-} !Int - (Ptr Word8 -> IO ()) - --- A monoid interface for the write actions. -instance Monoid Write where - mempty = Write 0 (const $ return ()) - {-# INLINE mempty #-} - mappend (Write l1 f1) (Write l2 f2) = Write (l1 + l2) $ \ptr -> do - f1 ptr - f2 (ptr `plusPtr` l1) - {-# INLINE mappend #-} - --- | Write a single byte. --- -writeByte :: Word8 -- ^ Byte to write - -> Write -- ^ Resulting write -writeByte x = Write 1 (\pf -> poke pf x) -{-# INLINE writeByte #-} - --- | Write a strict 'S.ByteString'. --- -writeByteString :: S.ByteString -- ^ 'S.ByteString' to write - -> Write -- ^ Resulting write -writeByteString bs = Write l io - where - (fptr, o, l) = S.toForeignPtr bs - io pf = withForeignPtr fptr $ \p -> copyBytes pf (p `plusPtr` o) l -{-# INLINE writeByteString #-} - --- | Construct a 'Builder' from a single 'Write' abstraction. --- -writeSingleton :: (a -> Write) -- ^ 'Write' abstraction - -> a -- ^ Actual value to write - -> Builder -- ^ Resulting 'Builder' -writeSingleton write = makeBuilder - where - makeBuilder x = Builder step - where - step k pf pe - | pf `plusPtr` size <= pe = do - io pf - let pf' = pf `plusPtr` size - pf' `seq` k pf' pe - | otherwise = return $ BufferFull size pf (step k) - where - Write size io = write x -{-# INLINE writeSingleton #-} - --- | Construct a builder writing a list of data from a write abstraction. --- -writeList :: (a -> Write) -- ^ 'Write' abstraction - -> [a] -- ^ List of values to write - -> Builder -- ^ Resulting 'Builder' -writeList write = makeBuilder - where - makeBuilder [] = mempty - makeBuilder xs0 = Builder $ step xs0 - where - step xs1 k pf0 pe0 = go xs1 pf0 - where - go [] !pf = k pf pe0 - go xs@(x':xs') !pf - | pf `plusPtr` size <= pe0 = do - io pf - go xs' (pf `plusPtr` size) - | otherwise = do return $ BufferFull size pf (step xs k) - where - Write size io = write x' -{-# INLINE writeList #-} - --- | Construct a 'Builder' from a single byte. --- -singleton :: Word8 -- ^ Byte to create a 'Builder' from - -> Builder -- ^ Resulting 'Builder' -singleton = writeSingleton writeByte - --- | /O(n)./ A Builder taking a 'S.ByteString`, copying it. --- -fromByteString :: S.ByteString -- ^ Strict 'S.ByteString' to copy - -> Builder -- ^ Resulting 'Builder' -fromByteString = writeSingleton writeByteString -{-# INLINE fromByteString #-} - --- | Copied from Data.ByteString.Lazy. --- -defaultSize :: Int -defaultSize = 32 * k - overhead - where k = 1024 - overhead = 2 * sizeOf (undefined :: Int) - --- | Run the builder with the default buffer size. --- -runBuilder :: Builder -> [S.ByteString] -> [S.ByteString] -runBuilder = runBuilderWith defaultSize -{-# INLINE runBuilder #-} - --- | Run the builder with buffers of at least the given size. --- --- Note that the builders should guarantee that on average the desired buffer --- size is attained almost perfectly. "Almost" because 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. --- -runBuilderWith :: Int -> Builder -> [S.ByteString] -> [S.ByteString] -runBuilderWith bufSize (Builder b) k = - S.inlinePerformIO $ go bufSize (b finalStep) - where - finalStep pf _ = return $ Done pf - - go !size !step = do - buf <- S.mallocByteString size - withForeignPtr buf $ \pf -> do - next <- step pf (pf `plusPtr` size) - case next of - Done pf' - | pf == pf' -> return k - | otherwise -> return $ S.PS buf 0 (pf' `minusPtr` pf) : k - BufferFull newSize pf' nextStep - | pf == pf' -> bufferFullError - | otherwise -> return $ S.PS buf 0 (pf' `minusPtr` pf) : - S.inlinePerformIO (go (max newSize bufSize) nextStep) - - bufferFullError = - error "runBuilder: buffer cannot be full; no data was written." - --- | /O(n)./ Extract the lazy 'L.ByteString' from the builder. --- -toLazyByteString :: Builder -- ^ 'Builder' to evaluate - -> L.ByteString -- ^ Resulting UTF-8 encoded 'L.ByteString' -toLazyByteString = L.fromChunks . flip runBuilder [] -{-# INLINE toLazyByteString #-} diff --git a/Text/Blaze/Builder/Html.hs b/Text/Blaze/Builder/Html.hs deleted file mode 100644 --- a/Text/Blaze/Builder/Html.hs +++ /dev/null @@ -1,55 +0,0 @@ --- | A module that extends the builder monoid from BlazeHtml with function to --- insert HTML, including HTML escaping and the like. --- -{-# LANGUAGE OverloadedStrings #-} -module Text.Blaze.Builder.Html - ( - -- * Custom writes to the builder - writeHtmlEscapedChar - - -- * Creating builders - , fromHtmlEscapedChar - , fromHtmlEscapedString - , fromHtmlEscapedText - ) where - -import Data.ByteString.Char8 () -import Data.Monoid (mempty, mappend) - -import Data.Text (Text) -import qualified Data.Text as T - -import Text.Blaze.Builder.Core -import Text.Blaze.Builder.Utf8 - --- | Write an unicode character to a 'Builder', doing HTML escaping. --- -writeHtmlEscapedChar :: Char -- ^ Character to write - -> Write -- ^ Resulting write -writeHtmlEscapedChar '<' = writeByteString "<" -writeHtmlEscapedChar '>' = writeByteString ">" -writeHtmlEscapedChar '&' = writeByteString "&" -writeHtmlEscapedChar '"' = writeByteString """ -writeHtmlEscapedChar '\'' = writeByteString "'" -writeHtmlEscapedChar c = writeChar c -{-# INLINE writeHtmlEscapedChar #-} - --- | A HTML escaped 'Char'. --- -fromHtmlEscapedChar :: Char -- ^ Character to write - -> Builder -- ^ Resulting 'Builder' -fromHtmlEscapedChar = writeSingleton writeHtmlEscapedChar - --- | A HTML escaped 'String'. --- -fromHtmlEscapedString :: String -- ^ String to create a 'Builder' from - -> Builder -- ^ Resulting 'Builder' -fromHtmlEscapedString = writeList writeHtmlEscapedChar - --- | An HTML escaped piece of 'Text'. --- -fromHtmlEscapedText :: Text -- ^ 'Text' to insert - -> Builder -- ^ Resulting 'Builder' -fromHtmlEscapedText = writeSingleton (T.foldl appendChar mempty) - where - appendChar w c = w `mappend` writeHtmlEscapedChar c diff --git a/Text/Blaze/Builder/Utf8.hs b/Text/Blaze/Builder/Utf8.hs deleted file mode 100644 --- a/Text/Blaze/Builder/Utf8.hs +++ /dev/null @@ -1,91 +0,0 @@ --- | A module that extends the builder monoid from BlazeHtml with a number of --- functions to insert unicode as UTF-8. --- -module Text.Blaze.Builder.Utf8 - ( - -- * Custom writes to the builder - writeChar - - -- * Creating builders - , fromChar - , fromString - , fromText - ) where - -import Foreign -import Data.Char (ord) -import Data.Monoid (mempty, mappend) - -import Data.Text (Text) -import qualified Data.Text as T - -import Text.Blaze.Builder.Core - --- | Write a Unicode character, encoding it as UTF-8. --- -writeChar :: Char -- ^ Character to write - -> Write -- ^ Resulting 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 #-} - --- | An unescaped, utf8 encoded character. --- -fromChar :: Char -- ^ 'Char' to insert - -> Builder -- ^ Resulting 'Builder' -fromChar = writeSingleton writeChar - --- | A list of unescaped, utf8 encoded characters. --- -fromString :: String -- ^ 'String' to insert - -> Builder -- ^ Resulting 'Builder' -fromString = writeList writeChar - --- | Create an UTF-8 encoded 'Builder' from some 'Text'. --- -fromText :: Text -- ^ 'Text' to insert - -> Builder -- ^ Resulting 'Builder' -fromText = writeSingleton (T.foldl (\w c -> w `mappend` writeChar c) mempty) diff --git a/benchmarks/BenchThroughput.hs b/benchmarks/BenchThroughput.hs new file mode 100644 --- /dev/null +++ b/benchmarks/BenchThroughput.hs @@ -0,0 +1,239 @@ +----------------------------------------------------------------------------- +-- | +-- Module : BenchThroughput +-- Copyright : Simon Meier +-- License : BSD3-style (see LICENSE) +-- +-- Maintainer : Simon Meier +-- Stability : experimental +-- 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 } + -- 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 + diff --git a/benchmarks/BlazeVsBinary.hs b/benchmarks/BlazeVsBinary.hs new file mode 100644 --- /dev/null +++ b/benchmarks/BlazeVsBinary.hs @@ -0,0 +1,83 @@ +{-# LANGUAGE OverloadedStrings #-} +-- | +-- Module : BlazeVsBinary +-- Copyright : (c) 2010 Jasper Van der Jeught & Simon Meier +-- License : BSD3-style (see LICENSE) +-- +-- Maintainer : Simon Meier +-- Stability : experimental +-- 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 . concatMap (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 #-} diff --git a/benchmarks/ChunkedWrite.hs b/benchmarks/ChunkedWrite.hs new file mode 100644 --- /dev/null +++ b/benchmarks/ChunkedWrite.hs @@ -0,0 +1,158 @@ +{-# LANGUAGE OverloadedStrings #-} +-- | +-- Module : ChunkedWrite +-- Copyright : (c) 2010 Simon Meier +-- License : BSD3-style (see LICENSE) +-- +-- Maintainer : Simon Meier +-- Stability : experimental +-- 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 + diff --git a/benchmarks/Compression.hs b/benchmarks/Compression.hs new file mode 100644 --- /dev/null +++ b/benchmarks/Compression.hs @@ -0,0 +1,55 @@ +-- | +-- Module : Compression +-- Copyright : (c) 2010 Simon Meier +-- License : BSD3-style (see LICENSE) +-- +-- Maintainer : Simon Meier +-- Stability : experimental +-- 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 diff --git a/benchmarks/PlotTest.hs b/benchmarks/PlotTest.hs new file mode 100644 --- /dev/null +++ b/benchmarks/PlotTest.hs @@ -0,0 +1,218 @@ +----------------------------------------------------------------------------- +-- | +-- Module : PlotTest +-- Copyright : Simon Meier +-- License : BSD3-style (see LICENSE) +-- +-- Maintainer : Simon Meier +-- Stability : experimental +-- 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) + +-} diff --git a/benchmarks/StringAndText.hs b/benchmarks/StringAndText.hs new file mode 100644 --- /dev/null +++ b/benchmarks/StringAndText.hs @@ -0,0 +1,125 @@ +{-# LANGUAGE OverloadedStrings #-} +-- | +-- Module : StringAndText +-- Copyright : (c) 2010 Simon Meier +-- License : BSD3-style (see LICENSE) +-- +-- Maintainer : Simon Meier +-- Stability : experimental +-- 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 Blaze.ByteString.Builder.Internal 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.Builder $ \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 $ \pfNew peNew -> do + let pfNew' = pfNew `plusPtr` size + io pfNew + k pfNew' peNew + 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.Builder $ \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 $ \pfNew peNew -> do + let pfNew' = pfNew `plusPtr` size + io pfNew + k pfNew' peNew + where + pf' = pf `plusPtr` size + Blaze.Write size io = Blaze.writeChar c +{-# INLINE fromLazyTextFolded #-} diff --git a/benchmarks/Throughput/BinaryBuilder.hs b/benchmarks/Throughput/BinaryBuilder.hs new file mode 100644 --- /dev/null +++ b/benchmarks/Throughput/BinaryBuilder.hs @@ -0,0 +1,697 @@ +{-# 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) + diff --git a/benchmarks/Throughput/BinaryBuilderDeclarative.hs b/benchmarks/Throughput/BinaryBuilderDeclarative.hs new file mode 100644 --- /dev/null +++ b/benchmarks/Throughput/BinaryBuilderDeclarative.hs @@ -0,0 +1,118 @@ +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 + diff --git a/benchmarks/Throughput/BinaryPut.hs b/benchmarks/Throughput/BinaryPut.hs new file mode 100644 --- /dev/null +++ b/benchmarks/Throughput/BinaryPut.hs @@ -0,0 +1,696 @@ +{-# 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) + diff --git a/benchmarks/Throughput/BlazeBuilder.hs b/benchmarks/Throughput/BlazeBuilder.hs new file mode 100644 --- /dev/null +++ b/benchmarks/Throughput/BlazeBuilder.hs @@ -0,0 +1,702 @@ +{-# 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) diff --git a/benchmarks/Throughput/BlazeBuilderDeclarative.hs b/benchmarks/Throughput/BlazeBuilderDeclarative.hs new file mode 100644 --- /dev/null +++ b/benchmarks/Throughput/BlazeBuilderDeclarative.hs @@ -0,0 +1,197 @@ +{-# 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 + + diff --git a/benchmarks/Throughput/BlazePut.hs b/benchmarks/Throughput/BlazePut.hs new file mode 100644 --- /dev/null +++ b/benchmarks/Throughput/BlazePut.hs @@ -0,0 +1,742 @@ +{-# 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) + diff --git a/benchmarks/Throughput/BlazePutMonad.hs b/benchmarks/Throughput/BlazePutMonad.hs new file mode 100644 --- /dev/null +++ b/benchmarks/Throughput/BlazePutMonad.hs @@ -0,0 +1,222 @@ +{-# 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 + +#ifdef APPLICATIVE_IN_BASE +import Control.Applicative +#endif + + +------------------------------------------------------------------------ + +-- 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 #-} + +#ifdef APPLICATIVE_IN_BASE +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') +#endif + +-- 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 #-} diff --git a/benchmarks/Throughput/CBenchmark.c b/benchmarks/Throughput/CBenchmark.c new file mode 100644 --- /dev/null +++ b/benchmarks/Throughput/CBenchmark.c @@ -0,0 +1,39 @@ +#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; +} diff --git a/benchmarks/Throughput/CBenchmark.h b/benchmarks/Throughput/CBenchmark.h new file mode 100644 --- /dev/null +++ b/benchmarks/Throughput/CBenchmark.h @@ -0,0 +1,4 @@ +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); diff --git a/benchmarks/Throughput/Memory.hs b/benchmarks/Throughput/Memory.hs new file mode 100644 --- /dev/null +++ b/benchmarks/Throughput/Memory.hs @@ -0,0 +1,98 @@ +{-# 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) diff --git a/benchmarks/Throughput/Utils.hs b/benchmarks/Throughput/Utils.hs new file mode 100644 --- /dev/null +++ b/benchmarks/Throughput/Utils.hs @@ -0,0 +1,12 @@ +module Throughput.Utils ( + Endian(..) +) where + + +data Endian + = Big + | Little + | Host + deriving (Eq,Ord,Show) + + diff --git a/blaze-builder.cabal b/blaze-builder.cabal --- a/blaze-builder.cabal +++ b/blaze-builder.cabal @@ -1,29 +1,56 @@ Name: blaze-builder -Version: 0.1 -Synopsis: Builder to efficiently append text. -Description: Builder to efficiently append text, optimized for - HTML generation. There is a small usage example in the - Text.Blaze.Builder.Core module, you should begin by - reading that. -Homepage: http://jaspervdj.be/blaze -Bug-Reports: http://github.com/jaspervdj/BlazeHtml/issues +Version: 0.2.0.0 +Synopsis: Efficient construction of bytestrings. + +Description: + This library provides an abstraction of buffered output of + byte streams and several convenience functions to exploit + it. For example, it 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 sytem call overhead + when writing the resulting lazy bytestring to a file or + sending it over the network. + +Homepage: http://github.com/jaspervdj/blaze-builder +Bug-Reports: http://github.com/jaspervdj/blaze-builder/issues License: BSD3 License-file: LICENSE Author: Jasper Van der Jeugt, Simon Meier -Maintainer: jaspervdj@gmail.com, simon.meier@inf.ethz.ch +Maintainer: jaspervdj@gmail.com, iridcode@gmail.com Stability: Experimental -Category: Text +Category: Data Build-type: Simple -Cabal-version: >=1.2 +Cabal-version: >= 1.6 + +Extra-source-files: + Makefile + README.markdown + TODO + CHANGES + + benchmarks/*.hs + benchmarks/Throughput/*.hs + benchmarks/Throughput/*.h + benchmarks/Throughput/*.c + + tests/*.hs + Library - Ghc-Options: -Wall + ghc-options: -Wall - -- Modules exported by the library. - Exposed-modules: Text.Blaze.Builder.Core - Text.Blaze.Builder.Utf8 - Text.Blaze.Builder.Html + exposed-modules: Blaze.ByteString.Builder + Blaze.ByteString.Builder.Write + Blaze.ByteString.Builder.Int + Blaze.ByteString.Builder.Word + Blaze.ByteString.Builder.ByteString + Blaze.ByteString.Builder.Char.Utf8 + Blaze.ByteString.Builder.Html.Utf8 + + Blaze.ByteString.Builder.Internal - -- Packages needed in order to build this package. - Build-depends: base >= 4 && < 5, - text >= 0.7, - bytestring >= 0.9 + -- FIXME: Ensure dependencies are strict enough + build-depends: base == 4.* , + bytestring == 0.9.* , + text == 0.10.* diff --git a/tests/LlvmSegfault.hs b/tests/LlvmSegfault.hs new file mode 100644 --- /dev/null +++ b/tests/LlvmSegfault.hs @@ -0,0 +1,35 @@ +-- 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 diff --git a/tests/Tests.hs b/tests/Tests.hs new file mode 100644 --- /dev/null +++ b/tests/Tests.hs @@ -0,0 +1,96 @@ +-- | Tests for the Blaze builder +-- +{-# LANGUAGE OverloadedStrings #-} +module Tests where + +import Control.Applicative ((<$>)) +import Data.Monoid (mempty, mappend, mconcat) + +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 + , 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 + +escaping1 :: Assertion +escaping1 = fromString "<hello>" @?= fromHtmlEscapedString "" + +escaping2 :: Assertion +escaping2 = fromString "f &&& g" @?= fromHtmlEscapedString "f &&& g" + +escaping3 :: Assertion +escaping3 = fromString ""'" @?= fromHtmlEscapedString "\"'" + +instance Show Builder where + show = show . toLazyByteString + +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 LB.ByteString where + arbitrary = (LB.concat . replicate numRepetitions . LB.pack) <$> arbitrary