blaze-builder-0.4.0.2/0000755000000000000000000000000012705234666012575 5ustar0000000000000000blaze-builder-0.4.0.2/Makefile0000644000000000000000000001357612705234666014251 0ustar0000000000000000 ############################################################################## ## 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 blaze-builder-0.4.0.2/TODO0000644000000000000000000000665312705234666013277 0ustar0000000000000000 !! UPDATE TODO !! !! UPDATE BENCHMARKS !! * custom serialization functions for lists of 'WordX's - benchmark chunk size speedup for more complicated computations of list elements => to be expected that we get no speedup anymore or even a slowdown => adapt Blaze.ByteString.Builder.Word accordingly. * fast serialization for 'Text' values (currently unpacking to 'String' is the fastest :-/) * implementation - further encodings for 'Char' - think about end-of-buffer wrapping when copying bytestrings - toByteStringIO with accumulator capability => provide 'toByteStringIO_' - allow buildr/foldr deforestation to happen for input to 'fromWriteList' (or whatever stream fusion framework is in place for lists) - implement 'toByteString' with an amortized O(n) runtime using the exponentional scaling trick. If the start size is chosen wisely this may even be faster than 'S.pack', as the one copy per element is cheaper than one list thunk per element. It is even likely that we can amortize three copies per element, which allows to avoid spilling any buffer space by doing a last compaction copy. - we could provide builders that honor alignment restrictions, either as builder transformers or as specialized write to builder converters. The trick is for the driver to ensure that the buffer beginning is aligned to the largest aligning (8 or 16 bytes?) required. This is probably the case by default. Then we can always align a pointer in the buffer by appropriately aligning the write pointer. * extend tests to new functions * benchmarks - understand why the declarative blaze-builder version is the fastest serializer for Word64 little-endian and big-endian - check the cost of using `mappend` on builders instead of writes. - show that using toByteStringIO has an advantage over toLazyByteString - check performance of toByteStringIO - compare speed of 'L.pack' to speed of 'toLazyByteString . fromWord8s' * documentation - sort out formultion: "serialization" vs. "encoding" * check portability to Hugs * performance: - check if reordering 'pe' and 'pf' change performance; it seems that 'pe' is only a reader argument while 'pf' is a state argument. - perhaps we could improve performance by taking page size, page alignment, and memory access alignment into account. - detect machine endianness and use host order writes for the supported endianness. - introduce a type 'BoundedWrite' that encapsulates a 'Write' generator with a bound on the number of bytes maximally written by the write. This way we can achieve data independence for the size check by sacrificing just a little bit of buffer space at buffer ends. - investigate where we would profit from static bounds on number of bytes written (e.g. to make the control flow more linear) * testing - port tests from 'Data.Binary.Builder' to ensure that the word writes and builders are working correctly. I may have missed some pitfalls about word types in Haskell during porting the functions from 'Data.Binary.Builder'. * portability - port to Hugs - test lower versions of GHC * deployment - add source repository to 'blaze-html' and 'blaze-builder' cabal files blaze-builder-0.4.0.2/blaze-builder.cabal0000644000000000000000000000652712705234666016314 0ustar0000000000000000Name: blaze-builder Version: 0.4.0.2 Synopsis: Efficient buffered output. Description: This library provides an implementation of the older blaze-builder interface in terms of the new builder that shipped with bytestring-0.10.4.0 . This implementation is mostly intended as a bridge to the new builder, so that code that uses the old interface can interoperate with code that uses the new implementation. Note that no attempt has been made to preserve the old internal modules, so code that has these dependencies cannot use this interface. . New code should, for the most part, use the new interface. However, this module does implement a chunked HTTP encoding, which is not otherwise implemented (yet?) with the new builder. Author: Jasper Van der Jeugt, Simon Meier, Leon P Smith Copyright: (c) 2010-2014 Simon Meier (c) 2010 Jasper Van der Jeugt (c) 2013-2015 Leon P Smith Maintainer: Leon Smith License: BSD3 License-file: LICENSE Homepage: http://github.com/lpsmith/blaze-builder Bug-Reports: http://github.com/lpsmith/blaze-builder/issues Stability: Experimental Category: Data Build-type: Simple Cabal-version: >= 1.8 Extra-source-files: Makefile README.markdown TODO CHANGES benchmarks/*.hs benchmarks/Throughput/*.hs benchmarks/Throughput/*.h benchmarks/Throughput/*.c tests/*.hs Source-repository head Type: git Location: https://github.com/lpsmith/blaze-builder.git Library ghc-options: -Wall exposed-modules: Blaze.ByteString.Builder Blaze.ByteString.Builder.Int Blaze.ByteString.Builder.Word Blaze.ByteString.Builder.ByteString Blaze.ByteString.Builder.Char.Utf8 Blaze.ByteString.Builder.Char8 Blaze.ByteString.Builder.Html.Utf8 Blaze.ByteString.Builder.HTTP Blaze.ByteString.Builder.Compat.Write Blaze.ByteString.Builder.Internal.Write build-depends: base == 4.* , deepseq, text >= 0.10 && < 1.3 if impl(ghc < 7.8) build-depends: bytestring >= 0.9 && < 1.0, bytestring-builder else build-depends: bytestring >= 0.10.4 && < 1.0 test-suite test 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 blaze-builder-0.4.0.2/Setup.hs0000644000000000000000000000005612705234666014232 0ustar0000000000000000import Distribution.Simple main = defaultMain blaze-builder-0.4.0.2/CHANGES0000644000000000000000000001231012705234666013565 0ustar0000000000000000* 0.4.0.2 - Fixed warnings on GHC 7.10, courtesy of Mikhail Glushenkov. * 0.4.0.1 - Tightened the version constraints on the bytestring package for GHC 7.8 * 0.4.0.0 - This is now a compatibility shim for the new bytestring builder. Most of the old internal modules are gone. See this blog post for more information: - The 'Blaze.ByteString.Builder.Html.Utf8.fromHtmlEscaped*' functions now strip out any ASCII control characters present in their inputs. See for more information. * 0.3.3.0 - exposed the 'Buffer' constructor to enable keeping around a pool of buffers. * 0.3.2.0 - added 'writeToByteString' to construct a strict bytestring in a single step. We can actually view 'Write's as strict-bytestring builders. * 0.3.1.1 - Changed imports of Foreign.Unsafe to make it GHC 7.8 compatible - -Wall clean on GHC 7.0 - 7.6 * 0.3.1.0 - Widened dependencies on text and bytestring * 0.3.0.1 - Fix build warning in Blaze.ByteString.Builder.Word (contributed by Greg Weber) * 0.3.0.1 - Remove comparison to the 'text' library encoding functions of 'Blaze.Builder.Char.Utf8.fromText' and 'Blaze.Builder.Char.Utf8.fromLazyText'. Bryan O'Sullivan reported that on his 64-bit system with GHC 7.0.3 the 'text' library is 5x faster than the 'blaze-builder' library. * 0.3.0.0 - Renamings in internal modules: WriteIO -> Poke and associated functions. * 0.2.1.4 - Fixed bug: appending to 'chunkedTransferEncoding somebuilder' also encoded the appended builder, which is obviously wrong. * 0.2.1.3 - Fixed bug: 'chunkedTransferTerminator' is now correctly set to "0\r\n\r\n". * 0.2.1.2 - Add 'MonoPatBinds' language extension to all relevant files to solve the issues caused by GHC bug http://hackage.haskell.org/trac/ghc/ticket/4498 * 0.2.1.1 - Reexport 'Write' datatype and 'fromWriteList', 'fromWriteSingleton', 'fromWrite' functions together with writes and builders for storables. - Add 'MonoPatBinds' language extension to (hopefully) solve the issues caused by GHC bug http://hackage.haskell.org/trac/ghc/ticket/4498 * 0.2.1.0 Incorporated several design changes: - Writable buffer range is now represented in a packed form. This improves speed slightly, as less currying is used. - Writes are abstracted such that their internal representation can be exchanged without breaking other library code. - Writes are represented in a form that allows for efficient monoid instances for branching code like UTF-8 encoding. For single character encoding this results currently in a slight slowdown due to GHC not recognizing the strictness of the returned value. This will be fixed in the future. - BuildSteps support returning a result in `Done`, which enables to implement a `Put` monad using CPS. - chunked list writes were removed, as they result in worse performance when writing non-trivial lists. (cf. benchmarks) - An internal buffering abstraction is introduced, which is used both by the adaption of the `binary` package, as well as by the `blaze-builder-enumeratee` package, to execute puts and builders. It will be used later also by the execution functions of the `blaze-builder` package. Implemented new functionality - `Blaze.ByteString.Builder.HTTP` provides a builder transformer for doing in-buffer chunked HTTP encoding of an arbitary other builder. - `Blaze.ByteString.Builder.Char8` provides functions to serialize the lower 8-bits of characters similiar to what `Data.ByteString.Char8` provides for bytestrings. * 0.2.0.3 Loosen 'text' dependency to '>= 0.10 && < 0.12' * 0.2.0.2 Fixed bug: use ' instead of ' for HTML escaping ' * 0.2.0.1 Added a missing benchmark file. * blaze-builder-0.2.0.0 Heavily restructured 'blaze-builder' such that 'Blaze.ByteString.Builder' serves as a drop-in replacement of 'binary:Data.Binary.Builder' which it improves upon with respect to both speed as well as expressivity. See the documentation and the benchmarks for details on improvements and new functionality. Changed module structure: Blaze.ByteString.Builder.Core -> Blaze.ByteString.Builder Blaze.ByteString.Builder.Utf8 -> Blaze.ByteString.Builder.Char.Utf8 Blaze.ByteString.Builder.Html -> Blaze.ByteString.Builder.Html.Utf8 Changed function names: writeByte -> writeWord8 fromByte -> fromWord8 fromWriteList -> fromWrite1List Possibly performance sensitive implementation changes: - 'fromByteString' and 'fromLazyByteString' check now if a direct insertion of the bytestring(s) would be cheaper than copying it. See their documentation on how to recover the old behaviour. Deprecated functions: 'empty' : use 'mempty' instead 'singleton': use 'fromWord8' instead 'append' : use 'mappend' instead * blaze-builder-0.1 This is the first version of 'blaze-builder'. It is explicitely targeted at fast generation of UTF-8 encoded HTML documents in the 'blaze-html' and the 'hamlet' HTML templating libraries. blaze-builder-0.4.0.2/README.markdown0000644000000000000000000000340712705234666015302 0ustar0000000000000000blaze-builder ============= [![Continuous Integration status][status-png]][status] [![Hackage page (downloads and API reference)][hackage-png]][hackage] This library allows to efficiently serialize Haskell values to lazy bytestrings with a large average chunk size. The large average chunk size allows to make good use of cache prefetching in later processing steps (e.g. compression) and reduces the system call overhead when writing the resulting lazy bytestring to a file or sending it over the network. This library was inspired by the module Data.Binary.Builder provided by the binary package. It was originally developed with the specific needs of the blaze-html package in mind. Since then it has been restructured to serve as a drop-in replacement for Data.Binary.Builder, which it improves upon both in speed as well as expressivity. To see the improvements in speed, run the throughput benchmark, which measures serialization speeds for writing Word8, Word16, Word32 and Word64 in different endian formats and different chunk sizes, using the command make bench-throughput or run the list serialization comparison benchmark make bench-blaze-vs-binary Checkout the combinators in the module "Blaze.ByteString.Builder.Write" to see the improvements in expressivity. This module allows to incorporate efficient primitive buffer manipulations as parts of a builder. We use this facility in the 'blaze-html' HTML templating library to allow for the efficient serialization of HTML escaped and UTF-8 encoded characters. [status-png]: https://api.travis-ci.org/lpsmith/blaze-builder.svg [status]: http://travis-ci.org/lpsmith/blaze-builder?branch=master [hackage-png]: http://img.shields.io/hackage/v/blaze-builder.svg [hackage]: http://hackage.haskell.org/package/blaze-builder blaze-builder-0.4.0.2/LICENSE0000644000000000000000000000302612705234666013603 0ustar0000000000000000Copyright Jasper Van der Jeugt 2010, Simon Meier 2010 & 2011 All rights reserved. Redistribution and use in source and binary forms, with or without modification, are permitted provided that the following conditions are met: * Redistributions of source code must retain the above copyright notice, this list of conditions and the following disclaimer. * Redistributions in binary form must reproduce the above copyright notice, this list of conditions and the following disclaimer in the documentation and/or other materials provided with the distribution. * Neither the name of Jasper Van der Jeugt nor the names of other contributors may be used to endorse or promote products derived from this software without specific prior written permission. THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. blaze-builder-0.4.0.2/benchmarks/0000755000000000000000000000000012705234666014712 5ustar0000000000000000blaze-builder-0.4.0.2/benchmarks/FastPut.hs0000644000000000000000000006076112705234666016646 0ustar0000000000000000{-# 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 ] blaze-builder-0.4.0.2/benchmarks/Utf8IO.hs0000644000000000000000000000734112705234666016331 0ustar0000000000000000{-# 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 blaze-builder-0.4.0.2/benchmarks/Compression.hs0000644000000000000000000000336312705234666017554 0ustar0000000000000000-- | -- 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 blaze-builder-0.4.0.2/benchmarks/BlazeVsBinary.hs0000644000000000000000000000512512705234666017764 0ustar0000000000000000{-# 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 #-} blaze-builder-0.4.0.2/benchmarks/BenchThroughput.hs0000644000000000000000000001645512705234666020372 0ustar0000000000000000----------------------------------------------------------------------------- -- | -- 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 blaze-builder-0.4.0.2/benchmarks/StrictIO.hs0000644000000000000000000000100412705234666016741 0ustar0000000000000000{-# LANGUAGE BangPatterns #-} -- | Demonstrate the problem with IO not allowing for unlifted types. -- -- TODO: Not yet finished. module StrictIO where loop :: Int -> Int -> IO () loop !i !c | i == 1 = print c | otherwise = do !i' <- subcases print i' loop i' (c+1) where subcases | i `mod` 2 == 0 = do print "even" return $ i `div` 2 | otherwise = do print "odd" return $ i + 1 {-# INLINE subcases #-} blaze-builder-0.4.0.2/benchmarks/UnboxedAppend.hs0000644000000000000000000002215212705234666020004 0ustar0000000000000000{-# 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) blaze-builder-0.4.0.2/benchmarks/StringAndText.hs0000644000000000000000000001114312705234666020004 0ustar0000000000000000{-# 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 #-} -} blaze-builder-0.4.0.2/benchmarks/BoundedWrite.hs0000644000000000000000000002053212705234666017643 0ustar0000000000000000{-# 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 #-} blaze-builder-0.4.0.2/benchmarks/BuilderBufferRange.hs0000644000000000000000000004342312705234666020751 0ustar0000000000000000{-# 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 #-} -} blaze-builder-0.4.0.2/benchmarks/LazyByteString.hs0000644000000000000000000006634712705234666020220 0ustar0000000000000000{-# 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 blaze-builder-0.4.0.2/benchmarks/PlotTest.hs0000644000000000000000000001365512705234666017036 0ustar0000000000000000----------------------------------------------------------------------------- -- | -- 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) -} blaze-builder-0.4.0.2/benchmarks/ChunkedWrite.hs0000644000000000000000000001305212705234666017643 0ustar0000000000000000{-# 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 blaze-builder-0.4.0.2/benchmarks/BenchmarkServer.hs0000644000000000000000000000627012705234666020334 0ustar0000000000000000{- Benchmark server based upon Jasper van der Jeugt's 'BenchmarkServer.lhs' from blaze-html. Modified for network-2.3 by Simon Meier -} {-# LANGUAGE OverloadedStrings #-} module BenchmarkServer where import Prelude hiding (putStrLn) import Data.Char (ord) import Data.Monoid import Data.ByteString.Char8 () -- IsString instance only import qualified Data.ByteString as S import qualified Data.ByteString.Lazy as L import qualified Data.ByteString.Lazy.Internal as L import Control.Concurrent (forkIO, putMVar, takeMVar, newEmptyMVar) import Control.Exception (bracket) import Control.Monad import Network.Socket (Socket, accept, sClose) import Network (listenOn, PortID (PortNumber)) import Network.Socket.ByteString as S import Network.Socket.ByteString.Lazy as L import System (getArgs) import Blaze.ByteString.Builder import Blaze.ByteString.Builder.Internal (defaultBufferSize, defaultMinimalBufferSize) import Blaze.ByteString.Builder.Char.Utf8 import Criterion.Main httpOkHeader :: S.ByteString httpOkHeader = S.concat [ "HTTP/1.1 200 OK\r\n" , "Content-Type: text/html; charset=UTF-8\r\n" , "\r\n" ] response :: Int -> Builder response n = fromByteString httpOkHeader `mappend` fromString (take n $ cycle "hello λ-world! ") sendVectoredBuilderLBS :: Socket -> Builder -> IO () sendVectoredBuilderLBS s = L.sendAll s . toLazyByteString {-# NOINLINE sendVectoredBuilderLBS #-} sendBuilderLBS :: Socket -> Builder -> IO () sendBuilderLBS s = -- mapM_ (S.sendAll s) . L.toChunks . toLazyByteString L.foldrChunks (\c -> (S.sendAll s c >>)) (return ()). toLazyByteString {-# NOINLINE sendBuilderLBS #-} sendBuilderBSIO :: Socket -> Builder -> IO () sendBuilderBSIO s = toByteStringIO $ S.sendAll s {-# NOINLINE sendBuilderBSIO #-} -- criterion benchmark determining the speed of response main2 = defaultMain [ bench ("response " ++ show n) $ whnf (L.length . toLazyByteString . response) n ] where n :: Int n = 1000000 main :: IO () main = do [port, nChars] <- map read `liftM` getArgs killSignal <- newEmptyMVar bracket (listenOn . PortNumber . fromIntegral $ port) sClose (\socket -> do _ <- forkIO $ loop (putMVar killSignal ()) nChars socket takeMVar killSignal) where loop killServer nChars socket = forever $ do (s, _) <- accept socket forkIO (respond s nChars) where respond s n = do input <- S.recv s 1024 let requestUrl = (S.split (fromIntegral $ ord ' ') input) !! 1 case tail (S.split (fromIntegral $ ord '/') requestUrl) of ["lbs"] -> sendBuilderLBS s $ response n ["lbs-vec"] -> sendVectoredBuilderLBS s $ response n ["bs-io"] -> sendBuilderBSIO s $ response n ["kill"] -> notFound s >> killServer _ -> notFound s sClose s notFound s = do _ <- S.sendAll s $ "HTTP/1.1 404 Not Found\r\n" `mappend` "Content-Type: text/html; charset=UTF-8\r\n" `mappend` "\r\n" `mappend` "

Page not found

" return () blaze-builder-0.4.0.2/benchmarks/Throughput/0000755000000000000000000000000012705234666017063 5ustar0000000000000000blaze-builder-0.4.0.2/benchmarks/Throughput/BinaryPut.hs0000644000000000000000000004661612705234666021351 0ustar0000000000000000{-# LANGUAGE BangPatterns #-} module Throughput.BinaryPut (serialize) where import qualified Data.ByteString.Lazy as L import Data.Binary.Put import Throughput.Utils serialize :: Int -> Int -> Endian -> Int -> L.ByteString serialize wordSize chunkSize end = runPut . case (wordSize, chunkSize, end) of (1, 1,_) -> putWord8N1 (1, 2,_) -> putWord8N2 (1, 4,_) -> putWord8N4 (1, 8,_) -> putWord8N8 (1, 16, _) -> putWord8N16 (2, 1, Big) -> putWord16N1Big (2, 2, Big) -> putWord16N2Big (2, 4, Big) -> putWord16N4Big (2, 8, Big) -> putWord16N8Big (2, 16, Big) -> putWord16N16Big (2, 1, Little) -> putWord16N1Little (2, 2, Little) -> putWord16N2Little (2, 4, Little) -> putWord16N4Little (2, 8, Little) -> putWord16N8Little (2, 16, Little) -> putWord16N16Little (2, 1, Host) -> putWord16N1Host (2, 2, Host) -> putWord16N2Host (2, 4, Host) -> putWord16N4Host (2, 8, Host) -> putWord16N8Host (2, 16, Host) -> putWord16N16Host (4, 1, Big) -> putWord32N1Big (4, 2, Big) -> putWord32N2Big (4, 4, Big) -> putWord32N4Big (4, 8, Big) -> putWord32N8Big (4, 16, Big) -> putWord32N16Big (4, 1, Little) -> putWord32N1Little (4, 2, Little) -> putWord32N2Little (4, 4, Little) -> putWord32N4Little (4, 8, Little) -> putWord32N8Little (4, 16, Little) -> putWord32N16Little (4, 1, Host) -> putWord32N1Host (4, 2, Host) -> putWord32N2Host (4, 4, Host) -> putWord32N4Host (4, 8, Host) -> putWord32N8Host (4, 16, Host) -> putWord32N16Host (8, 1, Host) -> putWord64N1Host (8, 2, Host) -> putWord64N2Host (8, 4, Host) -> putWord64N4Host (8, 8, Host) -> putWord64N8Host (8, 16, Host) -> putWord64N16Host (8, 1, Big) -> putWord64N1Big (8, 2, Big) -> putWord64N2Big (8, 4, Big) -> putWord64N4Big (8, 8, Big) -> putWord64N8Big (8, 16, Big) -> putWord64N16Big (8, 1, Little) -> putWord64N1Little (8, 2, Little) -> putWord64N2Little (8, 4, Little) -> putWord64N4Little (8, 8, Little) -> putWord64N8Little (8, 16, Little) -> putWord64N16Little ------------------------------------------------------------------------ putWord8N1 bytes = loop 0 0 where loop !s !n | n == bytes = return () | otherwise = do putWord8 s loop (s+1) (n+1) putWord8N2 = loop 0 where loop s n | s `seq` n `seq` False = undefined loop _ 0 = return () loop s n = do putWord8 (s+0) putWord8 (s+1) loop (s+2) (n-2) putWord8N4 = loop 0 where loop s n | s `seq` n `seq` False = undefined loop _ 0 = return () loop s n = do putWord8 (s+0) putWord8 (s+1) putWord8 (s+2) putWord8 (s+3) loop (s+4) (n-4) putWord8N8 = loop 0 where loop s n | s `seq` n `seq` False = undefined loop _ 0 = return () loop s n = do putWord8 (s+0) putWord8 (s+1) putWord8 (s+2) putWord8 (s+3) putWord8 (s+4) putWord8 (s+5) putWord8 (s+6) putWord8 (s+7) loop (s+8) (n-8) putWord8N16 = loop 0 where loop s n | s `seq` n `seq` False = undefined loop _ 0 = return () loop s n = do putWord8 (s+0) putWord8 (s+1) putWord8 (s+2) putWord8 (s+3) putWord8 (s+4) putWord8 (s+5) putWord8 (s+6) putWord8 (s+7) putWord8 (s+8) putWord8 (s+9) putWord8 (s+10) putWord8 (s+11) putWord8 (s+12) putWord8 (s+13) putWord8 (s+14) putWord8 (s+15) loop (s+16) (n-16) ------------------------------------------------------------------------ -- Big endian, word16 writes putWord16N1Big = loop 0 where loop s n | s `seq` n `seq` False = undefined loop _ 0 = return () loop s n = do putWord16be (s+0) loop (s+1) (n-1) putWord16N2Big = loop 0 where loop s n | s `seq` n `seq` False = undefined loop _ 0 = return () loop s n = do putWord16be (s+0) putWord16be (s+1) loop (s+2) (n-2) putWord16N4Big = loop 0 where loop s n | s `seq` n `seq` False = undefined loop _ 0 = return () loop s n = do putWord16be (s+0) putWord16be (s+1) putWord16be (s+2) putWord16be (s+3) loop (s+4) (n-4) putWord16N8Big = loop 0 where loop s n | s `seq` n `seq` False = undefined loop _ 0 = return () loop s n = do putWord16be (s+0) putWord16be (s+1) putWord16be (s+2) putWord16be (s+3) putWord16be (s+4) putWord16be (s+5) putWord16be (s+6) putWord16be (s+7) loop (s+8) (n-8) putWord16N16Big = loop 0 where loop s n | s `seq` n `seq` False = undefined loop _ 0 = return () loop s n = do putWord16be (s+0) putWord16be (s+1) putWord16be (s+2) putWord16be (s+3) putWord16be (s+4) putWord16be (s+5) putWord16be (s+6) putWord16be (s+7) putWord16be (s+8) putWord16be (s+9) putWord16be (s+10) putWord16be (s+11) putWord16be (s+12) putWord16be (s+13) putWord16be (s+14) putWord16be (s+15) loop (s+16) (n-16) ------------------------------------------------------------------------ -- Little endian, word16 writes putWord16N1Little = loop 0 where loop s n | s `seq` n `seq` False = undefined loop _ 0 = return () loop s n = do putWord16le (s+0) loop (s+1) (n-1) putWord16N2Little = loop 0 where loop s n | s `seq` n `seq` False = undefined loop _ 0 = return () loop s n = do putWord16le (s+0) putWord16le (s+1) loop (s+2) (n-2) putWord16N4Little = loop 0 where loop s n | s `seq` n `seq` False = undefined loop _ 0 = return () loop s n = do putWord16le (s+0) putWord16le (s+1) putWord16le (s+2) putWord16le (s+3) loop (s+4) (n-4) putWord16N8Little = loop 0 where loop s n | s `seq` n `seq` False = undefined loop _ 0 = return () loop s n = do putWord16le (s+0) putWord16le (s+1) putWord16le (s+2) putWord16le (s+3) putWord16le (s+4) putWord16le (s+5) putWord16le (s+6) putWord16le (s+7) loop (s+8) (n-8) putWord16N16Little = loop 0 where loop s n | s `seq` n `seq` False = undefined loop _ 0 = return () loop s n = do putWord16le (s+0) putWord16le (s+1) putWord16le (s+2) putWord16le (s+3) putWord16le (s+4) putWord16le (s+5) putWord16le (s+6) putWord16le (s+7) putWord16le (s+8) putWord16le (s+9) putWord16le (s+10) putWord16le (s+11) putWord16le (s+12) putWord16le (s+13) putWord16le (s+14) putWord16le (s+15) loop (s+16) (n-16) ------------------------------------------------------------------------ -- Host endian, unaligned, word16 writes putWord16N1Host = loop 0 where loop s n | s `seq` n `seq` False = undefined loop _ 0 = return () loop s n = do putWord16host (s+0) loop (s+1) (n-1) putWord16N2Host = loop 0 where loop s n | s `seq` n `seq` False = undefined loop _ 0 = return () loop s n = do putWord16host (s+0) putWord16host (s+1) loop (s+2) (n-2) putWord16N4Host = loop 0 where loop s n | s `seq` n `seq` False = undefined loop _ 0 = return () loop s n = do putWord16host (s+0) putWord16host (s+1) putWord16host (s+2) putWord16host (s+3) loop (s+4) (n-4) putWord16N8Host = loop 0 where loop s n | s `seq` n `seq` False = undefined loop _ 0 = return () loop s n = do putWord16host (s+0) putWord16host (s+1) putWord16host (s+2) putWord16host (s+3) putWord16host (s+4) putWord16host (s+5) putWord16host (s+6) putWord16host (s+7) loop (s+8) (n-8) putWord16N16Host = loop 0 where loop s n | s `seq` n `seq` False = undefined loop _ 0 = return () loop s n = do putWord16host (s+0) putWord16host (s+1) putWord16host (s+2) putWord16host (s+3) putWord16host (s+4) putWord16host (s+5) putWord16host (s+6) putWord16host (s+7) putWord16host (s+8) putWord16host (s+9) putWord16host (s+10) putWord16host (s+11) putWord16host (s+12) putWord16host (s+13) putWord16host (s+14) putWord16host (s+15) loop (s+16) (n-16) ------------------------------------------------------------------------ putWord32N1Big = loop 0 where loop s n | s `seq` n `seq` False = undefined loop _ 0 = return () loop s n = do putWord32be (s+0) loop (s+1) (n-1) putWord32N2Big = loop 0 where loop s n | s `seq` n `seq` False = undefined loop _ 0 = return () loop s n = do putWord32be (s+0) putWord32be (s+1) loop (s+2) (n-2) putWord32N4Big = loop 0 where loop s n | s `seq` n `seq` False = undefined loop _ 0 = return () loop s n = do putWord32be (s+0) putWord32be (s+1) putWord32be (s+2) putWord32be (s+3) loop (s+4) (n-4) putWord32N8Big = loop 0 where loop s n | s `seq` n `seq` False = undefined loop _ 0 = return () loop s n = do putWord32be (s+0) putWord32be (s+1) putWord32be (s+2) putWord32be (s+3) putWord32be (s+4) putWord32be (s+5) putWord32be (s+6) putWord32be (s+7) loop (s+8) (n-8) putWord32N16Big = loop 0 where loop s n | s `seq` n `seq` False = undefined loop _ 0 = return () loop s n = do putWord32be (s+0) putWord32be (s+1) putWord32be (s+2) putWord32be (s+3) putWord32be (s+4) putWord32be (s+5) putWord32be (s+6) putWord32be (s+7) putWord32be (s+8) putWord32be (s+9) putWord32be (s+10) putWord32be (s+11) putWord32be (s+12) putWord32be (s+13) putWord32be (s+14) putWord32be (s+15) loop (s+16) (n-16) ------------------------------------------------------------------------ putWord32N1Little = loop 0 where loop s n | s `seq` n `seq` False = undefined loop _ 0 = return () loop s n = do putWord32le (s+0) loop (s+1) (n-1) putWord32N2Little = loop 0 where loop s n | s `seq` n `seq` False = undefined loop _ 0 = return () loop s n = do putWord32le (s+0) putWord32le (s+1) loop (s+2) (n-2) putWord32N4Little = loop 0 where loop s n | s `seq` n `seq` False = undefined loop _ 0 = return () loop s n = do putWord32le (s+0) putWord32le (s+1) putWord32le (s+2) putWord32le (s+3) loop (s+4) (n-4) putWord32N8Little = loop 0 where loop s n | s `seq` n `seq` False = undefined loop _ 0 = return () loop s n = do putWord32le (s+0) putWord32le (s+1) putWord32le (s+2) putWord32le (s+3) putWord32le (s+4) putWord32le (s+5) putWord32le (s+6) putWord32le (s+7) loop (s+8) (n-8) putWord32N16Little = loop 0 where loop s n | s `seq` n `seq` False = undefined loop _ 0 = return () loop s n = do putWord32le (s+0) putWord32le (s+1) putWord32le (s+2) putWord32le (s+3) putWord32le (s+4) putWord32le (s+5) putWord32le (s+6) putWord32le (s+7) putWord32le (s+8) putWord32le (s+9) putWord32le (s+10) putWord32le (s+11) putWord32le (s+12) putWord32le (s+13) putWord32le (s+14) putWord32le (s+15) loop (s+16) (n-16) ------------------------------------------------------------------------ putWord32N1Host = loop 0 where loop s n | s `seq` n `seq` False = undefined loop _ 0 = return () loop s n = do putWord32host (s+0) loop (s+1) (n-1) putWord32N2Host = loop 0 where loop s n | s `seq` n `seq` False = undefined loop _ 0 = return () loop s n = do putWord32host (s+0) putWord32host (s+1) loop (s+2) (n-2) putWord32N4Host = loop 0 where loop s n | s `seq` n `seq` False = undefined loop _ 0 = return () loop s n = do putWord32host (s+0) putWord32host (s+1) putWord32host (s+2) putWord32host (s+3) loop (s+4) (n-4) putWord32N8Host = loop 0 where loop s n | s `seq` n `seq` False = undefined loop _ 0 = return () loop s n = do putWord32host (s+0) putWord32host (s+1) putWord32host (s+2) putWord32host (s+3) putWord32host (s+4) putWord32host (s+5) putWord32host (s+6) putWord32host (s+7) loop (s+8) (n-8) putWord32N16Host = loop 0 where loop s n | s `seq` n `seq` False = undefined loop _ 0 = return () loop s n = do putWord32host (s+0) putWord32host (s+1) putWord32host (s+2) putWord32host (s+3) putWord32host (s+4) putWord32host (s+5) putWord32host (s+6) putWord32host (s+7) putWord32host (s+8) putWord32host (s+9) putWord32host (s+10) putWord32host (s+11) putWord32host (s+12) putWord32host (s+13) putWord32host (s+14) putWord32host (s+15) loop (s+16) (n-16) ------------------------------------------------------------------------ putWord64N1Big = loop 0 where loop s n | s `seq` n `seq` False = undefined loop _ 0 = return () loop s n = do putWord64be (s+0) loop (s+1) (n-1) putWord64N2Big = loop 0 where loop s n | s `seq` n `seq` False = undefined loop _ 0 = return () loop s n = do putWord64be (s+0) putWord64be (s+1) loop (s+2) (n-2) putWord64N4Big = loop 0 where loop s n | s `seq` n `seq` False = undefined loop _ 0 = return () loop s n = do putWord64be (s+0) putWord64be (s+1) putWord64be (s+2) putWord64be (s+3) loop (s+4) (n-4) putWord64N8Big = loop 0 where loop s n | s `seq` n `seq` False = undefined loop _ 0 = return () loop s n = do putWord64be (s+0) putWord64be (s+1) putWord64be (s+2) putWord64be (s+3) putWord64be (s+4) putWord64be (s+5) putWord64be (s+6) putWord64be (s+7) loop (s+8) (n-8) putWord64N16Big = loop 0 where loop s n | s `seq` n `seq` False = undefined loop _ 0 = return () loop s n = do putWord64be (s+0) putWord64be (s+1) putWord64be (s+2) putWord64be (s+3) putWord64be (s+4) putWord64be (s+5) putWord64be (s+6) putWord64be (s+7) putWord64be (s+8) putWord64be (s+9) putWord64be (s+10) putWord64be (s+11) putWord64be (s+12) putWord64be (s+13) putWord64be (s+14) putWord64be (s+15) loop (s+16) (n-16) ------------------------------------------------------------------------ putWord64N1Little = loop 0 where loop s n | s `seq` n `seq` False = undefined loop _ 0 = return () loop s n = do putWord64le (s+0) loop (s+1) (n-1) putWord64N2Little = loop 0 where loop s n | s `seq` n `seq` False = undefined loop _ 0 = return () loop s n = do putWord64le (s+0) putWord64le (s+1) loop (s+2) (n-2) putWord64N4Little = loop 0 where loop s n | s `seq` n `seq` False = undefined loop _ 0 = return () loop s n = do putWord64le (s+0) putWord64le (s+1) putWord64le (s+2) putWord64le (s+3) loop (s+4) (n-4) putWord64N8Little = loop 0 where loop s n | s `seq` n `seq` False = undefined loop _ 0 = return () loop s n = do putWord64le (s+0) putWord64le (s+1) putWord64le (s+2) putWord64le (s+3) putWord64le (s+4) putWord64le (s+5) putWord64le (s+6) putWord64le (s+7) loop (s+8) (n-8) putWord64N16Little = loop 0 where loop s n | s `seq` n `seq` False = undefined loop _ 0 = return () loop s n = do putWord64le (s+0) putWord64le (s+1) putWord64le (s+2) putWord64le (s+3) putWord64le (s+4) putWord64le (s+5) putWord64le (s+6) putWord64le (s+7) putWord64le (s+8) putWord64le (s+9) putWord64le (s+10) putWord64le (s+11) putWord64le (s+12) putWord64le (s+13) putWord64le (s+14) putWord64le (s+15) loop (s+16) (n-16) ------------------------------------------------------------------------ putWord64N1Host = loop 0 where loop s n | s `seq` n `seq` False = undefined loop _ 0 = return () loop s n = do putWord64host (s+0) loop (s+1) (n-1) putWord64N2Host = loop 0 where loop s n | s `seq` n `seq` False = undefined loop _ 0 = return () loop s n = do putWord64host (s+0) putWord64host (s+1) loop (s+2) (n-2) putWord64N4Host = loop 0 where loop s n | s `seq` n `seq` False = undefined loop _ 0 = return () loop s n = do putWord64host (s+0) putWord64host (s+1) putWord64host (s+2) putWord64host (s+3) loop (s+4) (n-4) putWord64N8Host = loop 0 where loop s n | s `seq` n `seq` False = undefined loop _ 0 = return () loop s n = do putWord64host (s+0) putWord64host (s+1) putWord64host (s+2) putWord64host (s+3) putWord64host (s+4) putWord64host (s+5) putWord64host (s+6) putWord64host (s+7) loop (s+8) (n-8) putWord64N16Host = loop 0 where loop s n | s `seq` n `seq` False = undefined loop _ 0 = return () loop s n = do putWord64host (s+0) putWord64host (s+1) putWord64host (s+2) putWord64host (s+3) putWord64host (s+4) putWord64host (s+5) putWord64host (s+6) putWord64host (s+7) putWord64host (s+8) putWord64host (s+9) putWord64host (s+10) putWord64host (s+11) putWord64host (s+12) putWord64host (s+13) putWord64host (s+14) putWord64host (s+15) loop (s+16) (n-16) blaze-builder-0.4.0.2/benchmarks/Throughput/CBenchmark.c0000755000000000000000000000135612705234666021234 0ustar0000000000000000#include "CBenchmark.h" void bytewrite(unsigned char *a, int bytes) { unsigned char n = 0; int i = 0; int iterations = bytes; while (i < iterations) { a[i++] = n++; } } unsigned char byteread(unsigned char *a, int bytes) { unsigned char n = 0; int i = 0; int iterations = bytes; while (i < iterations) { n += a[i++]; } return n; } void wordwrite(unsigned long *a, int bytes) { unsigned long n = 0; int i = 0; int iterations = bytes / sizeof(unsigned long) ; while (i < iterations) { a[i++] = n++; } } unsigned int wordread(unsigned long *a, int bytes) { unsigned long n = 0; int i = 0; int iterations = bytes / sizeof(unsigned long); while (i < iterations) { n += a[i++]; } return n; } blaze-builder-0.4.0.2/benchmarks/Throughput/Utils.hs0000644000000000000000000000017612705234666020523 0ustar0000000000000000module Throughput.Utils ( Endian(..) ) where data Endian = Big | Little | Host deriving (Eq,Ord,Show) blaze-builder-0.4.0.2/benchmarks/Throughput/BlazeBuilder.hs0000644000000000000000000005723212705234666021774 0ustar0000000000000000{-# LANGUAGE BangPatterns #-} module Throughput.BlazeBuilder ( serialize ) where import Data.Monoid import qualified Data.ByteString.Lazy as L import Blaze.ByteString.Builder import Throughput.Utils serialize :: Int -> Int -> Endian -> Int -> L.ByteString serialize wordSize chunkSize end = toLazyByteString . case (wordSize, chunkSize, end) of (1, 1,_) -> writeByteN1 (1, 2,_) -> writeByteN2 (1, 4,_) -> writeByteN4 (1, 8,_) -> writeByteN8 (1, 16, _) -> writeByteN16 (2, 1, Big) -> writeWord16N1Big (2, 2, Big) -> writeWord16N2Big (2, 4, Big) -> writeWord16N4Big (2, 8, Big) -> writeWord16N8Big (2, 16, Big) -> writeWord16N16Big (2, 1, Little) -> writeWord16N1Little (2, 2, Little) -> writeWord16N2Little (2, 4, Little) -> writeWord16N4Little (2, 8, Little) -> writeWord16N8Little (2, 16, Little) -> writeWord16N16Little (2, 1, Host) -> writeWord16N1Host (2, 2, Host) -> writeWord16N2Host (2, 4, Host) -> writeWord16N4Host (2, 8, Host) -> writeWord16N8Host (2, 16, Host) -> writeWord16N16Host (4, 1, Big) -> writeWord32N1Big (4, 2, Big) -> writeWord32N2Big (4, 4, Big) -> writeWord32N4Big (4, 8, Big) -> writeWord32N8Big (4, 16, Big) -> writeWord32N16Big (4, 1, Little) -> writeWord32N1Little (4, 2, Little) -> writeWord32N2Little (4, 4, Little) -> writeWord32N4Little (4, 8, Little) -> writeWord32N8Little (4, 16, Little) -> writeWord32N16Little (4, 1, Host) -> writeWord32N1Host (4, 2, Host) -> writeWord32N2Host (4, 4, Host) -> writeWord32N4Host (4, 8, Host) -> writeWord32N8Host (4, 16, Host) -> writeWord32N16Host (8, 1, Host) -> writeWord64N1Host (8, 2, Host) -> writeWord64N2Host (8, 4, Host) -> writeWord64N4Host (8, 8, Host) -> writeWord64N8Host (8, 16, Host) -> writeWord64N16Host (8, 1, Big) -> writeWord64N1Big (8, 2, Big) -> writeWord64N2Big (8, 4, Big) -> writeWord64N4Big (8, 8, Big) -> writeWord64N8Big (8, 16, Big) -> writeWord64N16Big (8, 1, Little) -> writeWord64N1Little (8, 2, Little) -> writeWord64N2Little (8, 4, Little) -> writeWord64N4Little (8, 8, Little) -> writeWord64N8Little (8, 16, Little) -> writeWord64N16Little ------------------------------------------------------------------------ ------------------------------------------------------------------------ writeByteN1 bytes = loop 0 0 where loop !s !n | n == bytes = mempty | otherwise = fromWord8 s `mappend` loop (s+1) (n+1) writeByteN2 = loop 0 where loop s n | s `seq` n `seq` False = undefined loop _ 0 = mempty loop s n = fromWrite ( writeWord8 (s+0) `mappend` writeWord8 (s+1)) `mappend` loop (s+2) (n-2) writeByteN4 = loop 0 where loop s n | s `seq` n `seq` False = undefined loop _ 0 = mempty loop s n = fromWrite ( writeWord8 (s+0) `mappend` writeWord8 (s+1) `mappend` writeWord8 (s+2) `mappend` writeWord8 (s+3)) `mappend` loop (s+4) (n-4) writeByteN8 = loop 0 where loop s n | s `seq` n `seq` False = undefined loop _ 0 = mempty loop s n = fromWrite ( writeWord8 (s+0) `mappend` writeWord8 (s+1) `mappend` writeWord8 (s+2) `mappend` writeWord8 (s+3) `mappend` writeWord8 (s+4) `mappend` writeWord8 (s+5) `mappend` writeWord8 (s+6) `mappend` writeWord8 (s+7)) `mappend` loop (s+8) (n-8) writeByteN16 = loop 0 where loop s n | s `seq` n `seq` False = undefined loop _ 0 = mempty loop s n = fromWrite ( writeWord8 (s+0) `mappend` writeWord8 (s+1) `mappend` writeWord8 (s+2) `mappend` writeWord8 (s+3) `mappend` writeWord8 (s+4) `mappend` writeWord8 (s+5) `mappend` writeWord8 (s+6) `mappend` writeWord8 (s+7) `mappend` writeWord8 (s+8) `mappend` writeWord8 (s+9) `mappend` writeWord8 (s+10) `mappend` writeWord8 (s+11) `mappend` writeWord8 (s+12) `mappend` writeWord8 (s+13) `mappend` writeWord8 (s+14) `mappend` writeWord8 (s+15)) `mappend` loop (s+16) (n-16) ------------------------------------------------------------------------ -- Big endian, word16 writes writeWord16N1Big = loop 0 where loop s n | s `seq` n `seq` False = undefined loop _ 0 = mempty loop s n = fromWrite ( writeWord16be (s+0)) `mappend` loop (s+1) (n-1) writeWord16N2Big = loop 0 where loop s n | s `seq` n `seq` False = undefined loop _ 0 = mempty loop s n = fromWrite ( writeWord16be (s+0) `mappend` writeWord16be (s+1)) `mappend` loop (s+2) (n-2) writeWord16N4Big = loop 0 where loop s n | s `seq` n `seq` False = undefined loop _ 0 = mempty loop s n = fromWrite ( writeWord16be (s+0) `mappend` writeWord16be (s+1) `mappend` writeWord16be (s+2) `mappend` writeWord16be (s+3)) `mappend` loop (s+4) (n-4) writeWord16N8Big = loop 0 where loop s n | s `seq` n `seq` False = undefined loop _ 0 = mempty loop s n = fromWrite ( writeWord16be (s+0) `mappend` writeWord16be (s+1) `mappend` writeWord16be (s+2) `mappend` writeWord16be (s+3) `mappend` writeWord16be (s+4) `mappend` writeWord16be (s+5) `mappend` writeWord16be (s+6) `mappend` writeWord16be (s+7)) `mappend` loop (s+8) (n-8) writeWord16N16Big = loop 0 where loop s n | s `seq` n `seq` False = undefined loop _ 0 = mempty loop s n = fromWrite ( writeWord16be (s+0) `mappend` writeWord16be (s+1) `mappend` writeWord16be (s+2) `mappend` writeWord16be (s+3) `mappend` writeWord16be (s+4) `mappend` writeWord16be (s+5) `mappend` writeWord16be (s+6) `mappend` writeWord16be (s+7) `mappend` writeWord16be (s+8) `mappend` writeWord16be (s+9) `mappend` writeWord16be (s+10) `mappend` writeWord16be (s+11) `mappend` writeWord16be (s+12) `mappend` writeWord16be (s+13) `mappend` writeWord16be (s+14) `mappend` writeWord16be (s+15)) `mappend` loop (s+16) (n-16) ------------------------------------------------------------------------ -- Little endian, word16 writes writeWord16N1Little = loop 0 where loop s n | s `seq` n `seq` False = undefined loop _ 0 = mempty loop s n = fromWrite (writeWord16le (s+0)) `mappend` loop (s+1) (n-1) writeWord16N2Little = loop 0 where loop s n | s `seq` n `seq` False = undefined loop _ 0 = mempty loop s n = fromWrite ( writeWord16le (s+0) `mappend` writeWord16le (s+1)) `mappend` loop (s+2) (n-2) writeWord16N4Little = loop 0 where loop s n | s `seq` n `seq` False = undefined loop _ 0 = mempty loop s n = fromWrite ( writeWord16le (s+0) `mappend` writeWord16le (s+1) `mappend` writeWord16le (s+2) `mappend` writeWord16le (s+3)) `mappend` loop (s+4) (n-4) writeWord16N8Little = loop 0 where loop s n | s `seq` n `seq` False = undefined loop _ 0 = mempty loop s n = fromWrite ( writeWord16le (s+0) `mappend` writeWord16le (s+1) `mappend` writeWord16le (s+2) `mappend` writeWord16le (s+3) `mappend` writeWord16le (s+4) `mappend` writeWord16le (s+5) `mappend` writeWord16le (s+6) `mappend` writeWord16le (s+7)) `mappend` loop (s+8) (n-8) writeWord16N16Little = loop 0 where loop s n | s `seq` n `seq` False = undefined loop _ 0 = mempty loop s n = fromWrite ( writeWord16le (s+0) `mappend` writeWord16le (s+1) `mappend` writeWord16le (s+2) `mappend` writeWord16le (s+3) `mappend` writeWord16le (s+4) `mappend` writeWord16le (s+5) `mappend` writeWord16le (s+6) `mappend` writeWord16le (s+7) `mappend` writeWord16le (s+8) `mappend` writeWord16le (s+9) `mappend` writeWord16le (s+10) `mappend` writeWord16le (s+11) `mappend` writeWord16le (s+12) `mappend` writeWord16le (s+13) `mappend` writeWord16le (s+14) `mappend` writeWord16le (s+15)) `mappend` loop (s+16) (n-16) ------------------------------------------------------------------------ -- Host endian, unaligned, word16 writes writeWord16N1Host = loop 0 where loop s n | s `seq` n `seq` False = undefined loop _ 0 = mempty loop s n = fromWrite ( writeWord16host (s+0)) `mappend` loop (s+1) (n-1) writeWord16N2Host = loop 0 where loop s n | s `seq` n `seq` False = undefined loop _ 0 = mempty loop s n = fromWrite ( writeWord16host (s+0) `mappend` writeWord16host (s+1)) `mappend` loop (s+2) (n-2) writeWord16N4Host = loop 0 where loop s n | s `seq` n `seq` False = undefined loop _ 0 = mempty loop s n = fromWrite ( writeWord16host (s+0) `mappend` writeWord16host (s+1) `mappend` writeWord16host (s+2) `mappend` writeWord16host (s+3)) `mappend` loop (s+4) (n-4) writeWord16N8Host = loop 0 where loop s n | s `seq` n `seq` False = undefined loop _ 0 = mempty loop s n = fromWrite ( writeWord16host (s+0) `mappend` writeWord16host (s+1) `mappend` writeWord16host (s+2) `mappend` writeWord16host (s+3) `mappend` writeWord16host (s+4) `mappend` writeWord16host (s+5) `mappend` writeWord16host (s+6) `mappend` writeWord16host (s+7)) `mappend` loop (s+8) (n-8) writeWord16N16Host = loop 0 where loop s n | s `seq` n `seq` False = undefined loop _ 0 = mempty loop s n = fromWrite ( writeWord16host (s+0) `mappend` writeWord16host (s+1) `mappend` writeWord16host (s+2) `mappend` writeWord16host (s+3) `mappend` writeWord16host (s+4) `mappend` writeWord16host (s+5) `mappend` writeWord16host (s+6) `mappend` writeWord16host (s+7) `mappend` writeWord16host (s+8) `mappend` writeWord16host (s+9) `mappend` writeWord16host (s+10) `mappend` writeWord16host (s+11) `mappend` writeWord16host (s+12) `mappend` writeWord16host (s+13) `mappend` writeWord16host (s+14) `mappend` writeWord16host (s+15)) `mappend` loop (s+16) (n-16) ------------------------------------------------------------------------ writeWord32N1Big = loop 0 where loop s n | s `seq` n `seq` False = undefined loop _ 0 = mempty loop s n = fromWrite ( writeWord32be (s+0)) `mappend` loop (s+1) (n-1) writeWord32N2Big = loop 0 where loop s n | s `seq` n `seq` False = undefined loop _ 0 = mempty loop s n = fromWrite ( writeWord32be (s+0) `mappend` writeWord32be (s+1)) `mappend` loop (s+2) (n-2) writeWord32N4Big = loop 0 where loop s n | s `seq` n `seq` False = undefined loop _ 0 = mempty loop s n = fromWrite ( writeWord32be (s+0) `mappend` writeWord32be (s+1) `mappend` writeWord32be (s+2) `mappend` writeWord32be (s+3)) `mappend` loop (s+4) (n-4) writeWord32N8Big = loop 0 where loop s n | s `seq` n `seq` False = undefined loop _ 0 = mempty loop s n = fromWrite ( writeWord32be (s+0) `mappend` writeWord32be (s+1) `mappend` writeWord32be (s+2) `mappend` writeWord32be (s+3) `mappend` writeWord32be (s+4) `mappend` writeWord32be (s+5) `mappend` writeWord32be (s+6) `mappend` writeWord32be (s+7)) `mappend` loop (s+8) (n-8) writeWord32N16Big = loop 0 where loop s n | s `seq` n `seq` False = undefined loop _ 0 = mempty loop s n = fromWrite ( writeWord32be (s+0) `mappend` writeWord32be (s+1) `mappend` writeWord32be (s+2) `mappend` writeWord32be (s+3) `mappend` writeWord32be (s+4) `mappend` writeWord32be (s+5) `mappend` writeWord32be (s+6) `mappend` writeWord32be (s+7) `mappend` writeWord32be (s+8) `mappend` writeWord32be (s+9) `mappend` writeWord32be (s+10) `mappend` writeWord32be (s+11) `mappend` writeWord32be (s+12) `mappend` writeWord32be (s+13) `mappend` writeWord32be (s+14) `mappend` writeWord32be (s+15)) `mappend` loop (s+16) (n-16) ------------------------------------------------------------------------ writeWord32N1Little = loop 0 where loop s n | s `seq` n `seq` False = undefined loop _ 0 = mempty loop s n = fromWrite ( writeWord32le (s+0)) `mappend` loop (s+1) (n-1) writeWord32N2Little = loop 0 where loop s n | s `seq` n `seq` False = undefined loop _ 0 = mempty loop s n = fromWrite ( writeWord32le (s+0) `mappend` writeWord32le (s+1)) `mappend` loop (s+2) (n-2) writeWord32N4Little = loop 0 where loop s n | s `seq` n `seq` False = undefined loop _ 0 = mempty loop s n = fromWrite ( writeWord32le (s+0) `mappend` writeWord32le (s+1) `mappend` writeWord32le (s+2) `mappend` writeWord32le (s+3)) `mappend` loop (s+4) (n-4) writeWord32N8Little = loop 0 where loop s n | s `seq` n `seq` False = undefined loop _ 0 = mempty loop s n = fromWrite ( writeWord32le (s+0) `mappend` writeWord32le (s+1) `mappend` writeWord32le (s+2) `mappend` writeWord32le (s+3) `mappend` writeWord32le (s+4) `mappend` writeWord32le (s+5) `mappend` writeWord32le (s+6) `mappend` writeWord32le (s+7)) `mappend` loop (s+8) (n-8) writeWord32N16Little = loop 0 where loop s n | s `seq` n `seq` False = undefined loop _ 0 = mempty loop s n = fromWrite ( writeWord32le (s+0) `mappend` writeWord32le (s+1) `mappend` writeWord32le (s+2) `mappend` writeWord32le (s+3) `mappend` writeWord32le (s+4) `mappend` writeWord32le (s+5) `mappend` writeWord32le (s+6) `mappend` writeWord32le (s+7) `mappend` writeWord32le (s+8) `mappend` writeWord32le (s+9) `mappend` writeWord32le (s+10) `mappend` writeWord32le (s+11) `mappend` writeWord32le (s+12) `mappend` writeWord32le (s+13) `mappend` writeWord32le (s+14) `mappend` writeWord32le (s+15)) `mappend` loop (s+16) (n-16) ------------------------------------------------------------------------ writeWord32N1Host = loop 0 where loop s n | s `seq` n `seq` False = undefined loop _ 0 = mempty loop s n = fromWrite ( writeWord32host (s+0)) `mappend` loop (s+1) (n-1) writeWord32N2Host = loop 0 where loop s n | s `seq` n `seq` False = undefined loop _ 0 = mempty loop s n = fromWrite ( writeWord32host (s+0) `mappend` writeWord32host (s+1)) `mappend` loop (s+2) (n-2) writeWord32N4Host = loop 0 where loop s n | s `seq` n `seq` False = undefined loop _ 0 = mempty loop s n = fromWrite ( writeWord32host (s+0) `mappend` writeWord32host (s+1) `mappend` writeWord32host (s+2) `mappend` writeWord32host (s+3)) `mappend` loop (s+4) (n-4) writeWord32N8Host = loop 0 where loop s n | s `seq` n `seq` False = undefined loop _ 0 = mempty loop s n = fromWrite ( writeWord32host (s+0) `mappend` writeWord32host (s+1) `mappend` writeWord32host (s+2) `mappend` writeWord32host (s+3) `mappend` writeWord32host (s+4) `mappend` writeWord32host (s+5) `mappend` writeWord32host (s+6) `mappend` writeWord32host (s+7)) `mappend` loop (s+8) (n-8) writeWord32N16Host = loop 0 where loop s n | s `seq` n `seq` False = undefined loop _ 0 = mempty loop s n = fromWrite ( writeWord32host (s+0) `mappend` writeWord32host (s+1) `mappend` writeWord32host (s+2) `mappend` writeWord32host (s+3) `mappend` writeWord32host (s+4) `mappend` writeWord32host (s+5) `mappend` writeWord32host (s+6) `mappend` writeWord32host (s+7) `mappend` writeWord32host (s+8) `mappend` writeWord32host (s+9) `mappend` writeWord32host (s+10) `mappend` writeWord32host (s+11) `mappend` writeWord32host (s+12) `mappend` writeWord32host (s+13) `mappend` writeWord32host (s+14) `mappend` writeWord32host (s+15)) `mappend` loop (s+16) (n-16) ------------------------------------------------------------------------ writeWord64N1Big = loop 0 where loop s n | s `seq` n `seq` False = undefined loop _ 0 = mempty loop s n = fromWrite ( writeWord64be (s+0)) `mappend` loop (s+1) (n-1) writeWord64N2Big = loop 0 where loop s n | s `seq` n `seq` False = undefined loop _ 0 = mempty loop s n = fromWrite ( writeWord64be (s+0) `mappend` writeWord64be (s+1)) `mappend` loop (s+2) (n-2) writeWord64N4Big = loop 0 where loop s n | s `seq` n `seq` False = undefined loop _ 0 = mempty loop s n = fromWrite ( writeWord64be (s+0) `mappend` writeWord64be (s+1) `mappend` writeWord64be (s+2) `mappend` writeWord64be (s+3)) `mappend` loop (s+4) (n-4) writeWord64N8Big = loop 0 where loop s n | s `seq` n `seq` False = undefined loop _ 0 = mempty loop s n = fromWrite ( writeWord64be (s+0) `mappend` writeWord64be (s+1) `mappend` writeWord64be (s+2) `mappend` writeWord64be (s+3) `mappend` writeWord64be (s+4) `mappend` writeWord64be (s+5) `mappend` writeWord64be (s+6) `mappend` writeWord64be (s+7)) `mappend` loop (s+8) (n-8) writeWord64N16Big = loop 0 where loop s n | s `seq` n `seq` False = undefined loop _ 0 = mempty loop s n = fromWrite ( writeWord64be (s+0) `mappend` writeWord64be (s+1) `mappend` writeWord64be (s+2) `mappend` writeWord64be (s+3) `mappend` writeWord64be (s+4) `mappend` writeWord64be (s+5) `mappend` writeWord64be (s+6) `mappend` writeWord64be (s+7) `mappend` writeWord64be (s+8) `mappend` writeWord64be (s+9) `mappend` writeWord64be (s+10) `mappend` writeWord64be (s+11) `mappend` writeWord64be (s+12) `mappend` writeWord64be (s+13) `mappend` writeWord64be (s+14) `mappend` writeWord64be (s+15)) `mappend` loop (s+16) (n-16) ------------------------------------------------------------------------ writeWord64N1Little = loop 0 where loop s n | s `seq` n `seq` False = undefined loop _ 0 = mempty loop s n = fromWrite ( writeWord64le (s+0)) `mappend` loop (s+1) (n-1) writeWord64N2Little = loop 0 where loop s n | s `seq` n `seq` False = undefined loop _ 0 = mempty loop s n = fromWrite ( writeWord64le (s+0) `mappend` writeWord64le (s+1)) `mappend` loop (s+2) (n-2) writeWord64N4Little = loop 0 where loop s n | s `seq` n `seq` False = undefined loop _ 0 = mempty loop s n = fromWrite ( writeWord64le (s+0) `mappend` writeWord64le (s+1) `mappend` writeWord64le (s+2) `mappend` writeWord64le (s+3)) `mappend` loop (s+4) (n-4) writeWord64N8Little = loop 0 where loop s n | s `seq` n `seq` False = undefined loop _ 0 = mempty loop s n = fromWrite ( writeWord64le (s+0) `mappend` writeWord64le (s+1) `mappend` writeWord64le (s+2) `mappend` writeWord64le (s+3) `mappend` writeWord64le (s+4) `mappend` writeWord64le (s+5) `mappend` writeWord64le (s+6) `mappend` writeWord64le (s+7)) `mappend` loop (s+8) (n-8) writeWord64N16Little = loop 0 where loop s n | s `seq` n `seq` False = undefined loop _ 0 = mempty loop s n = fromWrite ( writeWord64le (s+0) `mappend` writeWord64le (s+1) `mappend` writeWord64le (s+2) `mappend` writeWord64le (s+3) `mappend` writeWord64le (s+4) `mappend` writeWord64le (s+5) `mappend` writeWord64le (s+6) `mappend` writeWord64le (s+7) `mappend` writeWord64le (s+8) `mappend` writeWord64le (s+9) `mappend` writeWord64le (s+10) `mappend` writeWord64le (s+11) `mappend` writeWord64le (s+12) `mappend` writeWord64le (s+13) `mappend` writeWord64le (s+14) `mappend` writeWord64le (s+15)) `mappend` loop (s+16) (n-16) ------------------------------------------------------------------------ writeWord64N1Host = loop 0 where loop s n | s `seq` n `seq` False = undefined loop _ 0 = mempty loop s n = fromWrite ( writeWord64host (s+0)) `mappend` loop (s+1) (n-1) writeWord64N2Host = loop 0 where loop s n | s `seq` n `seq` False = undefined loop _ 0 = mempty loop s n = fromWrite ( writeWord64host (s+0) `mappend` writeWord64host (s+1)) `mappend` loop (s+2) (n-2) writeWord64N4Host = loop 0 where loop s n | s `seq` n `seq` False = undefined loop _ 0 = mempty loop s n = fromWrite ( writeWord64host (s+0) `mappend` writeWord64host (s+1) `mappend` writeWord64host (s+2) `mappend` writeWord64host (s+3)) `mappend` loop (s+4) (n-4) writeWord64N8Host = loop 0 where loop s n | s `seq` n `seq` False = undefined loop _ 0 = mempty loop s n = fromWrite ( writeWord64host (s+0) `mappend` writeWord64host (s+1) `mappend` writeWord64host (s+2) `mappend` writeWord64host (s+3) `mappend` writeWord64host (s+4) `mappend` writeWord64host (s+5) `mappend` writeWord64host (s+6) `mappend` writeWord64host (s+7)) `mappend` loop (s+8) (n-8) writeWord64N16Host = loop 0 where loop s n | s `seq` n `seq` False = undefined loop _ 0 = mempty loop s n = fromWrite ( writeWord64host (s+0) `mappend` writeWord64host (s+1) `mappend` writeWord64host (s+2) `mappend` writeWord64host (s+3) `mappend` writeWord64host (s+4) `mappend` writeWord64host (s+5) `mappend` writeWord64host (s+6) `mappend` writeWord64host (s+7) `mappend` writeWord64host (s+8) `mappend` writeWord64host (s+9) `mappend` writeWord64host (s+10) `mappend` writeWord64host (s+11) `mappend` writeWord64host (s+12) `mappend` writeWord64host (s+13) `mappend` writeWord64host (s+14) `mappend` writeWord64host (s+15)) `mappend` loop (s+16) (n-16) blaze-builder-0.4.0.2/benchmarks/Throughput/BlazePut.hs0000644000000000000000000006110212705234666021145 0ustar0000000000000000{-# LANGUAGE BangPatterns #-} module Throughput.BlazePut (serialize) where import qualified Data.ByteString.Lazy as L import Blaze.ByteString.Builder import Throughput.BlazePutMonad as Put import Data.Monoid import Throughput.Utils ------------------------------------------------------------------------ serialize :: Int -> Int -> Endian -> Int -> L.ByteString serialize wordSize chunkSize end = runPut . case (wordSize, chunkSize, end) of (1, 1,_) -> writeByteN1 (1, 2,_) -> writeByteN2 (1, 4,_) -> writeByteN4 (1, 8,_) -> writeByteN8 (1, 16, _) -> writeByteN16 (2, 1, Big) -> writeWord16N1Big (2, 2, Big) -> writeWord16N2Big (2, 4, Big) -> writeWord16N4Big (2, 8, Big) -> writeWord16N8Big (2, 16, Big) -> writeWord16N16Big (2, 1, Little) -> writeWord16N1Little (2, 2, Little) -> writeWord16N2Little (2, 4, Little) -> writeWord16N4Little (2, 8, Little) -> writeWord16N8Little (2, 16, Little) -> writeWord16N16Little (2, 1, Host) -> writeWord16N1Host (2, 2, Host) -> writeWord16N2Host (2, 4, Host) -> writeWord16N4Host (2, 8, Host) -> writeWord16N8Host (2, 16, Host) -> writeWord16N16Host (4, 1, Big) -> writeWord32N1Big (4, 2, Big) -> writeWord32N2Big (4, 4, Big) -> writeWord32N4Big (4, 8, Big) -> writeWord32N8Big (4, 16, Big) -> writeWord32N16Big (4, 1, Little) -> writeWord32N1Little (4, 2, Little) -> writeWord32N2Little (4, 4, Little) -> writeWord32N4Little (4, 8, Little) -> writeWord32N8Little (4, 16, Little) -> writeWord32N16Little (4, 1, Host) -> writeWord32N1Host (4, 2, Host) -> writeWord32N2Host (4, 4, Host) -> writeWord32N4Host (4, 8, Host) -> writeWord32N8Host (4, 16, Host) -> writeWord32N16Host (8, 1, Host) -> writeWord64N1Host (8, 2, Host) -> writeWord64N2Host (8, 4, Host) -> writeWord64N4Host (8, 8, Host) -> writeWord64N8Host (8, 16, Host) -> writeWord64N16Host (8, 1, Big) -> writeWord64N1Big (8, 2, Big) -> writeWord64N2Big (8, 4, Big) -> writeWord64N4Big (8, 8, Big) -> writeWord64N8Big (8, 16, Big) -> writeWord64N16Big (8, 1, Little) -> writeWord64N1Little (8, 2, Little) -> writeWord64N2Little (8, 4, Little) -> writeWord64N4Little (8, 8, Little) -> writeWord64N8Little (8, 16, Little) -> writeWord64N16Little ------------------------------------------------------------------------ writeByteN1 bytes = loop 0 0 where loop !s !n | n == bytes = return () | otherwise = do Put.putWrite ( writeWord8 s) loop (s+1) (n+1) writeByteN2 = loop 0 where loop s n | s `seq` n `seq` False = undefined loop _ 0 = return () loop s n = do do Put.putWrite ( writeWord8 (s+0) `mappend` writeWord8 (s+1)) loop (s+2) (n-2) writeByteN4 = loop 0 where loop s n | s `seq` n `seq` False = undefined loop _ 0 = return () loop s n = do Put.putWrite ( writeWord8 (s+0) `mappend` writeWord8 (s+1) `mappend` writeWord8 (s+2) `mappend` writeWord8 (s+3)) loop (s+4) (n-4) writeByteN8 = loop 0 where loop s n | s `seq` n `seq` False = undefined loop _ 0 = return () loop s n = do Put.putWrite ( writeWord8 (s+0) `mappend` writeWord8 (s+1) `mappend` writeWord8 (s+2) `mappend` writeWord8 (s+3) `mappend` writeWord8 (s+4) `mappend` writeWord8 (s+5) `mappend` writeWord8 (s+6) `mappend` writeWord8 (s+7)) loop (s+8) (n-8) writeByteN16 = loop 0 where loop s n | s `seq` n `seq` False = undefined loop _ 0 = return () loop s n = do Put.putWrite ( writeWord8 (s+0) `mappend` writeWord8 (s+1) `mappend` writeWord8 (s+2) `mappend` writeWord8 (s+3) `mappend` writeWord8 (s+4) `mappend` writeWord8 (s+5) `mappend` writeWord8 (s+6) `mappend` writeWord8 (s+7) `mappend` writeWord8 (s+8) `mappend` writeWord8 (s+9) `mappend` writeWord8 (s+10) `mappend` writeWord8 (s+11) `mappend` writeWord8 (s+12) `mappend` writeWord8 (s+13) `mappend` writeWord8 (s+14) `mappend` writeWord8 (s+15)) loop (s+16) (n-16) ------------------------------------------------------------------------ -- Big endian, word16 writes writeWord16N1Big = loop 0 where loop s n | s `seq` n `seq` False = undefined loop _ 0 = return () loop s n = do Put.putWord16be (s+0) loop (s+1) (n-1) writeWord16N2Big = loop 0 where loop s n | s `seq` n `seq` False = undefined loop _ 0 = return () loop s n = do Put.putWrite ( writeWord16be (s+0) `mappend` writeWord16be (s+1)) loop (s+2) (n-2) writeWord16N4Big = loop 0 where loop s n | s `seq` n `seq` False = undefined loop _ 0 = return () loop s n = do Put.putWrite ( writeWord16be (s+0) `mappend` writeWord16be (s+1) `mappend` writeWord16be (s+2) `mappend` writeWord16be (s+3)) loop (s+4) (n-4) writeWord16N8Big = loop 0 where loop s n | s `seq` n `seq` False = undefined loop _ 0 = return () loop s n = do Put.putWrite ( writeWord16be (s+0) `mappend` writeWord16be (s+1) `mappend` writeWord16be (s+2) `mappend` writeWord16be (s+3) `mappend` writeWord16be (s+4) `mappend` writeWord16be (s+5) `mappend` writeWord16be (s+6) `mappend` writeWord16be (s+7)) loop (s+8) (n-8) writeWord16N16Big = loop 0 where loop s n | s `seq` n `seq` False = undefined loop _ 0 = return () loop s n = do Put.putWrite ( writeWord16be (s+0) `mappend` writeWord16be (s+1) `mappend` writeWord16be (s+2) `mappend` writeWord16be (s+3) `mappend` writeWord16be (s+4) `mappend` writeWord16be (s+5) `mappend` writeWord16be (s+6) `mappend` writeWord16be (s+7) `mappend` writeWord16be (s+8) `mappend` writeWord16be (s+9) `mappend` writeWord16be (s+10) `mappend` writeWord16be (s+11) `mappend` writeWord16be (s+12) `mappend` writeWord16be (s+13) `mappend` writeWord16be (s+14) `mappend` writeWord16be (s+15)) loop (s+16) (n-16) ------------------------------------------------------------------------ -- Little endian, word16 writes writeWord16N1Little = loop 0 where loop s n | s `seq` n `seq` False = undefined loop _ 0 = return () loop s n = do Put.putWord16le (s+0) loop (s+1) (n-1) writeWord16N2Little = loop 0 where loop s n | s `seq` n `seq` False = undefined loop _ 0 = return () loop s n = do Put.putWrite ( writeWord16le (s+0) `mappend` writeWord16le (s+1)) loop (s+2) (n-2) writeWord16N4Little = loop 0 where loop s n | s `seq` n `seq` False = undefined loop _ 0 = return () loop s n = do Put.putWrite ( writeWord16le (s+0) `mappend` writeWord16le (s+1) `mappend` writeWord16le (s+2) `mappend` writeWord16le (s+3)) loop (s+4) (n-4) writeWord16N8Little = loop 0 where loop s n | s `seq` n `seq` False = undefined loop _ 0 = return () loop s n = do Put.putWrite ( writeWord16le (s+0) `mappend` writeWord16le (s+1) `mappend` writeWord16le (s+2) `mappend` writeWord16le (s+3) `mappend` writeWord16le (s+4) `mappend` writeWord16le (s+5) `mappend` writeWord16le (s+6) `mappend` writeWord16le (s+7)) loop (s+8) (n-8) writeWord16N16Little = loop 0 where loop s n | s `seq` n `seq` False = undefined loop _ 0 = return () loop s n = do Put.putWrite ( writeWord16le (s+0) `mappend` writeWord16le (s+1) `mappend` writeWord16le (s+2) `mappend` writeWord16le (s+3) `mappend` writeWord16le (s+4) `mappend` writeWord16le (s+5) `mappend` writeWord16le (s+6) `mappend` writeWord16le (s+7) `mappend` writeWord16le (s+8) `mappend` writeWord16le (s+9) `mappend` writeWord16le (s+10) `mappend` writeWord16le (s+11) `mappend` writeWord16le (s+12) `mappend` writeWord16le (s+13) `mappend` writeWord16le (s+14) `mappend` writeWord16le (s+15)) loop (s+16) (n-16) ------------------------------------------------------------------------ -- Host endian, unaligned, word16 writes writeWord16N1Host = loop 0 where loop s n | s `seq` n `seq` False = undefined loop _ 0 = return () loop s n = do Put.putWord16host (s+0) loop (s+1) (n-1) writeWord16N2Host = loop 0 where loop s n | s `seq` n `seq` False = undefined loop _ 0 = return () loop s n = do Put.putWrite ( writeWord16host (s+0) `mappend` writeWord16host (s+1)) loop (s+2) (n-2) writeWord16N4Host = loop 0 where loop s n | s `seq` n `seq` False = undefined loop _ 0 = return () loop s n = do Put.putWrite ( writeWord16host (s+0) `mappend` writeWord16host (s+1) `mappend` writeWord16host (s+2) `mappend` writeWord16host (s+3)) loop (s+4) (n-4) writeWord16N8Host = loop 0 where loop s n | s `seq` n `seq` False = undefined loop _ 0 = return () loop s n = do Put.putWrite ( writeWord16host (s+0) `mappend` writeWord16host (s+1) `mappend` writeWord16host (s+2) `mappend` writeWord16host (s+3) `mappend` writeWord16host (s+4) `mappend` writeWord16host (s+5) `mappend` writeWord16host (s+6) `mappend` writeWord16host (s+7)) loop (s+8) (n-8) writeWord16N16Host = loop 0 where loop s n | s `seq` n `seq` False = undefined loop _ 0 = return () loop s n = do Put.putWrite ( writeWord16host (s+0) `mappend` writeWord16host (s+1) `mappend` writeWord16host (s+2) `mappend` writeWord16host (s+3) `mappend` writeWord16host (s+4) `mappend` writeWord16host (s+5) `mappend` writeWord16host (s+6) `mappend` writeWord16host (s+7) `mappend` writeWord16host (s+8) `mappend` writeWord16host (s+9) `mappend` writeWord16host (s+10) `mappend` writeWord16host (s+11) `mappend` writeWord16host (s+12) `mappend` writeWord16host (s+13) `mappend` writeWord16host (s+14) `mappend` writeWord16host (s+15)) loop (s+16) (n-16) ------------------------------------------------------------------------ writeWord32N1Big = loop 0 where loop s n | s `seq` n `seq` False = undefined loop _ 0 = return () loop s n = do Put.putWord32be (s+0) loop (s+1) (n-1) writeWord32N2Big = loop 0 where loop s n | s `seq` n `seq` False = undefined loop _ 0 = return () loop s n = do Put.putWrite ( writeWord32be (s+0) `mappend` writeWord32be (s+1)) loop (s+2) (n-2) writeWord32N4Big = loop 0 where loop s n | s `seq` n `seq` False = undefined loop _ 0 = return () loop s n = do Put.putWrite ( writeWord32be (s+0) `mappend` writeWord32be (s+1) `mappend` writeWord32be (s+2) `mappend` writeWord32be (s+3)) loop (s+4) (n-4) writeWord32N8Big = loop 0 where loop s n | s `seq` n `seq` False = undefined loop _ 0 = return () loop s n = do Put.putWrite ( writeWord32be (s+0) `mappend` writeWord32be (s+1) `mappend` writeWord32be (s+2) `mappend` writeWord32be (s+3) `mappend` writeWord32be (s+4) `mappend` writeWord32be (s+5) `mappend` writeWord32be (s+6) `mappend` writeWord32be (s+7)) loop (s+8) (n-8) writeWord32N16Big = loop 0 where loop s n | s `seq` n `seq` False = undefined loop _ 0 = return () loop s n = do Put.putWrite ( writeWord32be (s+0) `mappend` writeWord32be (s+1) `mappend` writeWord32be (s+2) `mappend` writeWord32be (s+3) `mappend` writeWord32be (s+4) `mappend` writeWord32be (s+5) `mappend` writeWord32be (s+6) `mappend` writeWord32be (s+7) `mappend` writeWord32be (s+8) `mappend` writeWord32be (s+9) `mappend` writeWord32be (s+10) `mappend` writeWord32be (s+11) `mappend` writeWord32be (s+12) `mappend` writeWord32be (s+13) `mappend` writeWord32be (s+14) `mappend` writeWord32be (s+15)) loop (s+16) (n-16) ------------------------------------------------------------------------ writeWord32N1Little = loop 0 where loop s n | s `seq` n `seq` False = undefined loop _ 0 = return () loop s n = do Put.putWord32le (s+0) loop (s+1) (n-1) writeWord32N2Little = loop 0 where loop s n | s `seq` n `seq` False = undefined loop _ 0 = return () loop s n = do Put.putWrite ( writeWord32le (s+0) `mappend` writeWord32le (s+1)) loop (s+2) (n-2) writeWord32N4Little = loop 0 where loop s n | s `seq` n `seq` False = undefined loop _ 0 = return () loop s n = do Put.putWrite ( writeWord32le (s+0) `mappend` writeWord32le (s+1) `mappend` writeWord32le (s+2) `mappend` writeWord32le (s+3)) loop (s+4) (n-4) writeWord32N8Little = loop 0 where loop s n | s `seq` n `seq` False = undefined loop _ 0 = return () loop s n = do Put.putWrite ( writeWord32le (s+0) `mappend` writeWord32le (s+1) `mappend` writeWord32le (s+2) `mappend` writeWord32le (s+3) `mappend` writeWord32le (s+4) `mappend` writeWord32le (s+5) `mappend` writeWord32le (s+6) `mappend` writeWord32le (s+7)) loop (s+8) (n-8) writeWord32N16Little = loop 0 where loop s n | s `seq` n `seq` False = undefined loop _ 0 = return () loop s n = do Put.putWrite ( writeWord32le (s+0) `mappend` writeWord32le (s+1) `mappend` writeWord32le (s+2) `mappend` writeWord32le (s+3) `mappend` writeWord32le (s+4) `mappend` writeWord32le (s+5) `mappend` writeWord32le (s+6) `mappend` writeWord32le (s+7) `mappend` writeWord32le (s+8) `mappend` writeWord32le (s+9) `mappend` writeWord32le (s+10) `mappend` writeWord32le (s+11) `mappend` writeWord32le (s+12) `mappend` writeWord32le (s+13) `mappend` writeWord32le (s+14) `mappend` writeWord32le (s+15)) loop (s+16) (n-16) ------------------------------------------------------------------------ writeWord32N1Host = loop 0 where loop s n | s `seq` n `seq` False = undefined loop _ 0 = return () loop s n = do Put.putWord32host (s+0) loop (s+1) (n-1) writeWord32N2Host = loop 0 where loop s n | s `seq` n `seq` False = undefined loop _ 0 = return () loop s n = do Put.putWrite ( writeWord32host (s+0) `mappend` writeWord32host (s+1)) loop (s+2) (n-2) writeWord32N4Host = loop 0 where loop s n | s `seq` n `seq` False = undefined loop _ 0 = return () loop s n = do Put.putWrite ( writeWord32host (s+0) `mappend` writeWord32host (s+1) `mappend` writeWord32host (s+2) `mappend` writeWord32host (s+3)) loop (s+4) (n-4) writeWord32N8Host = loop 0 where loop s n | s `seq` n `seq` False = undefined loop _ 0 = return () loop s n = do Put.putWrite ( writeWord32host (s+0) `mappend` writeWord32host (s+1) `mappend` writeWord32host (s+2) `mappend` writeWord32host (s+3) `mappend` writeWord32host (s+4) `mappend` writeWord32host (s+5) `mappend` writeWord32host (s+6) `mappend` writeWord32host (s+7)) loop (s+8) (n-8) writeWord32N16Host = loop 0 where loop s n | s `seq` n `seq` False = undefined loop _ 0 = return () loop s n = do Put.putWrite ( writeWord32host (s+0) `mappend` writeWord32host (s+1) `mappend` writeWord32host (s+2) `mappend` writeWord32host (s+3) `mappend` writeWord32host (s+4) `mappend` writeWord32host (s+5) `mappend` writeWord32host (s+6) `mappend` writeWord32host (s+7) `mappend` writeWord32host (s+8) `mappend` writeWord32host (s+9) `mappend` writeWord32host (s+10) `mappend` writeWord32host (s+11) `mappend` writeWord32host (s+12) `mappend` writeWord32host (s+13) `mappend` writeWord32host (s+14) `mappend` writeWord32host (s+15)) loop (s+16) (n-16) ------------------------------------------------------------------------ writeWord64N1Big = loop 0 where loop s n | s `seq` n `seq` False = undefined loop _ 0 = return () loop s n = do Put.putWord64be (s+0) loop (s+1) (n-1) writeWord64N2Big = loop 0 where loop s n | s `seq` n `seq` False = undefined loop _ 0 = return () loop s n = do Put.putWrite ( writeWord64be (s+0) `mappend` writeWord64be (s+1)) loop (s+2) (n-2) writeWord64N4Big = loop 0 where loop s n | s `seq` n `seq` False = undefined loop _ 0 = return () loop s n = do Put.putWrite ( writeWord64be (s+0) `mappend` writeWord64be (s+1) `mappend` writeWord64be (s+2) `mappend` writeWord64be (s+3)) loop (s+4) (n-4) writeWord64N8Big = loop 0 where loop s n | s `seq` n `seq` False = undefined loop _ 0 = return () loop s n = do Put.putWrite ( writeWord64be (s+0) `mappend` writeWord64be (s+1) `mappend` writeWord64be (s+2) `mappend` writeWord64be (s+3) `mappend` writeWord64be (s+4) `mappend` writeWord64be (s+5) `mappend` writeWord64be (s+6) `mappend` writeWord64be (s+7)) loop (s+8) (n-8) writeWord64N16Big = loop 0 where loop s n | s `seq` n `seq` False = undefined loop _ 0 = return () loop s n = do Put.putWrite ( writeWord64be (s+0) `mappend` writeWord64be (s+1) `mappend` writeWord64be (s+2) `mappend` writeWord64be (s+3) `mappend` writeWord64be (s+4) `mappend` writeWord64be (s+5) `mappend` writeWord64be (s+6) `mappend` writeWord64be (s+7) `mappend` writeWord64be (s+8) `mappend` writeWord64be (s+9) `mappend` writeWord64be (s+10) `mappend` writeWord64be (s+11) `mappend` writeWord64be (s+12) `mappend` writeWord64be (s+13) `mappend` writeWord64be (s+14) `mappend` writeWord64be (s+15)) loop (s+16) (n-16) ------------------------------------------------------------------------ writeWord64N1Little = loop 0 where loop s n | s `seq` n `seq` False = undefined loop _ 0 = return () loop s n = do Put.putWord64le (s+0) loop (s+1) (n-1) writeWord64N2Little = loop 0 where loop s n | s `seq` n `seq` False = undefined loop _ 0 = return () loop s n = do Put.putWrite ( writeWord64le (s+0) `mappend` writeWord64le (s+1)) loop (s+2) (n-2) writeWord64N4Little = loop 0 where loop s n | s `seq` n `seq` False = undefined loop _ 0 = return () loop s n = do Put.putWrite ( writeWord64le (s+0) `mappend` writeWord64le (s+1) `mappend` writeWord64le (s+2) `mappend` writeWord64le (s+3)) loop (s+4) (n-4) writeWord64N8Little = loop 0 where loop s n | s `seq` n `seq` False = undefined loop _ 0 = return () loop s n = do Put.putWrite ( writeWord64le (s+0) `mappend` writeWord64le (s+1) `mappend` writeWord64le (s+2) `mappend` writeWord64le (s+3) `mappend` writeWord64le (s+4) `mappend` writeWord64le (s+5) `mappend` writeWord64le (s+6) `mappend` writeWord64le (s+7)) loop (s+8) (n-8) writeWord64N16Little = loop 0 where loop s n | s `seq` n `seq` False = undefined loop _ 0 = return () loop s n = do Put.putWrite ( writeWord64le (s+0) `mappend` writeWord64le (s+1) `mappend` writeWord64le (s+2) `mappend` writeWord64le (s+3) `mappend` writeWord64le (s+4) `mappend` writeWord64le (s+5) `mappend` writeWord64le (s+6) `mappend` writeWord64le (s+7) `mappend` writeWord64le (s+8) `mappend` writeWord64le (s+9) `mappend` writeWord64le (s+10) `mappend` writeWord64le (s+11) `mappend` writeWord64le (s+12) `mappend` writeWord64le (s+13) `mappend` writeWord64le (s+14) `mappend` writeWord64le (s+15)) loop (s+16) (n-16) ------------------------------------------------------------------------ writeWord64N1Host = loop 0 where loop s n | s `seq` n `seq` False = undefined loop _ 0 = return () loop s n = do Put.putWord64host (s+0) loop (s+1) (n-1) writeWord64N2Host = loop 0 where loop s n | s `seq` n `seq` False = undefined loop _ 0 = return () loop s n = do Put.putWrite ( writeWord64host (s+0) `mappend` writeWord64host (s+1)) loop (s+2) (n-2) writeWord64N4Host = loop 0 where loop s n | s `seq` n `seq` False = undefined loop _ 0 = return () loop s n = do Put.putWrite ( writeWord64host (s+0) `mappend` writeWord64host (s+1) `mappend` writeWord64host (s+2) `mappend` writeWord64host (s+3)) loop (s+4) (n-4) writeWord64N8Host = loop 0 where loop s n | s `seq` n `seq` False = undefined loop _ 0 = return () loop s n = do Put.putWrite ( writeWord64host (s+0) `mappend` writeWord64host (s+1) `mappend` writeWord64host (s+2) `mappend` writeWord64host (s+3) `mappend` writeWord64host (s+4) `mappend` writeWord64host (s+5) `mappend` writeWord64host (s+6) `mappend` writeWord64host (s+7)) loop (s+8) (n-8) writeWord64N16Host = loop 0 where loop s n | s `seq` n `seq` False = undefined loop _ 0 = return () loop s n = do Put.putWrite ( writeWord64host (s+0) `mappend` writeWord64host (s+1) `mappend` writeWord64host (s+2) `mappend` writeWord64host (s+3) `mappend` writeWord64host (s+4) `mappend` writeWord64host (s+5) `mappend` writeWord64host (s+6) `mappend` writeWord64host (s+7) `mappend` writeWord64host (s+8) `mappend` writeWord64host (s+9) `mappend` writeWord64host (s+10) `mappend` writeWord64host (s+11) `mappend` writeWord64host (s+12) `mappend` writeWord64host (s+13) `mappend` writeWord64host (s+14) `mappend` writeWord64host (s+15)) loop (s+16) (n-16) blaze-builder-0.4.0.2/benchmarks/Throughput/BinaryBuilder.hs0000644000000000000000000005502012705234666022154 0ustar0000000000000000{-# LANGUAGE BangPatterns #-} module Throughput.BinaryBuilder (serialize) where import Data.Monoid import qualified Data.ByteString.Lazy as L import Data.Binary.Builder import Throughput.Utils serialize :: Int -> Int -> Endian -> Int -> L.ByteString serialize wordSize chunkSize end = toLazyByteString . case (wordSize, chunkSize, end) of (1, 1,_) -> writeByteN1 (1, 2,_) -> writeByteN2 (1, 4,_) -> writeByteN4 (1, 8,_) -> writeByteN8 (1, 16, _) -> writeByteN16 (2, 1, Big) -> writeWord16N1Big (2, 2, Big) -> writeWord16N2Big (2, 4, Big) -> writeWord16N4Big (2, 8, Big) -> writeWord16N8Big (2, 16, Big) -> writeWord16N16Big (2, 1, Little) -> writeWord16N1Little (2, 2, Little) -> writeWord16N2Little (2, 4, Little) -> writeWord16N4Little (2, 8, Little) -> writeWord16N8Little (2, 16, Little) -> writeWord16N16Little (2, 1, Host) -> writeWord16N1Host (2, 2, Host) -> writeWord16N2Host (2, 4, Host) -> writeWord16N4Host (2, 8, Host) -> writeWord16N8Host (2, 16, Host) -> writeWord16N16Host (4, 1, Big) -> writeWord32N1Big (4, 2, Big) -> writeWord32N2Big (4, 4, Big) -> writeWord32N4Big (4, 8, Big) -> writeWord32N8Big (4, 16, Big) -> writeWord32N16Big (4, 1, Little) -> writeWord32N1Little (4, 2, Little) -> writeWord32N2Little (4, 4, Little) -> writeWord32N4Little (4, 8, Little) -> writeWord32N8Little (4, 16, Little) -> writeWord32N16Little (4, 1, Host) -> writeWord32N1Host (4, 2, Host) -> writeWord32N2Host (4, 4, Host) -> writeWord32N4Host (4, 8, Host) -> writeWord32N8Host (4, 16, Host) -> writeWord32N16Host (8, 1, Host) -> writeWord64N1Host (8, 2, Host) -> writeWord64N2Host (8, 4, Host) -> writeWord64N4Host (8, 8, Host) -> writeWord64N8Host (8, 16, Host) -> writeWord64N16Host (8, 1, Big) -> writeWord64N1Big (8, 2, Big) -> writeWord64N2Big (8, 4, Big) -> writeWord64N4Big (8, 8, Big) -> writeWord64N8Big (8, 16, Big) -> writeWord64N16Big (8, 1, Little) -> writeWord64N1Little (8, 2, Little) -> writeWord64N2Little (8, 4, Little) -> writeWord64N4Little (8, 8, Little) -> writeWord64N8Little (8, 16, Little) -> writeWord64N16Little ------------------------------------------------------------------------ writeByteN1 bytes = loop 0 0 where loop !s !n | n == bytes = mempty | otherwise = singleton s `mappend` loop (s+1) (n+1) writeByteN2 = loop 0 where loop s n | s `seq` n `seq` False = undefined loop _ 0 = mempty loop s n = ( singleton (s+0) `mappend` singleton (s+1)) `mappend` loop (s+2) (n-2) writeByteN4 = loop 0 where loop s n | s `seq` n `seq` False = undefined loop _ 0 = mempty loop s n = ( singleton (s+0) `mappend` singleton (s+1) `mappend` singleton (s+2) `mappend` singleton (s+3)) `mappend` loop (s+4) (n-4) writeByteN8 = loop 0 where loop s n | s `seq` n `seq` False = undefined loop _ 0 = mempty loop s n = ( singleton (s+0) `mappend` singleton (s+1) `mappend` singleton (s+2) `mappend` singleton (s+3) `mappend` singleton (s+4) `mappend` singleton (s+5) `mappend` singleton (s+6) `mappend` singleton (s+7)) `mappend` loop (s+8) (n-8) writeByteN16 = loop 0 where loop s n | s `seq` n `seq` False = undefined loop _ 0 = mempty loop s n = ( singleton (s+0) `mappend` singleton (s+1) `mappend` singleton (s+2) `mappend` singleton (s+3) `mappend` singleton (s+4) `mappend` singleton (s+5) `mappend` singleton (s+6) `mappend` singleton (s+7) `mappend` singleton (s+8) `mappend` singleton (s+9) `mappend` singleton (s+10) `mappend` singleton (s+11) `mappend` singleton (s+12) `mappend` singleton (s+13) `mappend` singleton (s+14) `mappend` singleton (s+15)) `mappend` loop (s+16) (n-16) ------------------------------------------------------------------------ -- Big endian, word16 writes writeWord16N1Big = loop 0 where loop s n | s `seq` n `seq` False = undefined loop _ 0 = mempty loop s n = ( putWord16be (s+0)) `mappend` loop (s+1) (n-1) writeWord16N2Big = loop 0 where loop s n | s `seq` n `seq` False = undefined loop _ 0 = mempty loop s n = ( putWord16be (s+0) `mappend` putWord16be (s+1)) `mappend` loop (s+2) (n-2) writeWord16N4Big = loop 0 where loop s n | s `seq` n `seq` False = undefined loop _ 0 = mempty loop s n = ( putWord16be (s+0) `mappend` putWord16be (s+1) `mappend` putWord16be (s+2) `mappend` putWord16be (s+3)) `mappend` loop (s+4) (n-4) writeWord16N8Big = loop 0 where loop s n | s `seq` n `seq` False = undefined loop _ 0 = mempty loop s n = ( putWord16be (s+0) `mappend` putWord16be (s+1) `mappend` putWord16be (s+2) `mappend` putWord16be (s+3) `mappend` putWord16be (s+4) `mappend` putWord16be (s+5) `mappend` putWord16be (s+6) `mappend` putWord16be (s+7)) `mappend` loop (s+8) (n-8) writeWord16N16Big = loop 0 where loop s n | s `seq` n `seq` False = undefined loop _ 0 = mempty loop s n = ( putWord16be (s+0) `mappend` putWord16be (s+1) `mappend` putWord16be (s+2) `mappend` putWord16be (s+3) `mappend` putWord16be (s+4) `mappend` putWord16be (s+5) `mappend` putWord16be (s+6) `mappend` putWord16be (s+7) `mappend` putWord16be (s+8) `mappend` putWord16be (s+9) `mappend` putWord16be (s+10) `mappend` putWord16be (s+11) `mappend` putWord16be (s+12) `mappend` putWord16be (s+13) `mappend` putWord16be (s+14) `mappend` putWord16be (s+15)) `mappend` loop (s+16) (n-16) ------------------------------------------------------------------------ -- Little endian, word16 writes writeWord16N1Little = loop 0 where loop s n | s `seq` n `seq` False = undefined loop _ 0 = mempty loop s n = (putWord16le (s+0)) `mappend` loop (s+1) (n-1) writeWord16N2Little = loop 0 where loop s n | s `seq` n `seq` False = undefined loop _ 0 = mempty loop s n = ( putWord16le (s+0) `mappend` putWord16le (s+1)) `mappend` loop (s+2) (n-2) writeWord16N4Little = loop 0 where loop s n | s `seq` n `seq` False = undefined loop _ 0 = mempty loop s n = ( putWord16le (s+0) `mappend` putWord16le (s+1) `mappend` putWord16le (s+2) `mappend` putWord16le (s+3)) `mappend` loop (s+4) (n-4) writeWord16N8Little = loop 0 where loop s n | s `seq` n `seq` False = undefined loop _ 0 = mempty loop s n = ( putWord16le (s+0) `mappend` putWord16le (s+1) `mappend` putWord16le (s+2) `mappend` putWord16le (s+3) `mappend` putWord16le (s+4) `mappend` putWord16le (s+5) `mappend` putWord16le (s+6) `mappend` putWord16le (s+7)) `mappend` loop (s+8) (n-8) writeWord16N16Little = loop 0 where loop s n | s `seq` n `seq` False = undefined loop _ 0 = mempty loop s n = ( putWord16le (s+0) `mappend` putWord16le (s+1) `mappend` putWord16le (s+2) `mappend` putWord16le (s+3) `mappend` putWord16le (s+4) `mappend` putWord16le (s+5) `mappend` putWord16le (s+6) `mappend` putWord16le (s+7) `mappend` putWord16le (s+8) `mappend` putWord16le (s+9) `mappend` putWord16le (s+10) `mappend` putWord16le (s+11) `mappend` putWord16le (s+12) `mappend` putWord16le (s+13) `mappend` putWord16le (s+14) `mappend` putWord16le (s+15)) `mappend` loop (s+16) (n-16) ------------------------------------------------------------------------ -- Host endian, unaligned, word16 writes writeWord16N1Host = loop 0 where loop s n | s `seq` n `seq` False = undefined loop _ 0 = mempty loop s n = ( putWord16host (s+0)) `mappend` loop (s+1) (n-1) writeWord16N2Host = loop 0 where loop s n | s `seq` n `seq` False = undefined loop _ 0 = mempty loop s n = ( putWord16host (s+0) `mappend` putWord16host (s+1)) `mappend` loop (s+2) (n-2) writeWord16N4Host = loop 0 where loop s n | s `seq` n `seq` False = undefined loop _ 0 = mempty loop s n = ( putWord16host (s+0) `mappend` putWord16host (s+1) `mappend` putWord16host (s+2) `mappend` putWord16host (s+3)) `mappend` loop (s+4) (n-4) writeWord16N8Host = loop 0 where loop s n | s `seq` n `seq` False = undefined loop _ 0 = mempty loop s n = ( putWord16host (s+0) `mappend` putWord16host (s+1) `mappend` putWord16host (s+2) `mappend` putWord16host (s+3) `mappend` putWord16host (s+4) `mappend` putWord16host (s+5) `mappend` putWord16host (s+6) `mappend` putWord16host (s+7)) `mappend` loop (s+8) (n-8) writeWord16N16Host = loop 0 where loop s n | s `seq` n `seq` False = undefined loop _ 0 = mempty loop s n = ( putWord16host (s+0) `mappend` putWord16host (s+1) `mappend` putWord16host (s+2) `mappend` putWord16host (s+3) `mappend` putWord16host (s+4) `mappend` putWord16host (s+5) `mappend` putWord16host (s+6) `mappend` putWord16host (s+7) `mappend` putWord16host (s+8) `mappend` putWord16host (s+9) `mappend` putWord16host (s+10) `mappend` putWord16host (s+11) `mappend` putWord16host (s+12) `mappend` putWord16host (s+13) `mappend` putWord16host (s+14) `mappend` putWord16host (s+15)) `mappend` loop (s+16) (n-16) ------------------------------------------------------------------------ writeWord32N1Big = loop 0 where loop s n | s `seq` n `seq` False = undefined loop _ 0 = mempty loop s n = ( putWord32be (s+0)) `mappend` loop (s+1) (n-1) writeWord32N2Big = loop 0 where loop s n | s `seq` n `seq` False = undefined loop _ 0 = mempty loop s n = ( putWord32be (s+0) `mappend` putWord32be (s+1)) `mappend` loop (s+2) (n-2) writeWord32N4Big = loop 0 where loop s n | s `seq` n `seq` False = undefined loop _ 0 = mempty loop s n = ( putWord32be (s+0) `mappend` putWord32be (s+1) `mappend` putWord32be (s+2) `mappend` putWord32be (s+3)) `mappend` loop (s+4) (n-4) writeWord32N8Big = loop 0 where loop s n | s `seq` n `seq` False = undefined loop _ 0 = mempty loop s n = ( putWord32be (s+0) `mappend` putWord32be (s+1) `mappend` putWord32be (s+2) `mappend` putWord32be (s+3) `mappend` putWord32be (s+4) `mappend` putWord32be (s+5) `mappend` putWord32be (s+6) `mappend` putWord32be (s+7)) `mappend` loop (s+8) (n-8) writeWord32N16Big = loop 0 where loop s n | s `seq` n `seq` False = undefined loop _ 0 = mempty loop s n = ( putWord32be (s+0) `mappend` putWord32be (s+1) `mappend` putWord32be (s+2) `mappend` putWord32be (s+3) `mappend` putWord32be (s+4) `mappend` putWord32be (s+5) `mappend` putWord32be (s+6) `mappend` putWord32be (s+7) `mappend` putWord32be (s+8) `mappend` putWord32be (s+9) `mappend` putWord32be (s+10) `mappend` putWord32be (s+11) `mappend` putWord32be (s+12) `mappend` putWord32be (s+13) `mappend` putWord32be (s+14) `mappend` putWord32be (s+15)) `mappend` loop (s+16) (n-16) ------------------------------------------------------------------------ writeWord32N1Little = loop 0 where loop s n | s `seq` n `seq` False = undefined loop _ 0 = mempty loop s n = ( putWord32le (s+0)) `mappend` loop (s+1) (n-1) writeWord32N2Little = loop 0 where loop s n | s `seq` n `seq` False = undefined loop _ 0 = mempty loop s n = ( putWord32le (s+0) `mappend` putWord32le (s+1)) `mappend` loop (s+2) (n-2) writeWord32N4Little = loop 0 where loop s n | s `seq` n `seq` False = undefined loop _ 0 = mempty loop s n = ( putWord32le (s+0) `mappend` putWord32le (s+1) `mappend` putWord32le (s+2) `mappend` putWord32le (s+3)) `mappend` loop (s+4) (n-4) writeWord32N8Little = loop 0 where loop s n | s `seq` n `seq` False = undefined loop _ 0 = mempty loop s n = ( putWord32le (s+0) `mappend` putWord32le (s+1) `mappend` putWord32le (s+2) `mappend` putWord32le (s+3) `mappend` putWord32le (s+4) `mappend` putWord32le (s+5) `mappend` putWord32le (s+6) `mappend` putWord32le (s+7)) `mappend` loop (s+8) (n-8) writeWord32N16Little = loop 0 where loop s n | s `seq` n `seq` False = undefined loop _ 0 = mempty loop s n = ( putWord32le (s+0) `mappend` putWord32le (s+1) `mappend` putWord32le (s+2) `mappend` putWord32le (s+3) `mappend` putWord32le (s+4) `mappend` putWord32le (s+5) `mappend` putWord32le (s+6) `mappend` putWord32le (s+7) `mappend` putWord32le (s+8) `mappend` putWord32le (s+9) `mappend` putWord32le (s+10) `mappend` putWord32le (s+11) `mappend` putWord32le (s+12) `mappend` putWord32le (s+13) `mappend` putWord32le (s+14) `mappend` putWord32le (s+15)) `mappend` loop (s+16) (n-16) ------------------------------------------------------------------------ writeWord32N1Host = loop 0 where loop s n | s `seq` n `seq` False = undefined loop _ 0 = mempty loop s n = ( putWord32host (s+0)) `mappend` loop (s+1) (n-1) writeWord32N2Host = loop 0 where loop s n | s `seq` n `seq` False = undefined loop _ 0 = mempty loop s n = ( putWord32host (s+0) `mappend` putWord32host (s+1)) `mappend` loop (s+2) (n-2) writeWord32N4Host = loop 0 where loop s n | s `seq` n `seq` False = undefined loop _ 0 = mempty loop s n = ( putWord32host (s+0) `mappend` putWord32host (s+1) `mappend` putWord32host (s+2) `mappend` putWord32host (s+3)) `mappend` loop (s+4) (n-4) writeWord32N8Host = loop 0 where loop s n | s `seq` n `seq` False = undefined loop _ 0 = mempty loop s n = ( putWord32host (s+0) `mappend` putWord32host (s+1) `mappend` putWord32host (s+2) `mappend` putWord32host (s+3) `mappend` putWord32host (s+4) `mappend` putWord32host (s+5) `mappend` putWord32host (s+6) `mappend` putWord32host (s+7)) `mappend` loop (s+8) (n-8) writeWord32N16Host = loop 0 where loop s n | s `seq` n `seq` False = undefined loop _ 0 = mempty loop s n = ( putWord32host (s+0) `mappend` putWord32host (s+1) `mappend` putWord32host (s+2) `mappend` putWord32host (s+3) `mappend` putWord32host (s+4) `mappend` putWord32host (s+5) `mappend` putWord32host (s+6) `mappend` putWord32host (s+7) `mappend` putWord32host (s+8) `mappend` putWord32host (s+9) `mappend` putWord32host (s+10) `mappend` putWord32host (s+11) `mappend` putWord32host (s+12) `mappend` putWord32host (s+13) `mappend` putWord32host (s+14) `mappend` putWord32host (s+15)) `mappend` loop (s+16) (n-16) ------------------------------------------------------------------------ writeWord64N1Big = loop 0 where loop s n | s `seq` n `seq` False = undefined loop _ 0 = mempty loop s n = ( putWord64be (s+0)) `mappend` loop (s+1) (n-1) writeWord64N2Big = loop 0 where loop s n | s `seq` n `seq` False = undefined loop _ 0 = mempty loop s n = ( putWord64be (s+0) `mappend` putWord64be (s+1)) `mappend` loop (s+2) (n-2) writeWord64N4Big = loop 0 where loop s n | s `seq` n `seq` False = undefined loop _ 0 = mempty loop s n = ( putWord64be (s+0) `mappend` putWord64be (s+1) `mappend` putWord64be (s+2) `mappend` putWord64be (s+3)) `mappend` loop (s+4) (n-4) writeWord64N8Big = loop 0 where loop s n | s `seq` n `seq` False = undefined loop _ 0 = mempty loop s n = ( putWord64be (s+0) `mappend` putWord64be (s+1) `mappend` putWord64be (s+2) `mappend` putWord64be (s+3) `mappend` putWord64be (s+4) `mappend` putWord64be (s+5) `mappend` putWord64be (s+6) `mappend` putWord64be (s+7)) `mappend` loop (s+8) (n-8) writeWord64N16Big = loop 0 where loop s n | s `seq` n `seq` False = undefined loop _ 0 = mempty loop s n = ( putWord64be (s+0) `mappend` putWord64be (s+1) `mappend` putWord64be (s+2) `mappend` putWord64be (s+3) `mappend` putWord64be (s+4) `mappend` putWord64be (s+5) `mappend` putWord64be (s+6) `mappend` putWord64be (s+7) `mappend` putWord64be (s+8) `mappend` putWord64be (s+9) `mappend` putWord64be (s+10) `mappend` putWord64be (s+11) `mappend` putWord64be (s+12) `mappend` putWord64be (s+13) `mappend` putWord64be (s+14) `mappend` putWord64be (s+15)) `mappend` loop (s+16) (n-16) ------------------------------------------------------------------------ writeWord64N1Little = loop 0 where loop s n | s `seq` n `seq` False = undefined loop _ 0 = mempty loop s n = ( putWord64le (s+0)) `mappend` loop (s+1) (n-1) writeWord64N2Little = loop 0 where loop s n | s `seq` n `seq` False = undefined loop _ 0 = mempty loop s n = ( putWord64le (s+0) `mappend` putWord64le (s+1)) `mappend` loop (s+2) (n-2) writeWord64N4Little = loop 0 where loop s n | s `seq` n `seq` False = undefined loop _ 0 = mempty loop s n = ( putWord64le (s+0) `mappend` putWord64le (s+1) `mappend` putWord64le (s+2) `mappend` putWord64le (s+3)) `mappend` loop (s+4) (n-4) writeWord64N8Little = loop 0 where loop s n | s `seq` n `seq` False = undefined loop _ 0 = mempty loop s n = ( putWord64le (s+0) `mappend` putWord64le (s+1) `mappend` putWord64le (s+2) `mappend` putWord64le (s+3) `mappend` putWord64le (s+4) `mappend` putWord64le (s+5) `mappend` putWord64le (s+6) `mappend` putWord64le (s+7)) `mappend` loop (s+8) (n-8) writeWord64N16Little = loop 0 where loop s n | s `seq` n `seq` False = undefined loop _ 0 = mempty loop s n = ( putWord64le (s+0) `mappend` putWord64le (s+1) `mappend` putWord64le (s+2) `mappend` putWord64le (s+3) `mappend` putWord64le (s+4) `mappend` putWord64le (s+5) `mappend` putWord64le (s+6) `mappend` putWord64le (s+7) `mappend` putWord64le (s+8) `mappend` putWord64le (s+9) `mappend` putWord64le (s+10) `mappend` putWord64le (s+11) `mappend` putWord64le (s+12) `mappend` putWord64le (s+13) `mappend` putWord64le (s+14) `mappend` putWord64le (s+15)) `mappend` loop (s+16) (n-16) ------------------------------------------------------------------------ writeWord64N1Host = loop 0 where loop s n | s `seq` n `seq` False = undefined loop _ 0 = mempty loop s n = ( putWord64host (s+0)) `mappend` loop (s+1) (n-1) writeWord64N2Host = loop 0 where loop s n | s `seq` n `seq` False = undefined loop _ 0 = mempty loop s n = ( putWord64host (s+0) `mappend` putWord64host (s+1)) `mappend` loop (s+2) (n-2) writeWord64N4Host = loop 0 where loop s n | s `seq` n `seq` False = undefined loop _ 0 = mempty loop s n = ( putWord64host (s+0) `mappend` putWord64host (s+1) `mappend` putWord64host (s+2) `mappend` putWord64host (s+3)) `mappend` loop (s+4) (n-4) writeWord64N8Host = loop 0 where loop s n | s `seq` n `seq` False = undefined loop _ 0 = mempty loop s n = ( putWord64host (s+0) `mappend` putWord64host (s+1) `mappend` putWord64host (s+2) `mappend` putWord64host (s+3) `mappend` putWord64host (s+4) `mappend` putWord64host (s+5) `mappend` putWord64host (s+6) `mappend` putWord64host (s+7)) `mappend` loop (s+8) (n-8) writeWord64N16Host = loop 0 where loop s n | s `seq` n `seq` False = undefined loop _ 0 = mempty loop s n = ( putWord64host (s+0) `mappend` putWord64host (s+1) `mappend` putWord64host (s+2) `mappend` putWord64host (s+3) `mappend` putWord64host (s+4) `mappend` putWord64host (s+5) `mappend` putWord64host (s+6) `mappend` putWord64host (s+7) `mappend` putWord64host (s+8) `mappend` putWord64host (s+9) `mappend` putWord64host (s+10) `mappend` putWord64host (s+11) `mappend` putWord64host (s+12) `mappend` putWord64host (s+13) `mappend` putWord64host (s+14) `mappend` putWord64host (s+15)) `mappend` loop (s+16) (n-16) blaze-builder-0.4.0.2/benchmarks/Throughput/Memory.hs0000644000000000000000000000717212705234666020676 0ustar0000000000000000{-# LANGUAGE ForeignFunctionInterface, BangPatterns #-} module Throughput.Memory (memBench) where import Foreign import Foreign.C import Control.Exception import System.CPUTime import Numeric memBench :: Int -> IO () memBench mb = do let bytes = mb * 2^20 allocaBytes bytes $ \ptr -> do let bench label test = do seconds <- time $ test (castPtr ptr) (fromIntegral bytes) let throughput = fromIntegral mb / seconds putStrLn $ show mb ++ "MB of " ++ label ++ " in " ++ showFFloat (Just 3) seconds "s, at: " ++ showFFloat (Just 1) throughput "MB/s" bench "setup " c_wordwrite putStrLn "" putStrLn "C memory throughput benchmarks:" bench "bytes written " c_bytewrite bench "bytes read " c_byteread bench "words written " c_wordwrite bench "words read " c_wordread putStrLn "" putStrLn "Haskell memory throughput benchmarks:" bench "bytes written " hs_bytewrite bench "bytes written (loop unrolled once)" hs_bytewrite2 bench "bytes read " hs_byteread bench "words written " hs_wordwrite bench "words read " hs_wordread hs_bytewrite :: Ptr CUChar -> Int -> IO () hs_bytewrite !ptr bytes = loop 0 0 where iterations = bytes loop :: Int -> CUChar -> IO () loop !i !n | i == iterations = return () | otherwise = do pokeByteOff ptr i n loop (i+1) (n+1) hs_bytewrite2 :: Ptr CUChar -> Int -> IO () hs_bytewrite2 !start bytes = loop start 0 where end = start `plusPtr` bytes loop :: Ptr CUChar -> CUChar -> IO () loop !ptr !n | ptr `plusPtr` 2 < end = do poke ptr n poke (ptr `plusPtr` 1) (n+1) loop (ptr `plusPtr` 2) (n+2) | ptr `plusPtr` 1 < end = poke ptr n | otherwise = return () hs_byteread :: Ptr CUChar -> Int -> IO CUChar hs_byteread !ptr bytes = loop 0 0 where iterations = bytes loop :: Int -> CUChar -> IO CUChar loop !i !n | i == iterations = return n | otherwise = do x <- peekByteOff ptr i loop (i+1) (n+x) hs_wordwrite :: Ptr CULong -> Int -> IO () hs_wordwrite !ptr bytes = loop 0 0 where iterations = bytes `div` sizeOf (undefined :: CULong) loop :: Int -> CULong -> IO () loop !i !n | i == iterations = return () | otherwise = do pokeByteOff ptr i n loop (i+1) (n+1) hs_wordread :: Ptr CULong -> Int -> IO CULong hs_wordread !ptr bytes = loop 0 0 where iterations = bytes `div` sizeOf (undefined :: CULong) loop :: Int -> CULong -> IO CULong loop !i !n | i == iterations = return n | otherwise = do x <- peekByteOff ptr i loop (i+1) (n+x) foreign import ccall unsafe "CBenchmark.h byteread" c_byteread :: Ptr CUChar -> CInt -> IO () foreign import ccall unsafe "CBenchmark.h bytewrite" c_bytewrite :: Ptr CUChar -> CInt -> IO () foreign import ccall unsafe "CBenchmark.h wordread" c_wordread :: Ptr CUInt -> CInt -> IO () foreign import ccall unsafe "CBenchmark.h wordwrite" c_wordwrite :: Ptr CUInt -> CInt -> IO () time :: IO a -> IO Double time action = do start <- getCPUTime action end <- getCPUTime return $! (fromIntegral (end - start)) / (10^12) blaze-builder-0.4.0.2/benchmarks/Throughput/BlazeBuilderDeclarative.hs0000644000000000000000000001673412705234666024142 0ustar0000000000000000{-# LANGUAGE BangPatterns #-} module Throughput.BlazeBuilderDeclarative ( serialize ) where import Data.Monoid import Data.Word import qualified Data.ByteString.Lazy as L import Blaze.ByteString.Builder import Throughput.Utils serialize :: Int -> Int -> Endian -> Int -> L.ByteString serialize wordSize chunkSize end = toLazyByteString . case (wordSize, chunkSize, end) of (1, 1,_) -> writeByteN1 (1, 2,_) -> writeByteN2 (1, 4,_) -> writeByteN4 (1, 8,_) -> writeByteN8 (1, 16, _) -> writeByteN16 (2, 1, Big) -> writeWord16N1Big (2, 2, Big) -> writeWord16N2Big (2, 4, Big) -> writeWord16N4Big (2, 8, Big) -> writeWord16N8Big (2, 16, Big) -> writeWord16N16Big (2, 1, Little) -> writeWord16N1Little (2, 2, Little) -> writeWord16N2Little (2, 4, Little) -> writeWord16N4Little (2, 8, Little) -> writeWord16N8Little (2, 16, Little) -> writeWord16N16Little (2, 1, Host) -> writeWord16N1Host (2, 2, Host) -> writeWord16N2Host (2, 4, Host) -> writeWord16N4Host (2, 8, Host) -> writeWord16N8Host (2, 16, Host) -> writeWord16N16Host (4, 1, Big) -> writeWord32N1Big (4, 2, Big) -> writeWord32N2Big (4, 4, Big) -> writeWord32N4Big (4, 8, Big) -> writeWord32N8Big (4, 16, Big) -> writeWord32N16Big (4, 1, Little) -> writeWord32N1Little (4, 2, Little) -> writeWord32N2Little (4, 4, Little) -> writeWord32N4Little (4, 8, Little) -> writeWord32N8Little (4, 16, Little) -> writeWord32N16Little (4, 1, Host) -> writeWord32N1Host (4, 2, Host) -> writeWord32N2Host (4, 4, Host) -> writeWord32N4Host (4, 8, Host) -> writeWord32N8Host (4, 16, Host) -> writeWord32N16Host (8, 1, Host) -> writeWord64N1Host (8, 2, Host) -> writeWord64N2Host (8, 4, Host) -> writeWord64N4Host (8, 8, Host) -> writeWord64N8Host (8, 16, Host) -> writeWord64N16Host (8, 1, Big) -> writeWord64N1Big (8, 2, Big) -> writeWord64N2Big (8, 4, Big) -> writeWord64N4Big (8, 8, Big) -> writeWord64N8Big (8, 16, Big) -> writeWord64N16Big (8, 1, Little) -> writeWord64N1Little (8, 2, Little) -> writeWord64N2Little (8, 4, Little) -> writeWord64N4Little (8, 8, Little) -> writeWord64N8Little (8, 16, Little) -> writeWord64N16Little ------------------------------------------------------------------------ -- Word8 ------------------------------------------------------------------------ word8List :: Int -> [Word8] word8List n = take n $ cycle $ [0..] ------------------------------------------------------------------------ writeByteN1 = fromWrite1List writeWord8 . word8List writeByteN2 = fromWrite2List writeWord8 . word8List writeByteN4 = fromWrite4List writeWord8 . word8List writeByteN8 = fromWrite8List writeWord8 . word8List writeByteN16 = fromWrite16List writeWord8 . word8List ------------------------------------------------------------------------ -- Word16 ------------------------------------------------------------------------ word16List :: Int -> [Word16] word16List n = take n $ cycle $ [0..] ------------------------------------------------------------------------ -- Big endian, word16 writes writeWord16N1Big = fromWrite1List writeWord16be . word16List writeWord16N2Big = fromWrite2List writeWord16be . word16List writeWord16N4Big = fromWrite4List writeWord16be . word16List writeWord16N8Big = fromWrite8List writeWord16be . word16List writeWord16N16Big = fromWrite16List writeWord16be . word16List ------------------------------------------------------------------------ -- Little endian, word16 writes writeWord16N1Little = fromWrite1List writeWord16le . word16List writeWord16N2Little = fromWrite2List writeWord16le . word16List writeWord16N4Little = fromWrite4List writeWord16le . word16List writeWord16N8Little = fromWrite8List writeWord16le . word16List writeWord16N16Little = fromWrite16List writeWord16le . word16List ------------------------------------------------------------------------ -- Host endian, unaligned, word16 writes writeWord16N1Host = fromWrite1List writeWord16host . word16List writeWord16N2Host = fromWrite2List writeWord16host . word16List writeWord16N4Host = fromWrite4List writeWord16host . word16List writeWord16N8Host = fromWrite8List writeWord16host . word16List writeWord16N16Host = fromWrite16List writeWord16host . word16List ------------------------------------------------------------------------ -- Word32 ------------------------------------------------------------------------ word32List :: Int -> [Word32] word32List n = [0..fromIntegral (n-1)] ------------------------------------------------------------------------ -- Big endian, word16 writes writeWord32N1Big = fromWrite1List writeWord32be . word32List writeWord32N2Big = fromWrite2List writeWord32be . word32List writeWord32N4Big = fromWrite4List writeWord32be . word32List writeWord32N8Big = fromWrite8List writeWord32be . word32List writeWord32N16Big = fromWrite16List writeWord32be . word32List ------------------------------------------------------------------------ -- Little endian, word32 writes writeWord32N1Little = fromWrite1List writeWord32le . word32List writeWord32N2Little = fromWrite2List writeWord32le . word32List writeWord32N4Little = fromWrite4List writeWord32le . word32List writeWord32N8Little = fromWrite8List writeWord32le . word32List writeWord32N16Little = fromWrite16List writeWord32le . word32List ------------------------------------------------------------------------ -- Host endian, unaligned, word32 writes writeWord32N1Host = fromWrite1List writeWord32host . word32List writeWord32N2Host = fromWrite2List writeWord32host . word32List writeWord32N4Host = fromWrite4List writeWord32host . word32List writeWord32N8Host = fromWrite8List writeWord32host . word32List writeWord32N16Host = fromWrite16List writeWord32host . word32List ------------------------------------------------------------------------ -- Word64 ------------------------------------------------------------------------ word64List :: Int -> [Word64] word64List n = [0..fromIntegral (n-1)] ------------------------------------------------------------------------ -- Big endian, word16 writes writeWord64N1Big = fromWrite1List writeWord64be . word64List writeWord64N2Big = fromWrite2List writeWord64be . word64List writeWord64N4Big = fromWrite4List writeWord64be . word64List writeWord64N8Big = fromWrite8List writeWord64be . word64List writeWord64N16Big = fromWrite16List writeWord64be . word64List ------------------------------------------------------------------------ -- Little endian, word64 writes writeWord64N1Little = fromWrite1List writeWord64le . word64List writeWord64N2Little = fromWrite2List writeWord64le . word64List writeWord64N4Little = fromWrite4List writeWord64le . word64List writeWord64N8Little = fromWrite8List writeWord64le . word64List writeWord64N16Little = fromWrite16List writeWord64le . word64List ------------------------------------------------------------------------ -- Host endian, unaligned, word64 writes writeWord64N1Host = fromWrite1List writeWord64host . word64List writeWord64N2Host = fromWrite2List writeWord64host . word64List writeWord64N4Host = fromWrite4List writeWord64host . word64List writeWord64N8Host = fromWrite8List writeWord64host . word64List writeWord64N16Host = fromWrite16List writeWord64host . word64List blaze-builder-0.4.0.2/benchmarks/Throughput/CBenchmark.h0000755000000000000000000000030312705234666021230 0ustar0000000000000000void bytewrite(unsigned char *a, int bytes); unsigned char byteread(unsigned char *a, int bytes); void wordwrite(unsigned long *a, int bytes); unsigned int wordread(unsigned long *a, int bytes); blaze-builder-0.4.0.2/benchmarks/Throughput/BinaryBuilderDeclarative.hs0000644000000000000000000000672712705234666024332 0ustar0000000000000000module Throughput.BinaryBuilderDeclarative ( serialize ) where import Data.Monoid import Data.Word import qualified Data.ByteString.Lazy as L import Data.Binary.Builder import Control.Monad import Throughput.Utils serialize :: Int -> Int -> Endian -> Int -> Maybe L.ByteString serialize wordSize chunkSize end iters = fmap toLazyByteString $ case (wordSize, chunkSize, end) of (1, 1,_) -> return $ writeByteN1 iters (2, 1, Big) -> return $ writeWord16N1Big iters (2, 1, Little) -> return $ writeWord16N1Little iters (2, 1, Host) -> return $ writeWord16N1Host iters (4, 1, Big) -> return $ writeWord32N1Big iters (4, 1, Little) -> return $ writeWord32N1Little iters (4, 1, Host) -> return $ writeWord32N1Host iters (8, 1, Host) -> return $ writeWord64N1Host iters (8, 1, Big) -> return $ writeWord64N1Big iters (8, 1, Little) -> return $ writeWord64N1Little iters _ -> mzero ------------------------------------------------------------------------ -- Word8 ------------------------------------------------------------------------ word8List :: Int -> [Word8] word8List n = take n $ cycle $ [0..] ------------------------------------------------------------------------ writeByteN1 = mconcat . map singleton . word8List ------------------------------------------------------------------------ -- Word16 ------------------------------------------------------------------------ word16List :: Int -> [Word16] word16List n = take n $ cycle $ [0..] ------------------------------------------------------------------------ -- Big endian, word16 writes writeWord16N1Big = mconcat . map putWord16be . word16List ------------------------------------------------------------------------ -- Little endian, word16 writes writeWord16N1Little = mconcat . map putWord16le . word16List ------------------------------------------------------------------------ -- Host endian, unaligned, word16 writes writeWord16N1Host = mconcat . map putWord16host . word16List ------------------------------------------------------------------------ -- Word32 ------------------------------------------------------------------------ word32List :: Int -> [Word32] word32List n = [0..fromIntegral (n-1)] ------------------------------------------------------------------------ -- Big endian, word16 writes writeWord32N1Big = mconcat . map putWord32be . word32List ------------------------------------------------------------------------ -- Little endian, word32 writes writeWord32N1Little = mconcat . map putWord32le . word32List ------------------------------------------------------------------------ -- Host endian, unaligned, word32 writes writeWord32N1Host = mconcat . map putWord32host . word32List ------------------------------------------------------------------------ -- Word64 ------------------------------------------------------------------------ word64List :: Int -> [Word64] word64List n = [0..fromIntegral (n-1)] ------------------------------------------------------------------------ -- Big endian, word16 writes writeWord64N1Big = mconcat . map putWord64be . word64List ------------------------------------------------------------------------ -- Little endian, word64 writes writeWord64N1Little = mconcat . map putWord64le . word64List ------------------------------------------------------------------------ -- Host endian, unaligned, word64 writes writeWord64N1Host = mconcat . map putWord64host . word64List blaze-builder-0.4.0.2/benchmarks/Throughput/BlazePutMonad.hs0000755000000000000000000001451012705234666022130 0ustar0000000000000000{-# LANGUAGE CPP #-} ----------------------------------------------------------------------------- -- | -- Module : Data.Binary.Put -- Copyright : Lennart Kolmodin -- License : BSD3-style (see LICENSE) -- -- Maintainer : Lennart Kolmodin -- Stability : stable -- Portability : Portable to Hugs and GHC. Requires MPTCs -- -- The Put monad. A monad for efficiently constructing lazy bytestrings using -- the Builder developed for blaze-html. -- ----------------------------------------------------------------------------- module Throughput.BlazePutMonad ( -- * The Put type Put , PutM(..) , runPut , runPutM , putBuilder , execPut -- * Flushing the implicit parse state , flush -- * Primitives , putWrite , putWord8 , putByteString , putLazyByteString -- * Big-endian primitives , putWord16be , putWord32be , putWord64be -- * Little-endian primitives , putWord16le , putWord32le , putWord64le -- * Host-endian, unaligned writes , putWordhost -- :: Word -> Put , putWord16host -- :: Word16 -> Put , putWord32host -- :: Word32 -> Put , putWord64host -- :: Word64 -> Put ) where import Data.Monoid import Blaze.ByteString.Builder (Builder, toLazyByteString) import qualified Blaze.ByteString.Builder as B import Data.Word import qualified Data.ByteString as S import qualified Data.ByteString.Lazy as L import Control.Applicative ------------------------------------------------------------------------ -- XXX Strict in buffer only. data PairS a = PairS a {-# UNPACK #-}!Builder sndS :: PairS a -> Builder sndS (PairS _ b) = b -- | The PutM type. A Writer monad over the efficient Builder monoid. newtype PutM a = Put { unPut :: PairS a } -- | Put merely lifts Builder into a Writer monad, applied to (). type Put = PutM () instance Functor PutM where fmap f m = Put $ let PairS a w = unPut m in PairS (f a) w {-# INLINE fmap #-} instance Applicative PutM where pure = return m <*> k = Put $ let PairS f w = unPut m PairS x w' = unPut k in PairS (f x) (w `mappend` w') -- Standard Writer monad, with aggressive inlining instance Monad PutM where return a = Put $ PairS a mempty {-# INLINE return #-} m >>= k = Put $ let PairS a w = unPut m PairS b w' = unPut (k a) in PairS b (w `mappend` w') {-# INLINE (>>=) #-} m >> k = Put $ let PairS _ w = unPut m PairS b w' = unPut k in PairS b (w `mappend` w') {-# INLINE (>>) #-} tell :: Builder -> Put tell b = Put $ PairS () b {-# INLINE tell #-} putBuilder :: Builder -> Put putBuilder = tell {-# INLINE putBuilder #-} -- | Run the 'Put' monad execPut :: PutM a -> Builder execPut = sndS . unPut {-# INLINE execPut #-} -- | Run the 'Put' monad with a serialiser runPut :: Put -> L.ByteString runPut = toLazyByteString . sndS . unPut {-# INLINE runPut #-} -- | Run the 'Put' monad with a serialiser and get its result runPutM :: PutM a -> (a, L.ByteString) runPutM (Put (PairS f s)) = (f, toLazyByteString s) {-# INLINE runPutM #-} ------------------------------------------------------------------------ -- | Pop the ByteString we have constructed so far, if any, yielding a -- new chunk in the result ByteString. flush :: Put flush = tell B.flush {-# INLINE flush #-} -- | Efficiently write a byte into the output buffer putWord8 :: Word8 -> Put putWord8 = tell . B.fromWord8 {-# INLINE putWord8 #-} -- | Execute a write on the output buffer. putWrite :: B.Write -> Put putWrite = tell . B.fromWrite -- | An efficient primitive to write a strict ByteString into the output buffer. -- It flushes the current buffer, and writes the argument into a new chunk. putByteString :: S.ByteString -> Put putByteString = tell . B.fromByteString {-# INLINE putByteString #-} -- | Write a lazy ByteString efficiently, simply appending the lazy -- ByteString chunks to the output buffer putLazyByteString :: L.ByteString -> Put putLazyByteString = tell . B.fromLazyByteString {-# INLINE putLazyByteString #-} -- | Write a Word16 in big endian format putWord16be :: Word16 -> Put putWord16be = tell . B.fromWord16be {-# INLINE putWord16be #-} -- | Write a Word16 in little endian format putWord16le :: Word16 -> Put putWord16le = tell . B.fromWord16le {-# INLINE putWord16le #-} -- | Write a Word32 in big endian format putWord32be :: Word32 -> Put putWord32be = tell . B.fromWord32be {-# INLINE putWord32be #-} -- | Write a Word32 in little endian format putWord32le :: Word32 -> Put putWord32le = tell . B.fromWord32le {-# INLINE putWord32le #-} -- | Write a Word64 in big endian format putWord64be :: Word64 -> Put putWord64be = tell . B.fromWord64be {-# INLINE putWord64be #-} -- | Write a Word64 in little endian format putWord64le :: Word64 -> Put putWord64le = tell . B.fromWord64le {-# INLINE putWord64le #-} ------------------------------------------------------------------------ -- | /O(1)./ Write a single native machine word. The word is -- written in host order, host endian form, for the machine you're on. -- On a 64 bit machine the Word is an 8 byte value, on a 32 bit machine, -- 4 bytes. Values written this way are not portable to -- different endian or word sized machines, without conversion. -- putWordhost :: Word -> Put putWordhost = tell . B.fromWordhost {-# INLINE putWordhost #-} -- | /O(1)./ Write a Word16 in native host order and host endianness. -- For portability issues see @putWordhost@. putWord16host :: Word16 -> Put putWord16host = tell . B.fromWord16host {-# INLINE putWord16host #-} -- | /O(1)./ Write a Word32 in native host order and host endianness. -- For portability issues see @putWordhost@. putWord32host :: Word32 -> Put putWord32host = tell . B.fromWord32host {-# INLINE putWord32host #-} -- | /O(1)./ Write a Word64 in native host order -- On a 32 bit machine we write two host order Word32s, in big endian form. -- For portability issues see @putWordhost@. putWord64host :: Word64 -> Put putWord64host = tell . B.fromWord64host {-# INLINE putWord64host #-} blaze-builder-0.4.0.2/Blaze/0000755000000000000000000000000012705234666013632 5ustar0000000000000000blaze-builder-0.4.0.2/Blaze/ByteString/0000755000000000000000000000000012705234666015724 5ustar0000000000000000blaze-builder-0.4.0.2/Blaze/ByteString/Builder.hs0000644000000000000000000002431412705234666017652 0ustar0000000000000000{-# 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 #-} blaze-builder-0.4.0.2/Blaze/ByteString/Builder/0000755000000000000000000000000012705234666017312 5ustar0000000000000000blaze-builder-0.4.0.2/Blaze/ByteString/Builder/Word.hs0000644000000000000000000002221512705234666020563 0ustar0000000000000000------------------------------------------------------------------------------ -- | -- 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 #-} blaze-builder-0.4.0.2/Blaze/ByteString/Builder/Char8.hs0000644000000000000000000000443212705234666020616 0ustar0000000000000000------------------------------------------------------------------------------ -- | -- Module: Blaze.ByteString.Builder.Char8 -- Copyright: (c) 2013 Leon P Smith -- License: BSD3 -- Maintainer: Leon P Smith -- Stability: experimental -- -- //Note:// This package is intended for low-level use like implementing -- protocols. If you need to //serialize// Unicode characters use one of the -- UTF encodings (e.g. 'Blaze.ByteString.Builder.Char.UTF-8'). -- -- 'Write's and 'Builder's for serializing the lower 8-bits of characters. -- -- This corresponds to what the 'bytestring' package offer in -- 'Data.ByteString.Char8'. -- ------------------------------------------------------------------------------ module Blaze.ByteString.Builder.Char8 ( -- * Writing Latin-1 (ISO 8859-1) encodable characters to a buffer writeChar -- * Creating Builders from Latin-1 (ISO 8859-1) encodable characters , fromChar , fromString , fromShow , fromText , fromLazyText ) where import Blaze.ByteString.Builder.Compat.Write ( Write, writePrimFixed ) import Data.ByteString.Builder ( Builder ) import qualified Data.ByteString.Builder as B import qualified Data.ByteString.Builder.Prim as P import qualified Data.Text as TS import qualified Data.Text.Lazy as TL -- | Write the lower 8-bits of a character to a buffer. writeChar :: Char -> Write writeChar = writePrimFixed P.char8 {-# INLINE writeChar #-} -- | /O(1)/. Serialize the lower 8-bits of a character. fromChar :: Char -> Builder fromChar = B.char8 {-# INLINE fromChar #-} -- | /O(n)/. Serialize the lower 8-bits of all characters of a string fromString :: String -> Builder fromString = P.primMapListFixed P.char8 {-# INLINE fromString #-} -- | /O(n)/. Serialize a value by 'Show'ing it and serializing the lower 8-bits -- of the resulting string. fromShow :: Show a => a -> Builder fromShow = fromString . show {-# INLINE fromShow #-} -- | /O(n)/. Serialize the lower 8-bits of all characters in the strict text. fromText :: TS.Text -> Builder fromText = fromString . TS.unpack {-# INLINE fromText #-} -- | /O(n)/. Serialize the lower 8-bits of all characters in the lazy text. fromLazyText :: TL.Text -> Builder fromLazyText = fromString . TL.unpack {-# INLINE fromLazyText #-} blaze-builder-0.4.0.2/Blaze/ByteString/Builder/Int.hs0000644000000000000000000002105612705234666020404 0ustar0000000000000000------------------------------------------------------------------------------ -- | -- 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 #-} blaze-builder-0.4.0.2/Blaze/ByteString/Builder/HTTP.hs0000644000000000000000000001664612705234666020442 0ustar0000000000000000{-# LANGUAGE BangPatterns, CPP, MagicHash, OverloadedStrings #-} ------------------------------------------------------------------------------ -- | -- Module: Blaze.ByteString.Builder.HTTP -- Copyright: (c) 2013 Simon Meier -- License: BSD3 -- Maintainer: Leon P Smith -- Stability: experimental -- -- Support for HTTP response encoding. -- ------------------------------------------------------------------------------ module Blaze.ByteString.Builder.HTTP ( -- * Chunked HTTP transfer encoding chunkedTransferEncoding , chunkedTransferTerminator ) where #if defined(__GLASGOW_HASKELL__) && !defined(__HADDOCK__) #include "MachDeps.h" #endif #if defined(__GLASGOW_HASKELL__) && !defined(__HADDOCK__) import GHC.Base import GHC.Word (Word32(..)) #else import Data.Word #endif import Foreign import qualified Data.ByteString as S import Data.ByteString.Char8 () import Blaze.ByteString.Builder.Internal.Write import Data.ByteString.Builder import Data.ByteString.Builder.Internal import Blaze.ByteString.Builder.ByteString (copyByteString) import qualified Blaze.ByteString.Builder.Char8 as Char8 #if !MIN_VERSION_base(4,8,0) import Data.Monoid #endif {-# INLINE shiftr_w32 #-} shiftr_w32 :: Word32 -> Int -> Word32 #if defined(__GLASGOW_HASKELL__) && !defined(__HADDOCK__) shiftr_w32 (W32# w) (I# i) = W32# (w `uncheckedShiftRL#` i) #else shiftr_w32 = shiftR #endif -- | Write a CRLF sequence. writeCRLF :: Write writeCRLF = Char8.writeChar '\r' `mappend` Char8.writeChar '\n' {-# INLINE writeCRLF #-} -- | Execute a write {-# INLINE execWrite #-} execWrite :: Write -> Ptr Word8 -> IO () execWrite w op = do _ <- runPoke (getPoke w) op return () ------------------------------------------------------------------------------ -- Hex Encoding Infrastructure ------------------------------------------------------------------------------ pokeWord32HexN :: Int -> Word32 -> Ptr Word8 -> IO () pokeWord32HexN n0 w0 op0 = go w0 (op0 `plusPtr` (n0 - 1)) where go !w !op | op < op0 = return () | otherwise = do let nibble :: Word8 nibble = fromIntegral w .&. 0xF hex | nibble < 10 = 48 + nibble | otherwise = 55 + nibble poke op hex go (w `shiftr_w32` 4) (op `plusPtr` (-1)) {-# INLINE pokeWord32HexN #-} iterationsUntilZero :: Integral a => (a -> a) -> a -> Int iterationsUntilZero f = go 0 where go !count 0 = count go !count !x = go (count+1) (f x) {-# INLINE iterationsUntilZero #-} -- | Length of the hex-string required to encode the given 'Word32'. word32HexLength :: Word32 -> Int word32HexLength = max 1 . iterationsUntilZero (`shiftr_w32` 4) {-# INLINE word32HexLength #-} writeWord32Hex :: Word32 -> Write writeWord32Hex w = boundedWrite (2 * sizeOf w) (pokeN len $ pokeWord32HexN len w) where len = word32HexLength w {-# INLINE writeWord32Hex #-} ------------------------------------------------------------------------------ -- Chunked transfer encoding ------------------------------------------------------------------------------ -- | Transform a builder such that it uses chunked HTTP transfer encoding. chunkedTransferEncoding :: Builder -> Builder chunkedTransferEncoding innerBuilder = builder transferEncodingStep where transferEncodingStep k = go (runBuilder innerBuilder) where go innerStep !(BufferRange op ope) -- FIXME: Assert that outRemaining < maxBound :: Word32 | outRemaining < minimalBufferSize = return $ bufferFull minimalBufferSize op (go innerStep) | otherwise = do let !brInner@(BufferRange opInner _) = BufferRange (op `plusPtr` (chunkSizeLength + 2)) -- leave space for chunk header (ope `plusPtr` (-maxAfterBufferOverhead)) -- leave space at end of data -- wraps the chunk, if it is non-empty, and returns the -- signal constructed with the correct end-of-data pointer {-# INLINE wrapChunk #-} wrapChunk :: Ptr Word8 -> (Ptr Word8 -> IO (BuildSignal a)) -> IO (BuildSignal a) wrapChunk !opInner' mkSignal | opInner' == opInner = mkSignal op | otherwise = do pokeWord32HexN chunkSizeLength (fromIntegral $ opInner' `minusPtr` opInner) op execWrite writeCRLF (opInner `plusPtr` (-2)) execWrite writeCRLF opInner' mkSignal (opInner' `plusPtr` 2) -- prepare handlers doneH opInner' _ = wrapChunk opInner' $ \op' -> do let !br' = BufferRange op' ope k br' fullH opInner' minRequiredSize nextInnerStep = wrapChunk opInner' $ \op' -> return $! bufferFull (minRequiredSize + maxEncodingOverhead) op' (go nextInnerStep) insertChunkH opInner' bs nextInnerStep | S.null bs = -- flush wrapChunk opInner' $ \op' -> return $! insertChunk op' S.empty (go nextInnerStep) | otherwise = -- insert non-empty bytestring wrapChunk opInner' $ \op' -> do -- add header for inserted bytestring -- FIXME: assert(S.length bs < maxBound :: Word32) !op'' <- (`runPoke` op') $ getPoke $ writeWord32Hex (fromIntegral $ S.length bs) `mappend` writeCRLF -- insert bytestring and write CRLF in next buildstep return $! insertChunk op'' bs (runBuilderWith (fromWrite writeCRLF) $ go nextInnerStep) -- execute inner builder with reduced boundaries fillWithBuildStep innerStep doneH fullH insertChunkH brInner where -- minimal size guaranteed for actual data no need to require more -- than 1 byte to guarantee progress the larger sizes will be -- hopefully provided by the driver or requested by the wrapped -- builders. minimalChunkSize = 1 -- overhead computation maxBeforeBufferOverhead = sizeOf (undefined :: Int) + 2 -- max chunk size and CRLF after header maxAfterBufferOverhead = 2 + -- CRLF after data sizeOf (undefined :: Int) + 2 -- max bytestring size, CRLF after header maxEncodingOverhead = maxBeforeBufferOverhead + maxAfterBufferOverhead minimalBufferSize = minimalChunkSize + maxEncodingOverhead -- remaining and required space computation outRemaining :: Int outRemaining = ope `minusPtr` op chunkSizeLength = word32HexLength $ fromIntegral outRemaining -- | The zero-length chunk '0\r\n\r\n' signaling the termination of the data transfer. chunkedTransferTerminator :: Builder chunkedTransferTerminator = copyByteString "0\r\n\r\n" blaze-builder-0.4.0.2/Blaze/ByteString/Builder/ByteString.hs0000644000000000000000000001117312705234666021743 0ustar0000000000000000------------------------------------------------------------------------------ -- | -- 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 #-} blaze-builder-0.4.0.2/Blaze/ByteString/Builder/Internal/0000755000000000000000000000000012705234666021066 5ustar0000000000000000blaze-builder-0.4.0.2/Blaze/ByteString/Builder/Internal/Write.hs0000644000000000000000000002244412705234666022522 0ustar0000000000000000{-# LANGUAGE CPP, BangPatterns #-} -- | -- Module : Blaze.ByteString.Builder.Internal.Poke -- Copyright : (c) 2010 Simon Meier -- (c) 2010 Jasper van der Jeugt -- License : BSD3-style (see LICENSE) -- -- Maintainer : Leon Smith -- Stability : experimental -- Portability : tested on GHC only -- -- A general and efficient write type that allows for the easy construction of -- builders for (smallish) bounded size writes to a buffer. -- -- FIXME: Improve documentation. -- module Blaze.ByteString.Builder.Internal.Write ( -- * Poking a buffer Poke(..) , pokeN -- * Writing to abuffer , Write(..) , runWrite , getBound , getBound' , getPoke , exactWrite , boundedWrite , writeLiftIO , writeIf , writeEq , writeOrdering , writeOrd -- * Constructing builders from writes , fromWrite , fromWriteSingleton , fromWriteList -- * Writing 'Storable's , writeStorable , fromStorable , fromStorables ) where import Foreign import Control.Monad import Data.ByteString.Builder.Internal #if !MIN_VERSION_base(4,8,0) import Data.Monoid #endif ------------------------------------------------------------------------------ -- Poking a buffer and writing to a buffer ------------------------------------------------------------------------------ -- Sadly GHC is not smart enough: code where we branch and each branch should -- execute a few IO actions and then return a value cannot be taught to GHC. At -- least not such that it returns the value of the branches unpacked. -- -- Hmm.. at least he behaves much better for the Monoid instance of Write -- than the one for Poke. Serializing UTF-8 chars gets a slowdown of a -- factor 2 when 2 chars are composed. Perhaps I should try out the writeList -- instances also, as they may be more sensitive to to much work per Char. -- -- | Changing a sequence of bytes starting from the given pointer. 'Poke's are -- the most primitive buffer manipulation. In most cases, you don't use the -- explicitely but as part of a 'Write', which also tells how many bytes will -- be changed at most. newtype Poke = Poke { runPoke :: Ptr Word8 -> IO (Ptr Word8) } -- | A write of a bounded number of bytes. -- -- When defining a function @write :: a -> Write@ for some @a@, then it is -- important to ensure that the bound on the number of bytes written is -- data-independent. Formally, -- -- @ forall x y. getBound (write x) = getBound (write y) @ -- -- The idea is that this data-independent bound is specified such that the -- compiler can optimize the check, if there are enough free bytes in the buffer, -- to a single subtraction between the pointer to the next free byte and the -- pointer to the end of the buffer with this constant bound of the maximal -- number of bytes to be written. -- data Write = Write {-# UNPACK #-} !Int Poke -- | Extract the 'Poke' action of a write. {-# INLINE getPoke #-} getPoke :: Write -> Poke getPoke (Write _ wio) = wio -- | Run the 'Poke' action of a write. {-# INLINE runWrite #-} runWrite :: Write -> Ptr Word8 -> IO (Ptr Word8) runWrite = runPoke . getPoke -- | Extract the maximal number of bytes that this write could write. {-# INLINE getBound #-} getBound :: Write -> Int getBound (Write bound _) = bound -- | Extract the maximal number of bytes that this write could write in any -- case. Assumes that the bound of the write is data-independent. {-# INLINE getBound' #-} getBound' :: String -- ^ Name of caller: for debugging purposes. -> (a -> Write) -> Int getBound' msg write = getBound $ write $ error $ "getBound' called from " ++ msg ++ ": write bound is not data-independent." instance Monoid Poke where {-# INLINE mempty #-} mempty = Poke $ return {-# INLINE mappend #-} (Poke po1) `mappend` (Poke po2) = Poke $ po1 >=> po2 {-# INLINE mconcat #-} mconcat = foldr mappend mempty instance Monoid Write where {-# INLINE mempty #-} mempty = Write 0 mempty {-# INLINE mappend #-} (Write bound1 w1) `mappend` (Write bound2 w2) = Write (bound1 + bound2) (w1 `mappend` w2) {-# INLINE mconcat #-} mconcat = foldr mappend mempty -- | @pokeN size io@ creates a write that denotes the writing of @size@ bytes -- to a buffer using the IO action @io@. Note that @io@ MUST write EXACTLY @size@ -- bytes to the buffer! {-# INLINE pokeN #-} pokeN :: Int -> (Ptr Word8 -> IO ()) -> Poke pokeN size io = Poke $ \op -> io op >> (return $! (op `plusPtr` size)) -- | @exactWrite size io@ creates a bounded write that can later be converted to -- a builder that writes exactly @size@ bytes. Note that @io@ MUST write -- EXACTLY @size@ bytes to the buffer! {-# INLINE exactWrite #-} exactWrite :: Int -> (Ptr Word8 -> IO ()) -> Write exactWrite size io = Write size (pokeN size io) -- | @boundedWrite size write@ creates a bounded write from a @write@ that does -- not write more than @size@ bytes. {-# INLINE boundedWrite #-} boundedWrite :: Int -> Poke -> Write boundedWrite = Write -- | @writeLiftIO io write@ creates a write executes the @io@ action to compute -- the value that is then written. {-# INLINE writeLiftIO #-} writeLiftIO :: (a -> Write) -> IO a -> Write writeLiftIO write io = Write (getBound' "writeLiftIO" write) (Poke $ \pf -> do x <- io; runWrite (write x) pf) -- | @writeIf p wTrue wFalse x@ creates a 'Write' with a 'Poke' equal to @wTrue -- x@, if @p x@ and equal to @wFalse x@ otherwise. The bound of this new -- 'Write' is the maximum of the bounds for either 'Write'. This yields a data -- independent bound, if the bound for @wTrue@ and @wFalse@ is already data -- independent. {-# INLINE writeIf #-} writeIf :: (a -> Bool) -> (a -> Write) -> (a -> Write) -> (a -> Write) writeIf p wTrue wFalse x = boundedWrite (max (getBound $ wTrue x) (getBound $ wFalse x)) (if p x then getPoke $ wTrue x else getPoke $ wFalse x) -- | Compare the value to a test value and use the first write action for the -- equal case and the second write action for the non-equal case. {-# INLINE writeEq #-} writeEq :: Eq a => a -> (a -> Write) -> (a -> Write) -> (a -> Write) writeEq test = writeIf (test ==) -- | TODO: Test this. It might well be too difficult to use. -- FIXME: Better name required! {-# INLINE writeOrdering #-} writeOrdering :: (a -> Ordering) -> (a -> Write) -> (a -> Write) -> (a -> Write) -> (a -> Write) writeOrdering ord wLT wEQ wGT x = boundedWrite bound (case ord x of LT -> getPoke $ wLT x; EQ -> getPoke $ wEQ x; GT -> getPoke $ wGT x) where bound = max (getBound $ wLT x) (max (getBound $ wEQ x) (getBound $ wGT x)) -- | A write combinator useful to build decision trees for deciding what value -- to write with a constant bound on the maximal number of bytes written. {-# INLINE writeOrd #-} writeOrd :: Ord a => a -> (a -> Write) -> (a -> Write) -> (a -> Write) -> (a -> Write) writeOrd test = writeOrdering (`compare` test) -- | Create a builder that execute a single 'Write'. {-# INLINE fromWrite #-} fromWrite :: Write -> Builder fromWrite (Write maxSize wio) = builder step where step k (BufferRange op ope) | op `plusPtr` maxSize <= ope = do op' <- runPoke wio op let !br' = BufferRange op' ope k br' | otherwise = return $ bufferFull maxSize op (step k) {-# INLINE fromWriteSingleton #-} fromWriteSingleton :: (a -> Write) -> (a -> Builder) fromWriteSingleton write = mkBuilder where mkBuilder x = builder step where step k (BufferRange op ope) | op `plusPtr` maxSize <= ope = do op' <- runPoke wio op let !br' = BufferRange op' ope k br' | otherwise = return $ bufferFull maxSize op (step k) where Write maxSize wio = write x -- | Construct a 'Builder' writing a list of data one element at a time. fromWriteList :: (a -> Write) -> [a] -> Builder fromWriteList write = makeBuilder where makeBuilder xs0 = builder $ step xs0 where step xs1 k !(BufferRange op0 ope0) = go xs1 op0 where go [] !op = do let !br' = BufferRange op ope0 k br' go xs@(x':xs') !op | op `plusPtr` maxSize <= ope0 = do !op' <- runPoke wio op go xs' op' | otherwise = return $ bufferFull maxSize op (step xs k) where Write maxSize wio = write x' {-# INLINE fromWriteList #-} ------------------------------------------------------------------------------ -- Writing storables ------------------------------------------------------------------------------ -- | Write a storable value. {-# INLINE writeStorable #-} writeStorable :: Storable a => a -> Write writeStorable x = exactWrite (sizeOf x) (\op -> poke (castPtr op) x) -- | A builder that serializes a storable value. No alignment is done. {-# INLINE fromStorable #-} fromStorable :: Storable a => a -> Builder fromStorable = fromWriteSingleton writeStorable -- | A builder that serializes a list of storable values by writing them -- consecutively. No alignment is done. Parsing information needs to be -- provided externally. fromStorables :: Storable a => [a] -> Builder fromStorables = fromWriteList writeStorable blaze-builder-0.4.0.2/Blaze/ByteString/Builder/Char/0000755000000000000000000000000012705234666020167 5ustar0000000000000000blaze-builder-0.4.0.2/Blaze/ByteString/Builder/Char/Utf8.hs0000644000000000000000000000375412705234666021362 0ustar0000000000000000------------------------------------------------------------------------------ -- | -- 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 #-} blaze-builder-0.4.0.2/Blaze/ByteString/Builder/Compat/0000755000000000000000000000000012705234666020535 5ustar0000000000000000blaze-builder-0.4.0.2/Blaze/ByteString/Builder/Compat/Write.hs0000644000000000000000000000211412705234666022161 0ustar0000000000000000------------------------------------------------------------------------------ -- | -- Module: Blaze.ByteString.Builder.Compat.Write -- Copyright: (c) 2013 Leon P Smith -- License: BSD3 -- Maintainer: Leon P Smith -- Stability: experimental -- -- Conversions from the new Prims to the old Writes. -- ------------------------------------------------------------------------------ module Blaze.ByteString.Builder.Compat.Write ( Write , writePrimFixed , writePrimBounded ) where import Data.ByteString.Builder.Prim.Internal (BoundedPrim, FixedPrim , runB, runF, size, sizeBound) import Blaze.ByteString.Builder.Internal.Write (Poke(..), Write , boundedWrite, exactWrite) writePrimFixed :: FixedPrim a -> a -> Write writePrimFixed fe a = exactWrite (size fe) (runF fe a) {-# INLINE writePrimFixed #-} writePrimBounded :: BoundedPrim a -> a -> Write writePrimBounded be a = boundedWrite (sizeBound be) (Poke (runB be a)) {-# INLINE writePrimBounded #-} blaze-builder-0.4.0.2/Blaze/ByteString/Builder/Html/0000755000000000000000000000000012705234666020216 5ustar0000000000000000blaze-builder-0.4.0.2/Blaze/ByteString/Builder/Html/Utf8.hs0000644000000000000000000000766712705234666021420 0ustar0000000000000000{-# 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 blaze-builder-0.4.0.2/tests/0000755000000000000000000000000012705234666013737 5ustar0000000000000000blaze-builder-0.4.0.2/tests/Tests.hs0000644000000000000000000000742012705234666015400 0ustar0000000000000000{-# 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 blaze-builder-0.4.0.2/tests/LlvmSegfault.hs0000644000000000000000000000141112705234666016675 0ustar0000000000000000-- 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