diff --git a/.gitignore b/.gitignore index 40d143c..1cbc42f 100644 --- a/.gitignore +++ b/.gitignore @@ -1,26 +1,10 @@ dist/ +dist-newstyle/ +.stack-work/ *.o *.hi *.pdf *.png - -cabal-dev/ -cabal.sandbox.config - -benchmarks/BlazeVsBinary -benchmarks/ChunkedWrite -benchmarks/BenchThroughput -benchmarks/StringAndText -benchmarks/Compression -benchmarks/LazyByteString -benchmarks/BenchmarkServer -benchmarks/FastPut -benchmarks/BuilderBufferRange -benchmarks/BoundedWrite -benchmarks/UnboxedAppend -benchmarks/Utf8IO - -Criterion/ScalingBenchmark - -tests/LlvmSegfault -tests/Tests +*.ghc.environment* +cabal.project.local +cabal.project.freeze diff --git a/.travis.yml b/.travis.yml deleted file mode 100644 index 6988248..0000000 --- a/.travis.yml +++ /dev/null @@ -1,7 +0,0 @@ -language: haskell - -ghc: - - 7.0 - - 7.4 - - 7.6 - - 7.8 diff --git a/Blaze/ByteString/Builder.hs b/Blaze/ByteString/Builder.hs deleted file mode 100644 index 9cc61c2..0000000 --- a/Blaze/ByteString/Builder.hs +++ /dev/null @@ -1,258 +0,0 @@ -{-# LANGUAGE CPP, BangPatterns #-} -{-# LANGUAGE GeneralizedNewtypeDeriving #-} - ------------------------------------------------------------------------------- --- | --- Module: Blaze.ByteString.Builder --- Copyright: (c) 2013 Leon P Smith --- License: BSD3 --- Maintainer: Leon P Smith --- Stability: experimental --- --- "Blaze.ByteString.Builder" is the main module, which you should import as a user --- of the @blaze-builder@ library. --- --- > import Blaze.ByteString.Builder --- --- It provides you with a type 'Builder' that allows to efficiently construct --- lazy bytestrings with a large average chunk size. --- --- Intuitively, a 'Builder' denotes the construction of a part of a lazy --- bytestring. Builders can either be created using one of the primitive --- combinators in "Blaze.ByteString.Builder.Write" or by using one of the predefined --- combinators for standard Haskell values (see the exposed modules of this --- package). Concatenation of builders is done using 'mappend' from the --- 'Monoid' typeclass. --- --- Here is a small example that serializes a list of strings using the UTF-8 --- encoding. --- --- @ import "Blaze.ByteString.Builder.Char.Utf8"@ --- --- > strings :: [String] --- > strings = replicate 10000 "Hello there!" --- --- The function @'fromString'@ creates a 'Builder' denoting the UTF-8 encoded --- argument. Hence, UTF-8 encoding and concatenating all @strings@ can be done --- follows. --- --- > concatenation :: Builder --- > concatenation = mconcat $ map fromString strings --- --- The function 'toLazyByteString' can be used to execute a 'Builder' and --- obtain the resulting lazy bytestring. --- --- > result :: L.ByteString --- > result = toLazyByteString concatenation --- --- The @result@ is a lazy bytestring containing 10000 repetitions of the string --- @\"Hello there!\"@ encoded using UTF-8. The corresponding 120000 bytes are --- distributed among three chunks of 32kb and a last chunk of 6kb. --- --- /A note on history./ This serialization library was inspired by the --- @Data.Binary.Builder@ module provided by the @binary@ package. It was --- originally developed with the specific needs of the @blaze-html@ package in --- mind. Since then it has been restructured to serve as a drop-in replacement --- for @Data.Binary.Builder@, which it improves upon both in speed as well as --- expressivity. --- ------------------------------------------------------------------------------- - -module Blaze.ByteString.Builder - ( - -- * The 'Builder' type - B.Builder - - -- * Creating builders - , module Blaze.ByteString.Builder.Int - , module Blaze.ByteString.Builder.Word - , module Blaze.ByteString.Builder.ByteString - , B.flush - - -- * Executing builders - , B.toLazyByteString - , toLazyByteStringWith - , toByteString - , toByteStringIO - , toByteStringIOWith - - -- * 'Write's - , W.Write - , W.fromWrite - , W.fromWriteSingleton - , W.fromWriteList - , writeToByteString - - -- ** Writing 'Storable's - , W.writeStorable - , W.fromStorable - , W.fromStorables - - ) where - -import Control.Monad(unless) - -#if __GLASGOW_HASKELL__ >= 702 -import Foreign -import qualified Foreign.ForeignPtr.Unsafe as Unsafe -#else -import Foreign as Unsafe -#endif - -import qualified Blaze.ByteString.Builder.Internal.Write as W -import Blaze.ByteString.Builder.ByteString -import Blaze.ByteString.Builder.Word -import Blaze.ByteString.Builder.Int - -import Data.ByteString.Builder ( Builder ) -import qualified Data.ByteString.Builder as B -import qualified Data.ByteString.Builder.Extra as B - -import qualified Data.ByteString as S -import qualified Data.ByteString.Internal as S -import qualified Data.ByteString.Lazy as L -import qualified Data.ByteString.Lazy.Internal as L - -#if __GLASGOW_HASKELL__ >= 702 -import System.IO.Unsafe (unsafeDupablePerformIO) -#else -unsafeDupablePerformIO :: IO a -> a -unsafeDupablePerformIO = unsafePerformIO -#endif - - - --- | 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 . B.toLazyByteString - --- | Default size (~32kb) for the buffer that becomes a chunk of the output --- stream once it is filled. --- -defaultBufferSize :: Int -defaultBufferSize = 32 * 1024 - overhead -- Copied from Data.ByteString.Lazy. - where overhead = 2 * sizeOf (undefined :: Int) - - --- | @toByteStringIOWith bufSize io b@ runs the builder @b@ with a buffer of --- at least the size @bufSize@ and executes the 'IO' action @io@ whenever the --- buffer is full. --- --- Compared to 'toLazyByteStringWith' this function requires less allocation, --- as the output buffer is only allocated once at the start of the --- serialization and whenever something bigger than the current buffer size has --- to be copied into the buffer, which should happen very seldomly for the --- default buffer size of 32kb. Hence, the pressure on the garbage collector is --- reduced, which can be an advantage when building long sequences of bytes. --- -toByteStringIO :: (S.ByteString -> IO ()) -> Builder -> IO () -toByteStringIO = toByteStringIOWith defaultBufferSize - -toByteStringIOWith :: Int -- ^ Buffer size (upper bounds - -- the number of bytes forced - -- per call to the 'IO' action). - -> (S.ByteString -> IO ()) -- ^ 'IO' action to execute per - -- full buffer, which is - -- referenced by a strict - -- 'S.ByteString'. - -> Builder -- ^ 'Builder' to run. - -> IO () -- ^ Resulting 'IO' action. -toByteStringIOWith !bufSize io builder = do - S.mallocByteString bufSize >>= getBuffer (B.runBuilder builder) bufSize - where - getBuffer writer !size fp = do - let !ptr = Unsafe.unsafeForeignPtrToPtr fp - (bytes, next) <- writer ptr size - case next of - B.Done -> io $! S.PS fp 0 bytes - B.More req writer' -> do - io $! S.PS fp 0 bytes - let !size' = max bufSize req - S.mallocByteString size' >>= getBuffer writer' size' - B.Chunk bs' writer' -> do - if bytes > 0 - then do - io $! S.PS fp 0 bytes - unless (S.null bs') (io bs') - S.mallocByteString bufSize >>= getBuffer writer' bufSize - else do - unless (S.null bs') (io bs') - getBuffer writer' size fp - - --- | Run a 'Builder' with the given buffer sizes. --- --- Use this function for integrating the 'Builder' type with other libraries --- that generate lazy bytestrings. --- --- Note that the builders should guarantee that on average the desired chunk --- size is attained. Builders may decide to start a new buffer and not --- completely fill the existing buffer, if this is faster. However, they should --- not spill too much of the buffer, if they cannot compensate for it. --- --- FIXME: Note that the following paragraphs are not entirely correct as of --- blaze-builder-0.4: --- --- A call @toLazyByteStringWith bufSize minBufSize firstBufSize@ will generate --- a lazy bytestring according to the following strategy. First, we allocate --- a buffer of size @firstBufSize@ and start filling it. If it overflows, we --- allocate a buffer of size @minBufSize@ and copy the first buffer to it in --- order to avoid generating a too small chunk. Finally, every next buffer will --- be of size @bufSize@. This, slow startup strategy is required to achieve --- good speed for short (<200 bytes) resulting bytestrings, as for them the --- allocation cost is of a large buffer cannot be compensated. Moreover, this --- strategy also allows us to avoid spilling too much memory for short --- resulting bytestrings. --- --- Note that setting @firstBufSize >= minBufSize@ implies that the first buffer --- is no longer copied but allocated and filled directly. Hence, setting --- @firstBufSize = bufSize@ means that all chunks will use an underlying buffer --- of size @bufSize@. This is recommended, if you know that you always output --- more than @minBufSize@ bytes. -toLazyByteStringWith - :: Int -- ^ Buffer size (upper-bounds the resulting chunk size). - -> Int -- ^ This parameter is ignored as of blaze-builder-0.4 - -> Int -- ^ Size of the first buffer to be used and copied for - -- larger resulting sequences - -> Builder -- ^ Builder to run. - -> L.ByteString -- ^ Lazy bytestring to output after the builder is - -- finished. - -> L.ByteString -- ^ Resulting lazy bytestring -toLazyByteStringWith bufSize _minBufSize firstBufSize builder k = - B.toLazyByteStringWith (B.safeStrategy firstBufSize bufSize) k builder - --- | Run a 'Write' to produce a strict 'S.ByteString'. --- This is equivalent to @('toByteString' . 'fromWrite')@, but is more --- efficient because it uses just one appropriately-sized buffer. -writeToByteString :: W.Write -> S.ByteString -writeToByteString !w = unsafeDupablePerformIO $ do - fptr <- S.mallocByteString (W.getBound w) - len <- withForeignPtr fptr $ \ptr -> do - end <- W.runWrite w ptr - return $! end `minusPtr` ptr - return $! S.fromForeignPtr fptr 0 len -{-# INLINE writeToByteString #-} diff --git a/Blaze/ByteString/Builder/ByteString.hs b/Blaze/ByteString/Builder/ByteString.hs deleted file mode 100644 index 9962253..0000000 --- a/Blaze/ByteString/Builder/ByteString.hs +++ /dev/null @@ -1,128 +0,0 @@ ------------------------------------------------------------------------------- --- | --- Module: Blaze.ByteString.Builder.ByteString --- Copyright: (c) 2013 Leon P Smith --- License: BSD3 --- Maintainer: Leon P Smith --- Stability: experimental --- --- 'Write's and 'B.Builder's for strict and lazy bytestrings. --- --- We assume the following qualified imports in order to differentiate between --- strict and lazy bytestrings in the code examples. --- --- > import qualified Data.ByteString as S --- > import qualified Data.ByteString.Lazy as L --- ------------------------------------------------------------------------------- - -module Blaze.ByteString.Builder.ByteString - ( - -- * Strict bytestrings - writeByteString - , fromByteString - , fromByteStringWith - , copyByteString - , insertByteString - - -- * Lazy bytestrings - , fromLazyByteString - , fromLazyByteStringWith - , copyLazyByteString - , insertLazyByteString - - ) where - - -import Blaze.ByteString.Builder.Internal.Write ( Write, exactWrite ) -import Foreign -import qualified Data.ByteString.Builder as B -import qualified Data.ByteString.Builder.Extra as B -import qualified Data.ByteString as S -import qualified Data.ByteString.Internal as S -import qualified Data.ByteString.Lazy as L - - --- | Write a strict 'S.ByteString' to a buffer. -writeByteString :: S.ByteString -> Write -writeByteString bs = exactWrite l io - where - (fptr, o, l) = S.toForeignPtr bs - io pf = withForeignPtr fptr $ \p -> copyBytes pf (p `plusPtr` o) l -{-# INLINE writeByteString #-} - --- | Create a 'B.Builder' denoting the same sequence of bytes as a strict --- 'S.ByteString'. --- The 'B.Builder' inserts large 'S.ByteString's directly, but copies small ones --- to ensure that the generated chunks are large on average. -fromByteString :: S.ByteString -> B.Builder -fromByteString = B.byteString -{-# INLINE fromByteString #-} - - --- | Construct a 'B.Builder' that copies the strict 'S.ByteString's, if it is --- smaller than the treshold, and inserts it directly otherwise. --- --- For example, @fromByteStringWith 1024@ copies strict 'S.ByteString's whose size --- is less or equal to 1kb, and inserts them directly otherwise. This implies --- that the average chunk-size of the generated lazy 'L.ByteString' may be as --- low as 513 bytes, as there could always be just a single byte between the --- directly inserted 1025 byte, strict 'S.ByteString's. --- -fromByteStringWith :: Int -- ^ Maximal number of bytes to copy. - -> S.ByteString -- ^ Strict 'S.ByteString' to serialize. - -> B.Builder -- ^ Resulting 'B.Builder'. -fromByteStringWith = B.byteStringThreshold -{-# INLINE fromByteStringWith #-} - --- | Construct a 'B.Builder' that copies the strict 'S.ByteString'. --- --- Use this function to create 'B.Builder's from smallish (@<= 4kb@) --- 'S.ByteString's or if you need to guarantee that the 'S.ByteString' is not --- shared with the chunks generated by the 'B.Builder'. --- -copyByteString :: S.ByteString -> B.Builder -copyByteString = B.byteStringCopy -{-# INLINE copyByteString #-} - --- | Construct a 'B.Builder' that always inserts the strict 'S.ByteString' --- directly as a chunk. --- --- This implies flushing the output buffer, even if it contains just --- a single byte. You should therefore use 'insertByteString' only for large --- (@> 8kb@) 'S.ByteString's. Otherwise, the generated chunks are too --- fragmented to be processed efficiently afterwards. --- -insertByteString :: S.ByteString -> B.Builder -insertByteString = B.byteStringInsert -{-# INLINE insertByteString #-} - --- | Create a 'B.Builder' denoting the same sequence of bytes as a lazy --- 'S.ByteString'. --- The 'B.Builder' inserts large chunks of the lazy 'L.ByteString' directly, --- but copies small ones to ensure that the generated chunks are large on --- average. --- -fromLazyByteString :: L.ByteString -> B.Builder -fromLazyByteString = B.lazyByteString -{-# INLINE fromLazyByteString #-} - --- | Construct a 'B.Builder' that uses the thresholding strategy of 'fromByteStringWith' --- for each chunk of the lazy 'L.ByteString'. --- -fromLazyByteStringWith :: Int -> L.ByteString -> B.Builder -fromLazyByteStringWith = B.lazyByteStringThreshold -{-# INLINE fromLazyByteStringWith #-} - --- | Construct a 'B.Builder' that copies the lazy 'L.ByteString'. --- -copyLazyByteString :: L.ByteString -> B.Builder -copyLazyByteString = B.lazyByteStringCopy -{-# INLINE copyLazyByteString #-} - --- | Construct a 'B.Builder' that inserts all chunks of the lazy 'L.ByteString' --- directly. --- -insertLazyByteString :: L.ByteString -> B.Builder -insertLazyByteString = B.lazyByteStringInsert -{-# INLINE insertLazyByteString #-} diff --git a/Blaze/ByteString/Builder/Char/Utf8.hs b/Blaze/ByteString/Builder/Char/Utf8.hs deleted file mode 100644 index c14db6c..0000000 --- a/Blaze/ByteString/Builder/Char/Utf8.hs +++ /dev/null @@ -1,69 +0,0 @@ ------------------------------------------------------------------------------- --- | --- Module: Blaze.ByteString.Builder.Char.Utf8 --- Copyright: (c) 2013 Leon P Smith --- License: BSD3 --- Maintainer: Leon P Smith --- Stability: experimental --- --- 'Write's and 'Builder's for serializing Unicode characters using the UTF-8 --- encoding. --- ------------------------------------------------------------------------------- - -module Blaze.ByteString.Builder.Char.Utf8 - ( - -- * Writing UTF-8 encoded characters to a buffer - writeChar - - -- * Creating Builders from UTF-8 encoded characters - , fromChar - , fromString - , fromShow - , fromText - , fromLazyText - ) where - -import Blaze.ByteString.Builder.Compat.Write (Write, writePrimBounded) -import Data.ByteString.Builder ( Builder ) -import qualified Data.ByteString.Builder as B -import qualified Data.ByteString.Builder.Prim as P -import qualified Data.Text as TS -import qualified Data.Text.Lazy as TL - --- | Write a UTF-8 encoded Unicode character to a buffer. --- -writeChar :: Char -> Write -writeChar = writePrimBounded P.charUtf8 -{-# INLINE writeChar #-} - --- | /O(1)/. Serialize a Unicode character using the UTF-8 encoding. --- -fromChar :: Char -> Builder -fromChar = B.charUtf8 -{-# INLINE fromChar #-} - --- | /O(n)/. Serialize a Unicode 'String' using the UTF-8 encoding. --- -fromString :: String -> Builder -fromString = B.stringUtf8 -{-# INLINE fromString #-} - --- | /O(n)/. Serialize a value by 'Show'ing it and UTF-8 encoding the resulting --- 'String'. --- -fromShow :: Show a => a -> Builder -fromShow = fromString . show -{-# INLINE fromShow #-} - --- | /O(n)/. Serialize a strict Unicode 'TS.Text' value using the UTF-8 encoding. --- -fromText :: TS.Text -> Builder -fromText = fromString . TS.unpack -{-# INLINE fromText #-} - --- | /O(n)/. Serialize a lazy Unicode 'TL.Text' value using the UTF-8 encoding. --- -fromLazyText :: TL.Text -> Builder -fromLazyText = fromString . TL.unpack -{-# INLINE fromLazyText #-} diff --git a/Blaze/ByteString/Builder/Char8.hs b/Blaze/ByteString/Builder/Char8.hs index 6bfd770..c0bea15 100644 --- a/Blaze/ByteString/Builder/Char8.hs +++ b/Blaze/ByteString/Builder/Char8.hs @@ -21,35 +21,12 @@ module Blaze.ByteString.Builder.Char8 ( -- * Writing Latin-1 (ISO 8859-1) encodable characters to a buffer writeChar - - -- * Creating Builders from Latin-1 (ISO 8859-1) encodable characters - , fromChar - , fromString - , fromShow ) where import Blaze.ByteString.Builder.Compat.Write ( Write, writePrimFixed ) -import Data.ByteString.Builder ( Builder ) -import qualified Data.ByteString.Builder as B import qualified Data.ByteString.Builder.Prim as P -- | Write the lower 8-bits of a character to a buffer. writeChar :: Char -> Write writeChar = writePrimFixed P.char8 {-# INLINE writeChar #-} - --- | /O(1)/. Serialize the lower 8-bits of a character. -fromChar :: Char -> Builder -fromChar = B.char8 -{-# INLINE fromChar #-} - --- | /O(n)/. Serialize the lower 8-bits of all characters of a string -fromString :: String -> Builder -fromString = P.primMapListFixed P.char8 -{-# INLINE fromString #-} - --- | /O(n)/. Serialize a value by 'Show'ing it and serializing the lower 8-bits --- of the resulting string. -fromShow :: Show a => a -> Builder -fromShow = fromString . show -{-# INLINE fromShow #-} diff --git a/Blaze/ByteString/Builder/Compat/Write.hs b/Blaze/ByteString/Builder/Compat/Write.hs index 6d43bb1..6d5f672 100644 --- a/Blaze/ByteString/Builder/Compat/Write.hs +++ b/Blaze/ByteString/Builder/Compat/Write.hs @@ -13,18 +13,11 @@ module Blaze.ByteString.Builder.Compat.Write ( Write , writePrimFixed - , writePrimBounded ) where -import Data.ByteString.Builder.Prim.Internal (BoundedPrim, FixedPrim - , runB, runF, size, sizeBound) -import Blaze.ByteString.Builder.Internal.Write (Poke(..), Write - , boundedWrite, exactWrite) +import Data.ByteString.Builder.Prim.Internal (FixedPrim, runF, size) +import Blaze.ByteString.Builder.Internal.Write (Write, exactWrite) writePrimFixed :: FixedPrim a -> a -> Write writePrimFixed fe a = exactWrite (size fe) (runF fe a) {-# INLINE writePrimFixed #-} - -writePrimBounded :: BoundedPrim a -> a -> Write -writePrimBounded be a = boundedWrite (sizeBound be) (Poke (runB be a)) -{-# INLINE writePrimBounded #-} diff --git a/Blaze/ByteString/Builder/Html/Utf8.hs b/Blaze/ByteString/Builder/Html/Utf8.hs deleted file mode 100644 index ecdb5d6..0000000 --- a/Blaze/ByteString/Builder/Html/Utf8.hs +++ /dev/null @@ -1,109 +0,0 @@ -{-# LANGUAGE CPP #-} -#if __GLASGOW_HASKELL__ >= 704 -{-# OPTIONS_GHC -fsimpl-tick-factor=40000 #-} -#endif - ------------------------------------------------------------------------------- --- | --- Module: Blaze.ByteString.Builder.Html.Utf8 --- Copyright: (c) 2013 Leon P Smith --- License: BSD3 --- Maintainer: Leon P Smith --- Stability: experimental --- --- '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.Compat.Write ( Write, writePrimBounded ) -import qualified Data.ByteString.Builder as B -import Data.ByteString.Builder.Prim ((>*<), (>$<), condB) -import qualified Data.ByteString.Builder.Prim as P - -import Blaze.ByteString.Builder.Char.Utf8 - --- | Write a HTML escaped and UTF-8 encoded Unicode character to a bufffer. --- -writeHtmlEscapedChar :: Char -> Write -writeHtmlEscapedChar = writePrimBounded charUtf8HtmlEscaped -{-# INLINE writeHtmlEscapedChar #-} - --- | /O(1)./ Serialize a HTML escaped Unicode character using the UTF-8 --- encoding. -fromHtmlEscapedChar :: Char -> B.Builder -fromHtmlEscapedChar = P.primBounded charUtf8HtmlEscaped -{-# INLINE fromHtmlEscapedChar #-} - -{-# INLINE charUtf8HtmlEscaped #-} -charUtf8HtmlEscaped :: P.BoundedPrim Char -charUtf8HtmlEscaped = - condB (> '>' ) (condB (== '\DEL') P.emptyB P.charUtf8) $ - condB (== '<' ) (fixed4 ('&',('l',('t',';')))) $ -- < - condB (== '>' ) (fixed4 ('&',('g',('t',';')))) $ -- > - condB (== '&' ) (fixed5 ('&',('a',('m',('p',';'))))) $ -- & - condB (== '"' ) (fixed6 ('&',('q',('u',('o',('t',';')))))) $ -- &#quot; - condB (== '\'') (fixed5 ('&',('#',('3',('9',';'))))) $ -- ' - condB (\c -> c >= ' ' || c == '\t' || c == '\n' || c == '\r') - (P.liftFixedToBounded P.char7) $ - P.emptyB - where - {-# INLINE fixed4 #-} - fixed4 x = P.liftFixedToBounded $ const x >$< - P.char7 >*< P.char7 >*< P.char7 >*< P.char7 - - {-# INLINE fixed5 #-} - fixed5 x = P.liftFixedToBounded $ const x >$< - P.char7 >*< P.char7 >*< P.char7 >*< P.char7 >*< P.char7 - - {-# INLINE fixed6 #-} - fixed6 x = P.liftFixedToBounded $ const x >$< - P.char7 >*< P.char7 >*< P.char7 >*< P.char7 >*< P.char7 >*< P.char7 - --- | /O(n)/. Serialize a HTML escaped Unicode 'String' using the UTF-8 --- encoding. --- -fromHtmlEscapedString :: String -> B.Builder -fromHtmlEscapedString = P.primMapListBounded charUtf8HtmlEscaped - --- | /O(n)/. Serialize a value by 'Show'ing it and then, HTML escaping and --- UTF-8 encoding the resulting 'String'. --- -fromHtmlEscapedShow :: Show a => a -> B.Builder -fromHtmlEscapedShow = fromHtmlEscapedString . show - --- | /O(n)/. Serialize a HTML escaped strict Unicode 'TS.Text' value using the --- UTF-8 encoding. --- -fromHtmlEscapedText :: TS.Text -> B.Builder -fromHtmlEscapedText = fromHtmlEscapedString . TS.unpack - --- | /O(n)/. Serialize a HTML escaped Unicode 'TL.Text' using the UTF-8 encoding. --- -fromHtmlEscapedLazyText :: TL.Text -> B.Builder -fromHtmlEscapedLazyText = fromHtmlEscapedString . TL.unpack diff --git a/Blaze/ByteString/Builder/Int.hs b/Blaze/ByteString/Builder/Int.hs deleted file mode 100644 index 57ba7e7..0000000 --- a/Blaze/ByteString/Builder/Int.hs +++ /dev/null @@ -1,258 +0,0 @@ ------------------------------------------------------------------------------- --- | --- Module: Blaze.ByteString.Builder.Int --- Copyright: (c) 2013 Leon P Smith --- License: BSD3 --- Maintainer: Leon P Smith --- Stability: experimental --- --- 'Write's and 'Builder's for serializing integers. --- --- See "Blaze.ByteString.Builder.Word" for information about how to best write several --- integers at once. --- ------------------------------------------------------------------------------- - -module Blaze.ByteString.Builder.Int - ( - -- * Writing integers to a buffer - - writeInt8 - - -- ** Big-endian writes - , writeInt16be -- :: Int16 -> Write - , writeInt32be -- :: Int32 -> Write - , writeInt64be -- :: Int64 -> Write - - -- ** Little-endian writes - , writeInt16le -- :: Int16 -> Write - , writeInt32le -- :: Int32 -> Write - , writeInt64le -- :: Int64 -> Write - - -- ** Host-endian writes - , writeInthost -- :: Int -> Write - , writeInt16host -- :: Int16 -> Write - , writeInt32host -- :: Int32 -> Write - , writeInt64host -- :: Int64 -> Write - - -- * Creating builders from integers - - -- | We provide serialization functions both for singleton integers as well as - -- for lists of integers. Using these list serialization functions is /much/ faster - -- than using @mconcat . map fromInt/@, as the list serialization - -- functions use a tighter inner loop. - - , fromInt8 - , fromInt8s - - -- ** Big-endian serialization - , fromInt16be -- :: Int16 -> Builder - , fromInt32be -- :: Int32 -> Builder - , fromInt64be -- :: Int64 -> Builder - , fromInt32sbe -- :: [Int32] -> Builder - , fromInt16sbe -- :: [Int16] -> Builder - , fromInt64sbe -- :: [Int64] -> Builder - - -- ** Little-endian serialization - , fromInt16le -- :: Int16 -> Builder - , fromInt32le -- :: Int32 -> Builder - , fromInt64le -- :: Int64 -> Builder - , fromInt16sle -- :: [Int16] -> Builder - , fromInt32sle -- :: [Int32] -> Builder - , fromInt64sle -- :: [Int64] -> Builder - - -- ** Host-endian serialization - , fromInthost -- :: Int -> Builder - , fromInt16host -- :: Int16 -> Builder - , fromInt32host -- :: Int32 -> Builder - , fromInt64host -- :: Int64 -> Builder - , fromIntshost -- :: [Int] -> Builder - , fromInt16shost -- :: [Int16] -> Builder - , fromInt32shost -- :: [Int32] -> Builder - , fromInt64shost -- :: [Int64] -> Builder - - ) where - -import Data.Int -import Blaze.ByteString.Builder.Compat.Write ( Write, writePrimFixed ) -import Data.ByteString.Builder ( Builder ) -import qualified Data.ByteString.Builder as B -import qualified Data.ByteString.Builder.Extra as B -import qualified Data.ByteString.Builder.Prim as P - --- | Write a single signed byte. --- -writeInt8 :: Int8 -> Write -writeInt8 = writePrimFixed P.int8 -{-# INLINE writeInt8 #-} - --- | Write an 'Int16' in big endian format. -writeInt16be :: Int16 -> Write -writeInt16be = writePrimFixed P.int16BE -{-# INLINE writeInt16be #-} - --- | Write an 'Int32' in big endian format. -writeInt32be :: Int32 -> Write -writeInt32be = writePrimFixed P.int32BE -{-# INLINE writeInt32be #-} - --- | Write an 'Int64' in big endian format. -writeInt64be :: Int64 -> Write -writeInt64be = writePrimFixed P.int64BE -{-# INLINE writeInt64be #-} - --- | Write an 'Int16' in little endian format. -writeInt16le :: Int16 -> Write -writeInt16le = writePrimFixed P.int16LE -{-# INLINE writeInt16le #-} - --- | Write an 'Int32' in little endian format. -writeInt32le :: Int32 -> Write -writeInt32le = writePrimFixed P.int32LE -{-# INLINE writeInt32le #-} - --- | Write an 'Int64' in little endian format. -writeInt64le :: Int64 -> Write -writeInt64le = writePrimFixed P.int64LE -{-# INLINE writeInt64le #-} - --- | Write a single native machine 'Int'. The 'Int' is written in host order, --- host endian form, for the machine you're on. On a 64 bit machine the 'Int' --- is an 8 byte value, on a 32 bit machine, 4 bytes. Values written this way --- are not portable to different endian or integer sized machines, without --- conversion. --- -writeInthost :: Int -> Write -writeInthost = writePrimFixed P.intHost -{-# INLINE writeInthost #-} - --- | Write an 'Int16' in native host order and host endianness. -writeInt16host :: Int16 -> Write -writeInt16host = writePrimFixed P.int16Host -{-# INLINE writeInt16host #-} - --- | Write an 'Int32' in native host order and host endianness. -writeInt32host :: Int32 -> Write -writeInt32host = writePrimFixed P.int32Host -{-# INLINE writeInt32host #-} - --- | Write an 'Int64' in native host order and host endianness. -writeInt64host :: Int64 -> Write -writeInt64host = writePrimFixed P.int64Host -{-# INLINE writeInt64host #-} - --- | Serialize a single byte. -fromInt8 :: Int8 -> Builder -fromInt8 = B.int8 -{-# INLINE fromInt8 #-} - --- | Serialize a list of bytes. -fromInt8s :: [Int8] -> Builder -fromInt8s = P.primMapListFixed P.int8 -{-# INLINE fromInt8s #-} - --- | Serialize an 'Int16' in big endian format. -fromInt16be :: Int16 -> Builder -fromInt16be = B.int16BE -{-# INLINE fromInt16be #-} - --- | Serialize an 'Int32' in big endian format. -fromInt32be :: Int32 -> Builder -fromInt32be = B.int32BE -{-# INLINE fromInt32be #-} - --- | Serialize an 'Int64' in big endian format. -fromInt64be :: Int64 -> Builder -fromInt64be = B.int64BE -{-# INLINE fromInt64be #-} - --- | Serialize a list of 'Int32's in big endian format. -fromInt32sbe :: [Int32] -> Builder -fromInt32sbe = P.primMapListFixed P.int32BE -{-# INLINE fromInt32sbe #-} - --- | Serialize a list of 'Int16's in big endian format. -fromInt16sbe :: [Int16] -> Builder -fromInt16sbe = P.primMapListFixed P.int16BE -{-# INLINE fromInt16sbe #-} - --- | Serialize a list of 'Int64's in big endian format. -fromInt64sbe :: [Int64] -> Builder -fromInt64sbe = P.primMapListFixed P.int64BE -{-# INLINE fromInt64sbe #-} - --- | Serialize an 'Int16' in little endian format. -fromInt16le :: Int16 -> Builder -fromInt16le = B.int16LE -{-# INLINE fromInt16le #-} - --- | Serialize an 'Int32' in little endian format. -fromInt32le :: Int32 -> Builder -fromInt32le = B.int32LE -{-# INLINE fromInt32le #-} - --- | Serialize an 'Int64' in little endian format. -fromInt64le :: Int64 -> Builder -fromInt64le = B.int64LE -{-# INLINE fromInt64le #-} - --- | Serialize a list of 'Int16's in little endian format. -fromInt16sle :: [Int16] -> Builder -fromInt16sle = P.primMapListFixed P.int16LE -{-# INLINE fromInt16sle #-} - --- | Serialize a list of 'Int32's in little endian format. -fromInt32sle :: [Int32] -> Builder -fromInt32sle = P.primMapListFixed P.int32LE -{-# INLINE fromInt32sle #-} - --- | Serialize a list of 'Int64's in little endian format. -fromInt64sle :: [Int64] -> Builder -fromInt64sle = P.primMapListFixed P.int64LE -{-# INLINE fromInt64sle #-} - --- | Serialize a single native machine 'Int'. The 'Int' is serialized in host --- order, host endian form, for the machine you're on. On a 64 bit machine the --- 'Int' is an 8 byte value, on a 32 bit machine, 4 bytes. Values written this --- way are not portable to different endian or integer sized machines, without --- conversion. --- -fromInthost :: Int -> Builder -fromInthost = B.intHost -{-# INLINE fromInthost #-} - --- | Write an 'Int16' in native host order and host endianness. -fromInt16host :: Int16 -> Builder -fromInt16host = B.int16Host -{-# INLINE fromInt16host #-} - --- | Write an 'Int32' in native host order and host endianness. -fromInt32host :: Int32 -> Builder -fromInt32host = B.int32Host -{-# INLINE fromInt32host #-} - --- | Write an 'Int64' in native host order and host endianness. -fromInt64host :: Int64 -> Builder -fromInt64host = B.int64Host -{-# INLINE fromInt64host #-} - --- | Serialize a list of 'Int's. --- See 'fromInthost' for usage considerations. -fromIntshost :: [Int] -> Builder -fromIntshost = P.primMapListFixed P.intHost -{-# INLINE fromIntshost #-} - --- | Write a list of 'Int16's in native host order and host endianness. -fromInt16shost :: [Int16] -> Builder -fromInt16shost = P.primMapListFixed P.int16Host -{-# INLINE fromInt16shost #-} - --- | Write a list of 'Int32's in native host order and host endianness. -fromInt32shost :: [Int32] -> Builder -fromInt32shost = P.primMapListFixed P.int32Host -{-# INLINE fromInt32shost #-} - --- | Write a list of 'Int64's in native host order and host endianness. -fromInt64shost :: [Int64] -> Builder -fromInt64shost = P.primMapListFixed P.int64Host -{-# INLINE fromInt64shost #-} diff --git a/Blaze/ByteString/Builder/Internal/Write.hs b/Blaze/ByteString/Builder/Internal/Write.hs index 497eb5a..88c48df 100644 --- a/Blaze/ByteString/Builder/Internal/Write.hs +++ b/Blaze/ByteString/Builder/Internal/Write.hs @@ -22,29 +22,15 @@ module Blaze.ByteString.Builder.Internal.Write ( -- * Writing to abuffer , Write(..) - , runWrite - , getBound - , getBound' , getPoke , exactWrite , boundedWrite - , writeLiftIO - , writeIf - , writeEq - , writeOrdering - , writeOrd -- * Constructing builders from writes , fromWrite - , fromWriteSingleton - , fromWriteList -- * Writing 'Storable's - , writeStorable - , fromStorable - , fromStorables - ) where import Foreign @@ -100,26 +86,6 @@ data Write = Write {-# UNPACK #-} !Int Poke getPoke :: Write -> Poke getPoke (Write _ wio) = wio --- | Run the 'Poke' action of a write. -{-# INLINE runWrite #-} -runWrite :: Write -> Ptr Word8 -> IO (Ptr Word8) -runWrite = runPoke . getPoke - --- | Extract the maximal number of bytes that this write could write. -{-# INLINE getBound #-} -getBound :: Write -> Int -getBound (Write bound _) = bound - --- | Extract the maximal number of bytes that this write could write in any --- case. Assumes that the bound of the write is data-independent. -{-# INLINE getBound' #-} -getBound' :: String -- ^ Name of caller: for debugging purposes. - -> (a -> Write) - -> Int -getBound' msg write = - getBound $ write $ error $ - "getBound' called from " ++ msg ++ ": write bound is not data-independent." - #if MIN_VERSION_base(4,9,0) instance Semigroup Poke where {-# INLINE (<>) #-} @@ -131,7 +97,7 @@ instance Semigroup Poke where instance Monoid Poke where {-# INLINE mempty #-} - mempty = Poke $ return + mempty = Poke return #if !(MIN_VERSION_base(4,11,0)) {-# INLINE mappend #-} @@ -188,53 +154,6 @@ exactWrite size io = Write size (pokeN size io) boundedWrite :: Int -> Poke -> Write boundedWrite = Write --- | @writeLiftIO io write@ creates a write executes the @io@ action to compute --- the value that is then written. -{-# INLINE writeLiftIO #-} -writeLiftIO :: (a -> Write) -> IO a -> Write -writeLiftIO write io = - Write (getBound' "writeLiftIO" write) - (Poke $ \pf -> do x <- io; runWrite (write x) pf) - --- | @writeIf p wTrue wFalse x@ creates a 'Write' with a 'Poke' equal to @wTrue --- x@, if @p x@ and equal to @wFalse x@ otherwise. The bound of this new --- 'Write' is the maximum of the bounds for either 'Write'. This yields a data --- independent bound, if the bound for @wTrue@ and @wFalse@ is already data --- independent. -{-# INLINE writeIf #-} -writeIf :: (a -> Bool) -> (a -> Write) -> (a -> Write) -> (a -> Write) -writeIf p wTrue wFalse x = - boundedWrite (max (getBound $ wTrue x) (getBound $ wFalse x)) - (if p x then getPoke $ wTrue x else getPoke $ wFalse x) - --- | Compare the value to a test value and use the first write action for the --- equal case and the second write action for the non-equal case. -{-# INLINE writeEq #-} -writeEq :: Eq a => a -> (a -> Write) -> (a -> Write) -> (a -> Write) -writeEq test = writeIf (test ==) - --- | TODO: Test this. It might well be too difficult to use. --- FIXME: Better name required! -{-# INLINE writeOrdering #-} -writeOrdering :: (a -> Ordering) - -> (a -> Write) -> (a -> Write) -> (a -> Write) - -> (a -> Write) -writeOrdering ord wLT wEQ wGT x = - boundedWrite bound (case ord x of LT -> getPoke $ wLT x; - EQ -> getPoke $ wEQ x; - GT -> getPoke $ wGT x) - where - bound = max (getBound $ wLT x) (max (getBound $ wEQ x) (getBound $ wGT x)) - --- | A write combinator useful to build decision trees for deciding what value --- to write with a constant bound on the maximal number of bytes written. -{-# INLINE writeOrd #-} -writeOrd :: Ord a - => a - -> (a -> Write) -> (a -> Write) -> (a -> Write) - -> (a -> Write) -writeOrd test = writeOrdering (`compare` test) - -- | Create a builder that execute a single 'Write'. {-# INLINE fromWrite #-} fromWrite :: Write -> Builder @@ -247,65 +166,3 @@ fromWrite (Write maxSize wio) = let !br' = BufferRange op' ope k br' | otherwise = return $ bufferFull maxSize op (step k) - -{-# INLINE fromWriteSingleton #-} -fromWriteSingleton :: (a -> Write) -> (a -> Builder) -fromWriteSingleton write = - mkBuilder - where - mkBuilder x = builder step - where - step k (BufferRange op ope) - | op `plusPtr` maxSize <= ope = do - op' <- runPoke wio op - let !br' = BufferRange op' ope - k br' - | otherwise = return $ bufferFull maxSize op (step k) - where - Write maxSize wio = write x - - --- | Construct a 'Builder' writing a list of data one element at a time. -fromWriteList :: (a -> Write) -> [a] -> Builder -fromWriteList write = - makeBuilder - where - makeBuilder xs0 = builder $ step xs0 - where - step xs1 k !(BufferRange op0 ope0) = go xs1 op0 - where - go [] !op = do - let !br' = BufferRange op ope0 - k br' - - go xs@(x':xs') !op - | op `plusPtr` maxSize <= ope0 = do - !op' <- runPoke wio op - go xs' op' - | otherwise = return $ bufferFull maxSize op (step xs k) - where - Write maxSize wio = write x' -{-# INLINE fromWriteList #-} - - - ------------------------------------------------------------------------------- --- Writing storables ------------------------------------------------------------------------------- - - --- | Write a storable value. -{-# INLINE writeStorable #-} -writeStorable :: Storable a => a -> Write -writeStorable x = exactWrite (sizeOf x) (\op -> poke (castPtr op) x) - --- | A builder that serializes a storable value. No alignment is done. -{-# INLINE fromStorable #-} -fromStorable :: Storable a => a -> Builder -fromStorable = fromWriteSingleton writeStorable - --- | A builder that serializes a list of storable values by writing them --- consecutively. No alignment is done. Parsing information needs to be --- provided externally. -fromStorables :: Storable a => [a] -> Builder -fromStorables = fromWriteList writeStorable diff --git a/Blaze/ByteString/Builder/Word.hs b/Blaze/ByteString/Builder/Word.hs deleted file mode 100644 index 670a224..0000000 --- a/Blaze/ByteString/Builder/Word.hs +++ /dev/null @@ -1,268 +0,0 @@ ------------------------------------------------------------------------------- --- | --- Module: Blaze.ByteString.Builder.Word --- Copyright: (c) 2013 Leon P Smith --- License: BSD3 --- Maintainer: Leon P Smith --- Stability: experimental --- --- 'Write's and 'Builder's for serializing words. --- --- Note that for serializing a three tuple @(x,y,z)@ of bytes (or other word --- values) you should use the expression --- --- > fromWrite $ writeWord8 x `mappend` writeWord8 y `mappend` writeWord z --- --- instead of --- --- > fromWord8 x `mappend` fromWord8 y `mappend` fromWord z --- --- The first expression will result in a single atomic write of three bytes, --- while the second expression will check for each byte, if there is free space --- left in the output buffer. Coalescing these checks can improve performance --- quite a bit, as long as you use it sensibly. --- ------------------------------------------------------------------------------- - -module Blaze.ByteString.Builder.Word - ( - -- * Writing words to a buffer - - writeWord8 - - -- ** Big-endian writes - , writeWord16be -- :: Word16 -> Write - , writeWord32be -- :: Word32 -> Write - , writeWord64be -- :: Word64 -> Write - - -- ** Little-endian writes - , writeWord16le -- :: Word16 -> Write - , writeWord32le -- :: Word32 -> Write - , writeWord64le -- :: Word64 -> Write - - -- ** Host-endian writes - , writeWordhost -- :: Word -> Write - , writeWord16host -- :: Word16 -> Write - , writeWord32host -- :: Word32 -> Write - , writeWord64host -- :: Word64 -> Write - - -- * Creating builders from words - - -- | We provide serialization functions both for singleton words as well as - -- for lists of words. Using these list serialization functions is /much/ faster - -- than using @mconcat . map fromWord/@, as the list serialization - -- functions use a tighter inner loop. - - , fromWord8 - , fromWord8s - - -- ** Big-endian serialization - , fromWord16be -- :: Word16 -> Builder - , fromWord32be -- :: Word32 -> Builder - , fromWord64be -- :: Word64 -> Builder - , fromWord32sbe -- :: [Word32] -> Builder - , fromWord16sbe -- :: [Word16] -> Builder - , fromWord64sbe -- :: [Word64] -> Builder - - -- ** Little-endian serialization - , fromWord16le -- :: Word16 -> Builder - , fromWord32le -- :: Word32 -> Builder - , fromWord64le -- :: Word64 -> Builder - , fromWord16sle -- :: [Word16] -> Builder - , fromWord32sle -- :: [Word32] -> Builder - , fromWord64sle -- :: [Word64] -> Builder - - -- ** Host-endian serialization - , fromWordhost -- :: Word -> Builder - , fromWord16host -- :: Word16 -> Builder - , fromWord32host -- :: Word32 -> Builder - , fromWord64host -- :: Word64 -> Builder - , fromWordshost -- :: [Word] -> Builder - , fromWord16shost -- :: [Word16] -> Builder - , fromWord32shost -- :: [Word32] -> Builder - , fromWord64shost -- :: [Word64] -> Builder - - ) where - -import Data.Word -import Blaze.ByteString.Builder.Compat.Write ( Write, writePrimFixed ) -import Data.ByteString.Builder ( Builder ) -import qualified Data.ByteString.Builder as B -import qualified Data.ByteString.Builder.Extra as B -import qualified Data.ByteString.Builder.Prim as P - --- | Write a single byte. --- -writeWord8 :: Word8 -> Write -writeWord8 = writePrimFixed P.word8 -{-# INLINE writeWord8 #-} - --- | Write a 'Word16' in big endian format. -writeWord16be :: Word16 -> Write -writeWord16be = writePrimFixed P.word16BE -{-# INLINE writeWord16be #-} - --- | Write a 'Word32' in big endian format. -writeWord32be :: Word32 -> Write -writeWord32be = writePrimFixed P.word32BE -{-# INLINE writeWord32be #-} - --- | Write a 'Word64' in big endian format. -writeWord64be :: Word64 -> Write -writeWord64be = writePrimFixed P.word64BE -{-# INLINE writeWord64be #-} - --- | Write a 'Word16' in little endian format. -writeWord16le :: Word16 -> Write -writeWord16le = writePrimFixed P.word16LE -{-# INLINE writeWord16le #-} - --- | Write a 'Word32' in big endian format. -writeWord32le :: Word32 -> Write -writeWord32le = writePrimFixed P.word32LE -{-# INLINE writeWord32le #-} - --- | Write a 'Word64' in little endian format. -writeWord64le :: Word64 -> Write -writeWord64le = writePrimFixed P.word64LE -{-# INLINE writeWord64le #-} - --- | Write a single native machine 'Word'. The 'Word' is written in host order, --- host endian form, for the machine you're on. On a 64 bit machine the 'Word' --- is an 8 byte value, on a 32 bit machine, 4 bytes. Values written this way --- are not portable to different endian or word sized machines, without --- conversion. --- -writeWordhost :: Word -> Write -writeWordhost = writePrimFixed P.wordHost -{-# INLINE writeWordhost #-} - --- | Write a 'Word16' in native host order and host endianness. -writeWord16host :: Word16 -> Write -writeWord16host = writePrimFixed P.word16Host -{-# INLINE writeWord16host #-} - --- | Write a 'Word32' in native host order and host endianness. -writeWord32host :: Word32 -> Write -writeWord32host = writePrimFixed P.word32Host -{-# INLINE writeWord32host #-} - --- | Write a 'Word64' in native host order and host endianness. -writeWord64host :: Word64 -> Write -writeWord64host = writePrimFixed P.word64Host -{-# INLINE writeWord64host #-} - --- | Serialize a single byte. -fromWord8 :: Word8 -> Builder -fromWord8 = B.word8 -{-# INLINE fromWord8 #-} - --- | Serialize a list of bytes. -fromWord8s :: [Word8] -> Builder -fromWord8s = P.primMapListFixed P.word8 -{-# INLINE fromWord8s #-} - --- | Serialize a 'Word16' in big endian format. -fromWord16be :: Word16 -> Builder -fromWord16be = B.word16BE -{-# INLINE fromWord16be #-} - --- | Serialize a 'Word32' in big endian format. -fromWord32be :: Word32 -> Builder -fromWord32be = B.word32BE -{-# INLINE fromWord32be #-} - --- | Serialize a 'Word64' in big endian format. -fromWord64be :: Word64 -> Builder -fromWord64be = B.word64BE -{-# INLINE fromWord64be #-} - --- | Serialize a list of 'Word32's in big endian format. -fromWord32sbe :: [Word32] -> Builder -fromWord32sbe = P.primMapListFixed P.word32BE -{-# INLINE fromWord32sbe #-} - --- | Serialize a list of 'Word16's in big endian format. -fromWord16sbe :: [Word16] -> Builder -fromWord16sbe = P.primMapListFixed P.word16BE -{-# INLINE fromWord16sbe #-} - --- | Serialize a list of 'Word64's in big endian format. -fromWord64sbe :: [Word64] -> Builder -fromWord64sbe = P.primMapListFixed P.word64BE -{-# INLINE fromWord64sbe #-} - --- | Serialize a 'Word16' in little endian format. -fromWord16le :: Word16 -> Builder -fromWord16le = B.word16LE -{-# INLINE fromWord16le #-} - --- | Serialize a list of 'Word32's in little endian format. -fromWord32le :: Word32 -> Builder -fromWord32le = B.word32LE -{-# INLINE fromWord32le #-} - --- | Serialize a 'Word64' in little endian format. -fromWord64le :: Word64 -> Builder -fromWord64le = B.word64LE -{-# INLINE fromWord64le #-} - --- | Serialize a list of 'Word16's in little endian format. -fromWord16sle :: [Word16] -> Builder -fromWord16sle = P.primMapListFixed P.word16LE -{-# INLINE fromWord16sle #-} - --- | Serialize a list of 'Word32's in little endian format. -fromWord32sle :: [Word32] -> Builder -fromWord32sle = P.primMapListFixed P.word32LE -{-# INLINE fromWord32sle #-} - --- | Serialize a list of 'Word64's in little endian format. -fromWord64sle :: [Word64] -> Builder -fromWord64sle = P.primMapListFixed P.word64LE -{-# INLINE fromWord64sle #-} - --- | Serialize a single native machine 'Word'. The 'Word' is serialized in host --- order, host endian form, for the machine you're on. On a 64 bit machine the --- 'Word' is an 8 byte value, on a 32 bit machine, 4 bytes. Values written this --- way are not portable to different endian or word sized machines, without --- conversion. -fromWordhost :: Word -> Builder -fromWordhost = B.wordHost -{-# INLINE fromWordhost #-} - --- | Write a 'Word16' in native host order and host endianness. -fromWord16host :: Word16 -> Builder -fromWord16host = B.word16Host -{-# INLINE fromWord16host #-} - --- | Write a 'Word32' in native host order and host endianness. -fromWord32host :: Word32 -> Builder -fromWord32host = B.word32Host -{-# INLINE fromWord32host #-} - --- | Write a 'Word64' in native host order and host endianness. -fromWord64host :: Word64 -> Builder -fromWord64host = B.word64Host -{-# INLINE fromWord64host #-} - --- | Serialize a list of 'Word's. --- See 'fromWordhost' for usage considerations. -fromWordshost :: [Word] -> Builder -fromWordshost = P.primMapListFixed P.wordHost -{-# INLINE fromWordshost #-} - --- | Write a list of 'Word16's in native host order and host endianness. -fromWord16shost :: [Word16] -> Builder -fromWord16shost = P.primMapListFixed P.word16Host -{-# INLINE fromWord16shost #-} - --- | Write a list of 'Word32's in native host order and host endianness. -fromWord32shost :: [Word32] -> Builder -fromWord32shost = P.primMapListFixed P.word32Host -{-# INLINE fromWord32shost #-} - --- | Write a 'Word64' in native host order and host endianness. -fromWord64shost :: [Word64] -> Builder -fromWord64shost = P.primMapListFixed P.word64Host -{-# INLINE fromWord64shost #-} diff --git a/CHANGELOG.md b/CHANGELOG.md index db749e9..4825794 100644 --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,5 +1,9 @@ # Changelog for the `bsb-http-chunked` package +## [0.0.0.2] – 2018-03-13 + +- A lot of unused code was removed + ## [0.0.0.1] – 2018-03-13 - Documentation improvements @@ -14,5 +18,6 @@ Initial release. The format of this changelog is based on [Keep a Changelog](http://keepachangelog.com/en/1.0.0/) -[Unreleased]: https://github.com/sjakobi/bsb-http-chunked/compare/v0.0.0.1...HEAD +[Unreleased]: https://github.com/sjakobi/bsb-http-chunked/compare/v0.0.0.2...HEAD +[0.0.0.2]: https://github.com/sjakobi/bsb-http-chunked/compare/v0.0.0.1...v0.0.0.2 [0.0.0.1]: https://github.com/sjakobi/bsb-http-chunked/compare/v0...v0.0.0.1 diff --git a/Criterion/ScalingBenchmark.hs b/Criterion/ScalingBenchmark.hs deleted file mode 100644 index 0efab89..0000000 --- a/Criterion/ScalingBenchmark.hs +++ /dev/null @@ -1,497 +0,0 @@ -{-# LANGUAGE GADTs #-} ------------------------------------------------------------------------------ --- | --- Module : Criterion.ScalingBenchmark --- Copyright : Simon Meier --- License : BSD3-style (see LICENSE) --- --- Maintainer : Leon P Smith --- Stability : experimental --- Portability : GHC --- --- Measure the scaling behaviour of a benchmarkable function. --- ------------------------------------------------------------------------------ - -module Criterion.ScalingBenchmark where - -import Prelude hiding (lines) - -import Data.Function (on) -import Data.List (unfoldr, group, transpose, sortBy, intersperse) -import Data.Word (Word8) -import Data.Monoid -import Data.Int (Int64) - -import qualified Data.Vector.Generic as V - -import Blaze.ByteString.Builder -import Blaze.ByteString.Builder.Internal - -import qualified Data.Binary.Builder as B - -import Data.Maybe -import Data.Accessor -import Data.Colour -import Data.Colour.Names -import Data.Char (isSpace, toLower) - -import qualified Data.ByteString as S -import qualified Data.ByteString.Lazy as L - -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 hiding (Plot) -import Criterion.Measurement (secs) -import Criterion.Analysis (countOutliers, classifyOutliers) - -import Control.Arrow (first, second) -import Control.Monad -import Control.Monad.Trans -import Control.Monad.Trans.Reader - -import Statistics.Types -import Statistics.Sample -import Statistics.Quantile as Statistics -import Statistics.Function as Statistics - -import System.FilePath - -import Text.Printf (printf) - -import Codec.Compression.GZip - -import qualified System.Random as R - --- Main function ----------------- - -main :: IO () -main = do - let config = defaultConfig - env <- withConfig config measureEnvironment - mapM_ (runAndPlot config env) - [ (compressComparison, defaultPlotConfig { pcLogYAxis = False }) - , (packComparison, defaultPlotConfig) - , (zoomedPackComparison, defaultPlotConfig) - ] - where - runAndPlot config env (sc, plotConfig) = do - sc' <- withConfig config $ runScalingComparison env sc - mkPlots sc' plotConfig - - mkPlots sc plotConfig = sequence_ - [ plotScalingComparison outType - (plotConfig {pcBoxPlot = doBoxPlot}) conv sc - | outType <- outTypes PDF ++ outTypes PNG, - doBoxPlot <- [True, False] - ] - where - conv = fromIntegral :: Int -> Double - outTypes f = map (uncurry f) [(640,480),(800,600),(1280,1024)] - --- | Comparison of different implementations of packing [Word8]. -packComparison, zoomedPackComparison :: ScalingComparison Int -(packComparison, zoomedPackComparison) = - ( cmp "Packing [Word8]" broadVs (bsFaster ++ bsSlower) - , cmp "Packing short [Word8] lists" zoomedVs (bsFaster) - ) - where - cmp name = compareBenchmarks name "bytes" - - bsFaster = - [ ScalingBenchmark "S.pack" (\x-> whnf S.pack (take x word8s)) - , ScalingBenchmark "packLazy" (\x-> whnf (L.length . packLazy) (take x word8s)) - , ScalingBenchmark "packStrict" (\x-> whnf packStrict (take x word8s)) - ] - - bsSlower = - [ ScalingBenchmark "L.pack" (\x-> whnf (L.length . L.pack) (take x word8s)) - , ScalingBenchmark "declPackLazy" (\x-> whnf (L.length . declPackLazy) (take x word8s)) - , ScalingBenchmark "Binary.declPackLazy" (\x-> whnf (L.length . binaryDeclPackLazy) (take x word8s)) - ] - - mkLogVs :: Double -> Double -> [Int] - mkLogVs factor upperBound = - map head . group . map round . takeWhile (<= upperBound) $ - iterate (*factor) 1 - - broadVs = mkLogVs 1.5 (200 * 1024) - zoomedVs = mkLogVs 1.1 256 - - byteStringPackLazy :: [Word8] -> L.ByteString - byteStringPackLazy = L.pack - - byteStringPackStrict :: [Word8] -> S.ByteString - byteStringPackStrict = S.pack - - packLazy :: [Word8] -> L.ByteString - packLazy = toLazyByteString . fromWord8s - - packStrict :: [Word8] -> S.ByteString - packStrict = toByteString . fromWord8s - - declPackLazy :: [Word8] -> L.ByteString - declPackLazy = toLazyByteString . mconcat . map fromWord8 - - binaryDeclPackLazy :: [Word8] -> L.ByteString - binaryDeclPackLazy = B.toLazyByteString . mconcat . map B.singleton - - word8s :: [Word8] - word8s = cycle [0..] - {-# NOINLINE word8s #-} - - -chunk :: Int -> [a] -> [[a]] -chunk size xs = c : case xs' of [] -> []; _ -> chunk size xs' - where - (c, xs') = splitAt size xs - --- | Compare compressing a chunked sequence of bytes with and without --- compaction on redundant and random data. -compressComparison :: ScalingComparison Int -compressComparison = compareBenchmarks ("Compressing "++show kb++"kb of data") "chunk size in bytes" vs $ - {- - [ ScalingBenchmark "rnd. data / direct" (whnf compressDirectly . randomByteStrings) - , ScalingBenchmark "rnd. data / with compaction" (whnf compressCompacted . randomByteStrings) - , ScalingBenchmark "red. data / direct" (whnf compressDirectly . redundantByteStrings) - , ScalingBenchmark "red. data / with compaction" (whnf compressCompacted . redundantByteStrings) - ] - -} - [ ScalingBenchmark "direct" (whnf compressDirectly . redundantByteStrings) - , ScalingBenchmark "with compaction" (whnf compressCompacted . redundantByteStrings) - , ScalingBenchmark "compaction only" (whnf compaction . redundantByteStrings) - ] - where - kb = 200 - n = kb * 1024 - - vs :: [Int] - vs = takeWhile (<= 100000) $ iterate (2*) 1 - - -- randomWord8s = map fromIntegral . take n $ unfoldr (Just . R.next) (R.mkStdGen 666) - -- randomByteStrings c = L.fromChunks . map S.pack . chunk c $ randomWord8s - -- {-# NOINLINE randomByteStrings #-} - - redundantWord8s = take n $ cycle [0..] - redundantByteStrings c = L.fromChunks . map S.pack . chunk c $ redundantWord8s - {-# NOINLINE redundantByteStrings #-} - - compressDirectly :: L.ByteString -> Int64 - compressDirectly = L.length . compress - - compressCompacted :: L.ByteString -> Int64 - compressCompacted = - L.length . compress . toLazyByteString . fromLazyByteString - - compaction :: L.ByteString -> Int64 - compaction = L.length . toLazyByteString . fromLazyByteString - - --- BoxPlots ------------ - -data BoxPlot = BoxPlot - { bpMean :: Double - , bpHighSevereOutliers :: Sample - , bpHighMildOutliers :: Sample - , bpHighWhisker :: Double - , bpHighQuartile :: Double - , bpMedian :: Double - , bpLowQuartile :: Double - , bpLowWhisker :: Double - , bpLowMildOutliers :: Sample - , bpLowSevereOutliers :: Sample - } - -boxPlot :: Sample -> BoxPlot -boxPlot sa = BoxPlot - { bpMean = mean ssa - , bpHighSevereOutliers = V.filter (hiS <) ssa - , bpHighMildOutliers = V.filter (\x -> hiM < x && x <= hiS) ssa - , bpHighWhisker = fromMaybe hiM $ V.find (hiM >=) (V.reverse ssa) - , bpHighQuartile = q3 - , bpMedian = Statistics.weightedAvg 2 4 ssa - , bpLowQuartile = q1 - , bpLowWhisker = fromMaybe loM $ V.find (loM <=) ssa - , bpLowMildOutliers = V.filter (\x -> loS <= x && x < loM) ssa - , bpLowSevereOutliers = V.filter (< loS) ssa - } - where - ssa = Statistics.sort sa - loS = q1 - (iqr * 3) - loM = q1 - (iqr * 1.5) - hiM = q3 + (iqr * 1.5) - hiS = q3 + (iqr * 3) - q1 = Statistics.weightedAvg 1 4 ssa - q3 = Statistics.weightedAvg 3 4 ssa - iqr = q3 - q1 - --- | Compute the k-th percentile of a sample. -percentile :: Int -> Sample -> Double -percentile k = Statistics.weightedAvg k 100 - --- Scaling Benchmark Infrastructure ------------------------------------ - --- | A scaling benchmark denotes a named benchmark constructor, which can be --- used to investigate the scaling behaviour of a 'Benchmarkable' function. -data ScalingBenchmark a where - ScalingBenchmark :: (Benchmarkable b) - => String -- ^ Benchmark name - -> (a -> b) -- ^ Benchmark constructor - -> ScalingBenchmark a -- ^ Scaling benchmark - --- | Extract the name of a 'ScalingBenchmark'. -scalingBenchmarkName :: ScalingBenchmark a -> String -scalingBenchmarkName (ScalingBenchmark name _) = name - --- | A comparison of several benchmarks on a common set of test points. -data ScalingComparison a = ScalingComparison - { scName :: String - , scTestUnit :: String - , scTestValues :: [a] -- INV: non-empty - , scBenchmarks :: [ScalingBenchmark a] -- INV: non-empty - , scMeasurements :: [[Sample]] -- measurements: benchmarks * test points; - -- [] iff the benchmarks haven't been run yet - } - --- | Compare several benchmarks on a set of test values. -compareBenchmarks :: String -- ^ Name of comparison. - -> String -- ^ Unit of test values. - -> [a] -- ^ Test values. - -> [ScalingBenchmark a] -- ^ Benchmarks to compare. - -> ScalingComparison a -- ^ Resulting scaling comparison. -compareBenchmarks name unit vs bs = - ScalingComparison name unit vs bs [] - --- | Annotate the measurements stored in a 'ScalingComparison'. -annotateMeasurements :: (a -> b) - -> ScalingComparison a - -> [(String, [(b,Sample)])] -annotateMeasurements f sc = - zip (map scalingBenchmarkName $ scBenchmarks sc) - (map (zip (map f $ scTestValues sc)) (scMeasurements sc)) - --- | Run a 'ScalingComparison'. -runScalingComparison :: Show a - => Environment -- ^ Criterion environment. - -> ScalingComparison a -- ^ Comparison to run (may or may not contain any measurements already). - -> Criterion (ScalingComparison a) -- ^ Comparison with 'scMeasurements' field set to new measurements. -runScalingComparison env sc = do - samples <- mapM runBenchmarks $ scTestValues sc - return $ sc { scMeasurements = transpose samples } - where - - runBenchmarks x = do - let testPointStr = show x ++ " " ++ scTestUnit sc - liftIO $ putStrLn $ "" - liftIO $ putStrLn $ "running benchmarks for " ++ testPointStr - samples <- sequence - [ ((,) name) `liftM` runBenchmark env (mkBench x) - | ScalingBenchmark name mkBench <- scBenchmarks sc ] - liftIO $ putStrLn $ "" - liftIO $ putStrLn $ "ranking for " ++ testPointStr - liftIO $ quickAnalysis samples - return $ map snd samples - - quickAnalysis samples = do - let indent = length (show $ length samples + 1) + 2 - extent = maximum (map (length . fst) samples) + 2 - mapM_ (printStatistics indent extent) - (zip [1..] $ sortBy (compare `on` (mean . snd)) samples) - - printStatistics :: Int -> Int -> (Int, (String, Sample)) -> IO () - printStatistics indent extent (i, (info, sample)) = putStrLn $ - rightAlign indent (show i) ++ ". " ++ - leftAlign extent (info ++ ":") ++ - "mean " ++ secs (mean sample) ++ - " (2p " ++ secs p2 ++ - ", 98p " ++ secs p98 ++ - ", out " ++ rightAlign 2 (show outliers) ++ - ")" - where - -- percentiles - p2 = percentile 2 sample - p98 = percentile 98 sample - -- outliers - outliers = countOutliers . classifyOutliers $ sample - - rightAlign n cs = take (n - length cs) (repeat ' ') ++ cs - leftAlign n cs = cs ++ take (n - length cs) (repeat ' ') - -data PlotConfig = PlotConfig { - pcBoxPlot :: Bool - , pcLogYAxis :: Bool - , pcLogXAxis :: Bool - } - deriving( Eq, Ord, Show ) - -defaultPlotConfig :: PlotConfig -defaultPlotConfig = PlotConfig True True True - -prettyPlotConfig (PlotConfig boxPlot logY logX) = - concat $ intersperse "," $ msum - [f boxPlot "boxplot", f logY "log-y", f logX "log-x"] - where - f b info = if b then return info else mzero - --- | Plot a scaling comparison. -plotScalingComparison :: (PlotValue b, RealFloat b) - => PlotOutput -- ^ Output format. - -> PlotConfig -- ^ Plot configuration. - -> (a -> b) -- ^ Test point conversion function. - -> ScalingComparison a -- ^ Comparison to plot. - -> IO () - -plotScalingComparison output config conv sc = - renderableToFile $ renderScalingComparison config conv sc - where - renderableToFile = case output of - PDF x y -> \r -> renderableToPDFFile r x y (mkName "pdf" x y) - PNG x y -> \r -> renderableToPNGFile r x y (mkName "png" x y) - SVG x y -> \r -> renderableToSVGFile r x y (mkName "svg" x y) - Window x y -> \r -> renderableToWindow r x y - - mkName fileType x y = mangle $ - printf "%s scaling %s%dx%d.%s" (scName sc) plotType x y fileType - - plotType = case prettyPlotConfig config of - "" -> "" - info -> "("++info++")" - --- plotScalingComparison (PNG x y) doBoxplot conv sc = --- renderableToPNGFile (renderScalingComparison doBoxplot conv sc) x y --- (mangle $ printf "%s scaling %dx%d.png" (scName sc) x y) --- --- plotScalingComparison (SVG x y) doBoxplot conv sc = --- renderableToSVGFile (renderScalingComparison doBoxplot conv sc) x y --- (mangle $ printf "%s scaling %dx%d.svg" (scName sc) x y) --- --- plotScalingComparison (Window x y) doBoxplot conv sc = --- renderableToWindow (renderScalingComparison doBoxplot conv sc) x y --- - --- | Render a scaling comparison using an adaption of the boxplot technique to --- lineplots. -renderScalingComparison :: (PlotValue b, RealFloat b) - => PlotConfig -> (a -> b) -> ScalingComparison a -> Renderable () -renderScalingComparison config f sc = - toRenderable $ - layout1_plots ^= plots $ - layout1_title ^= scName sc $ - layout1_bottom_axis ^= mkAxis pcLogXAxis (scTestUnit sc) $ - layout1_right_axis ^= mkAxis pcLogYAxis "seconds" $ - defaultLayout1 - where - mkAxis proj | proj config = mkLogAxis - | otherwise = mkLinearAxis - plotFunction | pcBoxPlot config = boxplotAnnotatedSamples - | otherwise = plotAnnotatedSamples - plots = concat $ zipWith plotFunction - (map opaque $ colorPalette) - (annotateMeasurements f sc) - - - --- | Plot the means of the annotated samples --- -plotAnnotatedSamples :: AlphaColour Double - -> (String, [(a,Sample)]) - -> [Either (Plot a Double) (Plot a Double)] -plotAnnotatedSamples colour (name, points) = - return . Right $ line (solidLine 1) 1 mean - where - line style trans proj = toPlot $ plotLine name - (solidLine 1 $ dissolve trans colour) - (map (second proj) points) - --- | Plot the annotated samples as a boxplot. This should be used to check the --- soundness of the measured results. --- -boxplotAnnotatedSamples :: AlphaColour Double - -> (String, [(a,Sample)]) - -> [Either (Plot a Double) (Plot a Double)] -boxplotAnnotatedSamples colour (name, points) = - map (Right . noLegend . uncurry (line (solidLine 1))) - [ (0.2, bpLowWhisker) - , (0.4, bpLowQuartile) - , (0.4, bpHighQuartile) - , (0.2, bpHighWhisker) - ] ++ - [ Right $ line (solidLine 1) 0.9 bpMedian] ++ - map (Right . noLegend) - [ toPlot $ plotPoints name meanStyle (map (second bpMean) points') - , outliers severeOutStyle bpHighSevereOutliers - , outliers severeOutStyle bpLowSevereOutliers - , outliers mildOutStyle bpHighMildOutliers - , outliers mildOutStyle bpLowMildOutliers - ] - where - points' = map (second boxPlot) points - - line style trans proj = toPlot $ plotLine name - (solidLine 1 $ dissolve trans colour) - (map (second proj) points') - - outliers style proj = toPlot $ plotPoints name style - (concat [zip (repeat x) (V.toList $ proj bp) | (x, bp) <- points']) - - severeOutStyle = filledCircles 2 (dissolve 0.4 colour) - mildOutStyle = hollowCircles 2 1 (dissolve 0.4 colour) - meanStyle = exes 3 1 colour - - -noLegend :: Plot x y -> Plot x y -noLegend = plot_legend ^= [] - --- | Plot a single named line using the given line style. -plotLine :: String -> CairoLineStyle -> [(a,b)] -> PlotLines a b -plotLine name style points = - plot_lines_title ^= name $ - plot_lines_style ^= style $ - plot_lines_values ^= [points] $ - defaultPlotLines - --- | Plot a single named line using the given line style. -plotPoints :: String -> CairoPointStyle -> [(a,b)] -> PlotPoints a b -plotPoints name style points = - plot_points_title ^= name $ - plot_points_style ^= style $ - plot_points_values ^= points $ - defaultPlotPoints - - -colorPalette :: [Colour Double] -colorPalette = [blue, green, red, cyan, magenta, yellow] - -mkLinearAxis :: PlotValue x => String -> LayoutAxis x -mkLinearAxis name = laxis_title ^= name $ defaultLayoutAxis - -mkLogAxis :: (RealFloat x, PlotValue x) => String -> LayoutAxis x -mkLogAxis name = - laxis_title ^= name $ - laxis_generate ^= autoScaledLogAxis defaultLogAxis $ - defaultLayoutAxis - --- Filehandling ---------------- - - --- | Get rid of spaces and other potentially troublesome characters --- from output. --- --- Copied from: Criterion.Plot -mangle :: String -> FilePath -mangle = concatMap (replace ((==) '-' . head) "-") - . group - . map (replace isSpace '-' . replace (==pathSeparator) '-' . toLower) - where replace p r c | p c = r - | otherwise = c - diff --git a/Data/ByteString/Builder/HTTP/Chunked.hs b/Data/ByteString/Builder/HTTP/Chunked.hs index ceafccb..98d2565 100644 --- a/Data/ByteString/Builder/HTTP/Chunked.hs +++ b/Data/ByteString/Builder/HTTP/Chunked.hs @@ -25,7 +25,6 @@ import Data.ByteString.Char8 () import Blaze.ByteString.Builder.Internal.Write import Data.ByteString.Builder import Data.ByteString.Builder.Internal -import Blaze.ByteString.Builder.ByteString (copyByteString) import qualified Blaze.ByteString.Builder.Char8 as Char8 @@ -108,7 +107,7 @@ chunkedTransferEncoding innerBuilder = transferEncodingStep k = go (runBuilder innerBuilder) where - go innerStep !(BufferRange op ope) + go innerStep (BufferRange op ope) -- FIXME: Assert that outRemaining < maxBound :: Word32 | outRemaining < minimalBufferSize = return $ bufferFull minimalBufferSize op (go innerStep) @@ -188,4 +187,4 @@ chunkedTransferEncoding innerBuilder = -- | The zero-length chunk '0\r\n\r\n' signaling the termination of the data transfer. chunkedTransferTerminator :: Builder -chunkedTransferTerminator = copyByteString "0\r\n\r\n" +chunkedTransferTerminator = byteStringCopy "0\r\n\r\n" diff --git a/Makefile b/Makefile deleted file mode 100644 index 3d20e58..0000000 --- a/Makefile +++ /dev/null @@ -1,160 +0,0 @@ - -############################################################################## -## Benchmarks -############################################################################## - -## Config -######### - -GHC6 = ghc-6.12.3 -GHC7 = ghc-7.0.2 - -GHC = $(GHC7) - -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 Blaze/ByteString/Builder.o Blaze/ByteString/Builder.hi - rm -f Blaze/ByteString/Builder/*.o Blaze/ByteString/Builder/*.hi - rm -f Blaze/ByteString/Builder/Internal/*.o Blaze/ByteString/Builder/Internal/*.hi - rm -f Blaze/ByteString/Builder/Char/*.o Blaze/ByteString/Builder/Char/*.hi - rm -f Blaze/ByteString/Builder/Html/*.o Blaze/ByteString/Builder/Html/*.hi - rm -f Blaze/ByteString/Builder/Core/*.o Blaze/ByteString/Builder/Core/*.hi - rm -f benchmarks/Compression benchmarks/StringAndText benchmarks/BenchThroughput benchmarks/ChunkedWrite benchmarks/BlazeVsBinary - rm -f Criterion/*.o Criterion/*.hi - rm -f Criterion/ScalingBenchmark - -## Individual benchmarks -######################## - -# utf8 writing to a file -utf8-io: - $(GHC) --make -O2 -fforce-recomp -main-is Utf8IO benchmarks/Utf8IO.hs - time ./benchmarks/Utf8IO via-text 100000000 /dev/null - time ./benchmarks/Utf8IO text 100000000 /dev/null - time ./benchmarks/Utf8IO blaze 100000000 /dev/null - time ./benchmarks/Utf8IO base 100000000 /dev/null - time ./benchmarks/Utf8IO utf8-light 100000000 /dev/null - time ./benchmarks/Utf8IO utf8-string 100000000 /dev/null - -# 'blaze-builder' vs. 'binary' comparision -bench-blaze-vs-binary: - $(GHC) --make -O2 -fforce-recomp -main-is BlazeVsBinary benchmarks/BlazeVsBinary.hs - ./benchmarks/BlazeVsBinary --resamples 10000 - -# throughput benchmarks: interactive development -ghci-throughput: benchmarks/Throughput/CBenchmark.o - $(GHCI) -O2 -fforce-recomp -ibenchmarks -main-is BenchThroughput benchmarks/Throughput/CBenchmark.o benchmarks/BenchThroughput.hs - -bench-throughput: benchmarks/Throughput/CBenchmark.o - $(GHC) --make -O2 -fforce-recomp -fliberate-case-threshold=1000 -ibenchmarks -main-is BenchThroughput benchmarks/Throughput/CBenchmark.o benchmarks/BenchThroughput.hs - ./benchmarks/BenchThroughput 100 - -benchmarks/Throughput/CBenchmark.o: benchmarks/Throughput/CBenchmark.c - gcc -O3 -c $< -o $@ - -# Benchmark benefit of serializing several list elements at once -bench-chunked-write: - $(GHC) --make -O2 -fforce-recomp -main-is ChunkedWrite benchmarks/ChunkedWrite.hs - ./benchmarks/ChunkedWrite --resamples 10000 - -core-chunked-write: - ghc-core -- --make -O2 -fforce-recomp -main-is ChunkedWrite benchmarks/ChunkedWrite.hs - -# Benchmark best serialization techniques for 'String' and 'Text' -bench-string-and-text: - $(GHC) --make -O2 -fforce-recomp -ibenchmarks -main-is StringAndText StringAndText - echo $(GHC) - ./benchmarks/StringAndText --resamples 10000 - -# Benchmark benefit of compaction before compression -bench-compression: - $(GHC) --make -O2 -fforce-recomp -ibenchmarks -main-is Compression Compression - ./benchmarks/Compression --resamples 10000 - -# Benchmark the use of unboxed continuation calls -bench-unboxed-append: - $(GHC) --make -O2 -fforce-recomp -ibenchmarks -main-is UnboxedAppend UnboxedAppend - ./benchmarks/UnboxedAppend --resamples 10000 - -# Core of the use of unboxed continuation calls -core-unboxed-append: - ghc-core -- --make -O2 -fforce-recomp -main-is UnboxedAppend benchmarks/UnboxedAppend.hs - -# Benchmark the cost of the Put monad vs. the Builder monoid -bench-put-vs-builder: - $(GHC) --make -O2 -fforce-recomp -ibenchmarks -main-is FastPut FastPut - ./benchmarks/FastPut --resamples 10000 - -# Benchmark the cost/benefit of a more general write type -bench-bounded-write: - $(GHC7) --make -O2 -fforce-recomp -ibenchmarks -main-is BoundedWrite BoundedWrite - ./benchmarks/BoundedWrite --resamples 10000 - -core-bounded-write: - ghc-core -- --make -O2 -fforce-recomp -main-is BoundedWrite benchmarks/BoundedWrite.hs - - -# Benchmark the benefit of using a packed representation for the buffer range -bench-buffer-range: - $(GHC) --make -O2 -fforce-recomp -ibenchmarks -main-is BuilderBufferRange BuilderBufferRange - ./benchmarks/BuilderBufferRange --resamples 10000 - -# Benchmark improvements to lazy bytestring functions -bench-lazy-bytestring: - $(GHC) --make -O2 -fforce-recomp -ibenchmarks -main-is LazyByteString LazyByteString - ./benchmarks/LazyByteString --resamples 10000 - -core-lazy-bytestring: - ghc-core -- --make -O2 -fforce-recomp -ibenchmarks -main-is LazyByteString LazyByteString - -# Benchmark benefit of compaction before compression -bench-server: - $(GHC) --make -O2 -ibenchmarks -main-is BenchmarkServer BenchmarkServer - # ./benchmarks/BenchmarkServer --resamples 10000 - ./benchmarks/BenchmarkServer 9999 100000 +RTS -s& - ab -n 1000 localhost:9999/lbs - curl localhost:9999/kill > /dev/null 2>&1 - - - -############################################################################## -## Plots -############################################################################## - -plot-all: - $(GHC) --make -O2 -fforce-recomp -main-is Criterion.ScalingBenchmark Criterion.ScalingBenchmark - ./Criterion/ScalingBenchmark --resamples 10000 - - -############################################################################## -## Tests -############################################################################## - -test: - $(GHC) --make -fforce-recomp -O2 -itests -main-is Tests Tests - ./tests/Tests - -clean-tests: - rm -f tests/Tests tests/*.o tests/*.hi - -ghci-llvm-segfault: - $(GHCI) -itests -main-is LlvmSegfault tests/LlvmSegfault - -test-llvm-segfault: - ghc-7.0.0.20100924 --make -fllvm -itests -main-is LlvmSegfault tests/LlvmSegfault - ./tests/LlvmSegfault - -############################################################################## -## All inclusive targets -############################################################################## - -clean: clean-tests clean-bench-all diff --git a/TODO b/TODO deleted file mode 100644 index e1e4b8b..0000000 --- a/TODO +++ /dev/null @@ -1,73 +0,0 @@ - -!! UPDATE TODO !! - -!! UPDATE BENCHMARKS !! - - * custom serialization functions for lists of 'WordX's - - benchmark chunk size speedup for more complicated computations of list - elements => to be expected that we get no speedup anymore or even a - slowdown => adapt Blaze.ByteString.Builder.Word accordingly. - - * fast serialization for 'Text' values (currently unpacking to 'String' is - the fastest :-/) - - * implementation - - further encodings for 'Char' - - think about end-of-buffer wrapping when copying bytestrings - - toByteStringIO with accumulator capability => provide 'toByteStringIO_' - - allow buildr/foldr deforestation to happen for input to 'fromWriteList' - (or whatever stream fusion framework is in place for lists) - - implement 'toByteString' with an amortized O(n) runtime using the - exponentional scaling trick. If the start size is chosen wisely this - may even be faster than 'S.pack', as the one copy per element is - cheaper than one list thunk per element. It is even likely that we can - amortize three copies per element, which allows to avoid spilling any - buffer space by doing a last compaction copy. - - we could provide builders that honor alignment restrictions, either as - builder transformers or as specialized write to builder converters. The - trick is for the driver to ensure that the buffer beginning is aligned - to the largest aligning (8 or 16 bytes?) required. This is probably the - case by default. Then we can always align a pointer in the buffer by - appropriately aligning the write pointer. - - * extend tests to new functions - - * benchmarks - - understand why the declarative blaze-builder version is the fastest - serializer for Word64 little-endian and big-endian - - check the cost of using `mappend` on builders instead of writes. - - show that using toByteStringIO has an advantage over toLazyByteString - - check performance of toByteStringIO - - compare speed of 'L.pack' to speed of 'toLazyByteString . fromWord8s' - - * documentation - - sort out formultion: "serialization" vs. "encoding" - - * check portability to Hugs - - * performance: - - check if reordering 'pe' and 'pf' change performance; it seems that 'pe' - is only a reader argument while 'pf' is a state argument. - - perhaps we could improve performance by taking page size, page - alignment, and memory access alignment into account. - - detect machine endianness and use host order writes for the supported - endianness. - - introduce a type 'BoundedWrite' that encapsulates a 'Write' generator - with a bound on the number of bytes maximally written by the write. - This way we can achieve data independence for the size check by - sacrificing just a little bit of buffer space at buffer ends. - - investigate where we would profit from static bounds on number of bytes - written (e.g. to make the control flow more linear) - - * testing - - port tests from 'Data.Binary.Builder' to ensure that the word writes - and builders are working correctly. I may have missed some pitfalls - about word types in Haskell during porting the functions from - 'Data.Binary.Builder'. - - * portability - - port to Hugs - - test lower versions of GHC - - * deployment - - add source repository to 'blaze-html' and 'blaze-builder' cabal files diff --git a/benchmarks/BenchThroughput.hs b/benchmarks/BenchThroughput.hs deleted file mode 100644 index 3c3e2f5..0000000 --- a/benchmarks/BenchThroughput.hs +++ /dev/null @@ -1,240 +0,0 @@ ------------------------------------------------------------------------------ --- | --- Module : BenchThroughput --- Copyright : Simon Meier --- License : BSD3-style (see LICENSE) --- --- Maintainer : Leon P Smith --- 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 } - return () - -- renderableToWindow (toRenderable layout) 640 480 - - -measureSerializer :: (a, [(Int, IO (Maybe Double))]) -> IO (Maybe (a, [(Int,Double)])) -measureSerializer (info, tests) = do - optPoints <- forM tests $ \ (x, test) -> do - optY <- test - case optY of - Nothing -> return Nothing - Just y -> return $ Just (x, y) - case catMaybes optPoints of - [] -> return Nothing - points -> return $ Just (info, points) - ------------------------------------------------------------------------- - -time :: IO a -> IO Double -time action = do - start <- getCPUTime - action - end <- getCPUTime - return $! (fromIntegral (end - start)) / (10^12) - ------------------------------------------------------------------------- - -test :: (String, a, Int -> Int -> Endian -> Int -> Maybe L.ByteString) - -> Int -> Int -> Endian -> Int -> IO (Maybe Double) -test (serializeName, _, serialize) wordSize chunkSize end mb = do - let bytes :: Int - bytes = mb * 2^20 - iterations = bytes `div` wordSize - case serialize wordSize chunkSize end iterations of - Nothing -> return Nothing - Just bs -> do - _ <- printf "%17s: %dMB of Word%-2d in chunks of %2d (%6s endian):" - serializeName (mb :: Int) (8 * wordSize :: Int) (chunkSize :: Int) (show end) - - putSeconds <- time $ evaluate (L.length bs) - -- getSeconds <- time $ evaluate sum - -- print (L.length bs, sum) - let putThroughput = fromIntegral mb / putSeconds - -- getThroughput = fromIntegral mb / getSeconds - - _ <- printf "%6.1f MB/s write\n" - putThroughput - -- getThroughput - -- (getThroughput/putThroughput) - - hFlush stdout - return $ Just putThroughput - ------------------------------------------------------------------------- - -compareResults :: (String, a, Int -> Int -> Endian -> Int -> Maybe L.ByteString) - -> Int -> Int -> Endian -> Int -> IO () -compareResults (serializeName, _, serialize) wordSize chunkSize end mb0 = do - let mb :: Int - mb = max 1 (mb0 `div` 100) - bytes :: Int - bytes = mb * 2^20 - iterations = bytes `div` wordSize - bs0 = BinaryBuilder.serialize wordSize chunkSize end iterations - case serialize wordSize chunkSize end iterations of - Nothing -> return () - Just bs1 -> do - _ <- printf "%17s: %dMB of Word%-2d in chunks of %2d (%6s endian):" - serializeName (mb :: Int) (8 * wordSize :: Int) (chunkSize :: Int) (show end) - if (bs0 == bs1) - then putStrLn " Ok" - else putStrLn " Failed" - hFlush stdout - diff --git a/benchmarks/BenchmarkServer.hs b/benchmarks/BenchmarkServer.hs deleted file mode 100644 index fa173f9..0000000 --- a/benchmarks/BenchmarkServer.hs +++ /dev/null @@ -1,97 +0,0 @@ -{- Benchmark server based upon Jasper van der Jeugt's 'BenchmarkServer.lhs' - from blaze-html. Modified for network-2.3 by Simon Meier --} - -{-# LANGUAGE OverloadedStrings #-} -module BenchmarkServer where - -import Prelude hiding (putStrLn) - -import Data.Char (ord) -import Data.Monoid -import Data.ByteString.Char8 () -- IsString instance only -import qualified Data.ByteString as S -import qualified Data.ByteString.Lazy as L -import qualified Data.ByteString.Lazy.Internal as L - -import Control.Concurrent (forkIO, putMVar, takeMVar, newEmptyMVar) -import Control.Exception (bracket) -import Control.Monad - -import Network.Socket (Socket, accept, sClose) -import Network (listenOn, PortID (PortNumber)) -import Network.Socket.ByteString as S -import Network.Socket.ByteString.Lazy as L - -import System (getArgs) - -import Blaze.ByteString.Builder -import Blaze.ByteString.Builder.Internal (defaultBufferSize, defaultMinimalBufferSize) -import Blaze.ByteString.Builder.Char.Utf8 - -import Criterion.Main - -httpOkHeader :: S.ByteString -httpOkHeader = S.concat - [ "HTTP/1.1 200 OK\r\n" - , "Content-Type: text/html; charset=UTF-8\r\n" - , "\r\n" ] - -response :: Int -> Builder -response n = - fromByteString httpOkHeader `mappend` - fromString (take n $ cycle "hello λ-world! ") - -sendVectoredBuilderLBS :: Socket -> Builder -> IO () -sendVectoredBuilderLBS s = L.sendAll s . toLazyByteString -{-# NOINLINE sendVectoredBuilderLBS #-} - -sendBuilderLBS :: Socket -> Builder -> IO () -sendBuilderLBS s = - -- mapM_ (S.sendAll s) . L.toChunks . toLazyByteString - L.foldrChunks (\c -> (S.sendAll s c >>)) (return ()). toLazyByteString -{-# NOINLINE sendBuilderLBS #-} - -sendBuilderBSIO :: Socket -> Builder -> IO () -sendBuilderBSIO s = toByteStringIO $ S.sendAll s -{-# NOINLINE sendBuilderBSIO #-} - --- criterion benchmark determining the speed of response -main2 = defaultMain - [ bench ("response " ++ show n) $ whnf - (L.length . toLazyByteString . response) n - ] - where - n :: Int - n = 1000000 - -main :: IO () -main = do - [port, nChars] <- map read `liftM` getArgs - killSignal <- newEmptyMVar - bracket (listenOn . PortNumber . fromIntegral $ port) sClose - (\socket -> do - _ <- forkIO $ loop (putMVar killSignal ()) nChars socket - takeMVar killSignal) - where - loop killServer nChars socket = forever $ do - (s, _) <- accept socket - forkIO (respond s nChars) - where - respond s n = do - input <- S.recv s 1024 - let requestUrl = (S.split (fromIntegral $ ord ' ') input) !! 1 - case tail (S.split (fromIntegral $ ord '/') requestUrl) of - ["lbs"] -> sendBuilderLBS s $ response n - ["lbs-vec"] -> sendVectoredBuilderLBS s $ response n - ["bs-io"] -> sendBuilderBSIO s $ response n - ["kill"] -> notFound s >> killServer - _ -> notFound s - sClose s - - notFound s = do - _ <- S.sendAll s $ "HTTP/1.1 404 Not Found\r\n" - `mappend` "Content-Type: text/html; charset=UTF-8\r\n" - `mappend` "\r\n" - `mappend` "

Page not found

" - return () diff --git a/benchmarks/BlazeVsBinary.hs b/benchmarks/BlazeVsBinary.hs deleted file mode 100644 index e82dea3..0000000 --- a/benchmarks/BlazeVsBinary.hs +++ /dev/null @@ -1,83 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} --- | --- Module : BlazeVsBinary --- Copyright : (c) 2010 Jasper Van der Jeught & Simon Meier --- License : BSD3-style (see LICENSE) --- --- Maintainer : Leon P Smith --- 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 . map (mconcat . (map $ Binary.singleton . fromIntegral . ord))) - (mconcat . map Blaze.fromString) - strings - , benchmark "L.ByteString" - (Binary.fromLazyByteString) - (Blaze.fromLazyByteString) - byteStrings - , benchmark "[Text]" - (mconcat . map (Binary.fromByteString . encodeUtf8)) - (mconcat . map Blaze.fromText) - texts - , benchmark "[Word8]" - (mconcat . map Binary.singleton) - (Blaze.fromWord8s) - word8s - ] - where - benchmark name binaryF blazeF x = - [ bench (name ++ " (Data.Binary builder)") $ - whnf (L.length . Binary.toLazyByteString . binaryF) x - , bench (name ++ " (blaze builder)") $ - whnf (L.length . Blaze.toLazyByteString . blazeF) x - ] - -strings :: [String] -strings = replicate 10000 "" -{-# NOINLINE strings #-} - -byteStrings :: L.ByteString -byteStrings = L.fromChunks $ replicate 10000 "" -{-# NOINLINE byteStrings #-} - -texts :: [Text] -texts = replicate 10000 "" -{-# NOINLINE texts #-} - -word8s :: [Word8] -word8s = replicate 10000 $ fromIntegral $ ord 'a' -{-# NOINLINE word8s #-} diff --git a/benchmarks/BoundedWrite.hs b/benchmarks/BoundedWrite.hs deleted file mode 100644 index 42e21e9..0000000 --- a/benchmarks/BoundedWrite.hs +++ /dev/null @@ -1,241 +0,0 @@ -{-# LANGUAGE CPP, BangPatterns #-} --- | --- Module : BoundedWrite --- Copyright : (c) 2010 Simon Meier --- License : BSD3-style (see LICENSE) --- --- Maintainer : Leon P Smith --- Stability : experimental --- Portability : tested on GHC only --- --- A more general/efficient write type. --- -module BoundedWrite (main) where - -import Foreign -import Data.Monoid -import Data.Char - -import Foreign.UPtr - -import qualified Data.ByteString.Internal as S -import qualified Data.ByteString.Lazy as L - -import Blaze.ByteString.Builder.Internal -import Blaze.ByteString.Builder.Write -import Blaze.ByteString.Builder.Word - -import Criterion.Main - ------------------------------------------------------------------------------- --- Benchmarks ------------------------------------------------------------------------------- - -main :: IO () -main = defaultMain $ concat - {- - [ benchmark "mconcat . map (fromWriteSingleton writeChar)" - bfrom3Chars - from3Chars - chars3 - ] - -} - [ benchmark "mconcat . map fromWord8" - (mconcat . map bfromWord8) - (mconcat . map fromWord8) - word8s - ] - where - benchmark name boundedF staticF x = - [ bench (name ++ " <- bounded write") $ - whnf (L.length . toLazyByteString . boundedF) x - , bench (name ++ " <- static write") $ - whnf (L.length . toLazyByteString . staticF) x - ] - -word8s :: [Word8] -word8s = take 100000 $ cycle [0..] -{-# NOINLINE word8s #-} - -chars :: [Char] -chars = take 100000 $ ['\0'..] -{-# NOINLINE chars #-} - -chars2 :: [(Char,Char)] -chars2 = zip chars chars -{-# NOINLINE chars2 #-} - -chars3 :: [(Char, Char, Char)] -chars3 = zip3 chars (reverse chars) (reverse chars) -{-# NOINLINE chars3 #-} - -bfromChars = (mconcat . map (fromBWriteSingleton bwriteChar)) -{-# NOINLINE bfromChars #-} - -fromChars = (mconcat . map (fromWriteSingleton writeChar)) -{-# NOINLINE fromChars #-} - -bfrom2Chars = (mconcat . map (fromBWriteSingleton (\(c1, c2) -> bwriteChar c1 `mappend` bwriteChar c2))) -{-# NOINLINE bfrom2Chars #-} - -from2Chars = (mconcat . map (fromWriteSingleton (\(c1, c2) -> writeChar c1 `mappend` writeChar c2))) -{-# NOINLINE from2Chars #-} - -bfrom3Chars = (mconcat . map (fromBWriteSingleton (\(c1, c2, c3) -> bwriteChar c1 `mappend` bwriteChar c2 `mappend` bwriteChar c3))) -{-# NOINLINE bfrom3Chars #-} - -from3Chars = (mconcat . map (fromWriteSingleton (\(c1, c2, c3) -> writeChar c1 `mappend` writeChar c2 `mappend` writeChar c3))) -{-# NOINLINE from3Chars #-} - ------------------------------------------------------------------------------- --- The Bounded Write Type ------------------------------------------------------------------------------- - --- * GRRR* GHC is too 'clever'... code where we branch and each branch should --- execute a few IO actions and then return a value cannot be taught to GHC. --- At least not such that it returns the value of the branches unpacked. --- --- Hmm.. at least he behaves much better for the Monoid instance of BWrite --- than the one for Write. Serializing UTF-8 chars gets a slowdown of a --- factor 2 when 2 chars are composed. Perhaps I should try out the writeList --- instances also, as they may be more sensitive to to much work per Char. --- -data BWrite = BWrite {-# UNPACK #-} !Int (UPtr -> UPtr) - -newtype UWrite = UWrite { runUWrite :: UPtr -> UPtr } - -instance Monoid UWrite where - mempty = UWrite $ \x -> x - {-# INLINE mempty #-} - (UWrite uw1) `mappend` (UWrite uw2) = UWrite (\up -> uw2 (uw1 up)) - {-# INLINE mappend #-} - -instance Monoid BWrite where - mempty = BWrite 0 (\x -> x) - {-# INLINE mempty #-} - (BWrite b1 io1) `mappend` (BWrite b2 io2) = - BWrite (b1 + b2) (\op -> io2 (io1 op)) - {-# INLINE mappend #-} - -execWrite :: IO () -> UPtr -> UPtr -execWrite io op' = S.inlinePerformIO io `seq` op' -{-# INLINE execWrite #-} - -execWriteSize :: (Ptr Word8 -> IO ()) -> Int -> UPtr -> UPtr -execWriteSize io size op = execWrite (io (uptrToPtr op)) (op `plusUPtr` size) -{-# INLINE execWriteSize #-} - -staticBWrite :: Int -> (Ptr Word8 -> IO ()) -> BWrite -staticBWrite size io = BWrite size (execWriteSize io size) -{-# INLINE staticBWrite #-} - -bwriteWord8 :: Word8 -> BWrite -bwriteWord8 x = staticBWrite 1 (`poke` x) -{-# INLINE bwriteWord8 #-} - -fromBWrite :: BWrite -> Builder -fromBWrite (BWrite size io) = - Builder step - where - step k !pf !pe - | pf `plusPtr` size <= pe = do - let !pf' = io (ptrToUPtr pf) - k (uptrToPtr pf') pe - | otherwise = return $ BufferFull size pf (step k) -{-# INLINE fromBWrite #-} - -fromBWriteSingleton :: (a -> BWrite) -> a -> Builder -fromBWriteSingleton write = - mkPut - where - mkPut x = Builder step - where - step k !pf !pe - | pf `plusPtr` size <= pe = do - let !pf' = io (ptrToUPtr pf) - k (uptrToPtr pf') pe - | otherwise = return $ BufferFull size pf (step k) - where - BWrite size io = write x -{-# INLINE fromBWriteSingleton #-} - -bfromWord8 :: Word8 -> Builder -bfromWord8 = fromBWriteSingleton bwriteWord8 - --- Utf-8 encoding ------------------ - -bwriteChar :: Char -> BWrite -bwriteChar c = BWrite 4 (encodeCharUtf8 f1 f2 f3 f4 c) - where - f1 x = \uptr -> execWrite (do let !ptr = uptrToPtr uptr - poke ptr x ) - (uptr `plusUPtr` 1) - - f2 x1 x2 = \uptr -> execWrite (do let !ptr = uptrToPtr uptr - poke ptr x1 - poke (ptr `plusPtr` 1) x2 ) - (uptr `plusUPtr` 2) - - f3 x1 x2 x3 = \uptr -> execWrite (do let !ptr = uptrToPtr uptr - poke ptr x1 - poke (ptr `plusPtr` 1) x2 - poke (ptr `plusPtr` 2) x3 ) - (uptr `plusUPtr` 3) - - f4 x1 x2 x3 x4 = \uptr -> execWrite (do let !ptr = uptrToPtr uptr - poke ptr x1 - poke (ptr `plusPtr` 1) x2 - poke (ptr `plusPtr` 2) x3 - poke (ptr `plusPtr` 3) x4 ) - (uptr `plusUPtr` 4) -{-# INLINE bwriteChar #-} - -writeChar :: Char -> Write -writeChar = encodeCharUtf8 f1 f2 f3 f4 - where - f1 x = Write 1 $ \ptr -> poke ptr x - - f2 x1 x2 = Write 2 $ \ptr -> do poke ptr x1 - poke (ptr `plusPtr` 1) x2 - - f3 x1 x2 x3 = Write 3 $ \ptr -> do poke ptr x1 - poke (ptr `plusPtr` 1) x2 - poke (ptr `plusPtr` 2) x3 - - f4 x1 x2 x3 x4 = Write 4 $ \ptr -> do poke ptr x1 - poke (ptr `plusPtr` 1) x2 - poke (ptr `plusPtr` 2) x3 - poke (ptr `plusPtr` 3) x4 -{-# INLINE writeChar #-} - --- | Encode a Unicode character to another datatype, using UTF-8. This function --- acts as an abstract way of encoding characters, as it is unaware of what --- needs to happen with the resulting bytes: you have to specify functions to --- deal with those. --- -encodeCharUtf8 :: (Word8 -> a) -- ^ 1-byte UTF-8 - -> (Word8 -> Word8 -> a) -- ^ 2-byte UTF-8 - -> (Word8 -> Word8 -> Word8 -> a) -- ^ 3-byte UTF-8 - -> (Word8 -> Word8 -> Word8 -> Word8 -> a) -- ^ 4-byte UTF-8 - -> Char -- ^ Input 'Char' - -> a -- ^ Result -encodeCharUtf8 f1 f2 f3 f4 c = case ord c of - x | x <= 0x7F -> f1 $ fromIntegral x - | x <= 0x07FF -> - let x1 = fromIntegral $ (x `shiftR` 6) + 0xC0 - x2 = fromIntegral $ (x .&. 0x3F) + 0x80 - in f2 x1 x2 - | x <= 0xFFFF -> - let x1 = fromIntegral $ (x `shiftR` 12) + 0xE0 - x2 = fromIntegral $ ((x `shiftR` 6) .&. 0x3F) + 0x80 - x3 = fromIntegral $ (x .&. 0x3F) + 0x80 - in f3 x1 x2 x3 - | otherwise -> - let x1 = fromIntegral $ (x `shiftR` 18) + 0xF0 - x2 = fromIntegral $ ((x `shiftR` 12) .&. 0x3F) + 0x80 - x3 = fromIntegral $ ((x `shiftR` 6) .&. 0x3F) + 0x80 - x4 = fromIntegral $ (x .&. 0x3F) + 0x80 - in f4 x1 x2 x3 x4 -{-# INLINE encodeCharUtf8 #-} - diff --git a/benchmarks/BuilderBufferRange.hs b/benchmarks/BuilderBufferRange.hs deleted file mode 100644 index fb30991..0000000 --- a/benchmarks/BuilderBufferRange.hs +++ /dev/null @@ -1,463 +0,0 @@ -{-# LANGUAGE CPP, BangPatterns #-} --- | --- Module : BuilderBufferRange --- Copyright : (c) 2010 Simon Meier --- License : BSD3-style (see LICENSE) --- --- Maintainer : Leon P Smith --- Stability : experimental --- Portability : tested on GHC only --- --- Benchmark the benefit of using a packed representation for the buffer range. --- -module BuilderBufferRange where - - -import Foreign -import Data.Monoid -import Control.Monad (unless) -import qualified Data.ByteString as S -import qualified Data.ByteString.Lazy as L - -#ifdef BYTESTRING_IN_BASE -import Data.ByteString.Base (inlinePerformIO) -import qualified Data.ByteString.Base as S -import qualified Data.ByteString.Lazy.Base as L -- FIXME: is this the right module for access to 'Chunks'? -#else -import Data.ByteString.Internal (inlinePerformIO) -import qualified Data.ByteString.Internal as S -import qualified Data.ByteString.Lazy.Internal as L -#endif - -import qualified Blaze.ByteString.Builder.Internal as B -import Blaze.ByteString.Builder.Write -import Blaze.ByteString.Builder.Word - -import Criterion.Main - ------------------------------------------------------------------------------- --- Benchmarks ------------------------------------------------------------------------------- - -main :: IO () -main = defaultMain $ concat - [ benchmark "putBuilder" - (putBuilder . mconcat . map fromWord8) - (mconcat . map fromWord8) - word8s - , benchmark "fromWriteSingleton" - (mconcat . map putWord8) - (mconcat . map fromWord8) - word8s - , benchmark "fromWrite" - (mconcat . map (putWrite . writeWord8)) - (mconcat . map (fromWrite . writeWord8)) - word8s - ] - where - benchmark name putF builderF x = - [ bench (name ++ " Put") $ - whnf (L.length . toLazyByteString . putF) x - , bench (name ++ " Builder") $ - whnf (L.length . B.toLazyByteString . builderF) x - ] - -word8s :: [Word8] -word8s = take 100000 $ cycle [0..] -{-# NOINLINE word8s #-} - - ------------------------------------------------------------------------------- --- The Builder type ------------------------------------------------------------------------------- - -data BufferRange = BR {-# UNPACK #-} !(Ptr Word8) - {-# UNPACK #-} !(Ptr Word8) - -newtype Put = Put (PutStep -> PutStep) - -data PutSignal = - Done {-# UNPACK #-} !(Ptr Word8) - | BufferFull - {-# UNPACK #-} !Int - {-# UNPACK #-} !(Ptr Word8) - !PutStep - | ModifyChunks - {-# UNPACK #-} !(Ptr Word8) - !(L.ByteString -> L.ByteString) - !PutStep - -type PutStep = BufferRange -> IO PutSignal - -instance Monoid Put where - mempty = Put id - {-# INLINE mempty #-} - (Put p1) `mappend` (Put p2) = Put $ p1 . p2 - {-# INLINE mappend #-} - mconcat = foldr mappend mempty - {-# INLINE mconcat #-} - -putWrite :: Write -> Put -putWrite (Write size io) = - Put step - where - step k (BR pf pe) - | pf `plusPtr` size <= pe = do - io pf - let !br' = BR (pf `plusPtr` size) pe - k br' - | otherwise = return $ BufferFull size pf (step k) -{-# INLINE putWrite #-} - -putWriteSingleton :: (a -> Write) -> a -> Put -putWriteSingleton write = - mkPut - where - mkPut x = Put step - where - step k (BR pf pe) - | pf `plusPtr` size <= pe = do - io pf - let !br' = BR (pf `plusPtr` size) pe - k br' - | otherwise = return $ BufferFull size pf (step k) - where - Write size io = write x -{-# INLINE putWriteSingleton #-} - -putBuilder :: B.Builder -> Put -putBuilder (B.Builder b) = - Put step - where - finalStep _ pf = return $ B.Done pf - - step k = go (b finalStep) - where - go buildStep (BR pf pe) = do - signal <- buildStep pf pe - case signal of - B.Done pf' -> do - let !br' = BR pf' pe - k br' - B.BufferFull minSize pf' nextBuildStep -> - return $ BufferFull minSize pf' (go nextBuildStep) - B.ModifyChunks _ _ _ -> - error "putBuilder: ModifyChunks not implemented" - -putWord8 :: Word8 -> Put -putWord8 = putWriteSingleton writeWord8 - -{- - m >>= f = GetC $ \done empty pe -> - runGetC m (\pr' x -> runGetC (f x) done empty pe pr') - (\m' -> empty (m' >>= f)) - pe - - -newtype GetC r a = GetC { - runGetC :: - (Ptr Word8 -> a -> IO r) -> -- done - (GetC r a -> IO r ) -> -- empty buffer - Ptr Word8 -> -- end of buffer - Ptr Word8 -> -- next byte to read - IO r - } - -instance Functor (GetC r) where - fmap f g = GetC $ \done empty -> - runGetC g (\pr' x -> done pr' (f x)) - (\g' -> empty (fmap f g')) - -instance Monad (GetC r) where - return x = GetC $ \done _ _ pr -> done pr x - m >>= f = GetC $ \done empty pe -> - runGetC m (\pr' x -> runGetC (f x) done empty pe pr') - (\m' -> empty (m' >>= f)) - pe - --} - ------------------------------------------------------------------------------- --- Internal global constants. ------------------------------------------------------------------------------- - --- | Default size (~32kb) for the buffer that becomes a chunk of the output --- stream once it is filled. --- -defaultBufferSize :: Int -defaultBufferSize = 32 * 1024 - overhead -- Copied from Data.ByteString.Lazy. - where overhead = 2 * sizeOf (undefined :: Int) - --- | The minimal length (~4kb) a buffer must have before filling it and --- outputting it as a chunk of the output stream. --- --- This size determines when a buffer is spilled after a 'flush' or a direct --- bytestring insertion. It is also the size of the first chunk generated by --- 'toLazyByteString'. -defaultMinimalBufferSize :: Int -defaultMinimalBufferSize = 4 * 1024 - overhead - where overhead = 2 * sizeOf (undefined :: Int) - --- | The default length (64) for the first buffer to be allocated when --- converting a 'Builder' to a lazy bytestring. --- --- See 'toLazyByteStringWith' for further explanation. -defaultFirstBufferSize :: Int -defaultFirstBufferSize = 64 - --- | The maximal number of bytes for that copying is cheaper than direct --- insertion into the output stream. This takes into account the fragmentation --- that may occur in the output buffer due to the early 'flush' implied by the --- direct bytestring insertion. --- --- @'defaultMaximalCopySize' = 2 * 'defaultMinimalBufferSize'@ --- -defaultMaximalCopySize :: Int -defaultMaximalCopySize = 2 * defaultMinimalBufferSize - ------------------------------------------------------------------------------- --- Flushing and running a Builder ------------------------------------------------------------------------------- - - --- | Output all data written in the current buffer and start a new chunk. --- --- The use uf this function depends on how the resulting bytestrings are --- consumed. 'flush' is possibly not very useful in non-interactive scenarios. --- However, it is kept for compatibility with the builder provided by --- Data.Binary.Builder. --- --- When using 'toLazyByteString' to extract a lazy 'L.ByteString' from a --- 'Builder', this means that a new chunk will be started in the resulting lazy --- 'L.ByteString'. The remaining part of the buffer is spilled, if the --- reamining free space is smaller than the minimal desired buffer size. --- -{- -flush :: Builder -flush = Builder $ \k pf _ -> return $ ModifyChunks pf id k --} - --- | Run a 'Builder' with the given buffer sizes. --- --- Use this function for integrating the 'Builder' type with other libraries --- that generate lazy bytestrings. --- --- Note that the builders should guarantee that on average the desired chunk --- size is attained. Builders may decide to start a new buffer and not --- completely fill the existing buffer, if this is faster. However, they should --- not spill too much of the buffer, if they cannot compensate for it. --- --- A call @toLazyByteStringWith bufSize minBufSize firstBufSize@ will generate --- a lazy bytestring according to the following strategy. First, we allocate --- a buffer of size @firstBufSize@ and start filling it. If it overflows, we --- allocate a buffer of size @minBufSize@ and copy the first buffer to it in --- order to avoid generating a too small chunk. Finally, every next buffer will --- be of size @bufSize@. This, slow startup strategy is required to achieve --- good speed for short (<200 bytes) resulting bytestrings, as for them the --- allocation cost is of a large buffer cannot be compensated. Moreover, this --- strategy also allows us to avoid spilling too much memory for short --- resulting bytestrings. --- --- Note that setting @firstBufSize >= minBufSize@ implies that the first buffer --- is no longer copied but allocated and filled directly. Hence, setting --- @firstBufSize = bufSize@ means that all chunks will use an underlying buffer --- of size @bufSize@. This is recommended, if you know that you always output --- more than @minBufSize@ bytes. -toLazyByteStringWith - :: Int -- ^ Buffer size (upper-bounds the resulting chunk size). - -> Int -- ^ Minimal free buffer space for continuing filling - -- the same buffer after a 'flush' or a direct bytestring - -- insertion. This corresponds to the minimal desired - -- chunk size. - -> Int -- ^ Size of the first buffer to be used and copied for - -- larger resulting sequences - -> Put -- ^ Builder to run. - -> L.ByteString -- ^ Lazy bytestring to output after the builder is - -- finished. - -> L.ByteString -- ^ Resulting lazy bytestring -toLazyByteStringWith bufSize minBufSize firstBufSize (Put b) k = - inlinePerformIO $ fillFirstBuffer (b finalStep) - where - finalStep (BR pf _) = return $ Done pf - -- fill a first very small buffer, if we need more space then copy it - -- to the new buffer of size 'minBufSize'. This way we don't pay the - -- allocation cost of the big 'bufSize' buffer, when outputting only - -- small sequences. - fillFirstBuffer !step0 - | minBufSize <= firstBufSize = fillNewBuffer firstBufSize step0 - | otherwise = do - fpbuf <- S.mallocByteString firstBufSize - withForeignPtr fpbuf $ \pf -> do - let !br = BR pf (pf `plusPtr` firstBufSize) - mkbs pf' = S.PS fpbuf 0 (pf' `minusPtr` pf) - {-# INLINE mkbs #-} - next <- step0 br - case next of - Done pf' - | pf' == pf -> return k - | otherwise -> return $ L.Chunk (mkbs pf') k - - BufferFull newSize pf' nextStep -> do - let !l = pf' `minusPtr` pf - fillNewBuffer (max (l + newSize) minBufSize) $ - \(BR pfNew peNew) -> do - copyBytes pfNew pf l - let !brNew = BR (pfNew `plusPtr` l) peNew - nextStep brNew - - ModifyChunks pf' bsk nextStep - | pf' == pf -> - return $ bsk (inlinePerformIO $ fillNewBuffer bufSize nextStep) - | otherwise -> - return $ L.Chunk (mkbs pf') - (bsk (inlinePerformIO $ fillNewBuffer bufSize nextStep)) - - -- allocate and fill a new buffer - fillNewBuffer !size !step0 = do - fpbuf <- S.mallocByteString size - withForeignPtr fpbuf $ fillBuffer fpbuf - where - fillBuffer fpbuf !pbuf = fill pbuf step0 - where - !pe = pbuf `plusPtr` size - fill !pf !step = do - let !br = BR pf pe - next <- step br - let mkbs pf' = S.PS fpbuf (pf `minusPtr` pbuf) (pf' `minusPtr` pf) - {-# INLINE mkbs #-} - case next of - Done pf' - | pf' == pf -> return k - | otherwise -> return $ L.Chunk (mkbs pf') k - - BufferFull newSize pf' nextStep -> - return $ L.Chunk (mkbs pf') - (inlinePerformIO $ - fillNewBuffer (max newSize bufSize) nextStep) - - ModifyChunks pf' bsk nextStep - | pf' == pf -> - return $ bsk (inlinePerformIO $ fill pf' nextStep) - | minBufSize < pe `minusPtr` pf' -> - return $ L.Chunk (mkbs pf') - (bsk (inlinePerformIO $ fill pf' nextStep)) - | otherwise -> - return $ L.Chunk (mkbs pf') - (bsk (inlinePerformIO $ fillNewBuffer bufSize nextStep)) - - --- | Extract the lazy 'L.ByteString' from the builder by running it with default --- buffer sizes. Use this function, if you do not have any special --- considerations with respect to buffer sizes. --- --- @ 'toLazyByteString' b = 'toLazyByteStringWith' 'defaultBufferSize' 'defaultMinimalBufferSize' 'defaultFirstBufferSize' b L.empty@ --- --- Note that @'toLazyByteString'@ is a 'Monoid' homomorphism. --- --- > toLazyByteString mempty == mempty --- > toLazyByteString (x `mappend` y) == toLazyByteString x `mappend` toLazyByteString y --- --- However, in the second equation, the left-hand-side is generally faster to --- execute. --- -toLazyByteString :: Put -> L.ByteString -toLazyByteString b = toLazyByteStringWith - defaultBufferSize defaultMinimalBufferSize defaultFirstBufferSize b L.empty -{-# INLINE toLazyByteString #-} - -{- --- | Pack the chunks of a lazy bytestring into a single strict bytestring. -packChunks :: L.ByteString -> S.ByteString -packChunks lbs = do - S.unsafeCreate (fromIntegral $ L.length lbs) (copyChunks lbs) - where - copyChunks !L.Empty !_pf = return () - copyChunks !(L.Chunk (S.PS fpbuf o l) lbs') !pf = do - withForeignPtr fpbuf $ \pbuf -> - copyBytes pf (pbuf `plusPtr` o) l - copyChunks lbs' (pf `plusPtr` l) - --- | Run the builder to construct a strict bytestring containing the sequence --- of bytes denoted by the builder. This is done by first serializing to a lazy bytestring and then packing its --- chunks to a appropriately sized strict bytestring. --- --- > toByteString = packChunks . toLazyByteString --- --- Note that @'toByteString'@ is a 'Monoid' homomorphism. --- --- > toByteString mempty == mempty --- > toByteString (x `mappend` y) == toByteString x `mappend` toByteString y --- --- However, in the second equation, the left-hand-side is generally faster to --- execute. --- -toByteString :: Builder -> S.ByteString -toByteString = packChunks . toLazyByteString - - --- | @toByteStringIOWith bufSize io b@ runs the builder @b@ with a buffer of --- at least the size @bufSize@ and executes the 'IO' action @io@ whenever the --- buffer is full. --- --- Compared to 'toLazyByteStringWith' this function requires less allocation, --- as the output buffer is only allocated once at the start of the --- serialization and whenever something bigger than the current buffer size has --- to be copied into the buffer, which should happen very seldomly for the --- default buffer size of 32kb. Hence, the pressure on the garbage collector is --- reduced, which can be an advantage when building long sequences of bytes. --- -toByteStringIOWith :: Int -- ^ Buffer size (upper bounds - -- the number of bytes forced - -- per call to the 'IO' action). - -> (S.ByteString -> IO ()) -- ^ 'IO' action to execute per - -- full buffer, which is - -- referenced by a strict - -- 'S.ByteString'. - -> Builder -- ^ 'Builder' to run. - -> IO () -- ^ Resulting 'IO' action. -toByteStringIOWith bufSize io (Builder b) = - fillNewBuffer bufSize (b finalStep) - where - finalStep pf _ = return $ Done pf - - fillNewBuffer !size !step0 = do - S.mallocByteString size >>= fillBuffer - where - fillBuffer fpbuf = fill step0 - where - -- safe because the constructed ByteString references the foreign - -- pointer AFTER its buffer was filled. - pf = unsafeForeignPtrToPtr fpbuf - fill !step = do - next <- step pf (pf `plusPtr` size) - case next of - Done pf' -> - unless (pf' == pf) (io $ S.PS fpbuf 0 (pf' `minusPtr` pf)) - - BufferFull newSize pf' nextStep -> do - io $ S.PS fpbuf 0 (pf' `minusPtr` pf) - if bufSize < newSize - then fillNewBuffer newSize nextStep - else fill nextStep - - ModifyChunks pf' bsk nextStep -> do - unless (pf' == pf) (io $ S.PS fpbuf 0 (pf' `minusPtr` pf)) - -- was: mapM_ io $ L.toChunks (bsk L.empty) - L.foldrChunks (\bs -> (io bs >>)) (return ()) (bsk L.empty) - fill nextStep - --- | Run the builder with a 'defaultBufferSize'd buffer and execute the given --- 'IO' action whenever the buffer is full or gets flushed. --- --- @ 'toByteStringIO' = 'toByteStringIOWith' 'defaultBufferSize'@ --- --- This is a 'Monoid' homomorphism in the following sense. --- --- > toByteStringIO io mempty == return () --- > toByteStringIO io (x `mappend` y) == toByteStringIO io x >> toByteStringIO io y --- -toByteStringIO :: (S.ByteString -> IO ()) -> Builder -> IO () -toByteStringIO = toByteStringIOWith defaultBufferSize -{-# INLINE toByteStringIO #-} - --} diff --git a/benchmarks/ChunkedWrite.hs b/benchmarks/ChunkedWrite.hs deleted file mode 100644 index ccb2674..0000000 --- a/benchmarks/ChunkedWrite.hs +++ /dev/null @@ -1,158 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} --- | --- Module : ChunkedWrite --- Copyright : (c) 2010 Simon Meier --- License : BSD3-style (see LICENSE) --- --- Maintainer : Leon P Smith --- 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 deleted file mode 100644 index 6cce4d0..0000000 --- a/benchmarks/Compression.hs +++ /dev/null @@ -1,55 +0,0 @@ --- | --- Module : Compression --- Copyright : (c) 2010 Simon Meier --- License : BSD3-style (see LICENSE) --- --- Maintainer : Leon P Smith --- 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/FastPut.hs b/benchmarks/FastPut.hs deleted file mode 100644 index 0cab071..0000000 --- a/benchmarks/FastPut.hs +++ /dev/null @@ -1,643 +0,0 @@ -{-# LANGUAGE CPP, BangPatterns, Rank2Types #-} --- | --- Module : FastPut --- Copyright : (c) 2010 Simon Meier --- License : BSD3-style (see LICENSE) --- --- Maintainer : Leon P Smith --- Stability : experimental --- Portability : tested on GHC only --- --- Implementation of a 'Put' monad with similar performance characteristics --- like the 'Builder' monoid. --- -module FastPut where - -import Foreign -import Data.Monoid -import Control.Monad (unless) -import qualified Data.ByteString as S -import qualified Data.ByteString.Lazy as L - -#ifdef BYTESTRING_IN_BASE -import Data.ByteString.Base (inlinePerformIO) -import qualified Data.ByteString.Base as S -import qualified Data.ByteString.Lazy.Base as L -- FIXME: is this the right module for access to 'Chunks'? -#else -import Data.ByteString.Internal (inlinePerformIO) -import qualified Data.ByteString.Internal as S -import qualified Data.ByteString.Lazy.Internal as L -#endif - -import qualified Blaze.ByteString.Builder.Internal as B -import qualified Blaze.ByteString.Builder.Write as B -import Blaze.ByteString.Builder.Write (Write(..)) -import qualified Blaze.ByteString.Builder.Word as B -import Blaze.ByteString.Builder.Word (writeWord8) - -import Criterion.Main - ------------------------------------------------------------------------------- --- Benchmarks ------------------------------------------------------------------------------- - -main :: IO () -main = defaultMain $ concat - [ return $ bench "cost of putBuilder" $ whnf - (L.length . toLazyByteString2 . mapM_ (fromBuilder . fromWord8)) - word8s - , benchmark "putBuilder" - (fromBuilder . mconcat . map fromWord8) - (mconcat . map B.fromWord8) - word8s - , benchmark "fromWriteSingleton" - (mapM_ putWord8) - (mconcat . map B.fromWord8) - word8s - , benchmark "fromWrite" - (mapM_ (putWrite . writeWord8)) - (mconcat . map (B.fromWrite . writeWord8)) - word8s - ] - where - benchmark name putF builderF x = - [ bench (name ++ " Put") $ - whnf (L.length . toLazyByteString2 . putF) x - , bench (name ++ " Builder") $ - whnf (L.length . B.toLazyByteString . builderF) x - ] - -word8s :: [Word8] -word8s = take 100000 $ cycle [0..] -{-# NOINLINE word8s #-} - ------------------------------------------------------------------------------- --- The Put type ------------------------------------------------------------------------------- - -data BufRange = BufRange {-# UNPACK #-} !(Ptr Word8) {-# UNPACK #-} !(Ptr Word8) - -newtype Put a = Put { - unPut :: forall r. (a -> PutStep r) -> PutStep r - } - -data PutSignal a = - Done {-# UNPACK #-} !(Ptr Word8) a - | BufferFull - {-# UNPACK #-} !Int - {-# UNPACK #-} !(Ptr Word8) - !(PutStep a) - | InsertByteString - {-# UNPACK #-} !(Ptr Word8) - !S.ByteString - !(PutStep a) - -type PutStep a = BufRange -> IO (PutSignal a) - -instance Monad Put where - return x = Put $ \k -> k x - {-# INLINE return #-} - m >>= f = Put $ \k -> unPut m (\x -> unPut (f x) k) - {-# INLINE (>>=) #-} - m >> n = Put $ \k -> unPut m (\_ -> unPut n k) - {-# INLINE (>>) #-} - ------------------------------------------------------------------------------- --- The Builder type with equal signals as the Put type ------------------------------------------------------------------------------- - -newtype Builder = Builder (forall r. PutStep r -> PutStep r) - -instance Monoid Builder where - mempty = Builder id - {-# INLINE mempty #-} - (Builder b1) `mappend` (Builder b2) = Builder $ b1 . b2 - {-# INLINE mappend #-} - mconcat = foldr mappend mempty - {-# INLINE mconcat #-} - -fromBuilder :: Builder -> Put () -fromBuilder (Builder build) = Put $ \k -> build (k ()) - -toBuilder :: Put () -> Builder -toBuilder (Put put) = Builder $ \k -> put (\_ -> k) - -fromWrite :: Write -> Builder -fromWrite (Write size io) = - Builder step - where - step k (BufRange pf pe) - | pf `plusPtr` size <= pe = do - io pf - let !br' = BufRange (pf `plusPtr` size) pe - k br' - | otherwise = return $ BufferFull size pf (step k) -{-# INLINE fromWrite #-} - -fromWriteSingleton :: (a -> Write) -> a -> Builder -fromWriteSingleton write = - mkPut - where - mkPut x = Builder step - where - step k (BufRange pf pe) - | pf `plusPtr` size <= pe = do - io pf - let !br' = BufRange (pf `plusPtr` size) pe - k br' - | otherwise = return $ BufferFull size pf (step k) - where - Write size io = write x -{-# INLINE fromWriteSingleton #-} - -fromWord8 :: Word8 -> Builder -fromWord8 = fromWriteSingleton writeWord8 - - ------------------------------------------------------------------------------- --- Implementations ------------------------------------------------------------------------------- - -putWord8 :: Word8 -> Put () -putWord8 = putWriteSingleton writeWord8 - -putWrite :: Write -> Put () -putWrite (Write size io) = - Put step - where - step k (BufRange pf pe) - | pf `plusPtr` size <= pe = do - io pf - let !br' = BufRange (pf `plusPtr` size) pe - k () br' - | otherwise = return $ BufferFull size pf (step k) -{-# INLINE putWrite #-} - -putWriteSingleton :: (a -> Write) -> a -> Put () -putWriteSingleton write = - mkPut - where - mkPut x = Put step - where - step k (BufRange pf pe) - | pf `plusPtr` size <= pe = do - io pf - let !br' = BufRange (pf `plusPtr` size) pe - k () br' - | otherwise = return $ BufferFull size pf (step k) - where - Write size io = write x -{-# INLINE putWriteSingleton #-} - -putBuilder :: B.Builder -> Put () -putBuilder (B.Builder b) = - Put step - where - finalStep _ pf = return $ B.Done pf - - step k = go (b finalStep) - where - go buildStep (BufRange pf pe) = do - signal <- buildStep pf pe - case signal of - B.Done pf' -> do - let !br' = BufRange pf' pe - k () br' - B.BufferFull minSize pf' nextBuildStep -> - return $ BufferFull minSize pf' (go nextBuildStep) - B.ModifyChunks _ _ _ -> - error "putBuilder: ModifyChunks not implemented" - -{- - m >>= f = GetC $ \done empty pe -> - runGetC m (\pr' x -> runGetC (f x) done empty pe pr') - (\m' -> empty (m' >>= f)) - pe - - -newtype GetC r a = GetC { - runGetC :: - (Ptr Word8 -> a -> IO r) -> -- done - (GetC r a -> IO r ) -> -- empty buffer - Ptr Word8 -> -- end of buffer - Ptr Word8 -> -- next byte to read - IO r - } - -instance Functor (GetC r) where - fmap f g = GetC $ \done empty -> - runGetC g (\pr' x -> done pr' (f x)) - (\g' -> empty (fmap f g')) - -instance Monad (GetC r) where - return x = GetC $ \done _ _ pr -> done pr x - m >>= f = GetC $ \done empty pe -> - runGetC m (\pr' x -> runGetC (f x) done empty pe pr') - (\m' -> empty (m' >>= f)) - pe - --} - ------------------------------------------------------------------------------- --- Internal global constants. ------------------------------------------------------------------------------- - --- | Default size (~32kb) for the buffer that becomes a chunk of the output --- stream once it is filled. --- -defaultBufferSize :: Int -defaultBufferSize = 32 * 1024 - overhead -- Copied from Data.ByteString.Lazy. - where overhead = 2 * sizeOf (undefined :: Int) - --- | The minimal length (~4kb) a buffer must have before filling it and --- outputting it as a chunk of the output stream. --- --- This size determines when a buffer is spilled after a 'flush' or a direct --- bytestring insertion. It is also the size of the first chunk generated by --- 'toLazyByteString'. -defaultMinimalBufferSize :: Int -defaultMinimalBufferSize = 4 * 1024 - overhead - where overhead = 2 * sizeOf (undefined :: Int) - --- | The default length (64) for the first buffer to be allocated when --- converting a 'Builder' to a lazy bytestring. --- --- See 'toLazyByteStringWith' for further explanation. -defaultFirstBufferSize :: Int -defaultFirstBufferSize = 64 - --- | The maximal number of bytes for that copying is cheaper than direct --- insertion into the output stream. This takes into account the fragmentation --- that may occur in the output buffer due to the early 'flush' implied by the --- direct bytestring insertion. --- --- @'defaultMaximalCopySize' = 2 * 'defaultMinimalBufferSize'@ --- -defaultMaximalCopySize :: Int -defaultMaximalCopySize = 2 * defaultMinimalBufferSize - ------------------------------------------------------------------------------- --- Flushing and running a Builder ------------------------------------------------------------------------------- - - --- | Output all data written in the current buffer and start a new chunk. --- --- The use uf this function depends on how the resulting bytestrings are --- consumed. 'flush' is possibly not very useful in non-interactive scenarios. --- However, it is kept for compatibility with the builder provided by --- Data.Binary.Builder. --- --- When using 'toLazyByteString' to extract a lazy 'L.ByteString' from a --- 'Builder', this means that a new chunk will be started in the resulting lazy --- 'L.ByteString'. The remaining part of the buffer is spilled, if the --- reamining free space is smaller than the minimal desired buffer size. --- -{- -flush :: Builder -flush = Builder $ \k pf _ -> return $ ModifyChunks pf id k --} - --- | Run a 'Builder' with the given buffer sizes. --- --- Use this function for integrating the 'Builder' type with other libraries --- that generate lazy bytestrings. --- --- Note that the builders should guarantee that on average the desired chunk --- size is attained. Builders may decide to start a new buffer and not --- completely fill the existing buffer, if this is faster. However, they should --- not spill too much of the buffer, if they cannot compensate for it. --- --- A call @toLazyByteStringWith bufSize minBufSize firstBufSize@ will generate --- a lazy bytestring according to the following strategy. First, we allocate --- a buffer of size @firstBufSize@ and start filling it. If it overflows, we --- allocate a buffer of size @minBufSize@ and copy the first buffer to it in --- order to avoid generating a too small chunk. Finally, every next buffer will --- be of size @bufSize@. This, slow startup strategy is required to achieve --- good speed for short (<200 bytes) resulting bytestrings, as for them the --- allocation cost is of a large buffer cannot be compensated. Moreover, this --- strategy also allows us to avoid spilling too much memory for short --- resulting bytestrings. --- --- Note that setting @firstBufSize >= minBufSize@ implies that the first buffer --- is no longer copied but allocated and filled directly. Hence, setting --- @firstBufSize = bufSize@ means that all chunks will use an underlying buffer --- of size @bufSize@. This is recommended, if you know that you always output --- more than @minBufSize@ bytes. -toLazyByteStringWith - :: Int -- ^ Buffer size (upper-bounds the resulting chunk size). - -> Int -- ^ Minimal free buffer space for continuing filling - -- the same buffer after a 'flush' or a direct bytestring - -- insertion. This corresponds to the minimal desired - -- chunk size. - -> Int -- ^ Size of the first buffer to be used and copied for - -- larger resulting sequences - -> Put a -- ^ Builder to run. - -> L.ByteString -- ^ Lazy bytestring to output after the builder is - -- finished. - -> L.ByteString -- ^ Resulting lazy bytestring -toLazyByteStringWith bufSize minBufSize firstBufSize (Put b) k = - inlinePerformIO $ fillFirstBuffer (b finalStep) - where - finalStep _ (BufRange pf _) = return $ Done pf undefined - -- fill a first very small buffer, if we need more space then copy it - -- to the new buffer of size 'minBufSize'. This way we don't pay the - -- allocation cost of the big 'bufSize' buffer, when outputting only - -- small sequences. - fillFirstBuffer !step0 - | minBufSize <= firstBufSize = fillNewBuffer firstBufSize step0 - | otherwise = do - fpbuf <- S.mallocByteString firstBufSize - withForeignPtr fpbuf $ \pf -> do - let !br = BufRange pf (pf `plusPtr` firstBufSize) - mkbs pf' = S.PS fpbuf 0 (pf' `minusPtr` pf) - {-# INLINE mkbs #-} - next <- step0 br - case next of - Done pf' _ - | pf' == pf -> return k - | otherwise -> return $ L.Chunk (mkbs pf') k - - BufferFull newSize pf' nextStep -> do - let !l = pf' `minusPtr` pf - fillNewBuffer (max (l + newSize) minBufSize) $ - \(BufRange pfNew peNew) -> do - copyBytes pfNew pf l - let !brNew = BufRange (pfNew `plusPtr` l) peNew - nextStep brNew - - InsertByteString _ _ _ -> error "not yet implemented" - {- - ModifyChunks pf' bsk nextStep( - | pf' == pf -> - return $ bsk (inlinePerformIO $ fillNewBuffer bufSize nextStep) - | otherwise -> - return $ L.Chunk (mkbs pf') - (bsk (inlinePerformIO $ fillNewBuffer bufSize nextStep)) - -} - - -- allocate and fill a new buffer - fillNewBuffer !size !step0 = do - fpbuf <- S.mallocByteString size - withForeignPtr fpbuf $ fillBuffer fpbuf - where - fillBuffer fpbuf !pbuf = fill pbuf step0 - where - !pe = pbuf `plusPtr` size - fill !pf !step = do - let !br = BufRange pf pe - next <- step br - let mkbs pf' = S.PS fpbuf (pf `minusPtr` pbuf) (pf' `minusPtr` pf) - {-# INLINE mkbs #-} - case next of - Done pf' _ - | pf' == pf -> return k - | otherwise -> return $ L.Chunk (mkbs pf') k - - BufferFull newSize pf' nextStep -> - return $ L.Chunk (mkbs pf') - (inlinePerformIO $ - fillNewBuffer (max newSize bufSize) nextStep) - - InsertByteString _ _ _ -> error "not yet implemented2" - {- - ModifyChunks pf' bsk nextStep - | pf' == pf -> - return $ bsk (inlinePerformIO $ fill pf' nextStep) - | minBufSize < pe `minusPtr` pf' -> - return $ L.Chunk (mkbs pf') - (bsk (inlinePerformIO $ fill pf' nextStep)) - | otherwise -> - return $ L.Chunk (mkbs pf') - (bsk (inlinePerformIO $ fillNewBuffer bufSize nextStep)) - -} - - --- | Extract the lazy 'L.ByteString' from the builder by running it with default --- buffer sizes. Use this function, if you do not have any special --- considerations with respect to buffer sizes. --- --- @ 'toLazyByteString' b = 'toLazyByteStringWith' 'defaultBufferSize' 'defaultMinimalBufferSize' 'defaultFirstBufferSize' b L.empty@ --- --- Note that @'toLazyByteString'@ is a 'Monoid' homomorphism. --- --- > toLazyByteString mempty == mempty --- > toLazyByteString (x `mappend` y) == toLazyByteString x `mappend` toLazyByteString y --- --- However, in the second equation, the left-hand-side is generally faster to --- execute. --- -toLazyByteString :: Put a -> L.ByteString -toLazyByteString b = toLazyByteStringWith - defaultBufferSize defaultMinimalBufferSize defaultFirstBufferSize b L.empty -{-# INLINE toLazyByteString #-} - ------------------------------------------------------------------------------- --- Builder Enumeration ------------------------------------------------------------------------------- - -data BuildStream a = - BuildChunk S.ByteString (IO (BuildStream a)) - | BuildYield - a - (forall b. Bool -> - Either (Maybe S.ByteString) (Put b -> IO (BuildStream b))) - -enumPut :: Int -> Put a -> IO (BuildStream a) -enumPut bufSize (Put put0) = - fillBuffer bufSize (put0 finalStep) - where - finalStep :: forall b. b -> PutStep b - finalStep x (BufRange op _) = return $ Done op x - - fillBuffer :: forall b. Int -> PutStep b -> IO (BuildStream b) - fillBuffer size step = do - fpbuf <- S.mallocByteString bufSize - let !pbuf = unsafeForeignPtrToPtr fpbuf - -- safe due to later reference of fpbuf - -- BETTER than withForeignPtr, as we lose a tail call otherwise - !br = BufRange pbuf (pbuf `plusPtr` size) - fillStep fpbuf br step - - fillPut :: ForeignPtr Word8 -> BufRange -> - Bool -> Either (Maybe S.ByteString) (Put b -> IO (BuildStream b)) - fillPut !fpbuf !(BufRange op _) False - | pbuf == op = Left Nothing - | otherwise = Left $ Just $ - S.PS fpbuf 0 (op `minusPtr` pbuf) - where - pbuf = unsafeForeignPtrToPtr fpbuf - {-# INLINE pbuf #-} - fillPut !fpbuf !br True = - Right $ \(Put put) -> fillStep fpbuf br (put finalStep) - - fillStep :: forall b. ForeignPtr Word8 -> BufRange -> PutStep b -> IO (BuildStream b) - fillStep !fpbuf !br@(BufRange _ ope) step = do - let pbuf = unsafeForeignPtrToPtr fpbuf - {-# INLINE pbuf #-} - signal <- step br - case signal of - Done op' x -> do -- builder completed, buffer partially filled - let !br' = BufRange op' ope - return $ BuildYield x (fillPut fpbuf br') - - BufferFull minSize op' nextStep - | pbuf == op' -> do -- nothing written, larger buffer required - fillBuffer (max bufSize minSize) nextStep - | otherwise -> do -- some bytes written, new buffer required - return $ BuildChunk - (S.PS fpbuf 0 (op' `minusPtr` pbuf)) - (fillBuffer (max bufSize minSize) nextStep) - - InsertByteString op' bs nextStep - | S.null bs -> do -- empty bytestrings are ignored - let !br' = BufRange op' ope - fillStep fpbuf br' nextStep - | pbuf == op' -> do -- no bytes written: just insert bytestring - return $ BuildChunk bs (fillBuffer bufSize nextStep) - | otherwise -> do -- bytes written, insert buffer and bytestring - return $ BuildChunk (S.PS fpbuf 0 (op' `minusPtr` pbuf)) - (return $ BuildChunk bs (fillBuffer bufSize nextStep)) - - -toLazyByteString' :: Put () -> L.ByteString -toLazyByteString' put = - inlinePerformIO (consume `fmap` enumPut defaultBufferSize put) - where - consume :: BuildStream () -> L.ByteString - consume (BuildYield _ f) = - case f False of - Left Nothing -> L.Empty - Left (Just bs) -> L.Chunk bs L.Empty - Right _ -> error "toLazyByteString': enumPut violated postcondition" - consume (BuildChunk bs ioStream) = - L.Chunk bs $ inlinePerformIO (consume `fmap` ioStream) - - - -{- - BufferFull minSize pf' nextStep -> do - io $ S.PS fpbuf 0 (pf' `minusPtr` pf) - fillBuffer (max bufSize minSize) nextStep - - ModifyChunks pf' bsk nextStep -> do - io $ S.PS fpbuf 0 (pf' `minusPtr` pf) - L.foldrChunks (\bs -> (io bs >>)) (return ()) (bsk L.empty) - fillBuffer bufSize nextStep --} - ------------------------------------------------------------------------------- --- More explicit implementation of running builders ------------------------------------------------------------------------------- - - -data Buffer = Buffer {-# UNPACK #-} !(ForeignPtr Word8) -- underlying pinned array - {-# UNPACK #-} !(Ptr Word8) -- beginning of slice - {-# UNPACK #-} !(Ptr Word8) -- next free byte - {-# UNPACK #-} !(Ptr Word8) -- first byte after buffer - -allocBuffer :: Int -> IO Buffer -allocBuffer size = do - fpbuf <- S.mallocByteString size - let !pbuf = unsafeForeignPtrToPtr fpbuf - return $! Buffer fpbuf pbuf pbuf (pbuf `plusPtr` size) - -unsafeFreezeBuffer :: Buffer -> S.ByteString -unsafeFreezeBuffer (Buffer fpbuf p0 op _) = - S.PS fpbuf 0 (op `minusPtr` p0) - -unsafeFreezeNonEmptyBuffer :: Buffer -> Maybe S.ByteString -unsafeFreezeNonEmptyBuffer (Buffer fpbuf p0 op _) - | p0 == op = Nothing - | otherwise = Just $ S.PS fpbuf 0 (op `minusPtr` p0) - -nextSlice :: Int -> Buffer -> Maybe Buffer -nextSlice minSize (Buffer fpbuf _ op ope) - | ope `minusPtr` op <= minSize = Nothing - | otherwise = Just (Buffer fpbuf op op ope) - -runPut :: Monad m - => (IO (PutSignal a) -> m (PutSignal a)) -- lifting of buildsteps - -> (Int -> Buffer -> m Buffer) -- output function for a guaranteedly non-empty buffer, the returned buffer will be filled next - -> (S.ByteString -> m ()) -- output function for guaranteedly non-empty bytestrings, that are inserted directly into the stream - -> Put a -- put to execute - -> Buffer -- initial buffer to be used - -> m (a, Buffer) -- result of put and remaining buffer -runPut liftIO outputBuf outputBS (Put put) = - runStep (put finalStep) - where - finalStep x !(BufRange op _) = return $ Done op x - - runStep step buf@(Buffer fpbuf p0 op ope) = do - let !br = BufRange op ope - signal <- liftIO $ step br - case signal of - Done op' x -> -- put completed, buffer partially runSteped - return (x, Buffer fpbuf p0 op' ope) - - BufferFull minSize op' nextStep -> do - buf' <- outputBuf minSize (Buffer fpbuf p0 op' ope) - runStep nextStep buf' - - InsertByteString op' bs nextStep - | S.null bs -> -- flushing of buffer required - outputBuf 1 (Buffer fpbuf p0 op' ope) >>= runStep nextStep - | p0 == op' -> do -- no bytes written: just insert bytestring - outputBS bs - runStep nextStep buf - | otherwise -> do -- bytes written, insert buffer and bytestring - buf' <- outputBuf 1 (Buffer fpbuf p0 op' ope) - outputBS bs - runStep nextStep buf' -{-# INLINE runPut #-} - --- | A monad for lazily composing lazy bytestrings using continuations. -newtype LBSM a = LBSM { unLBSM :: (a, L.ByteString -> L.ByteString) } - -instance Monad LBSM where - return x = LBSM (x, id) - (LBSM (x,k)) >>= f = let LBSM (x',k') = f x in LBSM (x', k . k') - (LBSM (_,k)) >> (LBSM (x',k')) = LBSM (x', k . k') - --- | Execute a put and return the written buffers as the chunks of a lazy --- bytestring. -toLazyByteString2 :: Put a -> L.ByteString -toLazyByteString2 put = - k (bufToLBSCont (snd result) L.empty) - where - -- initial buffer - buf0 = inlinePerformIO $ allocBuffer defaultBufferSize - -- run put, but don't force result => we're lazy enough - LBSM (result, k) = runPut liftIO outputBuf outputBS put buf0 - -- convert a buffer to a lazy bytestring continuation - bufToLBSCont = maybe id L.Chunk . unsafeFreezeNonEmptyBuffer - -- lifting an io putsignal to a lazy bytestring monad - liftIO io = LBSM (inlinePerformIO io, id) - -- add buffer as a chunk prepare allocation of new one - outputBuf minSize buf = LBSM - ( inlinePerformIO $ allocBuffer (max minSize defaultBufferSize) - , bufToLBSCont buf ) - -- add bytestring directly as a chunk; exploits postcondition of runPut - -- that bytestrings are non-empty - outputBS bs = LBSM ((), L.Chunk bs) - --- | A Builder that traces a message -traceBuilder :: String -> Builder -traceBuilder msg = Builder $ \k br@(BufRange op ope) -> do - putStrLn $ "traceBuilder " ++ show (op, ope) ++ ": " ++ msg - k br - -flushBuilder :: Builder -flushBuilder = Builder $ \k (BufRange op _) -> do - return $ InsertByteString op S.empty k - -test2 :: Word8 -> [S.ByteString] -test2 x = L.toChunks $ toLazyByteString2 $ fromBuilder $ mconcat - [ traceBuilder "before flush" - , fromWord8 48 - , flushBuilder - , flushBuilder - , traceBuilder "after flush" - , fromWord8 x - ] - diff --git a/benchmarks/LazyByteString.hs b/benchmarks/LazyByteString.hs deleted file mode 100644 index 9844b1b..0000000 --- a/benchmarks/LazyByteString.hs +++ /dev/null @@ -1,782 +0,0 @@ -{-# LANGUAGE BangPatterns, OverloadedStrings #-} --- | --- Module : LazyByteString --- Copyright : (c) 2010 Simon Meier --- License : BSD3-style (see LICENSE) --- --- Maintainer : Leon P Smith --- Stability : experimental --- Portability : tested on GHC only --- --- Benchmarking of alternative implementations of functions in --- Data.ByteString.Lazy that construct lazy bytestrings and cannot be --- implemented with slicing only. -module LazyByteString where -- (main) where - -import Data.Char -import Data.Word -import Data.Monoid -import Data.List - -import Control.Monad -import Control.Arrow (second) -import Criterion.Main - -import Foreign -import qualified Data.ByteString as S -import qualified Data.ByteString.Unsafe as S -import qualified Data.ByteString.Internal as S -import qualified Data.ByteString.Lazy as L -import qualified Data.ByteString.Lazy.Internal as L - -import Data.ByteString.Base64 - -import Blaze.ByteString.Builder.Internal -import Blaze.ByteString.Builder.Word -import Blaze.ByteString.Builder.ByteString - ------------------------------------------------------------------------------- --- Benchmarks ------------------------------------------------------------------------------- - -main :: IO () -main = do - let (chunkInfos, benchmarks) = unzip - {- - [ lazyVsBlaze - ( "partitionLazy" - , (uncurry mappend) . L.partition ((0 <) . sin . fromIntegral) - , (uncurry mappend) . partitionLazy ((0 <) . sin . fromIntegral) - , (\i -> L.drop 13 $ L.pack $ take i $ cycle [0..]) - , n) - -} - {- - [ lazyVsBlaze - ( "base64mime" - , L.fromChunks . return . joinWith "\r\n" 76 . encode - , toLazyByteString . encodeBase64MIME - , (\i -> S.drop 13 $ S.pack $ take i $ cycle [0..]) - , n) - -} - {- - [ lazyVsBlaze - ( "joinWith" - , L.fromChunks . return . joinWith "\r\n" 76 - , toLazyByteString . intersperseBlocks 76 "\r\n" - , (\i -> S.drop 13 $ S.pack $ take i $ cycle [0..]) - , n) - -} - [ lazyVsBlaze - ( "base64" - , L.fromChunks . return . encode - , toLazyByteString . encodeBase64 - , (\i -> S.drop 13 $ S.pack $ take i $ cycle [0..]) - , n) - {- - , lazyVsBlaze - ( "copy" - , L.copy - , copyBlaze - , (\i -> L.drop 13 $ L.take (fromIntegral i) $ L.fromChunks $ repeat $ S.pack [0..]) - , n) - , lazyVsBlaze - ( "filter ((==0) . (`mod` 3))" - , L.filter ((==0) . (`mod` 3)) - , filterBlaze ((==0) . (`mod` 3)) - , (\i -> L.drop 13 $ L.pack $ take i $ cycle [0..]) - , n) - , lazyVsBlaze - ( "map (+1)" - , L.map (+1) - , mapBlaze (+1) - , (\i -> L.drop 13 $ L.pack $ take i $ cycle [0..]) - , n) - , lazyVsBlaze - ( "concatMap (replicate 10)" - , L.concatMap (L.replicate 10) - , toLazyByteString . concatMapBuilder (fromReplicateWord8 10) - , (\i -> L.pack $ take i $ cycle [0..]) - , n `div` 10 ) - , lazyVsBlaze - ( "unfoldr countToZero" - , L.unfoldr countToZero - , unfoldrBlaze countToZero - , id - , n ) - -} - ] - sequence_ (intersperse (putStrLn "") chunkInfos) - putStrLn "" - defaultMain benchmarks - where - n :: Int - n = 100000 - -lazyVsBlaze :: (String, a -> L.ByteString, a -> L.ByteString, Int -> a, Int) - -> (IO (), Benchmark) -lazyVsBlaze (cmpName, lazy, blaze, prep, n) = - ( do putStrLn $ cmpName ++ ": " ++ checkResults - showChunksize implLazy lazy - showChunksize implBlaze blaze - , bgroup cmpName - [ mkBench implBlaze blaze - , mkBench implLazy lazy - ] - ) - where - implLazy = "bytestring" - implBlaze = "blaze-builder" - x = prep n - - nInfo = "for n = " ++ show n - checkResults - | lazy x == blaze x = "implementations agree " ++ nInfo - | otherwise = unlines [ "ERROR: IMPLEMENTATIONS DISAGREE " ++ nInfo - , implLazy ++ ": " ++ show (lazy x) - , implBlaze ++ ": " ++ show (blaze x) - ] - - showChunksize implName impl = do - let bs = impl x - cs = map S.length $ L.toChunks bs - putStrLn $ " " ++ implName ++ ": " - putStrLn $ " chunks sizes: " ++ show cs - putStrLn $ " avg. chunk size: " ++ - show ((fromIntegral (sum cs) :: Double) / fromIntegral (length cs)) - - mkBench implName impl = bench implName $ whnf (L.length . impl) x - - ------------------------------------------------------------------------------- --- Alternative implementations ------------------------------------------------------------------------------- - --- Unfolding ------------- - -{- --- | /O(n)/ The 'unfoldr' function is analogous to the List \'unfoldr\'. --- 'unfoldr' builds a ByteString from a seed value. The function takes --- the element and returns 'Nothing' if it is done producing the --- ByteString or returns 'Just' @(a,b)@, in which case, @a@ is a --- prepending to the ByteString and @b@ is used as the next element in a --- recursive call. -unfoldr :: (a -> Maybe (Word8, a)) -> a -> ByteString -unfoldr f s0 = unfoldChunk 32 s0 - where unfoldChunk n s = - case S.unfoldrN n f s of - (c, Nothing) - | S.null c -> Empty - | otherwise -> Chunk c Empty - (c, Just s') -> Chunk c (unfoldChunk (n*2) s') --} - -countToZero :: Int -> Maybe (Word8, Int) -countToZero 0 = Nothing -countToZero i = Just (fromIntegral i, i - 1) - -unfoldrBlaze :: (a -> Maybe (Word8, a)) -> a -> L.ByteString -unfoldrBlaze f x = toLazyByteString $ fromWriteUnfoldr writeWord8 f x - -fromWriteUnfoldr :: (b -> Write) -> (a -> Maybe (b, a)) -> a -> Builder -fromWriteUnfoldr write = - makeBuilder - where - makeBuilder f x0 = fromBuildStepCont $ step x0 - where - step x1 !k = fill x1 - where - fill x !(BufRange pf0 pe0) = go (f x) pf0 - where - go !Nothing !pf = do - let !br' = BufRange pf pe0 - k br' - go !(Just (y, x')) !pf - | pf `plusPtr` bound <= pe0 = do - !pf' <- runWrite (write y) pf - go (f x') pf' - | otherwise = return $ bufferFull bound pf $ - \(BufRange pfNew peNew) -> do - !pfNew' <- runWrite (write y) pfNew - fill x' (BufRange pfNew' peNew) - where - bound = getBound $ write y -{-# INLINE fromWriteUnfoldr #-} - --- Filtering and mapping ------------------------- - -test :: Int -> (L.ByteString, L.ByteString) -test i = - ((L.filter ((==0) . (`mod` 3)) $ x) , - (filterBlaze ((==0) . (`mod` 3)) $ x)) - where - x = L.pack $ take i $ cycle [0..] - -filterBlaze :: (Word8 -> Bool) -> L.ByteString -> L.ByteString -filterBlaze f = toLazyByteString . filterLazyByteString f -{-# INLINE filterBlaze #-} - -mapBlaze :: (Word8 -> Word8) -> L.ByteString -> L.ByteString -mapBlaze f = toLazyByteString . mapLazyByteString f -{-# INLINE mapBlaze #-} - -filterByteString :: (Word8 -> Bool) -> S.ByteString -> Builder -filterByteString p = mapFilterMapByteString id p id -{-# INLINE filterByteString #-} - -filterLazyByteString :: (Word8 -> Bool) -> L.ByteString -> Builder -filterLazyByteString p = mapFilterMapLazyByteString id p id -{-# INLINE filterLazyByteString #-} - -mapByteString :: (Word8 -> Word8) -> S.ByteString -> Builder -mapByteString f = mapFilterMapByteString f (const True) id -{-# INLINE mapByteString #-} - -mapLazyByteString :: (Word8 -> Word8) -> L.ByteString -> Builder -mapLazyByteString f = mapFilterMapLazyByteString f (const True) id -{-# INLINE mapLazyByteString #-} - -mapFilterMapByteString :: (Word8 -> Word8) -> (Word8 -> Bool) -> (Word8 -> Word8) - -> S.ByteString -> Builder -mapFilterMapByteString f p g = - \bs -> fromBuildStepCont $ step bs - where - step (S.PS ifp ioff isize) !k = - goBS (unsafeForeignPtrToPtr ifp `plusPtr` ioff) - where - !ipe = unsafeForeignPtrToPtr ifp `plusPtr` (ioff + isize) - goBS !ip0 !br@(BufRange op0 ope) - | ip0 >= ipe = do touchForeignPtr ifp -- input buffer consumed - k br - | op0 < ope = goPartial (ip0 `plusPtr` min outRemaining inpRemaining) - | otherwise = return $ bufferFull 1 op0 (goBS ip0) - where - outRemaining = ope `minusPtr` op0 - inpRemaining = ipe `minusPtr` ip0 - goPartial !ipeTmp = go ip0 op0 - where - go !ip !op - | ip < ipeTmp = do - w <- peek ip - let w' = g w - if p w' - then poke op (f w') >> go (ip `plusPtr` 1) (op `plusPtr` 1) - else go (ip `plusPtr` 1) op - | otherwise = - goBS ip (BufRange op ope) -{-# INLINE mapFilterMapByteString #-} - -mapFilterMapLazyByteString :: (Word8 -> Word8) -> (Word8 -> Bool) -> (Word8 -> Word8) - -> L.ByteString -> Builder -mapFilterMapLazyByteString f p g = - L.foldrChunks (\c b -> mapFilterMapByteString f p g c `mappend` b) mempty -{-# INLINE mapFilterMapLazyByteString #-} - - --- Concatenation and replication --------------------------------- - -{- --- | Map a function over a 'ByteString' and concatenate the results -concatMap :: (Word8 -> ByteString) -> ByteString -> ByteString -concatMap _ Empty = Empty -concatMap f (Chunk c0 cs0) = to c0 cs0 - where - go :: ByteString -> P.ByteString -> ByteString -> ByteString - go Empty c' cs' = to c' cs' - go (Chunk c cs) c' cs' = Chunk c (go cs c' cs') - - to :: P.ByteString -> ByteString -> ByteString - to c cs | S.null c = case cs of - Empty -> Empty - (Chunk c' cs') -> to c' cs' - | otherwise = go (f (S.unsafeHead c)) (S.unsafeTail c) cs --} - -fromWriteReplicated :: (a -> Write) -> Int -> a -> Builder -fromWriteReplicated write = - makeBuilder - where - makeBuilder !n0 x = fromBuildStepCont $ step - where - bound = getBound $ write x - step !k = fill n0 - where - fill !n1 !(BufRange pf0 pe0) = go n1 pf0 - where - go 0 !pf = do - let !br' = BufRange pf pe0 - k br' - go n !pf - | pf `plusPtr` bound <= pe0 = do - pf' <- runWrite (write x) pf - go (n-1) pf' - | otherwise = return $ bufferFull bound pf $ - \(BufRange pfNew peNew) -> do - pfNew' <- runWrite (write x) pfNew - fill (n-1) (BufRange pfNew' peNew) -{-# INLINE fromWriteReplicated #-} - --- FIXME: Output repeated bytestrings for large replications. -fromReplicateWord8 :: Int -> Word8 -> Builder -fromReplicateWord8 !n0 x = - fromBuildStepCont $ step - where - step !k = fill n0 - where - fill !n !br@(BufRange pf pe) - | n <= 0 = k br - | pf' <= pe = do - _ <- S.memset pf x (fromIntegral n) -- FIXME: This conversion looses information for 64 bit systems. - let !br' = BufRange pf' pe - k br' - | otherwise = do - let !l = pe `minusPtr` pf - _ <- S.memset pf x (fromIntegral l) -- FIXME: This conversion looses information for 64 bit systems. - return $ bufferFull 1 pe $ fill (n - l) - where - pf' = pf `plusPtr` n -{-# INLINE fromReplicateWord8 #-} - - -{-# RULES "fromWriteReplicated/writeWord8" - fromWriteReplicated writeWord8 = fromReplicateWord8 - #-} - - -concatMapBuilder :: (Word8 -> Builder) -> L.ByteString -> Builder -concatMapBuilder f = L.foldr (\w b -> f w `mappend` b) mempty -{-# INLINE concatMapBuilder #-} - -concatMapBlaze :: (Word8 -> L.ByteString) -> L.ByteString -> L.ByteString -concatMapBlaze f = toLazyByteString . concatMapBuilder (fromLazyByteString . f) - - --- Interspersing ----------------- - --- --- not sure if it Builder version is needed, as chunks get only bigger. We --- would need it however, if we used a Builder to ensure latency guarantees; i.e., --- if we use a builder to ensure a bound on the maximal size of chunks. --- - -{- --- | The 'intersperse' function takes a 'Word8' and a 'ByteString' and --- \`intersperses\' that byte between the elements of the 'ByteString'. --- It is analogous to the intersperse function on Lists. -intersperse :: Word8 -> ByteString -> ByteString -intersperse _ Empty = Empty -intersperse w (Chunk c cs) = Chunk (S.intersperse w c) - (foldrChunks (Chunk . intersperse') Empty cs) - where intersperse' :: P.ByteString -> P.ByteString - intersperse' (S.PS fp o l) = - S.unsafeCreate (2*l) $ \p' -> withForeignPtr fp $ \p -> do - poke p' w - S.c_intersperse (p' `plusPtr` 1) (p `plusPtr` o) (fromIntegral l) w --} -{- -intersperseBlaze :: Word8 -- ^ Byte to intersperse. - -> L.ByteString -- ^ Lazy 'L.ByteString' to be "spread". - -> Builder -- ^ Resulting 'Builder'. -intersperseBlaze w lbs0 = - Builder $ step lbs0 - where - step lbs1 k = goChunk lbs1 - where - goChunk L.Empty pf0 pe0 = k pf0 pe0 - goChunk (L.Chunk (S.PS fpi oi li) lbs') pf0 pe0 = do - go - touch - where - go - where - !pf' = pf `plusPtr` - - - goChunk !L.Empty !pf = k pf pe0 - goChunk !lbs@(L.Chunk bs' lbs') !pf - | pf' <= pe0 = do - withForeignPtr fpbuf $ \pbuf -> - copyBytes pf (pbuf `plusPtr` offset) size - go lbs' pf' - - | otherwise = return $ BufferFull size pf (step lbs k) - where - !pf' = pf `plusPtr` - !(fpbuf, offset, size) = S.toForeignPtr bs' -{-# INLINE intersperseBlaze #-} - --} - - --- Packing ----------- - -packBlaze :: [Word8] -> L.ByteString -packBlaze = toLazyByteString . fromWriteList writeWord8 - - --- Reverse ----------- - - --- Transpose ------------- - - --- scanl, scanl1, scanr, scanr1 -------------------------------- - - --- mapAccumL, mapAccumR ------------------------ - - --- partition ------------- - --- unzip --------- - - --- copy -------- - -copyBlaze :: L.ByteString -> L.ByteString -copyBlaze = toLazyByteString . copyLazyByteString - - --- ?? packCString, packCStringLen ---------------------------------- - --- joinWith --------------------------------------------- - -intersperseBlocks :: Int -> S.ByteString -> S.ByteString -> Builder -intersperseBlocks blockSize sep (S.PS ifp ioff isize) = - fromPut $ do - lastBS <- go (ip0 `plusPtr` ioff) - unless (S.null lastBS) (putBuilder $ fromByteString lastBS) - where - ip0 = unsafeForeignPtrToPtr ifp - ipe = ip0 `plusPtr` (ioff + isize) - go !ip - | ip `plusPtr` blockSize >= ipe = - return $ S.PS ifp (ip `minusPtr` ip0) (ipe `minusPtr` ip) - | otherwise = do - putBuilder $ fromByteString (S.PS ifp (ip `minusPtr` ip0) blockSize) - `mappend` fromByteString sep - go (ip `plusPtr` blockSize) - -intersperseLazyBlocks :: Int -> Builder -> L.ByteString -> Builder -intersperseLazyBlocks blockSize sep bs = - go (splitLazyAt blockSize bs) - where - go (pre, suf) - | L.null suf = fromLazyByteString pre - | otherwise = fromLazyByteString pre `mappend` sep `mappend` - go (splitLazyAt blockSize suf) - -encodeBase64MIME :: S.ByteString -> Builder -encodeBase64MIME = - intersperseLazyBlocks 76 (fromByteString "\r\n") . toLazyByteString . encodeBase64 - - --- test blockwise mapping on base64 encoding --------------------------------------------- - --- | Encode a bytestring using Base64 encoding according to the specification --- in RFC 4648, . --- --- Note that you need to insert additional linebreaks every 76 bytes using the --- function @joinWith "\r\n" 76@ in order to achieve the MIME Base64 --- Content-Transfer-Encoding . --- --- TODO implement encoding of lazy bytestrings, implement joinWith --- functionality, and convencience function for MIME base-64 encoding. -encodeBase64 :: S.ByteString -> Builder -encodeBase64 = encodeLazyBase64 . L.fromChunks . return - -encodeLazyBase64 :: L.ByteString -> Builder -encodeLazyBase64 = - mkBuilder - where - mkBuilder bs = fromPut $ do - remainder <- putWriteLazyBlocks 3 writeBase64 bs - putBuilder $ complete remainder - - {-# INLINE writeBase64 #-} - writeBase64 ip = - exactWrite 4 $ \op -> do - b0 <- peekByte 0 - b1 <- peekByte 1 - b2 <- peekByte 2 - let w = (b0 `shiftL` 16) .|. (b1 `shiftL` 8) .|. b2 - poke (castPtr $ op ) =<< enc (w `shiftR` 12) - poke (castPtr $ op `plusPtr` 2) =<< enc (w .&. 0xfff) - where - peekByte :: Int -> IO Word32 - peekByte off = fmap fromIntegral (peekByteOff ip off :: IO Word8) - - enc = peekElemOff (unsafeForeignPtrToPtr encodeTable) . fromIntegral - - {-# INLINE complete #-} - complete bs - | S.null bs = mempty - | otherwise = fromWrite $ - exactWrite 4 $ \op -> do - let poke6Base64 off sh = pokeByteOff op off - (alphabet `S.unsafeIndex` fromIntegral (w `shiftR` sh .&. 63)) - pad off = pokeByteOff op off (fromIntegral $ ord '=' :: Word8) - poke6Base64 0 18 - poke6Base64 1 12 - if S.length bs == 1 then pad 2 - else poke6Base64 2 8 - pad 3 - where - getByte :: Int -> Int -> Word32 - getByte i sh = fromIntegral (bs `S.unsafeIndex` i) `shiftL` sh - w = getByte 0 16 .|. (if S.length bs == 1 then 0 else getByte 1 8) - - -- Lookup table trick from Data.ByteString.Base64 by Bryan O'Sullivan - {-# NOINLINE alphabet #-} - alphabet :: S.ByteString - alphabet = S.pack $ [65..90] ++ [97..122] ++ [48..57] ++ [43,47] - - -- FIXME: Check that the implementation of the lookup table aslo works on - -- big-endian systems. - {-# NOINLINE encodeTable #-} - encodeTable :: ForeignPtr Word16 - encodeTable = unsafePerformIO $ do - fp <- mallocForeignPtrArray 4096 - let ix = fromIntegral . S.index alphabet - withForeignPtr fp $ \p -> - sequence_ [ pokeElemOff p (j*64+k) ((ix k `shiftL` 8) .|. ix j) - | j <- [0..63], k <- [0..63] ] - return fp - - --- | Process a bytestring block-wise using a 'Write' action to produce the --- output per block. --- --- TODO: Compare speed with 'mapFilterMapByteString'. -{-# INLINE putWriteBlocks #-} -putWriteBlocks :: Int -- ^ Block size. - -> (Ptr Word8 -> Write) -- ^ 'Write' given a pointer to the - -- beginning of the block. - -> S.ByteString -- ^ 'S.ByteString' to consume blockwise. - -> Put S.ByteString -- ^ 'Put' returning the remaining - -- bytes, which are guaranteed to be - -- fewer than the block size. -putWriteBlocks blockSize write = - \bs -> putBuildStepCont $ step bs - where - step (S.PS ifp ioff isize) !k = - goBS (unsafeForeignPtrToPtr ifp `plusPtr` ioff) - where - !ipe = unsafeForeignPtrToPtr ifp `plusPtr` (ioff + isize) - goBS !ip0 !br@(BufRange op0 ope) - | ip0 `plusPtr` blockSize > ipe = do - touchForeignPtr ifp -- input buffer consumed - let !bs' = S.PS ifp (ip0 `minusPtr` unsafeForeignPtrToPtr ifp) - (ipe `minusPtr` ip0) - k bs' br - - | op0 `plusPtr` writeBound < ope = - goPartial (ip0 `plusPtr` (blockSize * min outRemaining inpRemaining)) - - | otherwise = return $ bufferFull writeBound op0 (goBS ip0) - where - writeBound = getBound' "putWriteBlocks" write - outRemaining = (ope `minusPtr` op0) `div` writeBound - inpRemaining = (ipe `minusPtr` ip0) `div` blockSize - - goPartial !ipeTmp = go ip0 op0 - where - go !ip !op - | ip < ipeTmp = do - op' <- runWrite (write ip) op - go (ip `plusPtr` blockSize) op' - | otherwise = - goBS ip (BufRange op ope) - - -{-# INLINE putWriteLazyBlocks #-} -putWriteLazyBlocks :: Int -- ^ Block size. - -> (Ptr Word8 -> Write) -- ^ 'Write' given a pointer to the - -- beginning of the block. - -> L.ByteString -- ^ 'L.ByteString' to consume blockwise. - -> Put S.ByteString -- ^ 'Put' returning the remaining - -- bytes, which are guaranteed to be - -- fewer than the block size. -putWriteLazyBlocks blockSize write = - go - where - go L.Empty = return S.empty - go (L.Chunk bs lbs) = do - bsRem <- putWriteBlocks blockSize write bs - case S.length bsRem of - lRem - | lRem <= 0 -> go lbs - | otherwise -> do - let (lbsPre, lbsSuf) = - L.splitAt (fromIntegral $ blockSize - lRem) lbs - case S.concat $ bsRem : L.toChunks lbsPre of - block@(S.PS bfp boff bsize) - | bsize < blockSize -> return block - | otherwise -> do - putBuilder $ fromWrite $ - write (unsafeForeignPtrToPtr bfp `plusPtr` boff) - putLiftIO $ touchForeignPtr bfp - go lbsSuf - - ------------------------------------------------------------------------------- --- Testing code ------------------------------------------------------------------------------- - - -chunks3 :: [Word8] -> [Word32] -chunks3 (b0 : b1 : b2 : bs) = - ((fromIntegral b0 `shiftL` 16) .|. - (fromIntegral b1 `shiftL` 8) .|. - (fromIntegral b2 ) - ) : chunks3 bs -chunks3 _ = [] - -cmpWriteToLib :: [Word8] -> (L.ByteString, L.ByteString) -cmpWriteToLib bs = - -- ( toLazyByteString $ fromWriteList write24bitsBase64 $ chunks3 bs - ( toLazyByteString $ encodeBase64 $ S.pack bs - , (`L.Chunk` L.empty) $ encode $ S.pack bs ) - -test3 :: Bool -test3 = uncurry (==) $ cmpWriteToLib $ [0..] - -test2 :: L.ByteString -test2 = toLazyByteString $ encodeBase64 $ S.pack [0..] - -{- OLD code - -{-# INLINE poke8 #-} -poke8 :: Word8 -> Ptr Word8 -> IO () -poke8 = flip poke - --- | @writeBase64 w@ writes the lower @24@ bits as four times 6 bit in --- little-endian order encoded using the standard alphabeth of Base 64 encoding --- as defined in . --- -{-# INLINE write6bitsBase64 #-} -write6bitsBase64 :: Word32 -> Write -write6bitsBase64 = exactWrite 1 . poke6bitsBase64 - -{-# INLINE poke6bitsBase64 #-} -poke6bitsBase64 :: Word32 -> Ptr Word8 -> IO () -poke6bitsBase64 w = poke8 (alphabet `S.unsafeIndex` fromIntegral (w .&. 63)) - {- - | i < 26 = withOffsets 0 'A' - | i < 52 = withOffsets 26 'a' - | i < 62 = withOffsets 52 '0' - | i == 62 = poke8 $ fromIntegral $ ord '+' - | otherwise = poke8 $ fromIntegral $ ord '/' - where - i :: Int - i = fromIntegral (w .&. 63) - - {-# INLINE withOffsets #-} - withOffsets neg pos = poke8 $ fromIntegral (i + ord pos - neg) - -} - -{-# INLINE writePaddedBitsBase64 #-} -writePaddedBitsBase64 :: Bool -- ^ Only 8 bits have to be output. - -> Word32 -- ^ Input whose lower 8 or 16 bits need to be output. - -> Write -writePaddedBitsBase64 only8 w = - write6bitsBase64 (w `shiftr_w32` 18) `mappend` - write6bitsBase64 (w `shiftr_w32` 12) `mappend` - writeIf (const only8) (const $ C8.writeChar '=') - (write6bitsBase64 . (`shiftr_w32` 6)) - w `mappend` - C8.writeChar '=' - -{-# INLINE write24bitsBase64 #-} -write24bitsBase64 :: Word32 -> Write -write24bitsBase64 w = write6bitsBase64 (w `shiftr_w32` 18) `mappend` - write6bitsBase64 (w `shiftr_w32` 12) `mappend` - write6bitsBase64 (w `shiftr_w32` 6) `mappend` - write6bitsBase64 (w ) - --- ASSUMES bits 25 - 31 are zero. -{-# INLINE write24bitsBase64' #-} -write24bitsBase64' :: Word32 -> Write -write24bitsBase64' w = - exactWrite 4 $ \p -> do - poke (castPtr p ) =<< enc (w `shiftR` 12) - poke (castPtr $ p `plusPtr` 2) =<< enc (w .&. 0xfff) - where - {-# INLINE enc #-} - enc = peekElemOff (unsafeForeignPtrToPtr encodeTable) . fromIntegral - --} - -------------------------------------------------------------------------------- --- A faster split for lazy bytestrings -------------------------------------------------------------------------------- - --- | /O(n\/c)/ 'splitAt' @n xs@ is equivalent to @('take' n xs, 'drop' n xs)@. -splitLazyAt :: Int -> L.ByteString -> (L.ByteString, L.ByteString) -splitLazyAt n cs0 - | n <= 0 = (L.Empty, cs0) - | otherwise = split cs0 - where - split L.Empty = (L.Empty, L.Empty) - split (L.Chunk c cs) - | n < len = case S.splitAt n c of - (pre, suf) -> (L.Chunk pre L.Empty, L.Chunk suf cs) - | otherwise = case splitLazyAt (n - len) cs of - (pre, suf) -> (L.Chunk c pre , suf ) - where - len = S.length c - - -------------------------------------------------------------------------------- --- A faster partition for strict and lazy bytestrings -------------------------------------------------------------------------------- - -{-# INLINE partitionStrict #-} -partitionStrict :: (Word8 -> Bool) -> S.ByteString -> (S.ByteString, S.ByteString) -partitionStrict f (S.PS ifp ioff ilen) = - second S.reverse $ S.inlinePerformIO $ do - ofp <- S.mallocByteString ilen - withForeignPtr ifp $ wrapper ofp - where - wrapper !ofp !ip0 = - go (ip0 `plusPtr` ioff) op0 (op0 `plusPtr` ilen) - where - op0 = unsafeForeignPtrToPtr ofp - - go !ip !opl !oph - | oph == opl = return (S.PS ofp 0 olen, S.PS ofp olen (ilen - olen)) - | otherwise = do - x <- peek ip - if f x - then do poke opl x - go (ip `plusPtr` 1) (opl `plusPtr` 1) oph - else do let oph' = oph `plusPtr` (-1) - poke oph' x - go (ip `plusPtr` 1) opl oph' - - where - olen = opl `minusPtr` op0 - -{-# INLINE partitionLazy #-} -partitionLazy :: (Word8 -> Bool) -> L.ByteString -> (L.ByteString, L.ByteString) -partitionLazy f = - L.foldrChunks partitionOne (L.empty, L.empty) - where - partitionOne bs (ls, rs) = - (L.Chunk l ls, L.Chunk r rs) - where - (l, r) = partitionStrict f bs diff --git a/benchmarks/PlotTest.hs b/benchmarks/PlotTest.hs deleted file mode 100644 index 7784ffe..0000000 --- a/benchmarks/PlotTest.hs +++ /dev/null @@ -1,218 +0,0 @@ ------------------------------------------------------------------------------ --- | --- Module : PlotTest --- Copyright : Simon Meier --- License : BSD3-style (see LICENSE) --- --- Maintainer : Leon P Smith --- 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/StrictIO.hs b/benchmarks/StrictIO.hs deleted file mode 100644 index a511ef3..0000000 --- a/benchmarks/StrictIO.hs +++ /dev/null @@ -1,28 +0,0 @@ -{-# LANGUAGE BangPatterns #-} --- | Demonstrate the problem with IO not allowing for unlifted types. --- --- TODO: Not yet finished. -module StrictIO where - - - -loop :: Int -> Int -> IO () -loop !i !c - | i == 1 = print c - | otherwise = do - !i' <- subcases - print i' - loop i' (c+1) - where - subcases - | i `mod` 2 == 0 = do - print "even" - return $ i `div` 2 - | otherwise = do - print "odd" - return $ i + 1 - {-# INLINE subcases #-} - - - - diff --git a/benchmarks/StringAndText.hs b/benchmarks/StringAndText.hs deleted file mode 100644 index 4018af9..0000000 --- a/benchmarks/StringAndText.hs +++ /dev/null @@ -1,127 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} --- | --- Module : StringAndText --- Copyright : (c) 2010 Simon Meier --- License : BSD3-style (see LICENSE) --- --- Maintainer : Leon P Smith --- 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.fromBuildStepCont $ \k -> TS.foldr step k t - where - step c k pf pe - | pf' <= pe = do - io pf - k pf' pe -- here it would be great, if we wouldn't have to pass - -- around pe: requires a more powerful fold for StrictText. - | otherwise = - return $ Blaze.bufferFull size pf $ \(Blaze.BufRange pfNew peNew) -> do - let !br' = Blaze.BufRange (pfNew `plusPtr` size) peNew - io pfNew - k br' - where - pf' = pf `plusPtr` size - Blaze.Write size io = Blaze.writeChar c -{-# INLINE fromStrictTextFolded #-} - --- | Encode the 'TL.Text' as UTF-8 by folding it and filling the raw buffer --- directly. -fromLazyTextFolded :: TL.Text -> Blaze.Builder -fromLazyTextFolded t = Blaze.fromBuildStepContBuilder $ \k -> TL.foldr step k t - where - step c k pf pe - | pf' <= pe = do - io pf - k pf' pe -- here it would be great, if we wouldn't have to pass - -- around pe: requires a more powerful fold for StrictText. - | otherwise = - return $ Blaze.bufferFull size pf $ \(Blaze.BufRange pfNew peNew) -> do - let !br' = Blaze.BufRange (pfNew `plusPtr` size) peNew - io pfNew - k br' - where - pf' = pf `plusPtr` size - Blaze.Write size io = Blaze.writeChar c -{-# INLINE fromLazyTextFolded #-} --} diff --git a/benchmarks/Throughput/BinaryBuilder.hs b/benchmarks/Throughput/BinaryBuilder.hs deleted file mode 100644 index ccfe2cc..0000000 --- a/benchmarks/Throughput/BinaryBuilder.hs +++ /dev/null @@ -1,697 +0,0 @@ -{-# 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 deleted file mode 100644 index 4de2535..0000000 --- a/benchmarks/Throughput/BinaryBuilderDeclarative.hs +++ /dev/null @@ -1,118 +0,0 @@ -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 deleted file mode 100644 index 55d31be..0000000 --- a/benchmarks/Throughput/BinaryPut.hs +++ /dev/null @@ -1,696 +0,0 @@ -{-# 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 deleted file mode 100644 index 58915ed..0000000 --- a/benchmarks/Throughput/BlazeBuilder.hs +++ /dev/null @@ -1,702 +0,0 @@ -{-# 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 deleted file mode 100644 index dc55a17..0000000 --- a/benchmarks/Throughput/BlazeBuilderDeclarative.hs +++ /dev/null @@ -1,197 +0,0 @@ -{-# 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 deleted file mode 100644 index fc74927..0000000 --- a/benchmarks/Throughput/BlazePut.hs +++ /dev/null @@ -1,742 +0,0 @@ -{-# 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 deleted file mode 100755 index 461c97c..0000000 --- a/benchmarks/Throughput/BlazePutMonad.hs +++ /dev/null @@ -1,218 +0,0 @@ -{-# LANGUAGE CPP #-} ------------------------------------------------------------------------------ --- | --- Module : Data.Binary.Put --- Copyright : Lennart Kolmodin --- License : BSD3-style (see LICENSE) --- --- Maintainer : Lennart Kolmodin --- Stability : stable --- Portability : Portable to Hugs and GHC. Requires MPTCs --- --- The Put monad. A monad for efficiently constructing lazy bytestrings using --- the Builder developed for blaze-html. --- ------------------------------------------------------------------------------ - -module Throughput.BlazePutMonad ( - - -- * The Put type - Put - , PutM(..) - , runPut - , runPutM - , putBuilder - , execPut - - -- * Flushing the implicit parse state - , flush - - -- * Primitives - , putWrite - , putWord8 - , putByteString - , putLazyByteString - - -- * Big-endian primitives - , putWord16be - , putWord32be - , putWord64be - - -- * Little-endian primitives - , putWord16le - , putWord32le - , putWord64le - - -- * Host-endian, unaligned writes - , putWordhost -- :: Word -> Put - , putWord16host -- :: Word16 -> Put - , putWord32host -- :: Word32 -> Put - , putWord64host -- :: Word64 -> Put - - ) where - -import Data.Monoid -import Blaze.ByteString.Builder (Builder, toLazyByteString) -import qualified Blaze.ByteString.Builder as B - -import Data.Word -import qualified Data.ByteString as S -import qualified Data.ByteString.Lazy as L - -import Control.Applicative - - ------------------------------------------------------------------------- - --- XXX Strict in buffer only. -data PairS a = PairS a {-# UNPACK #-}!Builder - -sndS :: PairS a -> Builder -sndS (PairS _ b) = b - --- | The PutM type. A Writer monad over the efficient Builder monoid. -newtype PutM a = Put { unPut :: PairS a } - --- | Put merely lifts Builder into a Writer monad, applied to (). -type Put = PutM () - -instance Functor PutM where - fmap f m = Put $ let PairS a w = unPut m in PairS (f a) w - {-# INLINE fmap #-} - -instance Applicative PutM where - pure = return - m <*> k = Put $ - let PairS f w = unPut m - PairS x w' = unPut k - in PairS (f x) (w `mappend` w') - --- Standard Writer monad, with aggressive inlining -instance Monad PutM where - return a = Put $ PairS a mempty - {-# INLINE return #-} - - m >>= k = Put $ - let PairS a w = unPut m - PairS b w' = unPut (k a) - in PairS b (w `mappend` w') - {-# INLINE (>>=) #-} - - m >> k = Put $ - let PairS _ w = unPut m - PairS b w' = unPut k - in PairS b (w `mappend` w') - {-# INLINE (>>) #-} - -tell :: Builder -> Put -tell b = Put $ PairS () b -{-# INLINE tell #-} - -putBuilder :: Builder -> Put -putBuilder = tell -{-# INLINE putBuilder #-} - --- | Run the 'Put' monad -execPut :: PutM a -> Builder -execPut = sndS . unPut -{-# INLINE execPut #-} - --- | Run the 'Put' monad with a serialiser -runPut :: Put -> L.ByteString -runPut = toLazyByteString . sndS . unPut -{-# INLINE runPut #-} - --- | Run the 'Put' monad with a serialiser and get its result -runPutM :: PutM a -> (a, L.ByteString) -runPutM (Put (PairS f s)) = (f, toLazyByteString s) -{-# INLINE runPutM #-} - ------------------------------------------------------------------------- - --- | Pop the ByteString we have constructed so far, if any, yielding a --- new chunk in the result ByteString. -flush :: Put -flush = tell B.flush -{-# INLINE flush #-} - --- | Efficiently write a byte into the output buffer -putWord8 :: Word8 -> Put -putWord8 = tell . B.fromWord8 -{-# INLINE putWord8 #-} - --- | Execute a write on the output buffer. -putWrite :: B.Write -> Put -putWrite = tell . B.fromWrite - --- | An efficient primitive to write a strict ByteString into the output buffer. --- It flushes the current buffer, and writes the argument into a new chunk. -putByteString :: S.ByteString -> Put -putByteString = tell . B.fromByteString -{-# INLINE putByteString #-} - --- | Write a lazy ByteString efficiently, simply appending the lazy --- ByteString chunks to the output buffer -putLazyByteString :: L.ByteString -> Put -putLazyByteString = tell . B.fromLazyByteString -{-# INLINE putLazyByteString #-} - --- | Write a Word16 in big endian format -putWord16be :: Word16 -> Put -putWord16be = tell . B.fromWord16be -{-# INLINE putWord16be #-} - --- | Write a Word16 in little endian format -putWord16le :: Word16 -> Put -putWord16le = tell . B.fromWord16le -{-# INLINE putWord16le #-} - --- | Write a Word32 in big endian format -putWord32be :: Word32 -> Put -putWord32be = tell . B.fromWord32be -{-# INLINE putWord32be #-} - --- | Write a Word32 in little endian format -putWord32le :: Word32 -> Put -putWord32le = tell . B.fromWord32le -{-# INLINE putWord32le #-} - --- | Write a Word64 in big endian format -putWord64be :: Word64 -> Put -putWord64be = tell . B.fromWord64be -{-# INLINE putWord64be #-} - --- | Write a Word64 in little endian format -putWord64le :: Word64 -> Put -putWord64le = tell . B.fromWord64le -{-# INLINE putWord64le #-} - ------------------------------------------------------------------------- - --- | /O(1)./ Write a single native machine word. The word is --- written in host order, host endian form, for the machine you're on. --- On a 64 bit machine the Word is an 8 byte value, on a 32 bit machine, --- 4 bytes. Values written this way are not portable to --- different endian or word sized machines, without conversion. --- -putWordhost :: Word -> Put -putWordhost = tell . B.fromWordhost -{-# INLINE putWordhost #-} - --- | /O(1)./ Write a Word16 in native host order and host endianness. --- For portability issues see @putWordhost@. -putWord16host :: Word16 -> Put -putWord16host = tell . B.fromWord16host -{-# INLINE putWord16host #-} - --- | /O(1)./ Write a Word32 in native host order and host endianness. --- For portability issues see @putWordhost@. -putWord32host :: Word32 -> Put -putWord32host = tell . B.fromWord32host -{-# INLINE putWord32host #-} - --- | /O(1)./ Write a Word64 in native host order --- On a 32 bit machine we write two host order Word32s, in big endian form. --- For portability issues see @putWordhost@. -putWord64host :: Word64 -> Put -putWord64host = tell . B.fromWord64host -{-# INLINE putWord64host #-} diff --git a/benchmarks/Throughput/CBenchmark.c b/benchmarks/Throughput/CBenchmark.c deleted file mode 100755 index c9b6d32..0000000 --- a/benchmarks/Throughput/CBenchmark.c +++ /dev/null @@ -1,39 +0,0 @@ -#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 deleted file mode 100755 index 3f5d524..0000000 --- a/benchmarks/Throughput/CBenchmark.h +++ /dev/null @@ -1,4 +0,0 @@ -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 deleted file mode 100644 index cce927b..0000000 --- a/benchmarks/Throughput/Memory.hs +++ /dev/null @@ -1,98 +0,0 @@ -{-# 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 deleted file mode 100644 index a5647c3..0000000 --- a/benchmarks/Throughput/Utils.hs +++ /dev/null @@ -1,12 +0,0 @@ -module Throughput.Utils ( - Endian(..) -) where - - -data Endian - = Big - | Little - | Host - deriving (Eq,Ord,Show) - - diff --git a/benchmarks/UnboxedAppend.hs b/benchmarks/UnboxedAppend.hs deleted file mode 100644 index 1e12fb5..0000000 --- a/benchmarks/UnboxedAppend.hs +++ /dev/null @@ -1,254 +0,0 @@ -{-# LANGUAGE CPP, BangPatterns, Rank2Types, MagicHash #-} --- | --- Module : UnboxedAppend --- Copyright : (c) 2010 Simon Meier --- License : BSD3-style (see LICENSE) --- --- Maintainer : Leon P Smith --- Stability : experimental --- Portability : tested on GHC only --- --- Try using unboxed pointers for the continuation calls to make abstract --- appends go faster. --- -module UnboxedAppend where - -import Foreign -import Foreign.UPtr -import Data.Monoid -import qualified Data.ByteString as S -import qualified Data.ByteString.Lazy as L - -#ifdef BYTESTRING_IN_BASE -import Data.ByteString.Base (inlinePerformIO) -import qualified Data.ByteString.Base as S -import qualified Data.ByteString.Lazy.Base as L -- FIXME: is this the right module for access to 'Chunks'? -#else -import Data.ByteString.Internal (inlinePerformIO) -import qualified Data.ByteString.Internal as S -import qualified Data.ByteString.Lazy.Internal as L -#endif - -import qualified Blaze.ByteString.Builder.Internal as B -import Blaze.ByteString.Builder.Write (Write(..)) -import qualified Blaze.ByteString.Builder.Word as B -import Blaze.ByteString.Builder.Word (writeWord8) - -import Criterion.Main - ------------------------------------------------------------------------------- --- Benchmarks ------------------------------------------------------------------------------- - -main :: IO () -main = defaultMain $ concat - [ benchmark "mconcat . map fromWord8" - myfromWord8s - yourfromWord8s - word8s - ] - where - benchmark name putF builderF x = - [ bench (name ++ " Put") $ - whnf (L.length . toLazyByteString2 . putF) x - , bench (name ++ " Builder") $ - whnf (L.length . B.toLazyByteString . builderF) x - ] - -word8s :: [Word8] -word8s = take 100000 $ cycle [0..] -{-# NOINLINE word8s #-} - -myfromWord8s :: [Word8] -> Put () -myfromWord8s = putBuilder . mconcat . map fromWord8 -{-# NOINLINE myfromWord8s #-} - -yourfromWord8s :: [Word8] -> B.Builder -yourfromWord8s = mconcat . map B.fromWord8 -{-# NOINLINE yourfromWord8s #-} - - ------------------------------------------------------------------------------- --- The Put type ------------------------------------------------------------------------------- - -data BufRange = BufRange {-# UNPACK #-} !(Ptr Word8) {-# UNPACK #-} !(Ptr Word8) - -newtype Put a = Put { - unPut :: forall r. (a -> PutStep r) -> PutStep r - } - -data PutSignal a = - Done {-# UNPACK #-} !(Ptr Word8) a - | BufferFull - {-# UNPACK #-} !Int - {-# UNPACK #-} !(Ptr Word8) - !(PutStep a) - | InsertByteString - {-# UNPACK #-} !(Ptr Word8) - !S.ByteString - !(PutStep a) - -type PutStep a = UPtr -> UPtr -> IO (PutSignal a) - -instance Monad Put where - return x = Put $ \k -> k x - {-# INLINE return #-} - m >>= f = Put $ \k -> unPut m (\x -> unPut (f x) k) - {-# INLINE (>>=) #-} - m >> n = Put $ \k -> unPut m (\_ -> unPut n k) - {-# INLINE (>>) #-} - ------------------------------------------------------------------------------- --- The Builder type with equal signals as the Put type ------------------------------------------------------------------------------- - -newtype Builder = Builder (forall r. PutStep r -> PutStep r) - -instance Monoid Builder where - mempty = Builder id - {-# INLINE mempty #-} - (Builder b1) `mappend` (Builder b2) = Builder $ b1 . b2 - {-# INLINE mappend #-} - mconcat = foldr mappend mempty - {-# INLINE mconcat #-} - -putBuilder :: Builder -> Put () -putBuilder (Builder build) = Put $ \k -> build (k ()) - -fromPut :: Put () -> Builder -fromPut (Put put) = Builder $ \k -> put (\_ -> k) - -fromBuildStep :: (forall r. PutStep r -> BufRange -> IO (PutSignal r)) -> Builder -fromBuildStep step = Builder step' - where - step' k op ope = step k (BufRange (uptrToPtr op) (uptrToPtr ope)) -{-# INLINE fromBuildStep #-} - -callBuildStep :: PutStep a -> BufRange -> IO (PutSignal a) -callBuildStep k (BufRange op ope) = k (ptrToUPtr op) (ptrToUPtr ope) -{-# INLINE callBuildStep #-} - -boxBuildStep :: PutStep a -> (BufRange -> IO (PutSignal a)) -boxBuildStep step (BufRange op ope) = step (ptrToUPtr op) (ptrToUPtr ope) -{-# INLINE boxBuildStep #-} - -unboxBuildStep :: (BufRange -> IO (PutSignal a)) -> PutStep a -unboxBuildStep step op ope = step (BufRange (uptrToPtr op) (uptrToPtr ope)) -{-# INLINE unboxBuildStep #-} - -fromWriteSingleton :: (a -> Write) -> a -> Builder -fromWriteSingleton write = - mkBuilder - where - mkBuilder x = fromBuildStep step - where - step k (BufRange pf pe) - | pf `plusPtr` size <= pe = do - io pf - let !br' = BufRange (pf `plusPtr` size) pe - callBuildStep k br' - | otherwise = - return $ BufferFull size pf (unboxBuildStep $ step k) - where - Write size io = write x -{-# INLINE fromWriteSingleton #-} - -fromWord8 :: Word8 -> Builder -fromWord8 = fromWriteSingleton writeWord8 -{-# INLINE fromWord8 #-} - ------------------------------------------------------------------------------- --- More explicit implementation of running builders ------------------------------------------------------------------------------- - - -data Buffer = Buffer {-# UNPACK #-} !(ForeignPtr Word8) -- underlying pinned array - {-# UNPACK #-} !(Ptr Word8) -- beginning of slice - {-# UNPACK #-} !(Ptr Word8) -- next free byte - {-# UNPACK #-} !(Ptr Word8) -- first byte after buffer - -allocBuffer :: Int -> IO Buffer -allocBuffer size = do - fpbuf <- S.mallocByteString size - let !pbuf = unsafeForeignPtrToPtr fpbuf - return $! Buffer fpbuf pbuf pbuf (pbuf `plusPtr` size) - -unsafeFreezeBuffer :: Buffer -> S.ByteString -unsafeFreezeBuffer (Buffer fpbuf p0 op _) = - S.PS fpbuf 0 (op `minusPtr` p0) - -unsafeFreezeNonEmptyBuffer :: Buffer -> Maybe S.ByteString -unsafeFreezeNonEmptyBuffer (Buffer fpbuf p0 op _) - | p0 == op = Nothing - | otherwise = Just $ S.PS fpbuf 0 (op `minusPtr` p0) - -nextSlice :: Int -> Buffer -> Maybe Buffer -nextSlice minSize (Buffer fpbuf _ op ope) - | ope `minusPtr` op <= minSize = Nothing - | otherwise = Just (Buffer fpbuf op op ope) - -runPut :: Monad m - => (IO (PutSignal a) -> m (PutSignal a)) -- lifting of buildsteps - -> (Int -> Buffer -> m Buffer) -- output function for a guaranteedly non-empty buffer, the returned buffer will be filled next - -> (S.ByteString -> m ()) -- output function for guaranteedly non-empty bytestrings, that are inserted directly into the stream - -> Put a -- put to execute - -> Buffer -- initial buffer to be used - -> m (a, Buffer) -- result of put and remaining buffer -runPut liftIO outputBuf outputBS (Put put) = - runStep (put $ (\x -> unboxBuildStep $ finalStep x)) - where - finalStep x !(BufRange op _) = return $ Done op x - - runStep step buf@(Buffer fpbuf p0 op ope) = do - let !br = BufRange op ope - signal <- liftIO $ callBuildStep step br - case signal of - Done op' x -> -- put completed, buffer partially runSteped - return (x, Buffer fpbuf p0 op' ope) - - BufferFull minSize op' nextStep -> do - buf' <- outputBuf minSize (Buffer fpbuf p0 op' ope) - runStep nextStep buf' - - InsertByteString op' bs nextStep - | S.null bs -> -- flushing of buffer required - outputBuf 1 (Buffer fpbuf p0 op' ope) >>= runStep nextStep - | p0 == op' -> do -- no bytes written: just insert bytestring - outputBS bs - runStep nextStep buf - | otherwise -> do -- bytes written, insert buffer and bytestring - buf' <- outputBuf 1 (Buffer fpbuf p0 op' ope) - outputBS bs - runStep nextStep buf' -{-# INLINE runPut #-} - --- | A monad for lazily composing lazy bytestrings using continuations. -newtype LBSM a = LBSM { unLBSM :: (a, L.ByteString -> L.ByteString) } - -instance Monad LBSM where - return x = LBSM (x, id) - (LBSM (x,k)) >>= f = let LBSM (x',k') = f x in LBSM (x', k . k') - (LBSM (_,k)) >> (LBSM (x',k')) = LBSM (x', k . k') - --- | Execute a put and return the written buffers as the chunks of a lazy --- bytestring. -toLazyByteString2 :: Put a -> L.ByteString -toLazyByteString2 put = - k (bufToLBSCont (snd result) L.empty) - where - -- initial buffer - buf0 = inlinePerformIO $ allocBuffer B.defaultBufferSize - -- run put, but don't force result => we're lazy enough - LBSM (result, k) = runPut liftIO outputBuf outputBS put buf0 - -- convert a buffer to a lazy bytestring continuation - bufToLBSCont = maybe id L.Chunk . unsafeFreezeNonEmptyBuffer - -- lifting an io putsignal to a lazy bytestring monad - liftIO io = LBSM (inlinePerformIO io, id) - -- add buffer as a chunk prepare allocation of new one - outputBuf minSize buf = LBSM - ( inlinePerformIO $ allocBuffer (max minSize B.defaultBufferSize) - , bufToLBSCont buf ) - -- add bytestring directly as a chunk; exploits postcondition of runPut - -- that bytestrings are non-empty - outputBS bs = LBSM ((), L.Chunk bs) diff --git a/benchmarks/Utf8IO.hs b/benchmarks/Utf8IO.hs deleted file mode 100644 index ca2ee10..0000000 --- a/benchmarks/Utf8IO.hs +++ /dev/null @@ -1,102 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} --- | --- Copyright : (c) 2011 Simon Meier --- License : BSD3-style (see LICENSE) --- --- Maintainer : Leon P Smith --- Stability : experimental --- Portability : tested on GHC only --- --- Benchmarking IO output speed of writing a string in Utf8 encoding to a file. -module Utf8IO (main) where - -import Control.Monad -import Control.Exception (evaluate) - -import qualified Codec.Binary.UTF8.Light as Utf8Light - -import Data.Char (chr) -import Data.Time.Clock -import qualified Data.ByteString.Lazy as L -import qualified Data.ByteString.Lazy.UTF8 as Utf8String -import qualified Data.Text.Lazy as TL -import qualified Data.Text.Lazy.Encoding as TL - -import System.IO -import System.Environment - -import Blaze.ByteString.Builder -import Blaze.ByteString.Builder.Internal (defaultBufferSize) -import qualified Blaze.ByteString.Builder.Char.Utf8 as Blaze - - --- | Write using the standard text utf8 encoding function built into 'base'. -writeUtf8_base :: String -> FilePath -> IO () -writeUtf8_base cs file = - withFile file WriteMode $ \h -> do - hSetEncoding h utf8 - hPutStr h cs - --- | Write using utf8 encoding as provided by the 'blaze-builder' library. -writeUtf8_blaze :: String -> FilePath -> IO () -writeUtf8_blaze cs file = L.writeFile file $ toLazyByteString $ Blaze.fromString cs - --- | Write using utf8 encoding as provided by the 'text' library. -writeUtf8_text :: TL.Text -> FilePath -> IO () -writeUtf8_text tx file = L.writeFile file $ TL.encodeUtf8 tx - --- | Write using utf8 encoding as provided by the 'utf8-string' library. -writeUtf8_string :: String -> FilePath -> IO () -writeUtf8_string cs file = L.writeFile file $ Utf8String.fromString cs - --- | Write using utf8 encoding as provided by the 'utf8-light' library. Note --- that this library only allows encoding the whole string as a strict --- bytestring. That might make it unusable in some circumstances. -{-# NOINLINE writeUtf8_light #-} -writeUtf8_light :: String -> FilePath -> IO () -writeUtf8_light cs file = Utf8Light.writeUTF8File file cs - - -main :: IO () -main = do - [how, len, file] <- getArgs - let blocksize = 32000 - block = map chr [0..blocksize] - n = read len - cs = take n $ cycle $ block - tx = TL.pack cs - writer <- case how of - "base" -> return $ writeUtf8_base cs - "blaze" -> return $ writeUtf8_blaze cs - "utf8-string" -> return $ writeUtf8_string cs - - -- utf8-light is missing support for lazy bytestrings => test 100 times - -- writing a 100 times smaller string to avoid out-of-memory errors. - "utf8-light" -> return $ \f -> sequence_ $ replicate 100 $ - writeUtf8_light (take (n `div` 100) cs) f - - "via-text" -> do return $ writeUtf8_text tx - - -- Here, we ensure that the text tx is already packed before timing. - "text" -> do _ <- evaluate (TL.length tx) - return $ writeUtf8_text tx - _ -> error $ "unknown writer '" ++ how ++ "'" - t <- timed_ $ writer file - putStrLn $ how ++ ": " ++ show t - ------------------------------------------------------------------------------- --- Timing ------------------------------------------------------------------------------- - --- | Execute an IO action and return its result plus the time it took to execute it. -timed :: IO a -> IO (a, NominalDiffTime) -timed io = do - t0 <- getCurrentTime - x <- io - t1 <- getCurrentTime - return (x, diffUTCTime t1 t0) - --- | Execute an IO action and return the time it took to execute it. -timed_ :: IO a -> IO NominalDiffTime -timed_ = (snd `liftM`) . timed - diff --git a/benchmarks/notes/bench_blaze_html_before_extended_builder b/benchmarks/notes/bench_blaze_html_before_extended_builder deleted file mode 100644 index a62c42f..0000000 --- a/benchmarks/notes/bench_blaze_html_before_extended_builder +++ /dev/null @@ -1,127 +0,0 @@ -warming up -estimating clock resolution... -mean is 16.88382 us (40001 iterations) -found 1536 outliers among 39999 samples (3.8%) - 28 (7.0e-2%) low severe - 1069 (2.7%) high severe -estimating cost of a clock call... -mean is 1.444274 us (72 iterations) -found 7 outliers among 72 samples (9.7%) - 7 (9.7%) high severe - -benchmarking bigTable (Utf8) -collecting 100 samples, 7 iterations each, in estimated 1.881072 s -bootstrapping with 100000 resamples -mean: 2.584626 ms, lb 2.580504 ms, ub 2.592990 ms, ci 0.950 -std dev: 28.73362 us, lb 14.43975 us, ub 48.08991 us, ci 0.950 -found 17 outliers among 100 samples (17.0%) - 4 (4.0%) low severe - 5 (5.0%) low mild - 3 (3.0%) high mild - 5 (5.0%) high severe -variance introduced by outliers: 0.990% -variance is unaffected by outliers - -benchmarking bigTable (String) -collecting 100 samples, 4 iterations each, in estimated 1.952195 s -bootstrapping with 100000 resamples -mean: 4.913297 ms, lb 4.907689 ms, ub 4.927607 ms, ci 0.950 -std dev: 42.65945 us, lb 20.58297 us, ub 84.61474 us, ci 0.950 -found 8 outliers among 100 samples (8.0%) - 7 (7.0%) high severe -variance introduced by outliers: 0.990% -variance is unaffected by outliers - -benchmarking basic (Utf8) -collecting 100 samples, 1730 iterations each, in estimated 1.688686 s -bootstrapping with 100000 resamples -mean: 9.814915 us, lb 9.804270 us, ub 9.843601 us, ci 0.950 -std dev: 82.32328 ns, lb 30.01711 ns, ub 168.0808 ns, ci 0.950 -found 10 outliers among 100 samples (10.0%) - 4 (4.0%) high mild - 6 (6.0%) high severe -variance introduced by outliers: 0.990% -variance is unaffected by outliers - -benchmarking basic (String) -collecting 100 samples, 1056 iterations each, in estimated 1.689023 s -bootstrapping with 100000 resamples -mean: 16.08221 us, lb 16.06504 us, ub 16.12133 us, ci 0.950 -std dev: 125.8313 ns, lb 69.00371 ns, ub 247.6060 ns, ci 0.950 -found 10 outliers among 100 samples (10.0%) - 2 (2.0%) high mild - 8 (8.0%) high severe -variance introduced by outliers: 0.990% -variance is unaffected by outliers - -benchmarking wideTree (Utf8) -collecting 100 samples, 7 iterations each, in estimated 1.958594 s -bootstrapping with 100000 resamples -mean: 3.063142 ms, lb 3.010301 ms, ub 3.117916 ms, ci 0.950 -std dev: 275.5234 us, lb 266.1363 us, ub 282.5958 us, ci 0.950 -variance introduced by outliers: 1.000% -variance is unaffected by outliers - -benchmarking wideTree (String) -collecting 100 samples, 4 iterations each, in estimated 1.920819 s -bootstrapping with 100000 resamples -mean: 4.806400 ms, lb 4.799060 ms, ub 4.815557 ms, ci 0.950 -std dev: 41.73762 us, lb 34.27933 us, ub 54.39989 us, ci 0.950 -found 3 outliers among 100 samples (3.0%) - 3 (3.0%) high mild -variance introduced by outliers: 0.990% -variance is unaffected by outliers - -benchmarking wideTreeEscaping (Utf8) -collecting 100 samples, 33 iterations each, in estimated 1.710217 s -bootstrapping with 100000 resamples -mean: 530.9193 us, lb 524.1955 us, ub 540.8656 us, ci 0.950 -std dev: 41.29335 us, lb 30.35683 us, ub 51.91998 us, ci 0.950 -found 13 outliers among 100 samples (13.0%) - 2 (2.0%) high mild - 11 (11.0%) high severe -variance introduced by outliers: 1.000% -variance is unaffected by outliers - -benchmarking wideTreeEscaping (String) -collecting 100 samples, 15 iterations each, in estimated 1.710556 s -bootstrapping with 100000 resamples -mean: 1.134601 ms, lb 1.132883 ms, ub 1.137927 ms, ci 0.950 -std dev: 11.83973 us, lb 7.447905 us, ub 22.26158 us, ci 0.950 -found 4 outliers among 100 samples (4.0%) - 3 (3.0%) high mild - 1 (1.0%) high severe -variance introduced by outliers: 0.990% -variance is unaffected by outliers - -benchmarking deepTree (Utf8) -collecting 100 samples, 24 iterations each, in estimated 1.719385 s -bootstrapping with 100000 resamples -mean: 754.8425 us, lb 739.7486 us, ub 772.3920 us, ci 0.950 -std dev: 83.10072 us, lb 73.88556 us, ub 89.97769 us, ci 0.950 -variance introduced by outliers: 1.000% -variance is unaffected by outliers - -benchmarking deepTree (String) -collecting 100 samples, 7 iterations each, in estimated 1.880331 s -bootstrapping with 100000 resamples -mean: 2.485456 ms, lb 2.421606 ms, ub 2.546204 ms, ci 0.950 -std dev: 319.6754 us, lb 301.3650 us, ub 336.2996 us, ci 0.950 -variance introduced by outliers: 1.000% -variance is unaffected by outliers - -benchmarking manyAttributes (Utf8) -collecting 100 samples, 8 iterations each, in estimated 1.825595 s -bootstrapping with 100000 resamples -mean: 2.491527 ms, lb 2.438397 ms, ub 2.548182 ms, ci 0.950 -std dev: 282.0034 us, lb 267.6402 us, ub 289.8338 us, ci 0.950 -variance introduced by outliers: 1.000% -variance is unaffected by outliers - -benchmarking manyAttributes (String) -collecting 100 samples, 6 iterations each, in estimated 1.736176 s -bootstrapping with 100000 resamples -mean: 3.218249 ms, lb 3.147520 ms, ub 3.293767 ms, ci 0.950 -std dev: 374.1855 us, lb 349.9660 us, ub 391.5972 us, ci 0.950 -variance introduced by outliers: 1.000% -variance is unaffected by outliers diff --git a/benchmarks/notes/bench_string_and_text-ghc-6.12.3 b/benchmarks/notes/bench_string_and_text-ghc-6.12.3 deleted file mode 100644 index 15973f0..0000000 --- a/benchmarks/notes/bench_string_and_text-ghc-6.12.3 +++ /dev/null @@ -1,144 +0,0 @@ -ghc-6.12.3 --make -O2 -fforce-recomp -ibenchmarks -main-is StringAndText StringAndText -echo ghc-6.12.3 -ghc-6.12.3 -./benchmarks/StringAndText --resamples 10000 -warming up -estimating clock resolution... -mean is 17.04065 us (40001 iterations) -found 3375 outliers among 39999 samples (8.4%) - 131 (0.3%) low severe - 1342 (3.4%) low mild - 536 (1.3%) high mild - 1366 (3.4%) high severe -estimating cost of a clock call... -mean is 1.461080 us (69 iterations) -found 5 outliers among 69 samples (7.2%) - 3 (4.3%) high mild - 2 (2.9%) high severe - -benchmarking TL.unpack :: LazyText -> String -collecting 100 samples, 1 iterations each, in estimated 5.718589 s -bootstrapping with 10000 resamples -mean: 10.14350 ms, lb 10.08825 ms, ub 10.26279 ms, ci 0.950 -std dev: 398.7148 us, lb 163.7693 us, ub 684.7091 us, ci 0.950 -found 5 outliers among 100 samples (5.0%) - 3 (3.0%) high mild - 2 (2.0%) high severe -variance introduced by outliers: 0.999% -variance is unaffected by outliers - -benchmarking TL.foldr :: LazyText -> String -collecting 100 samples, 8 iterations each, in estimated 1.847601 s -bootstrapping with 10000 resamples -mean: 2.350231 ms, lb 2.344587 ms, ub 2.360643 ms, ci 0.950 -std dev: 38.19062 us, lb 24.80574 us, ub 69.23253 us, ci 0.950 -found 4 outliers among 100 samples (4.0%) - 2 (2.0%) high mild - 2 (2.0%) high severe -variance introduced by outliers: 0.994% -variance is unaffected by outliers - -benchmarking fromString :: String --[Utf8 encoding]--> L.ByteString -collecting 100 samples, 12 iterations each, in estimated 1.771420 s -bootstrapping with 10000 resamples -mean: 1.466368 ms, lb 1.462081 ms, ub 1.476564 ms, ci 0.950 -std dev: 31.84601 us, lb 16.71494 us, ub 67.74246 us, ci 0.950 -found 18 outliers among 100 samples (18.0%) - 3 (3.0%) low mild - 12 (12.0%) high mild - 3 (3.0%) high severe -variance introduced by outliers: 0.997% -variance is unaffected by outliers - -benchmarking fromStrictTextUnpacked :: StrictText --[Utf8 encoding]--> L.ByteString -collecting 100 samples, 7 iterations each, in estimated 1.917475 s -bootstrapping with 10000 resamples -mean: 2.418367 ms, lb 2.377880 ms, ub 2.464558 ms, ci 0.950 -std dev: 224.0149 us, lb 206.1798 us, ub 254.8804 us, ci 0.950 -variance introduced by outliers: 1.000% -variance is unaffected by outliers - -benchmarking fromStrictTextFolded :: StrictText --[Utf8 encoding]--> L.ByteString -collecting 100 samples, 5 iterations each, in estimated 1.773566 s -bootstrapping with 10000 resamples -mean: 3.671555 ms, lb 3.624497 ms, ub 3.727544 ms, ci 0.950 -std dev: 259.9134 us, lb 227.3164 us, ub 289.9409 us, ci 0.950 -found 1 outliers among 100 samples (1.0%) -variance introduced by outliers: 1.000% -variance is unaffected by outliers - -benchmarking TS.encodeUtf8 :: StrictText --[Utf8 encoding]--> S.ByteString -collecting 100 samples, 2 iterations each, in estimated 1.885414 s -bootstrapping with 10000 resamples -mean: 9.717592 ms, lb 9.629451 ms, ub 9.832194 ms, ci 0.950 -std dev: 511.5830 us, lb 392.9119 us, ub 619.7238 us, ci 0.950 -found 15 outliers among 100 samples (15.0%) - 3 (3.0%) high mild - 12 (12.0%) high severe -variance introduced by outliers: 0.999% -variance is unaffected by outliers - -benchmarking fromLazyTextUnpacked :: LazyText --[Utf8 encoding]--> L.ByteString -collecting 100 samples, 2 iterations each, in estimated 2.057099 s -bootstrapping with 10000 resamples -mean: 10.64245 ms, lb 10.55541 ms, ub 10.76898 ms, ci 0.950 -std dev: 541.0501 us, lb 401.6060 us, ub 715.2630 us, ci 0.950 -found 13 outliers among 100 samples (13.0%) - 2 (2.0%) high mild - 11 (11.0%) high severe -variance introduced by outliers: 0.999% -variance is unaffected by outliers - -benchmarking fromLazyTextFolded :: LazyText --[Utf8 encoding]--> L.ByteString -collecting 100 samples, 4 iterations each, in estimated 1.883698 s -bootstrapping with 10000 resamples -mean: 4.942757 ms, lb 4.882399 ms, ub 5.015431 ms, ci 0.950 -std dev: 333.5807 us, lb 282.4905 us, ub 387.5383 us, ci 0.950 -found 22 outliers among 100 samples (22.0%) - 2 (2.0%) high mild - 20 (20.0%) high severe -variance introduced by outliers: 1.000% -variance is unaffected by outliers - -benchmarking TL.encodeUtf8 :: LazyText --[Utf8 encoding]--> L.ByteString -collecting 100 samples, 2 iterations each, in estimated 2.653909 s -bootstrapping with 10000 resamples -mean: 13.63214 ms, lb 13.54495 ms, ub 13.75497 ms, ci 0.950 -std dev: 535.2215 us, lb 426.5598 us, ub 645.6974 us, ci 0.950 -found 16 outliers among 100 samples (16.0%) - 2 (2.0%) high mild - 14 (14.0%) high severe -variance introduced by outliers: 0.999% -variance is unaffected by outliers - -benchmarking fromHtmlEscapedString :: String --[Html esc. & Utf8 encoding]--> L.ByteString -collecting 100 samples, 10 iterations each, in estimated 1.706555 s -bootstrapping with 10000 resamples -mean: 1.693403 ms, lb 1.691002 ms, ub 1.697351 ms, ci 0.950 -std dev: 15.61157 us, lb 10.90432 us, ub 25.54673 us, ci 0.950 -found 4 outliers among 100 samples (4.0%) - 2 (2.0%) high mild - 2 (2.0%) high severe -variance introduced by outliers: 0.990% -variance is unaffected by outliers - -benchmarking fromHtmlEscapedStrictTextUnpacked :: StrictText --[HTML esc. & Utf8 encoding]--> L.ByteString -collecting 100 samples, 8 iterations each, in estimated 1.894283 s -bootstrapping with 10000 resamples -mean: 2.300425 ms, lb 2.294907 ms, ub 2.307665 ms, ci 0.950 -std dev: 32.54546 us, lb 26.35558 us, ub 40.98003 us, ci 0.950 -found 5 outliers among 100 samples (5.0%) - 5 (5.0%) high mild -variance introduced by outliers: 0.992% -variance is unaffected by outliers - -benchmarking fromHtmlEscapedLazyTextUnpacked :: LazyText --[HTML esc. & Utf8 encoding]--> L.ByteString -collecting 100 samples, 2 iterations each, in estimated 2.188706 s -bootstrapping with 10000 resamples -mean: 10.58686 ms, lb 10.56533 ms, ub 10.62852 ms, ci 0.950 -std dev: 148.6497 us, lb 93.61102 us, ub 283.6501 us, ci 0.950 -found 3 outliers among 100 samples (3.0%) - 2 (2.0%) high mild - 1 (1.0%) high severe -variance introduced by outliers: 0.992% -variance is unaffected by outliers diff --git a/benchmarks/notes/bench_string_and_text-ghc-7.7.0.0.20100924 b/benchmarks/notes/bench_string_and_text-ghc-7.7.0.0.20100924 deleted file mode 100644 index 796fc9b..0000000 --- a/benchmarks/notes/bench_string_and_text-ghc-7.7.0.0.20100924 +++ /dev/null @@ -1,146 +0,0 @@ -ghc-7.0.0.20100924 --make -O2 -fforce-recomp -ibenchmarks -main-is StringAndText StringAndText -[1 of 9] Compiling Blaze.ByteString.Builder.Internal ( Text/Blaze/Builder/Internal.hs, Text/Blaze/Builder/Internal.o ) -[2 of 9] Compiling Blaze.ByteString.Builder.Write ( Text/Blaze/Builder/Write.hs, Text/Blaze/Builder/Write.o ) -[3 of 9] Compiling Blaze.ByteString.Builder.Char.Utf8 ( Text/Blaze/Builder/Char/Utf8.hs, Text/Blaze/Builder/Char/Utf8.o ) -[4 of 9] Compiling Blaze.ByteString.Builder.Word ( Text/Blaze/Builder/Word.hs, Text/Blaze/Builder/Word.o ) -[5 of 9] Compiling Blaze.ByteString.Builder.Int ( Text/Blaze/Builder/Int.hs, Text/Blaze/Builder/Int.o ) -[6 of 9] Compiling Blaze.ByteString.Builder.ByteString ( Text/Blaze/Builder/ByteString.hs, Text/Blaze/Builder/ByteString.o ) -[7 of 9] Compiling Blaze.ByteString.Builder ( Text/Blaze/Builder.hs, Text/Blaze/Builder.o ) -[8 of 9] Compiling Blaze.ByteString.Builder.Html.Utf8 ( Text/Blaze/Builder/Html/Utf8.hs, Text/Blaze/Builder/Html/Utf8.o ) -[9 of 9] Compiling StringAndText ( benchmarks/StringAndText.hs, benchmarks/StringAndText.o ) -echo ghc-7.0.0.20100924 -ghc-7.0.0.20100924 -./benchmarks/StringAndText --resamples 10000 -warming up -estimating clock resolution... -mean is 16.76892 us (40001 iterations) -found 2035 outliers among 39999 samples (5.1%) - 9 (2.3e-2%) low severe - 566 (1.4%) high mild - 1289 (3.2%) high severe -estimating cost of a clock call... -mean is 1.358619 us (74 iterations) -found 7 outliers among 74 samples (9.5%) - 3 (4.1%) high mild - 4 (5.4%) high severe - -benchmarking TL.unpack :: LazyText -> String -collecting 100 samples, 1 iterations each, in estimated 2.255201 s -bootstrapping with 10000 resamples -mean: 3.164735 ms, lb 3.154731 ms, ub 3.180340 ms, ci 0.950 -std dev: 62.97029 us, lb 47.34048 us, ub 99.49904 us, ci 0.950 -found 10 outliers among 100 samples (10.0%) - 7 (7.0%) high mild - 3 (3.0%) high severe -variance introduced by outliers: 0.996% -variance is unaffected by outliers - -benchmarking TL.foldr :: LazyText -> String -collecting 100 samples, 5 iterations each, in estimated 1.784563 s -bootstrapping with 10000 resamples -mean: 3.503787 ms, lb 3.498655 ms, ub 3.510877 ms, ci 0.950 -std dev: 30.53936 us, lb 23.84759 us, ub 41.59179 us, ci 0.950 -found 6 outliers among 100 samples (6.0%) - 4 (4.0%) high mild - 2 (2.0%) high severe -variance introduced by outliers: 0.990% -variance is unaffected by outliers - -benchmarking fromString :: String --[Utf8 encoding]--> L.ByteString -collecting 100 samples, 14 iterations each, in estimated 1.794976 s -bootstrapping with 10000 resamples -mean: 1.281082 ms, lb 1.277094 ms, ub 1.289682 ms, ci 0.950 -std dev: 29.39798 us, lb 15.70534 us, ub 55.49212 us, ci 0.950 -found 4 outliers among 100 samples (4.0%) - 3 (3.0%) high severe -variance introduced by outliers: 0.997% -variance is unaffected by outliers - -benchmarking fromStrictTextUnpacked :: StrictText --[Utf8 encoding]--> L.ByteString -collecting 100 samples, 8 iterations each, in estimated 1.770401 s -bootstrapping with 10000 resamples -mean: 2.393703 ms, lb 2.359663 ms, ub 2.430232 ms, ci 0.950 -std dev: 179.9504 us, lb 170.0655 us, ub 187.6502 us, ci 0.950 -variance introduced by outliers: 1.000% -variance is unaffected by outliers - -benchmarking fromStrictTextFolded :: StrictText --[Utf8 encoding]--> L.ByteString -collecting 100 samples, 4 iterations each, in estimated 1.892352 s -bootstrapping with 10000 resamples -mean: 4.343305 ms, lb 4.291738 ms, ub 4.406884 ms, ci 0.950 -std dev: 289.8338 us, lb 242.9020 us, ub 328.5388 us, ci 0.950 -found 20 outliers among 100 samples (20.0%) - 20 (20.0%) high severe -variance introduced by outliers: 1.000% -variance is unaffected by outliers - -benchmarking TS.encodeUtf8 :: StrictText --[Utf8 encoding]--> S.ByteString -collecting 100 samples, 7 iterations each, in estimated 1.906461 s -bootstrapping with 10000 resamples -mean: 2.543649 ms, lb 2.504738 ms, ub 2.585965 ms, ci 0.950 -std dev: 208.2177 us, lb 201.2286 us, ub 216.9054 us, ci 0.950 -variance introduced by outliers: 1.000% -variance is unaffected by outliers - -benchmarking fromLazyTextUnpacked :: LazyText --[Utf8 encoding]--> L.ByteString -collecting 100 samples, 5 iterations each, in estimated 1.693502 s -bootstrapping with 10000 resamples -mean: 3.515107 ms, lb 3.469601 ms, ub 3.570989 ms, ci 0.950 -std dev: 260.7349 us, lb 228.6872 us, ub 291.3777 us, ci 0.950 -found 19 outliers among 100 samples (19.0%) - 19 (19.0%) high mild -variance introduced by outliers: 1.000% -variance is unaffected by outliers - -benchmarking fromLazyTextFolded :: LazyText --[Utf8 encoding]--> L.ByteString -collecting 100 samples, 4 iterations each, in estimated 1.732302 s -bootstrapping with 10000 resamples -mean: 4.428189 ms, lb 4.375983 ms, ub 4.490870 ms, ci 0.950 -std dev: 295.6793 us, lb 250.2018 us, ub 333.3161 us, ci 0.950 -found 21 outliers among 100 samples (21.0%) - 21 (21.0%) high severe -variance introduced by outliers: 1.000% -variance is unaffected by outliers - -benchmarking TL.encodeUtf8 :: LazyText --[Utf8 encoding]--> L.ByteString -collecting 100 samples, 5 iterations each, in estimated 2.021313 s -bootstrapping with 10000 resamples -mean: 3.923355 ms, lb 3.832523 ms, ub 4.123685 ms, ci 0.950 -std dev: 661.0112 us, lb 274.1943 us, ub 1.148948 ms, ci 0.950 -found 3 outliers among 100 samples (3.0%) - 2 (2.0%) high severe -variance introduced by outliers: 1.000% -variance is unaffected by outliers - -benchmarking fromHtmlEscapedString :: String --[Html esc. & Utf8 encoding]--> L.ByteString -collecting 100 samples, 11 iterations each, in estimated 1.803237 s -bootstrapping with 10000 resamples -mean: 1.651575 ms, lb 1.649337 ms, ub 1.654994 ms, ci 0.950 -std dev: 13.90120 us, lb 10.29697 us, ub 20.96189 us, ci 0.950 -found 4 outliers among 100 samples (4.0%) - 3 (3.0%) high mild - 1 (1.0%) high severe -variance introduced by outliers: 0.990% -variance is unaffected by outliers - -benchmarking fromHtmlEscapedStrictTextUnpacked :: StrictText --[HTML esc. & Utf8 encoding]--> L.ByteString -collecting 100 samples, 8 iterations each, in estimated 1.849508 s -bootstrapping with 10000 resamples -mean: 2.353983 ms, lb 2.342031 ms, ub 2.372174 ms, ci 0.950 -std dev: 73.59482 us, lb 54.07068 us, ub 98.35096 us, ci 0.950 -found 12 outliers among 100 samples (12.0%) - 2 (2.0%) high mild - 10 (10.0%) high severe -variance introduced by outliers: 0.998% -variance is unaffected by outliers - -benchmarking fromHtmlEscapedLazyTextUnpacked :: LazyText --[HTML esc. & Utf8 encoding]--> L.ByteString -collecting 100 samples, 5 iterations each, in estimated 1.722440 s -bootstrapping with 10000 resamples -mean: 3.871486 ms, lb 3.746736 ms, ub 4.102136 ms, ci 0.950 -std dev: 844.5975 us, lb 529.5533 us, ub 1.291545 ms, ci 0.950 -found 10 outliers among 100 samples (10.0%) - 2 (2.0%) high mild - 8 (8.0%) high severe -variance introduced by outliers: 1.000% -variance is unaffected by outliers diff --git a/bsb-http-chunked.cabal b/bsb-http-chunked.cabal index 91d32b5..0e9ce4f 100644 --- a/bsb-http-chunked.cabal +++ b/bsb-http-chunked.cabal @@ -1,5 +1,5 @@ Name: bsb-http-chunked -Version: 0.0.0.1 +Version: 0.0.0.2 Synopsis: Chunked HTTP transfer encoding for bytestring builders Description: This library contains functions for encoding [bytestring @@ -27,8 +27,7 @@ Category: Data, Network Build-type: Simple Cabal-version: >= 1.8 -Extra-source-files: CHANGELOG.md, - tests/*.hs +Extra-source-files: CHANGELOG.md Source-repository head Type: git @@ -39,35 +38,10 @@ Library exposed-modules: Data.ByteString.Builder.HTTP.Chunked - other-modules: Blaze.ByteString.Builder - Blaze.ByteString.Builder.ByteString - Blaze.ByteString.Builder.Char8 + other-modules: Blaze.ByteString.Builder.Char8 Blaze.ByteString.Builder.Compat.Write - Blaze.ByteString.Builder.Int Blaze.ByteString.Builder.Internal.Write - Blaze.ByteString.Builder.Word build-depends: base >= 4.3 && < 4.12, bytestring >= 0.9 && < 0.11, bytestring-builder < 0.11 - -test-suite test - -- Turn off until the package is cleaned up - buildable: False - type: exitcode-stdio-1.0 - - hs-source-dirs: tests - main-is: Tests.hs - - ghc-options: -Wall -fno-warn-orphans - - build-depends: base - , blaze-builder - , bytestring - , HUnit - , QuickCheck - , test-framework - , test-framework-hunit - , test-framework-quickcheck2 - , text - , utf8-string diff --git a/tests/LlvmSegfault.hs b/tests/LlvmSegfault.hs deleted file mode 100644 index 02ced45..0000000 --- a/tests/LlvmSegfault.hs +++ /dev/null @@ -1,35 +0,0 @@ --- 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 deleted file mode 100644 index 3a6f413..0000000 --- a/tests/Tests.hs +++ /dev/null @@ -1,112 +0,0 @@ -{-# LANGUAGE CPP, OverloadedStrings #-} -#if __GLASGOW_HASKELL__ >= 704 -{-# OPTIONS_GHC -fsimpl-tick-factor=40000 #-} -#endif --- | Tests for the Blaze builder --- -module Main 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 - , testProperty "writeToByteString" writeToByteStringProp - , testCase "escaping case 1" escaping1 - , testCase "escaping case 2" escaping2 - , testCase "escaping case 3" escaping3 - ] - -monoidLeftIdentity :: Builder -> Bool -monoidLeftIdentity b = mappend mempty b == b - -monoidRightIdentity :: Builder -> Bool -monoidRightIdentity b = mappend b mempty == b - -monoidAssociativity :: Builder -> Builder -> Builder -> Bool -monoidAssociativity x y z = mappend x (mappend y z) == mappend (mappend x y) z - -monoidConcat :: [Builder] -> Bool -monoidConcat xs = mconcat xs == foldr mappend mempty xs - -fromStringToString :: String -> Bool -fromStringToString string = string == convert string - where - convert = decode . LB.unpack . toLazyByteString . fromString - -stringAndText :: String -> Bool -stringAndText string = fromString string == fromText (T.pack string) - -identityLazyByteString :: LB.ByteString -> Bool -identityLazyByteString lbs = lbs == toLazyByteString (fromLazyByteString lbs) - -identityFlushing :: String -> String -> Bool -identityFlushing s1 s2 = - let b1 = fromString s1 - b2 = fromString s2 - in b1 `mappend` b2 == b1 `mappend` flush `mappend` b2 - -writeToByteStringProp :: Write -> Bool -writeToByteStringProp w = toByteString (fromWrite w) == writeToByteString w - -escaping1 :: Assertion -escaping1 = fromString "<hello>" @?= fromHtmlEscapedString "" - -escaping2 :: Assertion -escaping2 = fromString "f &&& g" @?= fromHtmlEscapedString "f &&& g" - -escaping3 :: Assertion -escaping3 = fromString ""'" @?= fromHtmlEscapedString "\"'" - -instance Show Builder where - show = show . toLazyByteString - -instance Show Write where - show = show . fromWrite - -instance Eq Builder where - b1 == b2 = - -- different and small buffer sizses for testing wrapping behaviour - toLazyByteStringWith 1024 1024 256 b1 mempty == - toLazyByteStringWith 2001 511 256 b2 mempty - --- | Artificially scale up size to ensures that buffer wrapping behaviour is --- also tested. -numRepetitions :: Int -numRepetitions = 250 - -instance Arbitrary Builder where - arbitrary = (mconcat . replicate numRepetitions . fromString) <$> arbitrary - -instance Arbitrary Write where - arbitrary = mconcat . map singleWrite <$> arbitrary - where - singleWrite (Left bs) = writeByteString (mconcat (LB.toChunks bs)) - singleWrite (Right w) = writeWord8 w - -instance Arbitrary LB.ByteString where - arbitrary = (LB.concat . replicate numRepetitions . LB.pack) <$> arbitrary