diff --git a/Blaze/ByteString/Builder/Char/Utf8.hs b/Blaze/ByteString/Builder/Char/Utf8.hs --- a/Blaze/ByteString/Builder/Char/Utf8.hs +++ b/Blaze/ByteString/Builder/Char/Utf8.hs @@ -42,19 +42,19 @@ writeChar :: Char -> Write writeChar c = boundedWrite 4 (encodeCharUtf8 f1 f2 f3 f4 c) where - f1 x1 = writeN 1 $ \op -> do pokeByteOff op 0 x1 + f1 x1 = pokeN 1 $ \op -> do pokeByteOff op 0 x1 - f2 x1 x2 = writeN 2 $ \op -> do pokeByteOff op 0 x1 - pokeByteOff op 1 x2 + f2 x1 x2 = pokeN 2 $ \op -> do pokeByteOff op 0 x1 + pokeByteOff op 1 x2 - f3 x1 x2 x3 = writeN 3 $ \op -> do pokeByteOff op 0 x1 - pokeByteOff op 1 x2 - pokeByteOff op 2 x3 + f3 x1 x2 x3 = pokeN 3 $ \op -> do pokeByteOff op 0 x1 + pokeByteOff op 1 x2 + pokeByteOff op 2 x3 - f4 x1 x2 x3 x4 = writeN 4 $ \op -> do pokeByteOff op 0 x1 - pokeByteOff op 1 x2 - pokeByteOff op 2 x3 - pokeByteOff op 3 x4 + f4 x1 x2 x3 x4 = pokeN 4 $ \op -> do pokeByteOff op 0 x1 + pokeByteOff op 1 x2 + pokeByteOff op 2 x3 + pokeByteOff op 3 x4 -- | Encode a Unicode character to another datatype, using UTF-8. This function -- acts as an abstract way of encoding characters, as it is unaware of what diff --git a/Blaze/ByteString/Builder/HTTP.hs b/Blaze/ByteString/Builder/HTTP.hs --- a/Blaze/ByteString/Builder/HTTP.hs +++ b/Blaze/ByteString/Builder/HTTP.hs @@ -36,7 +36,7 @@ {-# INLINE execWrite #-} execWrite :: Write -> Ptr Word8 -> IO () execWrite w op = do - _ <- runWriteIO (runWrite w) op + _ <- runPoke (getPoke w) op return () @@ -95,7 +95,7 @@ writeWord32Hex :: Word32 -> Write writeWord32Hex w = - boundedWrite (2 * sizeOf w) (writeN len $ pokeWord32HexN len w) + boundedWrite (2 * sizeOf w) (pokeN len $ pokeWord32HexN len w) where len = word32HexLength w {-# INLINE writeWord32Hex #-} @@ -181,7 +181,7 @@ wrapChunk opInner' $ \op' -> do -- add header for inserted bytestring -- FIXME: assert(S.length bs < maxBound :: Word32) - !op'' <- (`runWriteIO` op') $ runWrite $ + !op'' <- (`runPoke` op') $ getPoke $ writeWord32Hex (fromIntegral $ S.length bs) `mappend` writeCRLF -- insert bytestring and write CRLF in next buildstep diff --git a/Blaze/ByteString/Builder/Html/Utf8.hs b/Blaze/ByteString/Builder/Html/Utf8.hs --- a/Blaze/ByteString/Builder/Html/Utf8.hs +++ b/Blaze/ByteString/Builder/Html/Utf8.hs @@ -46,12 +46,12 @@ boundedWrite 6 (io c0) -- WARNING: Don't forget to change the bound if you change the bytestrings. where - io '<' = runWrite $ writeByteString "<" - io '>' = runWrite $ writeByteString ">" - io '&' = runWrite $ writeByteString "&" - io '"' = runWrite $ writeByteString """ - io '\'' = runWrite $ writeByteString "'" - io c = runWrite $ writeChar c + io '<' = getPoke $ writeByteString "<" + io '>' = getPoke $ writeByteString ">" + io '&' = getPoke $ writeByteString "&" + io '"' = getPoke $ writeByteString """ + io '\'' = getPoke $ writeByteString "'" + io c = getPoke $ writeChar c {-# INLINE writeHtmlEscapedChar #-} -- | /O(1)./ Serialize a HTML escaped Unicode character using the UTF-8 diff --git a/Blaze/ByteString/Builder/Internal.hs b/Blaze/ByteString/Builder/Internal.hs --- a/Blaze/ByteString/Builder/Internal.hs +++ b/Blaze/ByteString/Builder/Internal.hs @@ -30,6 +30,7 @@ , Put , putBuilder , putBuildStepCont + , putLiftIO -- * Writes , module Blaze.ByteString.Builder.Internal.Write diff --git a/Blaze/ByteString/Builder/Internal/Types.hs b/Blaze/ByteString/Builder/Internal/Types.hs --- a/Blaze/ByteString/Builder/Internal/Types.hs +++ b/Blaze/ByteString/Builder/Internal/Types.hs @@ -134,4 +134,10 @@ fromPut :: Put a -> Builder fromPut (Put put) = Builder $ \k -> put (\_ -> k) +-- Lifting IO actions +--------------------- +-- | Lift the given IO action. +{-# INLINE putLiftIO #-} +putLiftIO :: IO a -> Put a +putLiftIO io = putBuildStepCont $ \k br -> io >>= (`k` br) diff --git a/Blaze/ByteString/Builder/Internal/Write.hs b/Blaze/ByteString/Builder/Internal/Write.hs --- a/Blaze/ByteString/Builder/Internal/Write.hs +++ b/Blaze/ByteString/Builder/Internal/Write.hs @@ -1,6 +1,6 @@ {-# LANGUAGE CPP, BangPatterns, MonoPatBinds #-} -- | --- Module : Blaze.ByteString.Builder.Internal.WriteIO +-- Module : Blaze.ByteString.Builder.Internal.Poke -- Copyright : (c) 2010 Simon Meier -- (c) 2010 Jasper van der Jeugt -- License : BSD3-style (see LICENSE) @@ -12,15 +12,28 @@ -- 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 ( - -- * Abstracting writes to a buffer - Write - , WriteIO - , writeN + -- * Poking a buffer + Poke + , runPoke + , pokeN + + -- * Writing to abuffer + , Write + , runWrite + , getBound + , getBound' + , getPoke + , exactWrite , boundedWrite - , runWrite - , runWriteIO + , writeLiftIO + , writeIf + , writeEq + , writeOrdering + , writeOrd -- * Constructing builders from writes , fromWrite @@ -44,7 +57,7 @@ ------------------------------------------------------------------------------ --- The Write WriteIO Type +-- Poking a buffer and writing to a buffer ------------------------------------------------------------------------------ -- Sadly GHC is not smart enough: code where we branch and each branch should @@ -52,80 +65,167 @@ -- least not such that it returns the value of the branches unpacked. -- -- Hmm.. at least he behaves much better for the Monoid instance of Write --- than the one for WriteIO. Serializing UTF-8 chars gets a slowdown of a +-- 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. -- --- | A write to a buffer. --- --- FIXME: Find better name: what about 'Poke' ? -newtype WriteIO = - WriteIO { runWriteIO :: Ptr Word8 -> IO (Ptr Word8) } +-- | 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. -data Write = Write {-# UNPACK #-} !Int WriteIO +-- +-- 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 'WriteIO' action of a write. +-- | 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 -> WriteIO -runWrite (Write _ wio) = wio +runWrite :: Write -> Ptr Word8 -> IO (Ptr Word8) +runWrite = runPoke . getPoke -instance Monoid WriteIO where - mempty = WriteIO $ return +-- | 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 #-} - (WriteIO w1) `mappend` (WriteIO w2) = WriteIO $ w1 >=> w2 + mempty = Poke $ return + {-# INLINE mappend #-} - mconcat = foldr mappend mempty + (Poke po1) `mappend` (Poke po2) = Poke $ po1 >=> po2 + {-# INLINE mconcat #-} + mconcat = foldr mappend mempty instance Monoid Write where - mempty = Write 0 mempty {-# INLINE mempty #-} + mempty = Write 0 mempty + + {-# INLINE mappend #-} (Write bound1 w1) `mappend` (Write bound2 w2) = Write (bound1 + bound2) (w1 `mappend` w2) - {-# INLINE mappend #-} - mconcat = foldr mappend mempty + {-# INLINE mconcat #-} + mconcat = foldr mappend mempty --- | @writeN size io@ creates a write that denotes the writing of @size@ bytes +-- | @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! -writeN :: Int - -> (Ptr Word8 -> IO ()) -> WriteIO -writeN size io = WriteIO $ \op -> io op >> return (op `plusPtr` size) -{-# INLINE writeN #-} +{-# 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 (writeN size io) -{-# INLINE exactWrite #-} +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. -boundedWrite :: Int -> WriteIO -> Write -boundedWrite = Write {-# 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) = fromBuildStepCont step where step k (BufRange op ope) | op `plusPtr` maxSize <= ope = do - op' <- runWriteIO wio op + op' <- runPoke wio op let !br' = BufRange op' ope k br' | otherwise = return $ bufferFull maxSize op (step k) -{-# INLINE fromWrite #-} -fromWriteSingleton :: (a -> Write) -> a -> Builder +{-# INLINE fromWriteSingleton #-} +fromWriteSingleton :: (a -> Write) -> (a -> Builder) fromWriteSingleton write = mkBuilder where @@ -133,13 +233,12 @@ where step k (BufRange op ope) | op `plusPtr` maxSize <= ope = do - op' <- runWriteIO wio op + op' <- runPoke wio op let !br' = BufRange op' ope k br' | otherwise = return $ bufferFull maxSize op (step k) where Write maxSize wio = write x -{-# INLINE fromWriteSingleton #-} -- | Construct a 'Builder' writing a list of data one element at a time. fromWriteList :: (a -> Write) -> [a] -> Builder @@ -156,7 +255,7 @@ go xs@(x':xs') !op | op `plusPtr` maxSize <= ope0 = do - !op' <- runWriteIO wio op + !op' <- runPoke wio op go xs' op' | otherwise = return $ bufferFull maxSize op (step xs k) where diff --git a/LICENSE b/LICENSE --- a/LICENSE +++ b/LICENSE @@ -1,4 +1,4 @@ -Copyright Jasper Van der Jeugt 2010 +Copyright Jasper Van der Jeugt 2010, Simon Meier 2010 & 2011 All rights reserved. diff --git a/Makefile b/Makefile --- a/Makefile +++ b/Makefile @@ -7,7 +7,7 @@ ######### GHC6 = ghc-6.12.3 -GHC7 = ghc-7.0.1 +GHC7 = ghc-7.0.2 GHC = $(GHC7) @@ -22,11 +22,12 @@ clean-bench-all: rm -f benchmarks/*.o benchmarks/*.hi rm -f benchmarks/Throughput/*.o benchmarks/Throughput/*.hi - rm -f Text/Blaze/Builder.o Text/Blaze/Builder.hi - rm -f Text/Blaze/Builder/*.o Text/Blaze/Builder/*.hi - rm -f Text/Blaze/Builder/Char/*.o Text/Blaze/Builder/Char/*.hi - rm -f Text/Blaze/Builder/Html/*.o Text/Blaze/Builder/Html/*.hi - rm -f Text/Blaze/Builder/Core/*.o Text/Blaze/Builder/Core/*.hi + rm -f 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 @@ -34,6 +35,16 @@ ## 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 @@ -101,6 +112,9 @@ 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: diff --git a/benchmarks/LazyByteString.hs b/benchmarks/LazyByteString.hs --- a/benchmarks/LazyByteString.hs +++ b/benchmarks/LazyByteString.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE BangPatterns, OverloadedStrings #-} -- | -- Module : LazyByteString -- Copyright : (c) 2010 Simon Meier @@ -13,20 +13,25 @@ -- 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.Write import Blaze.ByteString.Builder.Word import Blaze.ByteString.Builder.ByteString @@ -37,7 +42,38 @@ 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 @@ -67,6 +103,7 @@ , unfoldrBlaze countToZero , id , n ) + -} ] sequence_ (intersperse (putStrLn "") chunkInfos) putStrLn "" @@ -82,8 +119,8 @@ showChunksize implLazy lazy showChunksize implBlaze blaze , bgroup cmpName - [ mkBench implLazy lazy - , mkBench implBlaze blaze + [ mkBench implBlaze blaze + , mkBench implLazy lazy ] ) where @@ -145,27 +182,31 @@ fromWriteUnfoldr write = makeBuilder where - makeBuilder f x0 = Builder $ step x0 + makeBuilder f x0 = fromBuildStepCont $ step x0 where step x1 !k = fill x1 where - fill x !pf0 !pe0 = go (f x) pf0 + fill x !(BufRange pf0 pe0) = go (f x) pf0 where - go !Nothing !pf = k pf pe0 + go !Nothing !pf = do + let !br' = BufRange pf pe0 + k br' go !(Just (y, x')) !pf - | pf `plusPtr` size <= pe0 = do - io pf - go (f x') (pf `plusPtr` size) - | otherwise = return $ BufferFull size pf $ \pfNew peNew -> do - io pfNew - fill x' (pfNew `plusPtr` size) peNew + | 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 - !(Write size io) = write y + 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)) @@ -199,17 +240,17 @@ mapFilterMapByteString :: (Word8 -> Word8) -> (Word8 -> Bool) -> (Word8 -> Word8) -> S.ByteString -> Builder mapFilterMapByteString f p g = - \bs -> Builder $ step bs + \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 !op0 !ope + goBS !ip0 !br@(BufRange op0 ope) | ip0 >= ipe = do touchForeignPtr ifp -- input buffer consumed - k op0 ope + k br | op0 < ope = goPartial (ip0 `plusPtr` min outRemaining inpRemaining) - | otherwise = return $ BufferFull 1 op0 (goBS ip0) + | otherwise = return $ bufferFull 1 op0 (goBS ip0) where outRemaining = ope `minusPtr` op0 inpRemaining = ipe `minusPtr` ip0 @@ -223,7 +264,7 @@ then poke op (f w') >> go (ip `plusPtr` 1) (op `plusPtr` 1) else go (ip `plusPtr` 1) op | otherwise = - goBS ip op ope + goBS ip (BufRange op ope) {-# INLINE mapFilterMapByteString #-} mapFilterMapLazyByteString :: (Word8 -> Word8) -> (Word8 -> Bool) -> (Word8 -> Word8) @@ -257,39 +298,43 @@ fromWriteReplicated write = makeBuilder where - makeBuilder !n0 x = Builder $ step + makeBuilder !n0 x = fromBuildStepCont $ step where - Write size io = write x + bound = getBound $ write x step !k = fill n0 where - fill !n1 !pf0 !pe0 = go n1 pf0 + fill !n1 !(BufRange pf0 pe0) = go n1 pf0 where - go 0 !pf = k pf pe0 + go 0 !pf = do + let !br' = BufRange pf pe0 + k br' go n !pf - | pf `plusPtr` size <= pe0 = do - io pf - go (n-1) (pf `plusPtr` size) - | otherwise = return $ BufferFull size pf $ \pfNew peNew -> do - io pfNew - fill (n-1) (pfNew `plusPtr` size) peNew + | 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 = - Builder $ step + fromBuildStepCont $ step where step !k = fill n0 where - fill !n !pf !pe - | n <= 0 = k pf pe + 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. - k pf' pe + 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) + return $ bufferFull 1 pe $ fill (n - l) where pf' = pf `plusPtr` n {-# INLINE fromReplicateWord8 #-} @@ -370,7 +415,7 @@ ---------- packBlaze :: [Word8] -> L.ByteString -packBlaze = toLazyByteString . fromWrite1List writeWord8 +packBlaze = toLazyByteString . fromWriteList writeWord8 -- Reverse @@ -399,7 +444,6 @@ -- copy ------- --- FIXME: Implement wrapping copyBlaze :: L.ByteString -> L.ByteString copyBlaze = toLazyByteString . copyLazyByteString @@ -407,4 +451,332 @@ -- ?? packCString, packCStringLen --------------------------------- +-- joinWith +-------------------------------------------- +intersperseBlocks :: Int -> S.ByteString -> S.ByteString -> Builder +intersperseBlocks blockSize sep (S.PS ifp ioff isize) = + fromPut $ do + lastBS <- go (ip0 `plusPtr` ioff) + unless (S.null lastBS) (putBuilder $ fromByteString lastBS) + where + ip0 = unsafeForeignPtrToPtr ifp + ipe = ip0 `plusPtr` (ioff + isize) + go !ip + | ip `plusPtr` blockSize >= ipe = + return $ S.PS ifp (ip `minusPtr` ip0) (ipe `minusPtr` ip) + | otherwise = do + putBuilder $ fromByteString (S.PS ifp (ip `minusPtr` ip0) blockSize) + `mappend` fromByteString sep + go (ip `plusPtr` blockSize) + +intersperseLazyBlocks :: Int -> Builder -> L.ByteString -> Builder +intersperseLazyBlocks blockSize sep bs = + go (splitLazyAt blockSize bs) + where + go (pre, suf) + | L.null suf = fromLazyByteString pre + | otherwise = fromLazyByteString pre `mappend` sep `mappend` + go (splitLazyAt blockSize suf) + +encodeBase64MIME :: S.ByteString -> Builder +encodeBase64MIME = + intersperseLazyBlocks 76 (fromByteString "\r\n") . toLazyByteString . encodeBase64 + + +-- test blockwise mapping on base64 encoding +-------------------------------------------- + +-- | Encode a bytestring using Base64 encoding according to the specification +-- in RFC 4648, . +-- +-- Note that you need to insert additional linebreaks every 76 bytes using the +-- function @joinWith "\r\n" 76@ in order to achieve the MIME Base64 +-- Content-Transfer-Encoding . +-- +-- TODO implement encoding of lazy bytestrings, implement joinWith +-- functionality, and convencience function for MIME base-64 encoding. +encodeBase64 :: S.ByteString -> Builder +encodeBase64 = encodeLazyBase64 . L.fromChunks . return + +encodeLazyBase64 :: L.ByteString -> Builder +encodeLazyBase64 = + mkBuilder + where + mkBuilder bs = fromPut $ do + remainder <- putWriteLazyBlocks 3 writeBase64 bs + putBuilder $ complete remainder + + {-# INLINE writeBase64 #-} + writeBase64 ip = + exactWrite 4 $ \op -> do + b0 <- peekByte 0 + b1 <- peekByte 1 + b2 <- peekByte 2 + let w = (b0 `shiftL` 16) .|. (b1 `shiftL` 8) .|. b2 + poke (castPtr $ op ) =<< enc (w `shiftR` 12) + poke (castPtr $ op `plusPtr` 2) =<< enc (w .&. 0xfff) + where + peekByte :: Int -> IO Word32 + peekByte off = fmap fromIntegral (peekByteOff ip off :: IO Word8) + + enc = peekElemOff (unsafeForeignPtrToPtr encodeTable) . fromIntegral + + {-# INLINE complete #-} + complete bs + | S.null bs = mempty + | otherwise = fromWrite $ + exactWrite 4 $ \op -> do + let poke6Base64 off sh = pokeByteOff op off + (alphabet `S.unsafeIndex` fromIntegral (w `shiftR` sh .&. 63)) + pad off = pokeByteOff op off (fromIntegral $ ord '=' :: Word8) + poke6Base64 0 18 + poke6Base64 1 12 + if S.length bs == 1 then pad 2 + else poke6Base64 2 8 + pad 3 + where + getByte :: Int -> Int -> Word32 + getByte i sh = fromIntegral (bs `S.unsafeIndex` i) `shiftL` sh + w = getByte 0 16 .|. (if S.length bs == 1 then 0 else getByte 1 8) + + -- Lookup table trick from Data.ByteString.Base64 by Bryan O'Sullivan + {-# NOINLINE alphabet #-} + alphabet :: S.ByteString + alphabet = S.pack $ [65..90] ++ [97..122] ++ [48..57] ++ [43,47] + + -- FIXME: Check that the implementation of the lookup table aslo works on + -- big-endian systems. + {-# NOINLINE encodeTable #-} + encodeTable :: ForeignPtr Word16 + encodeTable = unsafePerformIO $ do + fp <- mallocForeignPtrArray 4096 + let ix = fromIntegral . S.index alphabet + withForeignPtr fp $ \p -> + sequence_ [ pokeElemOff p (j*64+k) ((ix k `shiftL` 8) .|. ix j) + | j <- [0..63], k <- [0..63] ] + return fp + + +-- | Process a bytestring block-wise using a 'Write' action to produce the +-- output per block. +-- +-- TODO: Compare speed with 'mapFilterMapByteString'. +{-# INLINE putWriteBlocks #-} +putWriteBlocks :: Int -- ^ Block size. + -> (Ptr Word8 -> Write) -- ^ 'Write' given a pointer to the + -- beginning of the block. + -> S.ByteString -- ^ 'S.ByteString' to consume blockwise. + -> Put S.ByteString -- ^ 'Put' returning the remaining + -- bytes, which are guaranteed to be + -- fewer than the block size. +putWriteBlocks blockSize write = + \bs -> putBuildStepCont $ step bs + where + step (S.PS ifp ioff isize) !k = + goBS (unsafeForeignPtrToPtr ifp `plusPtr` ioff) + where + !ipe = unsafeForeignPtrToPtr ifp `plusPtr` (ioff + isize) + goBS !ip0 !br@(BufRange op0 ope) + | ip0 `plusPtr` blockSize > ipe = do + touchForeignPtr ifp -- input buffer consumed + let !bs' = S.PS ifp (ip0 `minusPtr` unsafeForeignPtrToPtr ifp) + (ipe `minusPtr` ip0) + k bs' br + + | op0 `plusPtr` writeBound < ope = + goPartial (ip0 `plusPtr` (blockSize * min outRemaining inpRemaining)) + + | otherwise = return $ bufferFull writeBound op0 (goBS ip0) + where + writeBound = getBound' "putWriteBlocks" write + outRemaining = (ope `minusPtr` op0) `div` writeBound + inpRemaining = (ipe `minusPtr` ip0) `div` blockSize + + goPartial !ipeTmp = go ip0 op0 + where + go !ip !op + | ip < ipeTmp = do + op' <- runWrite (write ip) op + go (ip `plusPtr` blockSize) op' + | otherwise = + goBS ip (BufRange op ope) + + +{-# INLINE putWriteLazyBlocks #-} +putWriteLazyBlocks :: Int -- ^ Block size. + -> (Ptr Word8 -> Write) -- ^ 'Write' given a pointer to the + -- beginning of the block. + -> L.ByteString -- ^ 'L.ByteString' to consume blockwise. + -> Put S.ByteString -- ^ 'Put' returning the remaining + -- bytes, which are guaranteed to be + -- fewer than the block size. +putWriteLazyBlocks blockSize write = + go + where + go L.Empty = return S.empty + go (L.Chunk bs lbs) = do + bsRem <- putWriteBlocks blockSize write bs + case S.length bsRem of + lRem + | lRem <= 0 -> go lbs + | otherwise -> do + let (lbsPre, lbsSuf) = + L.splitAt (fromIntegral $ blockSize - lRem) lbs + case S.concat $ bsRem : L.toChunks lbsPre of + block@(S.PS bfp boff bsize) + | bsize < blockSize -> return block + | otherwise -> do + putBuilder $ fromWrite $ + write (unsafeForeignPtrToPtr bfp `plusPtr` boff) + putLiftIO $ touchForeignPtr bfp + go lbsSuf + + +------------------------------------------------------------------------------ +-- Testing code +------------------------------------------------------------------------------ + + +chunks3 :: [Word8] -> [Word32] +chunks3 (b0 : b1 : b2 : bs) = + ((fromIntegral b0 `shiftL` 16) .|. + (fromIntegral b1 `shiftL` 8) .|. + (fromIntegral b2 ) + ) : chunks3 bs +chunks3 _ = [] + +cmpWriteToLib :: [Word8] -> (L.ByteString, L.ByteString) +cmpWriteToLib bs = + -- ( toLazyByteString $ fromWriteList write24bitsBase64 $ chunks3 bs + ( toLazyByteString $ encodeBase64 $ S.pack bs + , (`L.Chunk` L.empty) $ encode $ S.pack bs ) + +test3 :: Bool +test3 = uncurry (==) $ cmpWriteToLib $ [0..] + +test2 :: L.ByteString +test2 = toLazyByteString $ encodeBase64 $ S.pack [0..] + +{- OLD code + +{-# INLINE poke8 #-} +poke8 :: Word8 -> Ptr Word8 -> IO () +poke8 = flip poke + +-- | @writeBase64 w@ writes the lower @24@ bits as four times 6 bit in +-- little-endian order encoded using the standard alphabeth of Base 64 encoding +-- as defined in . +-- +{-# INLINE write6bitsBase64 #-} +write6bitsBase64 :: Word32 -> Write +write6bitsBase64 = exactWrite 1 . poke6bitsBase64 + +{-# INLINE poke6bitsBase64 #-} +poke6bitsBase64 :: Word32 -> Ptr Word8 -> IO () +poke6bitsBase64 w = poke8 (alphabet `S.unsafeIndex` fromIntegral (w .&. 63)) + {- + | i < 26 = withOffsets 0 'A' + | i < 52 = withOffsets 26 'a' + | i < 62 = withOffsets 52 '0' + | i == 62 = poke8 $ fromIntegral $ ord '+' + | otherwise = poke8 $ fromIntegral $ ord '/' + where + i :: Int + i = fromIntegral (w .&. 63) + + {-# INLINE withOffsets #-} + withOffsets neg pos = poke8 $ fromIntegral (i + ord pos - neg) + -} + +{-# INLINE writePaddedBitsBase64 #-} +writePaddedBitsBase64 :: Bool -- ^ Only 8 bits have to be output. + -> Word32 -- ^ Input whose lower 8 or 16 bits need to be output. + -> Write +writePaddedBitsBase64 only8 w = + write6bitsBase64 (w `shiftr_w32` 18) `mappend` + write6bitsBase64 (w `shiftr_w32` 12) `mappend` + writeIf (const only8) (const $ C8.writeChar '=') + (write6bitsBase64 . (`shiftr_w32` 6)) + w `mappend` + C8.writeChar '=' + +{-# INLINE write24bitsBase64 #-} +write24bitsBase64 :: Word32 -> Write +write24bitsBase64 w = write6bitsBase64 (w `shiftr_w32` 18) `mappend` + write6bitsBase64 (w `shiftr_w32` 12) `mappend` + write6bitsBase64 (w `shiftr_w32` 6) `mappend` + write6bitsBase64 (w ) + +-- ASSUMES bits 25 - 31 are zero. +{-# INLINE write24bitsBase64' #-} +write24bitsBase64' :: Word32 -> Write +write24bitsBase64' w = + exactWrite 4 $ \p -> do + poke (castPtr p ) =<< enc (w `shiftR` 12) + poke (castPtr $ p `plusPtr` 2) =<< enc (w .&. 0xfff) + where + {-# INLINE enc #-} + enc = peekElemOff (unsafeForeignPtrToPtr encodeTable) . fromIntegral + +-} + +------------------------------------------------------------------------------- +-- A faster split for lazy bytestrings +------------------------------------------------------------------------------- + +-- | /O(n\/c)/ 'splitAt' @n xs@ is equivalent to @('take' n xs, 'drop' n xs)@. +splitLazyAt :: Int -> L.ByteString -> (L.ByteString, L.ByteString) +splitLazyAt n cs0 + | n <= 0 = (L.Empty, cs0) + | otherwise = split cs0 + where + split L.Empty = (L.Empty, L.Empty) + split (L.Chunk c cs) + | n < len = case S.splitAt n c of + (pre, suf) -> (L.Chunk pre L.Empty, L.Chunk suf cs) + | otherwise = case splitLazyAt (n - len) cs of + (pre, suf) -> (L.Chunk c pre , suf ) + where + len = S.length c + + +------------------------------------------------------------------------------- +-- A faster partition for strict and lazy bytestrings +------------------------------------------------------------------------------- + +{-# INLINE partitionStrict #-} +partitionStrict :: (Word8 -> Bool) -> S.ByteString -> (S.ByteString, S.ByteString) +partitionStrict f (S.PS ifp ioff ilen) = + second S.reverse $ S.inlinePerformIO $ do + ofp <- S.mallocByteString ilen + withForeignPtr ifp $ wrapper ofp + where + wrapper !ofp !ip0 = + go (ip0 `plusPtr` ioff) op0 (op0 `plusPtr` ilen) + where + op0 = unsafeForeignPtrToPtr ofp + + go !ip !opl !oph + | oph == opl = return (S.PS ofp 0 olen, S.PS ofp olen (ilen - olen)) + | otherwise = do + x <- peek ip + if f x + then do poke opl x + go (ip `plusPtr` 1) (opl `plusPtr` 1) oph + else do let oph' = oph `plusPtr` (-1) + poke oph' x + go (ip `plusPtr` 1) opl oph' + + where + olen = opl `minusPtr` op0 + +{-# INLINE partitionLazy #-} +partitionLazy :: (Word8 -> Bool) -> L.ByteString -> (L.ByteString, L.ByteString) +partitionLazy f = + L.foldrChunks partitionOne (L.empty, L.empty) + where + partitionOne bs (ls, rs) = + (L.Chunk l ls, L.Chunk r rs) + where + (l, r) = partitionStrict f bs diff --git a/benchmarks/Utf8IO.hs b/benchmarks/Utf8IO.hs new file mode 100644 --- /dev/null +++ b/benchmarks/Utf8IO.hs @@ -0,0 +1,102 @@ +{-# LANGUAGE OverloadedStrings #-} +-- | +-- Copyright : (c) 2011 Simon Meier +-- License : BSD3-style (see LICENSE) +-- +-- Maintainer : Simon Meier +-- Stability : experimental +-- Portability : tested on GHC only +-- +-- Benchmarking IO output speed of writing a string in Utf8 encoding to a file. +module Utf8IO (main) where + +import Control.Monad +import Control.Exception (evaluate) + +import qualified Codec.Binary.UTF8.Light as Utf8Light + +import Data.Char (chr) +import Data.Time.Clock +import qualified Data.ByteString.Lazy as L +import qualified Data.ByteString.Lazy.UTF8 as Utf8String +import qualified Data.Text.Lazy as TL +import qualified Data.Text.Lazy.Encoding as TL + +import System.IO +import System.Environment + +import Blaze.ByteString.Builder +import Blaze.ByteString.Builder.Internal (defaultBufferSize) +import qualified Blaze.ByteString.Builder.Char.Utf8 as Blaze + + +-- | Write using the standard text utf8 encoding function built into 'base'. +writeUtf8_base :: String -> FilePath -> IO () +writeUtf8_base cs file = + withFile file WriteMode $ \h -> do + hSetEncoding h utf8 + hPutStr h cs + +-- | Write using utf8 encoding as provided by the 'blaze-builder' library. +writeUtf8_blaze :: String -> FilePath -> IO () +writeUtf8_blaze cs file = L.writeFile file $ toLazyByteString $ Blaze.fromString cs + +-- | Write using utf8 encoding as provided by the 'text' library. +writeUtf8_text :: TL.Text -> FilePath -> IO () +writeUtf8_text tx file = L.writeFile file $ TL.encodeUtf8 tx + +-- | Write using utf8 encoding as provided by the 'utf8-string' library. +writeUtf8_string :: String -> FilePath -> IO () +writeUtf8_string cs file = L.writeFile file $ Utf8String.fromString cs + +-- | Write using utf8 encoding as provided by the 'utf8-light' library. Note +-- that this library only allows encoding the whole string as a strict +-- bytestring. That might make it unusable in some circumstances. +{-# NOINLINE writeUtf8_light #-} +writeUtf8_light :: String -> FilePath -> IO () +writeUtf8_light cs file = Utf8Light.writeUTF8File file cs + + +main :: IO () +main = do + [how, len, file] <- getArgs + let blocksize = 32000 + block = map chr [0..blocksize] + n = read len + cs = take n $ cycle $ block + tx = TL.pack cs + writer <- case how of + "base" -> return $ writeUtf8_base cs + "blaze" -> return $ writeUtf8_blaze cs + "utf8-string" -> return $ writeUtf8_string cs + + -- utf8-light is missing support for lazy bytestrings => test 100 times + -- writing a 100 times smaller string to avoid out-of-memory errors. + "utf8-light" -> return $ \f -> sequence_ $ replicate 100 $ + writeUtf8_light (take (n `div` 100) cs) f + + "via-text" -> do return $ writeUtf8_text tx + + -- Here, we ensure that the text tx is already packed before timing. + "text" -> do _ <- evaluate (TL.length tx) + return $ writeUtf8_text tx + _ -> error $ "unknown writer '" ++ how ++ "'" + t <- timed_ $ writer file + putStrLn $ how ++ ": " ++ show t + +------------------------------------------------------------------------------ +-- Timing +------------------------------------------------------------------------------ + +-- | Execute an IO action and return its result plus the time it took to execute it. +timed :: IO a -> IO (a, NominalDiffTime) +timed io = do + t0 <- getCurrentTime + x <- io + t1 <- getCurrentTime + return (x, diffUTCTime t1 t0) + +-- | Execute an IO action and return the time it took to execute it. +timed_ :: IO a -> IO NominalDiffTime +timed_ = (snd `liftM`) . timed + diff --git a/blaze-builder.cabal b/blaze-builder.cabal --- a/blaze-builder.cabal +++ b/blaze-builder.cabal @@ -1,5 +1,5 @@ Name: blaze-builder -Version: 0.2.1.4 +Version: 0.3.0.0 Synopsis: Efficient buffered output. Description: