bytestring 0.10.2.0 → 0.10.4.0
raw patch · 33 files changed
+1843/−2263 lines, 33 filesdep +integerdep +integer-gmpdep −criteriondep ~basedep ~deepseqdep ~directory
Dependencies added: integer, integer-gmp
Dependencies removed: criterion
Dependency ranges changed: base, deepseq, directory
Files
- Data/ByteString.hs +70/−55
- Data/ByteString/Builder.hs +9/−3
- Data/ByteString/Builder/ASCII.hs +118/−9
- Data/ByteString/Builder/Extra.hs +22/−28
- Data/ByteString/Builder/Internal.hs +494/−229
- Data/ByteString/Builder/Prim.hs +42/−77
- Data/ByteString/Builder/Prim/ASCII.hs +8/−8
- Data/ByteString/Builder/Prim/Binary.hs +9/−9
- Data/ByteString/Builder/Prim/Extra.hs +0/−890
- Data/ByteString/Builder/Prim/Internal.hs +28/−109
- Data/ByteString/Builder/Prim/Internal/Base16.hs +6/−45
- Data/ByteString/Builder/Prim/Internal/Floating.hs +2/−2
- Data/ByteString/Builder/Prim/Internal/UncheckedShifts.hs +6/−1
- Data/ByteString/Char8.hs +1/−10
- Data/ByteString/Internal.hs +64/−7
- Data/ByteString/Lazy.hs +1/−2
- Data/ByteString/Lazy/Builder/ASCII.hs +10/−0
- Data/ByteString/Lazy/Internal.hs +8/−3
- Data/ByteString/Short.hs +85/−0
- Data/ByteString/Short/Internal.hs +590/−0
- Data/ByteString/Unsafe.hs +4/−35
- bench/BenchAll.hs +0/−243
- bench/BoundsCheckFusion.hs +0/−127
- bytestring.cabal +58/−74
- cbits/fpstring.c +8/−0
- cbits/itoa.c +45/−1
- tests/Properties.hs +102/−5
- tests/Rules.hs +7/−0
- tests/TestFramework.hs +4/−1
- tests/builder/Data/ByteString/Builder/Prim/TestUtils.hs +15/−23
- tests/builder/Data/ByteString/Builder/Prim/Tests.hs +5/−174
- tests/builder/Data/ByteString/Builder/Tests.hs +17/−89
- tests/builder/TestSuite.hs +5/−4
Data/ByteString.hs view
@@ -1,7 +1,7 @@ {-# LANGUAGE CPP #-} #if __GLASGOW_HASKELL__ {-# LANGUAGE MagicHash, UnboxedTuples,- NamedFieldPuns, BangPatterns, RecordWildCards #-}+ NamedFieldPuns, BangPatterns #-} #endif {-# OPTIONS_HADDOCK prune #-} #if __GLASGOW_HASKELL__ >= 701@@ -15,7 +15,7 @@ -- (c) Simon Marlow 2005, -- (c) Bjorn Bringert 2006, -- (c) Don Stewart 2005-2008,--- (c) Duncan Coutts 2006-2011+-- (c) Duncan Coutts 2006-2013 -- License : BSD-style -- -- Maintainer : dons00@gmail.com, duncan@community.haskell.org@@ -28,6 +28,9 @@ -- are encoded as strict 'Word8' arrays of bytes, held in a 'ForeignPtr', -- and can be passed between C and Haskell with little effort. --+-- The recomended way to assemble ByteStrings from smaller parts+-- is to use the builder monoid from "Data.ByteString.Builder".+-- -- This module is intended to be imported @qualified@, to avoid name -- clashes with "Prelude" functions. eg. --@@ -234,7 +237,14 @@ import Foreign.C.String (CString, CStringLen) import Foreign.C.Types (CSize)-import Foreign.ForeignPtr+#if MIN_VERSION_base(4,5,0)+import Foreign.ForeignPtr (ForeignPtr, newForeignPtr, withForeignPtr+ ,touchForeignPtr)+import Foreign.ForeignPtr.Unsafe(unsafeForeignPtrToPtr)+#else+import Foreign.ForeignPtr (ForeignPtr, newForeignPtr, withForeignPtr+ ,touchForeignPtr, unsafeForeignPtrToPtr)+#endif import Foreign.Marshal.Alloc (allocaBytes, mallocBytes, reallocBytes, finalizerFree) import Foreign.Marshal.Array (allocaArray) import Foreign.Ptr@@ -271,7 +281,7 @@ import GHC.IO.Handle.Types import GHC.IO.Buffer import GHC.IO.BufferedIO as Buffered-import GHC.IO (unsafePerformIO)+import GHC.IO (unsafePerformIO, unsafeDupablePerformIO) import Data.Char (ord) import Foreign.Marshal.Utils (copyBytes) #else@@ -301,6 +311,10 @@ hWaitForInput _ _ = return () #endif +#ifndef __GLASGOW_HASKELL__+unsafeDupablePerformIO = unsafePerformIO+#endif+ -- ----------------------------------------------------------------------------- -- -- Useful macros, until we have bang patterns@@ -358,30 +372,19 @@ unpack = unpackBytes #else -unpack ps = build (unpackFoldr ps)+unpack bs = build (unpackFoldr bs) {-# INLINE unpack #-} -- -- Have unpack fuse with good list consumers ----- critical this isn't strict in the acc--- as it will break in the presence of list fusion. this is a known--- issue with seq and build/foldr rewrite rules, which rely on lazy--- demanding to avoid bottoms in the list.--- unpackFoldr :: ByteString -> (Word8 -> a -> a) -> a -> a-unpackFoldr (PS fp off len) f ch = withPtr fp $ \p -> do- let loop q n _ | q `seq` n `seq` False = undefined -- n.b.- loop _ (-1) acc = return acc- loop q n acc = do- a <- peekByteOff q n- loop q (n-1) (a `f` acc)- loop (p `plusPtr` off) (len-1) ch+unpackFoldr bs k z = foldr k z bs {-# INLINE [0] unpackFoldr #-} {-# RULES-"ByteString unpack-list" [1] forall p .- unpackFoldr p (:) [] = unpackBytes p+"ByteString unpack-list" [1] forall bs .+ unpackFoldr bs (:) [] = unpackBytes bs #-} #endif@@ -406,7 +409,7 @@ infixl 5 `snoc` -- | /O(n)/ 'cons' is analogous to (:) for lists, but of different--- complexity, as it requires a memcpy.+-- complexity, as it requires making a copy. cons :: Word8 -> ByteString -> ByteString cons c (PS x s l) = unsafeCreate (l+1) $ \p -> withForeignPtr x $ \f -> do poke p c@@ -483,9 +486,9 @@ -- Transformations -- | /O(n)/ 'map' @f xs@ is the ByteString obtained by applying @f@ to each--- element of @xs@. This function is subject to array fusion.+-- element of @xs@. map :: (Word8 -> Word8) -> ByteString -> ByteString-map f (PS fp s len) = inlinePerformIO $ withForeignPtr fp $ \a ->+map f (PS fp s len) = unsafeDupablePerformIO $ withForeignPtr fp $ \a -> create len $ map_ 0 (a `plusPtr` s) where map_ :: Int -> Ptr Word8 -> Ptr Word8 -> IO ()@@ -525,52 +528,64 @@ -- the left-identity of the operator), and a ByteString, reduces the -- ByteString using the binary operator, from left to right. ----- This function is subject to array fusion.--- foldl :: (a -> Word8 -> a) -> a -> ByteString -> a-foldl f v (PS x s l) = inlinePerformIO $ withForeignPtr x $ \ptr ->- lgo v (ptr `plusPtr` s) (ptr `plusPtr` (s+l))+foldl f z (PS fp off len) =+ let p = unsafeForeignPtrToPtr fp+ in go (p `plusPtr` (off+len-1)) (p `plusPtr` (off-1)) where- STRICT3(lgo)- lgo z p q | p == q = return z- | otherwise = do c <- peek p- lgo (f z c) (p `plusPtr` 1) q+ -- not tail recursive; traverses array right to left+ go !p !q | p == q = z+ | otherwise = let !x = inlinePerformIO $ do+ x' <- peek p+ touchForeignPtr fp+ return x'+ in f (go (p `plusPtr` (-1)) q) x {-# INLINE foldl #-} --- | 'foldl\'' is like 'foldl', but strict in the accumulator.--- However, for ByteStrings, all left folds are strict in the accumulator.+-- | 'foldl'' is like 'foldl', but strict in the accumulator. -- foldl' :: (a -> Word8 -> a) -> a -> ByteString -> a-foldl' = foldl+foldl' f v (PS fp off len) =+ inlinePerformIO $ withForeignPtr fp $ \p ->+ go v (p `plusPtr` off) (p `plusPtr` (off+len))+ where+ -- tail recursive; traverses array left to right+ go !z !p !q | p == q = return z+ | otherwise = do x <- peek p+ go (f z x) (p `plusPtr` 1) q {-# INLINE foldl' #-} -- | 'foldr', applied to a binary operator, a starting value -- (typically the right-identity of the operator), and a ByteString, -- reduces the ByteString using the binary operator, from right to left. foldr :: (Word8 -> a -> a) -> a -> ByteString -> a-foldr k v (PS x s l) = inlinePerformIO $ withForeignPtr x $ \ptr ->- go v (ptr `plusPtr` (s+l-1)) (ptr `plusPtr` (s-1))+foldr k z (PS fp off len) =+ let p = unsafeForeignPtrToPtr fp+ in go (p `plusPtr` off) (p `plusPtr` (off+len)) where- STRICT3(go)- go z p q | p == q = return z- | otherwise = do c <- peek p- go (c `k` z) (p `plusPtr` (-1)) q -- tail recursive+ -- not tail recursive; traverses array left to right+ go !p !q | p == q = z+ | otherwise = let !x = inlinePerformIO $ do+ x' <- peek p+ touchForeignPtr fp+ return x'+ in k x (go (p `plusPtr` 1) q) {-# INLINE foldr #-} --- | 'foldr\'' is like 'foldr', but strict in the accumulator.+-- | 'foldr'' is like 'foldr', but strict in the accumulator. foldr' :: (Word8 -> a -> a) -> a -> ByteString -> a-foldr' k v (PS x s l) = inlinePerformIO $ withForeignPtr x $ \ptr ->- go v (ptr `plusPtr` (s+l-1)) (ptr `plusPtr` (s-1))+foldr' k v (PS fp off len) =+ inlinePerformIO $ withForeignPtr fp $ \p ->+ go v (p `plusPtr` (off+len-1)) (p `plusPtr` (off-1)) where- STRICT3(go)- go z p q | p == q = return z- | otherwise = do c <- peek p- go (c `k` z) (p `plusPtr` (-1)) q -- tail recursive+ -- tail recursive; traverses array right to left+ go !z !p !q | p == q = return z+ | otherwise = do x <- peek p+ go (k x z) (p `plusPtr` (-1)) q {-# INLINE foldr' #-} -- | 'foldl1' is a variant of 'foldl' that has no starting value -- argument, and thus must be applied to non-empty 'ByteStrings'.--- This function is subject to array fusion. -- An exception will be thrown in the case of an empty ByteString. foldl1 :: (Word8 -> Word8 -> Word8) -> ByteString -> Word8 foldl1 f ps@@ -676,7 +691,7 @@ -- passing an accumulating parameter from left to right, and returning a -- final value of this accumulator together with the new list. mapAccumL :: (acc -> Word8 -> (acc, Word8)) -> acc -> ByteString -> (acc, ByteString)-mapAccumL f acc (PS fp o len) = inlinePerformIO $ withForeignPtr fp $ \a -> do+mapAccumL f acc (PS fp o len) = unsafeDupablePerformIO $ withForeignPtr fp $ \a -> do gp <- mallocByteString len acc' <- withForeignPtr gp $ \p -> mapAccumL_ acc 0 (a `plusPtr` o) p return $! (acc', PS gp 0 len)@@ -696,7 +711,7 @@ -- passing an accumulating parameter from right to left, and returning a -- final value of this accumulator together with the new ByteString. mapAccumR :: (acc -> Word8 -> (acc, Word8)) -> acc -> ByteString -> (acc, ByteString)-mapAccumR f acc (PS fp o len) = inlinePerformIO $ withForeignPtr fp $ \a -> do+mapAccumR f acc (PS fp o len) = unsafeDupablePerformIO $ withForeignPtr fp $ \a -> do gp <- mallocByteString len acc' <- withForeignPtr gp $ \p -> mapAccumR_ acc (len-1) (a `plusPtr` o) p return $! (acc', PS gp 0 len)@@ -725,7 +740,7 @@ -- scanl :: (Word8 -> Word8 -> Word8) -> Word8 -> ByteString -> ByteString -scanl f v (PS fp s len) = inlinePerformIO $ withForeignPtr fp $ \a ->+scanl f v (PS fp s len) = unsafeDupablePerformIO $ withForeignPtr fp $ \a -> create (len+1) $ \q -> do poke q v scanl_ v 0 (a `plusPtr` s) (q `plusPtr` 1)@@ -756,7 +771,7 @@ -- | scanr is the right-to-left dual of scanl. scanr :: (Word8 -> Word8 -> Word8) -> Word8 -> ByteString -> ByteString-scanr f v (PS fp s len) = inlinePerformIO $ withForeignPtr fp $ \a ->+scanr f v (PS fp s len) = unsafeDupablePerformIO $ withForeignPtr fp $ \a -> create (len+1) $ \q -> do poke (q `plusPtr` len) v scanr_ v (len-1) (a `plusPtr` s) q@@ -1267,7 +1282,7 @@ -- | /O(n)/ 'filter', applied to a predicate and a ByteString, -- returns a ByteString containing those characters that satisfy the--- predicate. This function is subject to array fusion.+-- predicate. filter :: (Word8 -> Bool) -> ByteString -> ByteString filter k ps@(PS x s l) | null ps = ps@@ -1509,7 +1524,7 @@ -- performed on the result of zipWith. -- zipWith' :: (Word8 -> Word8 -> Word8) -> ByteString -> ByteString -> ByteString-zipWith' f (PS fp s l) (PS fq t m) = inlinePerformIO $+zipWith' f (PS fp s l) (PS fq t m) = unsafeDupablePerformIO $ withForeignPtr fp $ \a -> withForeignPtr fq $ \b -> create len $ zipWith_ 0 (a `plusPtr` s) (b `plusPtr` t)@@ -1602,8 +1617,8 @@ -- Low level constructors -- | /O(n) construction/ Use a @ByteString@ with a function requiring a--- null-terminated @CString@. The @CString@ will be freed--- automatically. This is a memcpy(3).+-- null-terminated @CString@. The @CString@ is a copy and will be freed+-- automatically. useAsCString :: ByteString -> (CString -> IO a) -> IO a useAsCString (PS fp o l) action = do allocaBytes (l+1) $ \buf ->
Data/ByteString/Builder.hs view
@@ -1,5 +1,8 @@ {-# LANGUAGE CPP, BangPatterns #-}-{-# OPTIONS_GHC -fno-warn-unused-imports #-}+{-# OPTIONS_GHC -fno-warn-unused-imports -fno-warn-orphans #-}+#if __GLASGOW_HASKELL__ >= 701+{-# LANGUAGE Trustworthy #-}+#endif {- | Copyright : (c) 2010 Jasper Van der Jeugt (c) 2010 - 2011 Simon Meier License : BSD3-style (see LICENSE)@@ -54,7 +57,6 @@ @ import qualified "Data.ByteString.Lazy" as L import "Data.ByteString.Builder"-import "Data.ByteString.Builder.ASCII" ('intDec') import Data.Monoid import Data.Foldable ('foldMap') import Data.List ('intersperse')@@ -195,6 +197,7 @@ -- ** Binary encodings , byteString , lazyByteString+ , shortByteString , int8 , word8 @@ -262,12 +265,13 @@ import Data.ByteString.Builder.Internal import qualified Data.ByteString.Builder.Prim as P import qualified Data.ByteString.Lazy.Internal as L+import Data.ByteString.Builder.ASCII +import Data.String (IsString(..)) import System.IO (Handle) import Foreign -- HADDOCK only imports-import Data.ByteString.Builder.ASCII (intDec) import qualified Data.ByteString as S (concat) import Data.Monoid import Data.Foldable (foldMap)@@ -450,3 +454,5 @@ stringUtf8 :: String -> Builder stringUtf8 = P.primMapListBounded P.charUtf8 +instance IsString Builder where+ fromString = stringUtf8
Data/ByteString/Builder/ASCII.hs view
@@ -1,5 +1,9 @@-{-# LANGUAGE ScopedTypeVariables, CPP, ForeignFunctionInterface #-}+{-# LANGUAGE ScopedTypeVariables, CPP, ForeignFunctionInterface,+ MagicHash, UnboxedTuples #-} {-# OPTIONS_HADDOCK hide #-}+#if __GLASGOW_HASKELL__ >= 701+{-# LANGUAGE Trustworthy #-}+#endif -- | Copyright : (c) 2010 - 2011 Simon Meier -- License : BSD3-style (see LICENSE) --@@ -67,13 +71,33 @@ ) where -import Data.ByteString as S-import Data.ByteString.Lazy.Internal as L+import Data.ByteString as S+import Data.ByteString.Lazy as L import Data.ByteString.Builder.Internal (Builder)-import qualified Data.ByteString.Builder.Prim as P+import qualified Data.ByteString.Builder.Prim as P import Foreign ++#if defined(__GLASGOW_HASKELL__) && defined(INTEGER_GMP)+import Data.Monoid (mappend)+import Foreign.C.Types++import qualified Data.ByteString.Builder.Prim.Internal as P+import Data.ByteString.Builder.Prim.Internal.UncheckedShifts+ ( caseWordSize_32_64 )++import GHC.Num (quotRemInteger)+import GHC.Types (Int(..))+++# if __GLASGOW_HASKELL__ < 611+import GHC.Integer.Internals+# else+import GHC.Integer.GMP.Internals+# endif+#endif+ ------------------------------------------------------------------------------ -- Decimal Encoding ------------------------------------------------------------------------------@@ -122,12 +146,7 @@ intDec :: Int -> Builder intDec = P.primBounded P.intDec --- | /Currently slow./ Decimal encoding of an 'Integer' using the ASCII digits.-{-# INLINE integerDec #-}-integerDec :: Integer -> Builder-integerDec = string7 . show - -- Unsigned integers -------------------- @@ -268,3 +287,93 @@ {-# NOINLINE lazyByteStringHex #-} -- share code lazyByteStringHex :: L.ByteString -> Builder lazyByteStringHex = P.primMapLazyByteStringFixed P.word8HexFixed+++------------------------------------------------------------------------------+-- Fast decimal 'Integer' encoding.+------------------------------------------------------------------------------++#if defined(__GLASGOW_HASKELL__) && defined(INTEGER_GMP)+-- An optimized version of the integer serialization code+-- in blaze-textual (c) 2011 MailRank, Inc. Bryan O'Sullivan+-- <bos@mailrank.com>. It is 2.5x faster on Int-sized integers and 4.5x faster+-- on larger integers.++# define PAIR(a,b) (# a,b #)++-- | Maximal power of 10 fitting into an 'Int' without using the MSB.+-- 10 ^ 9 for 32 bit ints (31 * log 2 / log 10 = 9.33)+-- 10 ^ 18 for 64 bit ints (63 * log 2 / log 10 = 18.96)+--+-- FIXME: Think about also using the MSB. For 64 bit 'Int's this makes a+-- difference.+maxPow10 :: Integer+maxPow10 = toInteger $ (10 :: Int) ^ caseWordSize_32_64 (9 :: Int) 18++-- | Decimal encoding of an 'Integer' using the ASCII digits.+integerDec :: Integer -> Builder+integerDec (S# i#) = intDec (I# i#)+integerDec i+ | i < 0 = P.primFixed P.char8 '-' `mappend` go (-i)+ | otherwise = go ( i)+ where+ errImpossible fun =+ error $ "integerDec: " ++ fun ++ ": the impossible happened."++ go :: Integer -> Builder+ go n | n < maxPow10 = intDec (fromInteger n)+ | otherwise =+ case putH (splitf (maxPow10 * maxPow10) n) of+ (x:xs) -> intDec x `mappend` P.primMapListBounded intDecPadded xs+ [] -> errImpossible "integerDec: go"++ splitf :: Integer -> Integer -> [Integer]+ splitf pow10 n0+ | pow10 > n0 = [n0]+ | otherwise = splith (splitf (pow10 * pow10) n0)+ where+ splith [] = errImpossible "splith"+ splith (n:ns) =+ case n `quotRemInteger` pow10 of+ PAIR(q,r) | q > 0 -> q : r : splitb ns+ | otherwise -> r : splitb ns++ splitb [] = []+ splitb (n:ns) = case n `quotRemInteger` pow10 of+ PAIR(q,r) -> q : r : splitb ns++ putH :: [Integer] -> [Int]+ putH [] = errImpossible "putH"+ putH (n:ns) = case n `quotRemInteger` maxPow10 of+ PAIR(x,y)+ | q > 0 -> q : r : putB ns+ | otherwise -> r : putB ns+ where q = fromInteger x+ r = fromInteger y++ putB :: [Integer] -> [Int]+ putB [] = []+ putB (n:ns) = case n `quotRemInteger` maxPow10 of+ PAIR(q,r) -> fromInteger q : fromInteger r : putB ns+++foreign import ccall unsafe "static _hs_bytestring_int_dec_padded9"+ c_int_dec_padded9 :: CInt -> Ptr Word8 -> IO ()++foreign import ccall unsafe "static _hs_bytestring_long_long_int_dec_padded18"+ c_long_long_int_dec_padded18 :: CLLong -> Ptr Word8 -> IO ()++{-# INLINE intDecPadded #-}+intDecPadded :: P.BoundedPrim Int+intDecPadded = P.liftFixedToBounded $ caseWordSize_32_64+ (P.fixedPrim 9 $ c_int_dec_padded9 . fromIntegral)+ (P.fixedPrim 18 $ c_long_long_int_dec_padded18 . fromIntegral)++#else+-- compilers other than GHC++-- | Decimal encoding of an 'Integer' using the ASCII digits. Implemented+-- using via the 'Show' instance of 'Integer's.+integerDec :: Integer -> Builder+integerDec = string7 . show+#endif
Data/ByteString/Builder/Extra.hs view
@@ -1,4 +1,8 @@+{-# LANGUAGE CPP #-} {-# LANGUAGE BangPatterns #-}+#if __GLASGOW_HASKELL__ >= 701+{-# LANGUAGE Trustworthy #-}+#endif ----------------------------------------------------------------------------- -- | Copyright : (c) 2010 Jasper Van der Jeugt -- (c) 2010-2011 Simon Meier@@ -64,9 +68,7 @@ import qualified Data.ByteString.Builder.Internal as I import qualified Data.ByteString.Builder.Prim as P import qualified Data.ByteString.Internal as S-import qualified Data.ByteString.Lazy.Internal as L - import Foreign ------------------------------------------------------------------------------@@ -118,37 +120,29 @@ runBuilder :: Builder -> BufferWriter runBuilder = run . I.runBuilder where+ bytesWritten startPtr endPtr = endPtr `minusPtr` startPtr+ run :: I.BuildStep () -> BufferWriter- run step = \buf len -> do- sig <- step (I.BufferRange buf (buf `plusPtr` len))- case sig of- I.Done endPtr () ->- let !wc = bytesWritten buf endPtr- next = Done- in return (wc, next)+ run step = \buf len ->+ let doneH endPtr () =+ let !wc = bytesWritten buf endPtr+ next = Done+ in return (wc, next) - I.BufferFull minReq endPtr step' ->- let !wc = bytesWritten buf endPtr- next = More minReq (run step')- in return (wc, next)+ bufferFullH endPtr minReq step' =+ let !wc = bytesWritten buf endPtr+ next = More minReq (run step')+ in return (wc, next) - I.InsertChunks endPtr _ lbsc step' ->- let !wc = bytesWritten buf endPtr- next = case lbsc L.Empty of- L.Empty -> More (len - wc) (run step')- L.Chunk c cs -> Chunk c (yieldChunks step' cs)- in return (wc, next)+ insertChunkH endPtr bs step' =+ let !wc = bytesWritten buf endPtr+ next = Chunk bs (run step')+ in return (wc, next) - yieldChunks :: I.BuildStep () -> L.ByteString -> BufferWriter- yieldChunks step' cs = \buf len ->- case cs of- L.Empty -> run step' buf len- L.Chunk c cs' ->- let wc = 0- next = Chunk c (yieldChunks step' cs')- in return (wc, next)+ br = I.BufferRange buf (buf `plusPtr` len) - bytesWritten startPtr endPtr = endPtr `minusPtr` startPtr+ in I.fillWithBuildStep step doneH bufferFullH insertChunkH br+ ------------------------------------------------------------------------------
Data/ByteString/Builder/Internal.hs view
@@ -1,4 +1,7 @@-{-# LANGUAGE ScopedTypeVariables, CPP, BangPatterns, Rank2Types #-}+{-# LANGUAGE ScopedTypeVariables, CPP, BangPatterns, RankNTypes #-}+#if __GLASGOW_HASKELL__ >= 701+{-# LANGUAGE Unsafe #-}+#endif {-# OPTIONS_HADDOCK hide #-} -- | Copyright : (c) 2010 - 2011 Simon Meier -- License : BSD3-style (see LICENSE)@@ -46,17 +49,26 @@ -- buffer-overflow attack on a Haskell server! -- module Data.ByteString.Builder.Internal (+ -- * Buffer management+ Buffer(..)+ , BufferRange(..)+ , newBuffer+ , bufferSize+ , byteStringFromBuffer - -- * Build signals and steps- BufferRange(..)- , LazyByteStringC+ , ChunkIOStream(..)+ , buildStepToCIOS+ , ciosUnitToLazyByteString+ , ciosToLazyByteString - , BuildSignal(..)+ -- * Build signals and steps+ , BuildSignal , BuildStep+ , finalBuildStep , done , bufferFull- , insertChunks+ , insertChunk , fillWithBuildStep @@ -71,6 +83,7 @@ , append , flush , ensureFree+ -- , sizedChunksInsert , byteStringCopy , byteStringInsert@@ -79,98 +92,189 @@ , lazyByteStringCopy , lazyByteStringInsert , lazyByteStringThreshold-- , lazyByteStringC+ + , shortByteString , maximalCopySize , byteString , lazyByteString - -- ** Execution strategies+ -- ** Execution , toLazyByteStringWith , AllocationStrategy , safeStrategy , untrimmedStrategy+ , customStrategy , L.smallChunkSize , L.defaultChunkSize+ , L.chunkOverhead -- * The Put monad , Put , put , runPut- , hPut - -- ** Streams of chunks interleaved with IO- , ChunkIOStream(..)- , buildStepToCIOS- , ciosToLazyByteString+ -- ** Execution+ , putToLazyByteString+ , putToLazyByteStringWith+ , hPut -- ** Conversion to and from Builders , putBuilder , fromPut - -- ** Lifting IO actions+ -- -- ** Lifting IO actions -- , putLiftIO ) where -import Control.Applicative (Applicative(..), (<$>))+import Control.Arrow (second)+import Control.Applicative (Applicative(..), (<$>))+-- import Control.Exception (return) -import Data.Monoid+import Data.Monoid import qualified Data.ByteString as S import qualified Data.ByteString.Internal as S import qualified Data.ByteString.Lazy.Internal as L+import qualified Data.ByteString.Short.Internal as Sh #if __GLASGOW_HASKELL__ >= 611-import GHC.IO.Buffer (Buffer(..), newByteBuffer)-import GHC.IO.Handle.Internals (wantWritableHandle, flushWriteBuffer)-import GHC.IO.Handle.Types (Handle__, haByteBuffer, haBufferMode)-import System.IO (hFlush, BufferMode(..))-import Data.IORef+import qualified GHC.IO.Buffer as IO (Buffer(..), newByteBuffer)+import GHC.IO.Handle.Internals (wantWritableHandle, flushWriteBuffer)+import GHC.IO.Handle.Types (Handle__, haByteBuffer, haBufferMode)+import System.IO (hFlush, BufferMode(..))+import Data.IORef #else import qualified Data.ByteString.Lazy as L #endif-import System.IO (Handle)+import System.IO (Handle) #if MIN_VERSION_base(4,4,0)-import Foreign hiding (unsafePerformIO, unsafeForeignPtrToPtr)-import Foreign.ForeignPtr.Unsafe (unsafeForeignPtrToPtr)-import System.IO.Unsafe (unsafePerformIO)+#if MIN_VERSION_base(4,7,0)+import Foreign #else-import Foreign+import Foreign hiding (unsafeForeignPtrToPtr) #endif---type LazyByteStringC = L.ByteString -> L.ByteString+import Foreign.ForeignPtr.Unsafe (unsafeForeignPtrToPtr)+import System.IO.Unsafe (unsafeDupablePerformIO)+#else+import Foreign+import GHC.IO (unsafeDupablePerformIO)+#endif +------------------------------------------------------------------------------+-- Buffers+------------------------------------------------------------------------------ -- | A range of bytes in a buffer represented by the pointer to the first byte -- of the range and the pointer to the first byte /after/ the range. data BufferRange = BufferRange {-# UNPACK #-} !(Ptr Word8) -- First byte of range {-# UNPACK #-} !(Ptr Word8) -- First byte /after/ range +-- | A 'Buffer' together with the 'BufferRange' of free bytes. The filled+-- space starts at offset 0 and ends at the first free byte.+data Buffer = Buffer {-# UNPACK #-} !(ForeignPtr Word8)+ {-# UNPACK #-} !BufferRange ++-- | Combined size of the filled and free space in the buffer.+{-# INLINE bufferSize #-}+bufferSize :: Buffer -> Int+bufferSize (Buffer fpbuf (BufferRange _ ope)) =+ ope `minusPtr` unsafeForeignPtrToPtr fpbuf++-- | Allocate a new buffer of the given size.+{-# INLINE newBuffer #-}+newBuffer :: Int -> IO Buffer+newBuffer size = do+ fpbuf <- S.mallocByteString size+ let pbuf = unsafeForeignPtrToPtr fpbuf+ return $! Buffer fpbuf (BufferRange pbuf (pbuf `plusPtr` size))++-- | Convert the filled part of a 'Buffer' to a strict 'S.ByteString'.+{-# INLINE byteStringFromBuffer #-}+byteStringFromBuffer :: Buffer -> S.ByteString+byteStringFromBuffer (Buffer fpbuf (BufferRange op _)) =+ S.PS fpbuf 0 (op `minusPtr` unsafeForeignPtrToPtr fpbuf)++--- | Prepend the filled part of a 'Buffer' to a lazy 'L.ByteString'+--- trimming it if necessary.+{-# INLINE trimmedChunkFromBuffer #-}+trimmedChunkFromBuffer :: AllocationStrategy -> Buffer+ -> L.ByteString -> L.ByteString+trimmedChunkFromBuffer (AllocationStrategy _ _ trim) buf k+ | S.null bs = k+ | trim (S.length bs) (bufferSize buf) = L.Chunk (S.copy bs) k+ | otherwise = L.Chunk bs k+ where+ bs = byteStringFromBuffer buf+ ------------------------------------------------------------------------------+-- Chunked IO Stream+------------------------------------------------------------------------------++-- | A stream of chunks that are constructed in the 'IO' monad.+--+-- This datatype serves as the common interface for the buffer-by-buffer+-- execution of a 'BuildStep' by 'buildStepToCIOS'. Typical users of this+-- interface are 'ciosToLazyByteString' or iteratee-style libraries like+-- @enumerator@.+data ChunkIOStream a =+ Finished Buffer a+ -- ^ The partially filled last buffer together with the result.+ | Yield1 S.ByteString (IO (ChunkIOStream a))+ -- ^ Yield a /non-empty/ strict 'S.ByteString'.++-- | A smart constructor for yielding one chunk that ignores the chunk if+-- it is empty.+{-# INLINE yield1 #-}+yield1 :: S.ByteString -> IO (ChunkIOStream a) -> IO (ChunkIOStream a)+yield1 bs cios | S.null bs = cios+ | otherwise = return $ Yield1 bs cios++-- | Convert a @'ChunkIOStream' ()@ to a lazy 'L.ByteString' using+-- 'unsafeDupablePerformIO'.+{-# INLINE ciosUnitToLazyByteString #-}+ciosUnitToLazyByteString :: AllocationStrategy+ -> L.ByteString -> ChunkIOStream () -> L.ByteString+ciosUnitToLazyByteString strategy k = go+ where+ go (Finished buf _) = trimmedChunkFromBuffer strategy buf k+ go (Yield1 bs io) = L.Chunk bs $ unsafeDupablePerformIO (go <$> io)++-- | Convert a 'ChunkIOStream' to a lazy tuple of the result and the written+-- 'L.ByteString' using 'unsafeDupablePerformIO'.+{-# INLINE ciosToLazyByteString #-}+ciosToLazyByteString :: AllocationStrategy+ -> (a -> (b, L.ByteString))+ -> ChunkIOStream a+ -> (b, L.ByteString)+ciosToLazyByteString strategy k =+ go+ where+ go (Finished buf x) =+ second (trimmedChunkFromBuffer strategy buf) $ k x+ go (Yield1 bs io) = second (L.Chunk bs) $ unsafeDupablePerformIO (go <$> io)++------------------------------------------------------------------------------ -- Build signals ------------------------------------------------------------------------------ --- | 'BuildStep's may assume that they are called at most once. However,--- they must not execute any function that may rise an async. exception,--- as this would invalidate the code of 'hPut' below.+-- | 'BuildStep's may be called *multiple times* and they must not rise an+-- async. exception. type BuildStep a = BufferRange -> IO (BuildSignal a) -- | 'BuildSignal's abstract signals to the caller of a 'BuildStep'. There are--- exactly three signals: 'done', 'bufferFull', and 'insertChunks'.+-- three signals: 'done', 'bufferFull', or 'insertChunks signals data BuildSignal a = Done {-# UNPACK #-} !(Ptr Word8) a | BufferFull {-# UNPACK #-} !Int {-# UNPACK #-} !(Ptr Word8)- !(BuildStep a)- | InsertChunks+ (BuildStep a)+ | InsertChunk {-# UNPACK #-} !(Ptr Word8)- {-# UNPACK #-} !Int64 -- size of bytes in continuation- LazyByteStringC- !(BuildStep a)+ S.ByteString+ (BuildStep a) -- | Signal that the current 'BuildStep' is done and has computed a value. {-# INLINE done #-}@@ -193,22 +297,19 @@ -> BuildSignal a bufferFull = BufferFull --- TODO: Decide whether we should inline the bytestring constructor.--- Therefore, making builders independent of strict bytestrings. --- | Signal that several chunks should be inserted directly.-{-# INLINE insertChunks #-}-insertChunks :: Ptr Word8+-- | Signal that a 'S.ByteString' chunk should be inserted directly.+{-# INLINE insertChunk #-}+insertChunk :: Ptr Word8 -- ^ Next free byte in current 'BufferRange'- -> Int64- -- ^ Number of bytes in 'L.ByteString' continuation.- -> (L.ByteString -> L.ByteString)- -- ^ Chunks to insert.+ -> S.ByteString+ -- ^ Chunk to insert. -> BuildStep a -- ^ 'BuildStep' to run on next 'BufferRange' -> BuildSignal a-insertChunks = InsertChunks+insertChunk op bs = InsertChunk op bs + -- | Fill a 'BufferRange' using a 'BuildStep'. {-# INLINE fillWithBuildStep #-} fillWithBuildStep@@ -218,19 +319,18 @@ -- ^ Handling the 'done' signal -> (Ptr Word8 -> Int -> BuildStep a -> IO b) -- ^ Handling the 'bufferFull' signal- -> (Ptr Word8 -> Int64 -> LazyByteStringC -> BuildStep a -> IO b)- -- ^ Handling the 'insertChunks' signal+ -> (Ptr Word8 -> S.ByteString -> BuildStep a -> IO b)+ -- ^ Handling the 'insertChunk' signal -> BufferRange -- ^ Buffer range to fill. -> IO b- -- ^ Value computed by filling this 'BufferRange'.+ -- ^ Value computed while filling this 'BufferRange'. fillWithBuildStep step fDone fFull fChunk !br = do signal <- step br case signal of- Done op x -> fDone op x- BufferFull minSize op nextStep -> fFull op minSize nextStep- InsertChunks op len lbsC nextStep -> fChunk op len lbsC nextStep-+ Done op x -> fDone op x+ BufferFull minSize op nextStep -> fFull op minSize nextStep+ InsertChunk op bs nextStep -> fChunk op bs nextStep ------------------------------------------------------------------------------@@ -252,23 +352,27 @@ -- to proceed using 'done', 'bufferFull', or 'insertChunk'. -- -- This function must be referentially transparent; i.e., calling it- -- multiple times must result in the same sequence of bytes being- -- written. If you need mutable state, then you must allocate it newly- -- upon each call of this function. Moroever, this function must call- -- the continuation once its done. Otherwise, concatenation of- -- 'Builder's does not work. Finally, this function must write to all- -- bytes that it claims it has written. Otherwise, the resulting- -- 'Builder' is not guaranteed to be referentially transparent and- -- sensitive data might leak.+ -- multiple times with equally sized 'BufferRange's must result in the+ -- same sequence of bytes being written. If you need mutable state,+ -- then you must allocate it anew upon each call of this function.+ -- Moroever, this function must call the continuation once its done.+ -- Otherwise, concatenation of 'Builder's does not work. Finally, this+ -- function must write to all bytes that it claims it has written.+ -- Otherwise, the resulting 'Builder' is not guaranteed to be+ -- referentially transparent and sensitive data might leak. -> Builder builder = Builder --- | Run a 'Builder'.+-- | The final build step that returns the 'done' signal.+finalBuildStep :: BuildStep ()+finalBuildStep !(BufferRange op _) = return $ Done op ()++-- | Run a 'Builder' with the 'finalBuildStep'. {-# INLINE runBuilder #-} runBuilder :: Builder -- ^ 'Builder' to run -> BuildStep () -- ^ 'BuildStep' that writes the byte stream of this -- 'Builder' and signals 'done' upon completion.-runBuilder (Builder b) = b $ \(BufferRange op _) -> return $ done op ()+runBuilder b = runBuilderWith b finalBuildStep -- | Run a 'Builder'. {-# INLINE runBuilderWith #-}@@ -297,22 +401,12 @@ {-# INLINE mconcat #-} mconcat = foldr mappend mempty -instance Show Builder where- show = show . showBuilder--{-# NOINLINE showBuilder #-} -- ensure code is shared-showBuilder :: Builder -> L.ByteString-showBuilder = toLazyByteStringWith- (safeStrategy L.smallChunkSize L.smallChunkSize) L.Empty-- -- | Flush the current buffer. This introduces a chunk boundary.--- {-# INLINE flush #-} flush :: Builder flush = builder step where- step k !(BufferRange op _) = return $ insertChunks op 0 id k+ step k !(BufferRange op _) = return $ insertChunk op S.empty k ------------------------------------------------------------------------------@@ -324,18 +418,18 @@ -- stream of bytes will always be written before the computed value is -- returned. ----- 'Put's are a generalization of 'Builder's. They are used when values need to--- be returned during the computation of a stream of bytes. For example, when--- performing a block-based encoding of 'S.ByteString's like Base64 encoding,--- there might be a left-over partial block. Using the 'Put' monad, this--- partial block can be returned after the complete blocks have been encoded.--- Then, in a later step when more input is known, this partial block can be--- completed and also encoded.+-- 'Put's are a generalization of 'Builder's. The typical use case is the+-- implementation of an encoding that might fail (e.g., an interface to the+-- 'zlib' compression library or the conversion from Base64 encoded data to+-- 8-bit data). For a 'Builder', the only way to handle and report such a+-- failure is ignore it or call 'error'. In contrast, 'Put' actions are+-- expressive enough to allow reportng and handling such a failure in a pure+-- fashion. ----- @Put ()@ actions are isomorphic to 'Builder's. The functions 'putBuilder'+-- @'Put' ()@ actions are isomorphic to 'Builder's. The functions 'putBuilder' -- and 'fromPut' convert between these two types. Where possible, you should--- use 'Builder's, as they are slightly cheaper than 'Put's because they do not--- carry a computed value.+-- use 'Builder's, as sequencing them is slightly cheaper than sequencing+-- 'Put's because they do not carry around a computed value. newtype Put a = Put { unPut :: forall r. (a -> BuildStep r) -> BuildStep r } -- | Construct a 'Put' action. In contrast to 'BuildStep's, 'Put's are@@ -346,17 +440,18 @@ -- ^ A function that fills a 'BufferRange', calls the continuation with -- the updated 'BufferRange' and its computed value once its done, and -- signals its caller how to proceed using 'done', 'bufferFull', or- -- 'insertChunk'.+ -- 'insertChunk' signals. --- -- This function must be referentially transparent; i.e., calling it- -- multiple times must result in the same sequence of bytes being- -- written and the same value being computed. If you need mutable state,- -- then you must allocate it newly upon each call of this function.- -- Moroever, this function must call the continuation once its done.- -- Otherwise, monadic sequencing of 'Put's does not work. Finally, this- -- function must write to all bytes that it claims it has written.- -- Otherwise, the resulting 'Put' is not guaranteed to be referentially- -- transparent and sensitive data might leak.+ -- This function must be referentially transparent; i.e., calling it+ -- multiple times with equally sized 'BufferRange's must result in the+ -- same sequence of bytes being written and the same value being+ -- computed. If you need mutable state, then you must allocate it anew+ -- upon each call of this function. Moroever, this function must call+ -- the continuation once its done. Otherwise, monadic sequencing of+ -- 'Put's does not work. Finally, this function must write to all bytes+ -- that it claims it has written. Otherwise, the resulting 'Put' is+ -- not guaranteed to be referentially transparent and sensitive data+ -- might leak. -> Put a put = Put @@ -372,6 +467,17 @@ fmap f p = Put $ \k -> unPut p (\x -> k (f x)) {-# INLINE fmap #-} +-- | Synonym for '<*' from 'Applicative'; used in rewriting rules.+{-# INLINE[1] ap_l #-}+ap_l :: Put a -> Put b -> Put a+ap_l (Put a) (Put b) = Put $ \k -> a (\a' -> b (\_ -> k a'))++-- | Synonym for '*>' from 'Applicative' and '>>' from 'Monad'; used in+-- rewriting rules.+{-# INLINE[1] ap_r #-}+ap_r :: Put a -> Put b -> Put b+ap_r (Put a) (Put b) = Put $ \k -> a (\_ -> b k)+ instance Applicative Put where {-# INLINE pure #-} pure x = Put $ \k -> k x@@ -379,9 +485,9 @@ Put f <*> Put a = Put $ \k -> f (\f' -> a (\a' -> k (f' a'))) #if MIN_VERSION_base(4,2,0) {-# INLINE (<*) #-}- Put a <* Put b = Put $ \k -> a (\a' -> b (\_ -> k a'))+ (<*) = ap_l {-# INLINE (*>) #-}- Put a *> Put b = Put $ \k -> a (\_ -> b k)+ (*>) = ap_r #endif instance Monad Put where@@ -390,23 +496,81 @@ {-# INLINE (>>=) #-} Put m >>= f = Put $ \k -> m (\m' -> unPut (f m') k) {-# INLINE (>>) #-}- Put m >> Put n = Put $ \k -> m (\_ -> n k)+ (>>) = ap_r -- Conversion between Put and Builder ------------------------------------- --- | Run a 'Builder' as a side-effect of a @Put ()@ action.-{-# INLINE putBuilder #-}+-- | Run a 'Builder' as a side-effect of a @'Put' ()@ action.+{-# INLINE[1] putBuilder #-} putBuilder :: Builder -> Put () putBuilder (Builder b) = Put $ \k -> b (k ()) --- | Convert a @Put ()@ action to a 'Builder'.+-- | Convert a @'Put' ()@ action to a 'Builder'. {-# INLINE fromPut #-} fromPut :: Put () -> Builder fromPut (Put p) = Builder $ \k -> p (\_ -> k) +-- We rewrite consecutive uses of 'putBuilder' such that the append of the+-- involved 'Builder's is used. This can significantly improve performance,+-- when the bound-checks of the concatenated builders are fused. +-- ap_l rules+{-# RULES++"ap_l/putBuilder" forall b1 b2.+ ap_l (putBuilder b1) (putBuilder b2)+ = putBuilder (append b1 b2)++"ap_l/putBuilder/assoc_r" forall b1 b2 (p :: Put a).+ ap_l (putBuilder b1) (ap_l (putBuilder b2) p)+ = ap_l (putBuilder (append b1 b2)) p++"ap_l/putBuilder/assoc_l" forall (p :: Put a) b1 b2.+ ap_l (ap_l p (putBuilder b1)) (putBuilder b2)+ = ap_l p (putBuilder (append b1 b2))+ #-}++-- ap_r rules+{-# RULES++"ap_r/putBuilder" forall b1 b2.+ ap_r (putBuilder b1) (putBuilder b2)+ = putBuilder (append b1 b2)++"ap_r/putBuilder/assoc_r" forall b1 b2 (p :: Put a).+ ap_r (putBuilder b1) (ap_r (putBuilder b2) p)+ = ap_r (putBuilder (append b1 b2)) p++"ap_r/putBuilder/assoc_l" forall (p :: Put a) b1 b2.+ ap_r (ap_r p (putBuilder b1)) (putBuilder b2)+ = ap_r p (putBuilder (append b1 b2))++ #-}++-- combined ap_l/ap_r rules+{-# RULES++"ap_l/ap_r/putBuilder/assoc_r" forall b1 b2 (p :: Put a).+ ap_l (putBuilder b1) (ap_r (putBuilder b2) p)+ = ap_l (putBuilder (append b1 b2)) p++"ap_r/ap_l/putBuilder/assoc_r" forall b1 b2 (p :: Put a).+ ap_r (putBuilder b1) (ap_l (putBuilder b2) p)+ = ap_l (putBuilder (append b1 b2)) p++"ap_l/ap_r/putBuilder/assoc_l" forall (p :: Put a) b1 b2.+ ap_l (ap_r p (putBuilder b1)) (putBuilder b2)+ = ap_r p (putBuilder (append b1 b2))++"ap_r/ap_l/putBuilder/assoc_l" forall (p :: Put a) b1 b2.+ ap_r (ap_l p (putBuilder b1)) (putBuilder b2)+ = ap_r p (putBuilder (append b1 b2))++ #-}++ -- Lifting IO actions --------------------- @@ -442,12 +606,18 @@ -- -- 1. GHC.IO.Handle.Internals mentions in "Note [async]" that -- we should never do any side-effecting operations before- -- an interruptible operation that may raise an async. exception+ -- an interuptible operation that may raise an async. exception -- as long as we are inside 'wantWritableHandle' and the like. -- We possibly run the interuptible 'flushWriteBuffer' right at -- the start of 'fillHandle', hence entering it a second time is -- not safe, as it could lead to a 'BuildStep' being run twice. --+ -- FIXME (SM): Adapt this function or at least its documentation,+ -- as it is OK to run a 'BuildStep' twice. We dropped this+ -- requirement in favor of being able to use+ -- 'unsafeDupablePerformIO' and the speed improvement that it+ -- brings.+ -- -- 2. We use the 'S.hPut' function to also write to the handle. -- This function tries to take the same lock taken by -- 'wantWritableHandle'. Therefore, we cannot call 'S.hPut'@@ -459,13 +629,13 @@ fillBuffer =<< readIORef refBuf where refBuf = haByteBuffer h_- freeSpace buf = bufSize buf - bufR buf+ freeSpace buf = IO.bufSize buf - IO.bufR buf makeSpace buf- | bufSize buf < minFree = do+ | IO.bufSize buf < minFree = do flushWriteBuffer h_- s <- bufState <$> readIORef refBuf- newByteBuffer minFree s >>= writeIORef refBuf+ s <- IO.bufState <$> readIORef refBuf+ IO.newByteBuffer minFree s >>= writeIORef refBuf | freeSpace buf < minFree = flushWriteBuffer h_ | otherwise =@@ -485,19 +655,19 @@ , " free: " ++ show (freeSpace buf) ] | otherwise = do- let !br = BufferRange op (pBuf `plusPtr` bufSize buf)- res <- fillWithBuildStep step doneH fullH insertChunksH br+ let !br = BufferRange op (pBuf `plusPtr` IO.bufSize buf)+ res <- fillWithBuildStep step doneH fullH insertChunkH br touchForeignPtr fpBuf return res where- fpBuf = bufRaw buf+ fpBuf = IO.bufRaw buf pBuf = unsafeForeignPtrToPtr fpBuf- op = pBuf `plusPtr` bufR buf+ op = pBuf `plusPtr` IO.bufR buf {-# INLINE updateBufR #-} updateBufR op' = do let !off' = op' `minusPtr` pBuf- !buf' = buf {bufR = off'}+ !buf' = buf {IO.bufR = off'} writeIORef refBuf buf' doneH op' x = do@@ -518,22 +688,100 @@ -- really less than 'minSize' space left) before executing -- the 'nextStep'. - insertChunksH op' _ lbsC nextStep = do+ insertChunkH op' bs nextStep = do updateBufR op' return $ do- L.foldrChunks (\c rest -> S.hPut h c >> rest) (return ())- (lbsC L.Empty)+ S.hPut h bs fillHandle 1 nextStep #else hPut h p =- go =<< buildStepToCIOS strategy (return . Finished) (runPut p)+ go =<< buildStepToCIOS strategy (runPut p) where- go (Finished k) = return k- go (Yield1 bs io) = S.hPut h bs >> io >>= go- go (YieldC _ lbsC io) = L.hPut h (lbsC L.Empty) >> io >>= go strategy = untrimmedStrategy L.smallChunkSize L.defaultChunkSize++ go (Finished buf x) = S.hPut h (byteStringFromBuffer buf) >> return x+ go (Yield1 bs io) = S.hPut h bs >> io >>= go #endif +-- | Execute a 'Put' and return the computed result and the bytes+-- written during the computation as a lazy 'L.ByteString'.+--+-- This function is strict in the computed result and lazy in the writing of+-- the bytes. For example, given+--+-- @+--infinitePut = sequence_ (repeat (putBuilder (word8 1))) >> return 0+-- @+--+-- evaluating the expression+--+-- @+--fst $ putToLazyByteString infinitePut+-- @+--+-- does not terminate, while evaluating the expression+--+-- @+--L.head $ snd $ putToLazyByteString infinitePut+-- @+--+-- does terminate and yields the value @1 :: Word8@.+--+-- An illustrative example for these strictness properties is the+-- implementation of Base64 decoding (<http://en.wikipedia.org/wiki/Base64>).+--+-- @+--type DecodingState = ...+--+--decodeBase64 :: 'S.ByteString' -> DecodingState -> 'Put' (Maybe DecodingState)+--decodeBase64 = ...+-- @+--+-- The above function takes a strict 'S.ByteString' supposed to represent+-- Base64 encoded data and the current decoding state.+-- It writes the decoded bytes as the side-effect of the 'Put' and returns the+-- new decoding state, if the decoding of all data in the 'S.ByteString' was+-- successful. The checking if the strict 'S.ByteString' represents Base64+-- encoded data and the actual decoding are fused. This makes the common case,+-- where all data represents Base64 encoded data, more efficient. It also+-- implies that all data must be decoded before the final decoding+-- state can be returned. 'Put's are intended for implementing such fused+-- checking and decoding/encoding, which is reflected in their strictness+-- properties.+{-# NOINLINE putToLazyByteString #-}+putToLazyByteString+ :: Put a -- ^ 'Put' to execute+ -> (a, L.ByteString) -- ^ Result and lazy 'L.ByteString'+ -- written as its side-effect+putToLazyByteString = putToLazyByteStringWith+ (safeStrategy L.smallChunkSize L.defaultChunkSize) (\x -> (x, L.Empty))+++-- | Execute a 'Put' with a buffer-allocation strategy and a continuation. For+-- example, 'putToLazyByteString' is implemented as follows.+--+-- @+--putToLazyByteString = 'putToLazyByteStringWith'+-- ('safeStrategy' 'L.smallChunkSize' 'L.defaultChunkSize') (\x -> (x, L.empty))+-- @+--+{-# INLINE putToLazyByteStringWith #-}+putToLazyByteStringWith+ :: AllocationStrategy+ -- ^ Buffer allocation strategy to use+ -> (a -> (b, L.ByteString))+ -- ^ Continuation to use for computing the final result and the tail of+ -- its side-effect (the written bytes).+ -> Put a+ -- ^ 'Put' to execute+ -> (b, L.ByteString)+ -- ^ Resulting lazy 'L.ByteString'+putToLazyByteStringWith strategy k p =+ ciosToLazyByteString strategy k $ unsafeDupablePerformIO $+ buildStepToCIOS strategy (runPut p)+++ ------------------------------------------------------------------------------ -- ByteString insertion / controlling chunk boundaries ------------------------------------------------------------------------------@@ -552,10 +800,9 @@ | otherwise = k br -- | Copy the bytes from a 'BufferRange' into the output stream.-{-# INLINE bytesCopyStep #-}-bytesCopyStep :: BufferRange -- ^ Input 'BufferRange'.- -> BuildStep a -> BuildStep a-bytesCopyStep !(BufferRange ip0 ipe) k =+wrappedBytesCopyStep :: BufferRange -- ^ Input 'BufferRange'.+ -> BuildStep a -> BuildStep a+wrappedBytesCopyStep !(BufferRange ip0 ipe) k = go ip0 where go !ip !(BufferRange op ope)@@ -572,7 +819,6 @@ inpRemaining = ipe `minusPtr` ip - -- Strict ByteStrings ------------------------------------------------------------------------------ @@ -593,8 +839,7 @@ where step !bs@(S.PS _ _ len) !k br@(BufferRange !op _) | len <= maxCopySize = byteStringCopyStep bs k br- | otherwise =- return $! insertChunks op (fromIntegral len) (L.chunk bs) k+ | otherwise = return $ insertChunk op bs k -- | Construct a 'Builder' that copies the strict 'S.ByteString'. --@@ -608,9 +853,15 @@ {-# INLINE byteStringCopyStep #-} byteStringCopyStep :: S.ByteString -> BuildStep a -> BuildStep a-byteStringCopyStep (S.PS ifp ioff isize) !k0 =- bytesCopyStep (BufferRange ip ipe) k+byteStringCopyStep (S.PS ifp ioff isize) !k0 br0@(BufferRange op ope)+ -- Ensure that the common case is not recursive and therefore yields+ -- better code.+ | op' <= ope = do copyBytes op ip isize+ touchForeignPtr ifp+ k0 (BufferRange op' ope)+ | otherwise = do wrappedBytesCopyStep (BufferRange ip ipe) k br0 where+ op' = op `plusPtr` isize ip = unsafeForeignPtrToPtr ifp `plusPtr` ioff ipe = ip `plusPtr` isize k br = do touchForeignPtr ifp -- input consumed: OK to release here@@ -627,12 +878,36 @@ {-# INLINE byteStringInsert #-} byteStringInsert :: S.ByteString -> Builder byteStringInsert =- \bs -> builder $ step bs+ \bs -> builder $ \k (BufferRange op _) -> return $ insertChunk op bs k++-- Short bytestrings+------------------------------------------------------------------------------++-- | Construct a 'Builder' that copies the 'SH.ShortByteString'.+--+{-# INLINE shortByteString #-}+shortByteString :: Sh.ShortByteString -> Builder+shortByteString = \sbs -> builder $ shortByteStringCopyStep sbs++-- | Copy the bytes from a 'SH.ShortByteString' into the output stream.+{-# INLINE shortByteStringCopyStep #-}+shortByteStringCopyStep :: Sh.ShortByteString -- ^ Input 'SH.ShortByteString'.+ -> BuildStep a -> BuildStep a+shortByteStringCopyStep !sbs k =+ go 0 (Sh.length sbs) where- step !bs k !br@(BufferRange op _)- | S.null bs = k br- | otherwise =- return $ insertChunks op (fromIntegral $ S.length bs) (L.Chunk bs) k+ go !ip !ipe !(BufferRange op ope)+ | inpRemaining <= outRemaining = do+ Sh.copyToPtr sbs ip op inpRemaining+ let !br' = BufferRange (op `plusPtr` inpRemaining) ope+ k br'+ | otherwise = do+ Sh.copyToPtr sbs ip op outRemaining+ let !ip' = ip + outRemaining+ return $ bufferFull 1 ope (go ip' ipe)+ where+ outRemaining = ope `minusPtr` op+ inpRemaining = ipe - ip -- Lazy bytestrings@@ -655,23 +930,13 @@ lazyByteStringCopy = L.foldrChunks (\bs b -> byteStringCopy bs `mappend` b) mempty - -- | Construct a 'Builder' that inserts all chunks of the lazy 'L.ByteString' -- directly. -- {-# INLINE lazyByteStringInsert #-} lazyByteStringInsert :: L.ByteString -> Builder lazyByteStringInsert =- \lbs -> builder $ step lbs- where- step L.Empty k br = k br- step lbs k (BufferRange op _) = case go 0 id lbs of- (n, lbsC) -> return $ insertChunks op n lbsC k-- go !n lbsC L.Empty = (n, lbsC)- go !n lbsC (L.Chunk bs lbs) =- go (n + fromIntegral (S.length bs)) (lbsC . L.Chunk bs) lbs-+ L.foldrChunks (\bs b -> byteStringInsert bs `mappend` b) mempty -- | Create a 'Builder' denoting the same sequence of bytes as a strict -- 'S.ByteString'.@@ -703,15 +968,6 @@ maximalCopySize :: Int maximalCopySize = 2 * L.smallChunkSize --- LazyByteStringC: difference lists of lazy bytestrings------------------------------------------------------------- | Insert a 'LazyByteStringC' of the given size directly.-{-# INLINE lazyByteStringC #-}-lazyByteStringC :: Int64 -> LazyByteStringC -> Builder-lazyByteStringC n lbsC =- builder $ \k (BufferRange op _) -> return $ insertChunks op n lbsC k- ------------------------------------------------------------------------------ -- Builder execution ------------------------------------------------------------------------------@@ -726,11 +982,29 @@ -- are of size @bufSize@, and a buffer of size @n@ filled with @k@ bytes should -- be trimmed iff @trim k n@ is 'True'. data AllocationStrategy = AllocationStrategy- {-# UNPACK #-} !Int -- size of first buffer- {-# UNPACK #-} !Int -- size of successive buffers- (Int -> Int -> Bool) -- trim+ (Maybe (Buffer, Int) -> IO Buffer)+ {-# UNPACK #-} !Int+ (Int -> Int -> Bool) --- | Sanitize a buffer size; i.e., make it at least the size of a 'Int'.+-- | Create a custom allocation strategy. See the code for 'safeStrategy' and+-- 'untrimmedStrategy' for examples.+{-# INLINE customStrategy #-}+customStrategy+ :: (Maybe (Buffer, Int) -> IO Buffer)+ -- ^ Buffer allocation function. If 'Nothing' is given, then a new first+ -- buffer should be allocated. If @'Just' (oldBuf, minSize)@ is given,+ -- then a buffer with minimal size 'minSize' must be returned. The+ -- strategy may reuse the 'oldBuffer', if it can guarantee that this+ -- referentially transparent and 'oldBuffer' is large enough.+ -> Int+ -- ^ Default buffer size.+ -> (Int -> Int -> Bool)+ -- ^ A predicate @trim used allocated@ returning 'True', if the buffer+ -- should be trimmed before it is returned.+ -> AllocationStrategy+customStrategy = AllocationStrategy++-- | Sanitize a buffer size; i.e., make it at least the size of an 'Int'. {-# INLINE sanitize #-} sanitize :: Int -> Int sanitize = max (sizeOf (undefined :: Int))@@ -743,9 +1017,13 @@ -> Int -- ^ Size of successive buffers -> AllocationStrategy -- ^ An allocation strategy that does not trim any of the- -- filled buffers before converting it to a chunk.+ -- filled buffers before converting it to a chunk untrimmedStrategy firstSize bufSize =- AllocationStrategy (sanitize firstSize) (sanitize bufSize) (\_ _ -> False)+ AllocationStrategy nextBuffer (sanitize bufSize) (\_ _ -> False)+ where+ {-# INLINE nextBuffer #-}+ nextBuffer Nothing = newBuffer $ sanitize firstSize+ nextBuffer (Just (_, minSize)) = newBuffer minSize -- | Use this strategy for generating lazy 'L.ByteString's whose chunks are@@ -758,25 +1036,26 @@ -- ^ An allocation strategy that guarantees that at least half -- of the allocated memory is used for live data safeStrategy firstSize bufSize =- AllocationStrategy (sanitize firstSize) (sanitize bufSize)- (\used size -> 2*used < size)+ AllocationStrategy nextBuffer (sanitize bufSize) trim+ where+ trim used size = 2 * used < size+ {-# INLINE nextBuffer #-}+ nextBuffer Nothing = newBuffer $ sanitize firstSize+ nextBuffer (Just (_, minSize)) = newBuffer minSize --- | Execute a 'Builder' with custom execution parameters.+-- | /Heavy inlining./ Execute a 'Builder' with custom execution parameters. ----- This function is forced to be inlined to allow fusing with the allocation--- strategy despite its rather heavy code-size. We therefore recommend--- that you introduce a top-level function once you have fixed your strategy.--- This avoids unnecessary code duplication.--- For example, the default 'Builder' execution function 'toLazyByteString' is--- defined as follows.+-- This function is inlined despite its heavy code-size to allow fusing with+-- the allocation strategy. For example, the default 'Builder' execution+-- function 'toLazyByteString' is defined as follows. -- -- @--- {-# NOINLINE toLazyByteString #-}+-- {-\# NOINLINE toLazyByteString \#-} -- toLazyByteString =--- toLazyByteStringWith ('safeStrategy' 'L.smallChunkSize' 'L.defaultChunkSize') empty+-- toLazyByteStringWith ('safeStrategy' 'L.smallChunkSize' 'L.defaultChunkSize') L.empty -- @ ----- where @empty@ is the zero-length lazy 'L.ByteString'.+-- where @L.empty@ is the zero-length lazy 'L.ByteString'. -- -- In most cases, the parameters used by 'toLazyByteString' give good -- performance. A sub-performing case of 'toLazyByteString' is executing short@@ -784,11 +1063,11 @@ -- 4kb buffer and the trimming cost dominate the cost of executing the -- 'Builder'. You can avoid this problem using ----- >toLazyByteStringWith (safeStrategy 128 smallChunkSize) empty+-- >toLazyByteStringWith (safeStrategy 128 smallChunkSize) L.empty -- -- This reduces the allocation and trimming overhead, as all generated -- 'L.ByteString's fit into the first buffer and there is no trimming--- required, if more than 64 bytes are written.+-- required, if more than 64 bytes and less than 128 bytes are written. -- {-# INLINE toLazyByteStringWith #-} toLazyByteStringWith@@ -798,71 +1077,57 @@ -- ^ Lazy 'L.ByteString' to use as the tail of the generated lazy -- 'L.ByteString' -> Builder- -- ^ Builder to execute+ -- ^ 'Builder' to execute -> L.ByteString -- ^ Resulting lazy 'L.ByteString' toLazyByteStringWith strategy k b =- ciosToLazyByteString k $ unsafePerformIO $- buildStepToCIOS strategy (return . Finished) (runBuilder b)---- | A stream of non-empty chunks interleaved with 'IO'.-data ChunkIOStream a =- Finished a- | Yield1 {-# UNPACK #-} !S.ByteString (IO (ChunkIOStream a))- | YieldC {-# UNPACK #-} !Int64 LazyByteStringC (IO (ChunkIOStream a))--{-# INLINE ciosToLazyByteString #-}-ciosToLazyByteString :: L.ByteString -> ChunkIOStream () -> L.ByteString-ciosToLazyByteString k = go- where- go (Finished _) = k- go (Yield1 bs io) = L.Chunk bs $ unsafePerformIO (go <$> io)- go (YieldC _ lbsC io) = lbsC $ unsafePerformIO (go <$> io)+ ciosUnitToLazyByteString strategy k $ unsafeDupablePerformIO $+ buildStepToCIOS strategy (runBuilder b) +-- | Convert a 'BuildStep' to a 'ChunkIOStream' stream by executing it on+-- 'Buffer's allocated according to the given 'AllocationStrategy'. {-# INLINE buildStepToCIOS #-} buildStepToCIOS :: AllocationStrategy -- ^ Buffer allocation strategy to use- -> (a -> IO (ChunkIOStream b)) -- ^ Continuation stream constructor.- -> BuildStep a -- ^ 'Put' to execute- -> IO (ChunkIOStream b)-buildStepToCIOS (AllocationStrategy firstSize bufSize trim) k =- \step -> fillNew step firstSize+ -> BuildStep a -- ^ 'BuildStep' to execute+ -> IO (ChunkIOStream a)+buildStepToCIOS !(AllocationStrategy nextBuffer bufSize trim) =+ \step -> nextBuffer Nothing >>= fill step where- fillNew !step0 !size = do- S.mallocByteString size >>= fill step0+ fill !step !buf@(Buffer fpbuf br@(BufferRange _ pe)) = do+ res <- fillWithBuildStep step doneH fullH insertChunkH br+ touchForeignPtr fpbuf+ return res where- fill !step !fpbuf = do- res <- fillWithBuildStep step doneH fullH insertChunksH br- touchForeignPtr fpbuf- return res- where- op = unsafeForeignPtrToPtr fpbuf -- safe due to mkCIOS- pe = op `plusPtr` size- br = BufferRange op pe+ pbuf = unsafeForeignPtrToPtr fpbuf - doneH op' x = wrapChunk op' (const $ k x)+ doneH op' x = return $+ Finished (Buffer fpbuf (BufferRange op' pe)) x - fullH op' minSize nextStep =- wrapChunk op' (const $ fillNew nextStep (max minSize bufSize))+ fullH op' minSize nextStep =+ wrapChunk op' $ const $+ nextBuffer (Just (buf, max minSize bufSize)) >>= fill nextStep - insertChunksH op' n lbsC nextStep =- wrapChunk op' $ \isEmpty -> return $ YieldC n lbsC $- -- Checking for empty case avoids allocating 'n-1' empty- -- buffers for 'n' insertChunksH right after each other.- if isEmpty- then fill nextStep fpbuf- else fillNew nextStep bufSize+ insertChunkH op' bs nextStep =+ wrapChunk op' $ \isEmpty -> yield1 bs $+ -- Checking for empty case avoids allocating 'n-1' empty+ -- buffers for 'n' insertChunkH right after each other.+ if isEmpty+ then fill nextStep buf+ else do buf' <- nextBuffer (Just (buf, bufSize))+ fill nextStep buf' - -- Yield a chunk, trimming it if necesary- {-# INLINE wrapChunk #-}- wrapChunk !op' mkCIOS- | pe < op' = error $- "buildStepToCIOS: overwrite by " ++ show (op' `minusPtr` pe) ++ " bytes"- | chunkSize == 0 = mkCIOS True- | trim chunkSize size = do- bs <- S.create chunkSize $ \pbuf -> copyBytes pbuf op chunkSize- return $ Yield1 bs (mkCIOS False)- | otherwise =- return $ Yield1 (S.PS fpbuf 0 chunkSize) (mkCIOS False)- where- chunkSize = op' `minusPtr` op+ -- Wrap and yield a chunk, trimming it if necesary+ {-# INLINE wrapChunk #-}+ wrapChunk !op' mkCIOS+ | chunkSize == 0 = mkCIOS True+ | trim chunkSize size = do+ bs <- S.create chunkSize $ \pbuf' ->+ copyBytes pbuf' pbuf chunkSize+ -- FIXME: We could reuse the trimmed buffer here.+ return $ Yield1 bs (mkCIOS False)+ | otherwise =+ return $ Yield1 (S.PS fpbuf 0 chunkSize) (mkCIOS False)+ where+ chunkSize = op' `minusPtr` pbuf+ size = pe `minusPtr` pbuf
Data/ByteString/Builder/Prim.hs view
@@ -1,5 +1,8 @@ {-# LANGUAGE CPP, BangPatterns, ScopedTypeVariables #-} {-# OPTIONS_GHC -fno-warn-unused-imports #-}+#if __GLASGOW_HASKELL__ >= 701+{-# LANGUAGE Trustworthy #-}+#endif {- | Copyright : (c) 2010-2011 Simon Meier (c) 2010 Jasper van der Jeugt License : BSD3-style (see LICENSE)@@ -41,7 +44,7 @@ The first most common step is the concatenation of two 'Builder's. Internally, concatenation corresponds to function composition. (Note that 'Builder's can-be seen as difference-lists of buffer-filling functions; cf. +be seen as difference-lists of buffer-filling functions; cf. <http://hackage.haskell.org/cgi-bin/hackage-scripts/package/dlist>. ) Function composition is a fast /O(1)/ operation. However, we can use bounded primitives to remove some of these function compositions altogether, which is@@ -447,7 +450,6 @@ import Data.ByteString.Builder.Internal import Data.ByteString.Builder.Prim.Internal.UncheckedShifts-import Data.ByteString.Builder.Prim.Internal.Base16 (lowerTable, encode4_as_8) import qualified Data.ByteString as S import qualified Data.ByteString.Internal as S@@ -464,9 +466,12 @@ import Data.ByteString.Builder.Prim.ASCII #if MIN_VERSION_base(4,4,0)-import Foreign hiding (unsafePerformIO, unsafeForeignPtrToPtr)+#if MIN_VERSION_base(4,7,0)+import Foreign+#else+import Foreign hiding (unsafeForeignPtrToPtr)+#endif import Foreign.ForeignPtr.Unsafe (unsafeForeignPtrToPtr)-import System.IO.Unsafe (unsafePerformIO) #else import Foreign #endif@@ -537,18 +542,16 @@ -- {-# INLINE[1] primBounded #-} primBounded :: BoundedPrim a -> (a -> Builder)-primBounded w =- mkBuilder+primBounded w x =+ -- It is important to avoid recursive 'BuildStep's where possible, as+ -- their closure allocation is expensive. Using 'ensureFree' allows the+ -- 'step' to assume that at least 'sizeBound w' free space is available.+ ensureFree (I.sizeBound w) `mappend` builder step where- bound = I.sizeBound w- mkBuilder x = builder step- where- step k (BufferRange op ope)- | op `plusPtr` bound <= ope = do- op' <- runB w x op- let !br' = BufferRange op' ope- k br'- | otherwise = return $ bufferFull bound op (step k)+ step k (BufferRange op ope) = do+ op' <- runB w x op+ let !br' = BufferRange op' ope+ k br' {-# RULES @@ -585,23 +588,19 @@ -- because it moves several variables out of the inner loop. {-# INLINE primMapListBounded #-} primMapListBounded :: BoundedPrim a -> [a] -> Builder-primMapListBounded w =- makeBuilder+primMapListBounded w xs0 =+ builder $ step xs0 where- bound = I.sizeBound w- makeBuilder xs0 = builder $ step xs0+ step xs1 k (BufferRange op0 ope0) =+ go xs1 op0 where- step xs1 k !(BufferRange op0 ope0) = go xs1 op0- where- go [] !op = do- let !br' = BufferRange op ope0- k br'+ go [] !op = k (BufferRange op ope0)+ go xs@(x':xs') !op+ | op `plusPtr` bound <= ope0 = runB w x' op >>= go xs'+ | otherwise =+ return $ bufferFull bound op (step xs k) - go xs@(x':xs') !op- | op `plusPtr` bound <= ope0 = do- !op' <- runB w x' op- go xs' op'- | otherwise = return $ bufferFull bound op (step xs k)+ bound = I.sizeBound w -- TODO: Add 'foldMap/encodeWith' its variants -- TODO: Ensure rewriting 'primBounded w . f = primBounded (w #. f)'@@ -610,27 +609,21 @@ -- using a 'BoundedPrim' for each sequence element. {-# INLINE primUnfoldrBounded #-} primUnfoldrBounded :: BoundedPrim b -> (a -> Maybe (b, a)) -> a -> Builder-primUnfoldrBounded w =- makeBuilder+primUnfoldrBounded w f x0 =+ builder $ fillWith x0 where- bound = I.sizeBound w- makeBuilder f x0 = builder $ step x0+ fillWith x k !(BufferRange op0 ope0) =+ go (f x) op0 where- step x1 !k = fill x1- where- fill x !(BufferRange pf0 pe0) = go (f x) pf0- where- go !Nothing !pf = do- let !br' = BufferRange pf pe0- k br'- go !(Just (y, x')) !pf- | pf `plusPtr` bound <= pe0 = do- !pf' <- runB w y pf- go (f x') pf'- | otherwise = return $ bufferFull bound pf $- \(BufferRange pfNew peNew) -> do- !pfNew' <- runB w y pfNew- fill x' (BufferRange pfNew' peNew)+ go !Nothing !op = do let !br' = BufferRange op ope0+ k br'+ go !(Just (y, x')) !op+ | op `plusPtr` bound <= ope0 = runB w y op >>= go (f x')+ | otherwise = return $ bufferFull bound op $+ \(BufferRange opNew opeNew) -> do+ !opNew' <- runB w y opNew+ fillWith x' k (BufferRange opNew' opeNew)+ bound = I.sizeBound w -- | Create a 'Builder' that encodes each 'Word8' of a strict 'S.ByteString' -- using a 'BoundedPrim'. For example, we can write a 'Builder' that filters@@ -697,7 +690,7 @@ -- | UTF-8 encode a 'Char'. {-# INLINE charUtf8 #-} charUtf8 :: BoundedPrim Char-charUtf8 = boundedEncoding 4 (encodeCharUtf8 f1 f2 f3 f4)+charUtf8 = boudedPrim 4 (encodeCharUtf8 f1 f2 f3 f4) where pokeN n io op = io op >> return (op `plusPtr` n) @@ -745,32 +738,4 @@ x4 = fromIntegral $ (x .&. 0x3F) + 0x80 in f4 x1 x2 x3 x4 ----------------------------------------------------------------------------------- Testing encodings--------------------------------------------------------------------------------{---- | /For testing use only./ Evaluate a 'FixedPrim' on a given value.-evalF :: FixedPrim a -> a -> [Word8]-evalF fe = S.unpack . S.unsafeCreate (I.size fe) . runF fe---- | /For testing use only./ Evaluate a 'BoundedPrim' on a given value.-evalB :: BoundedPrim a -> a -> [Word8]-evalB be x = S.unpack $ unsafePerformIO $- S.createAndTrim (I.sizeBound be) $ \op -> do- op' <- runB be x op- return (op' `minusPtr` op)---- | /For testing use only./ Show the result of a 'FixedPrim' of a given--- value as a 'String' by interpreting the resulting bytes as Unicode--- codepoints.-showF :: FixedPrim a -> a -> String-showF fe = map (chr . fromIntegral) . evalF fe---- | /For testing use only./ Show the result of a 'BoundedPrim' of a given--- value as a 'String' by interpreting the resulting bytes as Unicode--- codepoints.-showB :: BoundedPrim a -> a -> String-showB be = map (chr . fromIntegral) . evalB be--}
Data/ByteString/Builder/Prim/ASCII.hs view
@@ -1,4 +1,4 @@-{-# LANGUAGE ScopedTypeVariables, CPP, ForeignFunctionInterface #-}+{-# LANGUAGE ScopedTypeVariables, ForeignFunctionInterface #-} -- | Copyright : (c) 2010 Jasper Van der Jeugt -- (c) 2010 - 2011 Simon Meier -- License : BSD3-style (see LICENSE)@@ -108,7 +108,7 @@ {-# INLINE encodeIntDecimal #-} encodeIntDecimal :: Integral a => Int -> BoundedPrim a-encodeIntDecimal bound = boundedEncoding bound $ c_int_dec . fromIntegral+encodeIntDecimal bound = boudedPrim bound $ c_int_dec . fromIntegral -- | Decimal encoding of an 'Int8'. {-# INLINE int8Dec #-}@@ -129,7 +129,7 @@ -- | Decimal encoding of an 'Int64'. {-# INLINE int64Dec #-} int64Dec :: BoundedPrim Int64-int64Dec = boundedEncoding 20 $ c_long_long_int_dec . fromIntegral+int64Dec = boudedPrim 20 $ c_long_long_int_dec . fromIntegral -- | Decimal encoding of an 'Int'. {-# INLINE intDec #-}@@ -150,7 +150,7 @@ {-# INLINE encodeWordDecimal #-} encodeWordDecimal :: Integral a => Int -> BoundedPrim a-encodeWordDecimal bound = boundedEncoding bound $ c_uint_dec . fromIntegral+encodeWordDecimal bound = boudedPrim bound $ c_uint_dec . fromIntegral -- | Decimal encoding of a 'Word8'. {-# INLINE word8Dec #-}@@ -170,7 +170,7 @@ -- | Decimal encoding of a 'Word64'. {-# INLINE word64Dec #-} word64Dec :: BoundedPrim Word64-word64Dec = boundedEncoding 20 $ c_long_long_uint_dec . fromIntegral+word64Dec = boudedPrim 20 $ c_long_long_uint_dec . fromIntegral -- | Decimal encoding of a 'Word'. {-# INLINE wordDec #-}@@ -195,7 +195,7 @@ {-# INLINE encodeWordHex #-} encodeWordHex :: forall a. (Storable a, Integral a) => BoundedPrim a encodeWordHex =- boundedEncoding (2 * sizeOf (undefined :: a)) $ c_uint_hex . fromIntegral+ boudedPrim (2 * sizeOf (undefined :: a)) $ c_uint_hex . fromIntegral -- | Hexadecimal encoding of a 'Word8'. {-# INLINE word8Hex #-}@@ -215,7 +215,7 @@ -- | Hexadecimal encoding of a 'Word64'. {-# INLINE word64Hex #-} word64Hex :: BoundedPrim Word64-word64Hex = boundedEncoding 16 $ c_long_long_uint_hex . fromIntegral+word64Hex = boudedPrim 16 $ c_long_long_uint_hex . fromIntegral -- | Hexadecimal encoding of a 'Word'. {-# INLINE wordHex #-}@@ -231,7 +231,7 @@ -- | Encode a 'Word8' using 2 nibbles (hexadecimal digits). {-# INLINE word8HexFixed #-} word8HexFixed :: FixedPrim Word8-word8HexFixed = fixedEncoding 2 $+word8HexFixed = fixedPrim 2 $ \x op -> poke (castPtr op) =<< encode8_as_16h lowerTable x -- | Encode a 'Word16' using 4 nibbles.
Data/ByteString/Builder/Prim/Binary.hs view
@@ -83,7 +83,7 @@ #ifdef WORD_BIGENDIAN word16BE = word16Host #else-word16BE = fixedEncoding 2 $ \w p -> do+word16BE = fixedPrim 2 $ \w p -> do poke p (fromIntegral (shiftr_w16 w 8) :: Word8) poke (p `plusPtr` 1) (fromIntegral (w) :: Word8) #endif@@ -92,7 +92,7 @@ {-# INLINE word16LE #-} word16LE :: FixedPrim Word16 #ifdef WORD_BIGENDIAN-word16LE = fixedEncoding 2 $ \w p -> do+word16LE = fixedPrim 2 $ \w p -> do poke p (fromIntegral (w) :: Word8) poke (p `plusPtr` 1) (fromIntegral (shiftr_w16 w 8) :: Word8) #else@@ -105,7 +105,7 @@ #ifdef WORD_BIGENDIAN word32BE = word32Host #else-word32BE = fixedEncoding 4 $ \w p -> do+word32BE = fixedPrim 4 $ \w p -> do poke p (fromIntegral (shiftr_w32 w 24) :: Word8) poke (p `plusPtr` 1) (fromIntegral (shiftr_w32 w 16) :: Word8) poke (p `plusPtr` 2) (fromIntegral (shiftr_w32 w 8) :: Word8)@@ -116,7 +116,7 @@ {-# INLINE word32LE #-} word32LE :: FixedPrim Word32 #ifdef WORD_BIGENDIAN-word32LE = fixedEncoding 4 $ \w p -> do+word32LE = fixedPrim 4 $ \w p -> do poke p (fromIntegral (w) :: Word8) poke (p `plusPtr` 1) (fromIntegral (shiftr_w32 w 8) :: Word8) poke (p `plusPtr` 2) (fromIntegral (shiftr_w32 w 16) :: Word8)@@ -126,7 +126,7 @@ #endif -- on a little endian machine:--- word32LE w32 = fixedEncoding 4 (\w p -> poke (castPtr p) w32)+-- word32LE w32 = fixedPrim 4 (\w p -> poke (castPtr p) w32) -- | Encoding 'Word64's in big endian format. {-# INLINE word64BE #-}@@ -140,7 +140,7 @@ -- Word32, and write that -- word64BE =- fixedEncoding 8 $ \w p -> do+ fixedPrim 8 $ \w p -> do let a = fromIntegral (shiftr_w64 w 32) :: Word32 b = fromIntegral w :: Word32 poke p (fromIntegral (shiftr_w32 a 24) :: Word8)@@ -152,7 +152,7 @@ poke (p `plusPtr` 6) (fromIntegral (shiftr_w32 b 8) :: Word8) poke (p `plusPtr` 7) (fromIntegral (b) :: Word8) #else-word64BE = fixedEncoding 8 $ \w p -> do+word64BE = fixedPrim 8 $ \w p -> do poke p (fromIntegral (shiftr_w64 w 56) :: Word8) poke (p `plusPtr` 1) (fromIntegral (shiftr_w64 w 48) :: Word8) poke (p `plusPtr` 2) (fromIntegral (shiftr_w64 w 40) :: Word8)@@ -170,7 +170,7 @@ #ifdef WORD_BIGENDIAN #if WORD_SIZE_IN_BITS < 64 word64LE =- fixedEncoding 8 $ \w p -> do+ fixedPrim 8 $ \w p -> do let b = fromIntegral (shiftr_w64 w 32) :: Word32 a = fromIntegral w :: Word32 poke (p) (fromIntegral (a) :: Word8)@@ -182,7 +182,7 @@ poke (p `plusPtr` 6) (fromIntegral (shiftr_w32 b 16) :: Word8) poke (p `plusPtr` 7) (fromIntegral (shiftr_w32 b 24) :: Word8) #else-word64LE = fixedEncoding 8 $ \w p -> do+word64LE = fixedPrim 8 $ \w p -> do poke p (fromIntegral (w) :: Word8) poke (p `plusPtr` 1) (fromIntegral (shiftr_w64 w 8) :: Word8) poke (p `plusPtr` 2) (fromIntegral (shiftr_w64 w 16) :: Word8)
− Data/ByteString/Builder/Prim/Extra.hs
@@ -1,890 +0,0 @@-{-# LANGUAGE CPP, BangPatterns, ScopedTypeVariables #-}-{-# OPTIONS_GHC -fno-warn-unused-imports #-}-{-# OPTIONS_HADDOCK hide #-}-{- | Copyright : (c) 2010-2011 Simon Meier-License : BSD3-style (see LICENSE)--Maintainer : Simon Meier <iridcode@gmail.com>-Stability : experimental-Portability : GHC--An /encoding/ is a conversion function of Haskell values to sequences of bytes.-A /fixed(-size) encoding/ is an encoding that always results in sequence of bytes- of a pre-determined, fixed length.-An example for a fixed encoding is the big-endian encoding of a 'Word64',- which always results in exactly 8 bytes.-A /bounded(-size) encoding/ is an encoding that always results in sequence- of bytes that is no larger than a pre-determined bound.-An example for a bounded encoding is the UTF-8 encoding of a 'Char',- which results always in less or equal to 4 bytes.-Note that every fixed encoding is also a bounded encoding.-We explicitly identify fixed encodings because they allow some optimizations- that are impossible with bounded encodings.-In the following,- we first motivate the use of bounded encodings- and then give examples of optimizations- that are only possible with fixed encodings.--Typicall, encodings are implemented efficiently by allocating a buffer- (a mutable array of bytes)- and repeatedly executing the following two steps:- (1) writing to the buffer until it is full and- (2) handing over the filled part to the consumer of the encoded value.-Step (1) is where bounded encodings are used.-We must use a bounded encoding,- as we must check that there is enough free space- /before/ actually writing to the buffer.--In term of expressivity,- it would be sufficient to construct all encodings- from the single fixed encoding that encodes a 'Word8' as-is.-However,- this is not sufficient in terms of efficiency.-It results in unnecessary buffer-full checks and- it complicates the program-flow for writing to the buffer,- as buffer-full checks are interleaved with analyzing the value to be- encoded (e.g., think about the program-flow for UTF-8 encoding).-This has a significant effect on overall encoding performance,- as encoding primitive Haskell values such as 'Word8's or 'Char's- lies at the heart of every encoding implementation.--The 'BoundedPrim's provided by this module remove this performance problem.-Intuitively,- they consist of a tuple of the bound on the maximal number of bytes written- and the actual implementation of the encoding as- a function that modifies a mutable buffer.-Hence when executing a 'BoundedPrim',- the buffer-full check can be done once before the actual writing to the buffer.-The provided 'BoundedPrim's also take care to implement the- actual writing to the buffer efficiently.-Moreover, combinators are provided to construct new bounded encodings- from the provided ones.----The result of an encoding can be consumed efficiently,- if it is represented as a sequence of large enough- /chunks/ of consecutive memory (i.e., C @char@ arrays).-The precise meaning of /large enough/ is application dependent.-Typically, an average chunk size between 4kb and 32kb is suitable- for writing the result to disk or sending it over the network.-We desire large enough chunk sizes because each chunk boundary- incurs extra work that we must be able to amortize.---The need for fixed-size encodings arises when considering- the efficient implementation of encodings that require the encoding of a- value to be prefixed with the size of the resulting sequence of bytes.-An efficient implementation avoids unnecessary buffer-We can implement this efficiently as follows.-We first reserve the space for the encoding of the size.-Then, we encode the value.-Finally, we encode the size of the resulting sequence of bytes into- the reserved space.-For this to work--This works only if the encoding resulting size fits--by first, reserving the space for the encoding- of the size, then performing the--For efficiency,- we want to avoid unnecessary copying.---For example, the HTTP/1.0 requires the size of the body to be given in- the Content-Length field.--chunked-transfer encoding requires each chunk to- be prefixed with the hexadecimal encoding of the chunk size.----}--{---------- A /bounded encoding/ is an encoding that never results in a sequence--- longer than some fixed number of bytes. This number of bytes must be--- independent of the value being encoded. Typical examples of bounded--- encodings are the big-endian encoding of a 'Word64', which results always--- in exactly 8 bytes, or the UTF-8 encoding of a 'Char', which results always--- in less or equal to 4 bytes.------ Typically, encodings are implemented efficiently by allocating a buffer (an--- array of bytes) and repeatedly executing the following two steps: (1)--- writing to the buffer until it is full and (2) handing over the filled part--- to the consumer of the encoded value. Step (1) is where bounded encodings--- are used. We must use a bounded encoding, as we must check that there is--- enough free space /before/ actually writing to the buffer.------ In term of expressivity, it would be sufficient to construct all encodings--- from the single bounded encoding that encodes a 'Word8' as-is. However,--- this is not sufficient in terms of efficiency. It results in unnecessary--- buffer-full checks and it complicates the program-flow for writing to the--- buffer, as buffer-full checks are interleaved with analyzing the value to be--- encoded (e.g., think about the program-flow for UTF-8 encoding). This has a--- significant effect on overall encoding performance, as encoding primitive--- Haskell values such as 'Word8's or 'Char's lies at the heart of every--- encoding implementation.------ The bounded 'Encoding's provided by this module remove this performance--- problem. Intuitively, they consist of a tuple of the bound on the maximal--- number of bytes written and the actual implementation of the encoding as a--- function that modifies a mutable buffer. Hence when executing a bounded--- 'Encoding', the buffer-full check can be done once before the actual writing--- to the buffer. The provided 'Encoding's also take care to implement the--- actual writing to the buffer efficiently. Moreover, combinators are--- provided to construct new bounded encodings from the provided ones.------ A typical example for using the combinators is a bounded 'Encoding' that--- combines escaping the ' and \\ characters with UTF-8 encoding. More--- precisely, the escaping to be done is the one implemented by the following--- @escape@ function.------ > escape :: Char -> [Char]--- > escape '\'' = "\\'"--- > escape '\\' = "\\\\"--- > escape c = [c]------ The bounded 'Encoding' that combines this escaping with UTF-8 encoding is--- the following.------ > import Data.ByteString.Builder.Prim.Utf8 (char)--- >--- > {-# INLINE escapeChar #-}--- > escapeUtf8 :: BoundedPrim Char--- > escapeUtf8 =--- > encodeIf ('\'' ==) (char <#> char #. const ('\\','\'')) $--- > encodeIf ('\\' ==) (char <#> char #. const ('\\','\\')) $--- > char------ The definition of 'escapeUtf8' is more complicated than 'escape', because--- the combinators ('encodeIf', 'encodePair', '#.', and 'char') used in--- 'escapeChar' compute both the bound on the maximal number of bytes written--- (8 for 'escapeUtf8') as well as the low-level buffer manipulation required--- to implement the encoding. Bounded 'Encoding's should always be inlined.--- Otherwise, the compiler cannot compute the bound on the maximal number of--- bytes written at compile-time. Without inlinining, it would also fail to--- optimize the constant encoding of the escape characters in the above--- example. Functions that execute bounded 'Encoding's also perform--- suboptimally, if the definition of the bounded 'Encoding' is not inlined.--- Therefore we add an 'INLINE' pragma to 'escapeUtf8'.------ Currently, the only library that executes bounded 'Encoding's is the--- 'bytestring' library (<http://hackage.haskell.org/package/bytestring>). It--- uses bounded 'Encoding's to implement most of its lazy bytestring builders.--- Executing a bounded encoding should be done using the corresponding--- functions in the lazy bytestring builder 'Extras' module.------ TODO: Merge with explanation/example below------ Bounded 'E.Encoding's abstract encodings of Haskell values that can be implemented by--- writing a bounded-size sequence of bytes directly to memory. They are--- lifted to conversions from Haskell values to 'Builder's by wrapping them--- with a bound-check. The compiler can implement this bound-check very--- efficiently (i.e, a single comparison of the difference of two pointers to a--- constant), because the bound of a 'E.Encoding' is always independent of the--- value being encoded and, in most cases, a literal constant.------ 'E.Encoding's are the primary means for defining conversion functions from--- primitive Haskell values to 'Builder's. Most 'Builder' constructors--- provided by this library are implemented that way.--- 'E.Encoding's are also used to construct conversions that exploit the internal--- representation of data-structures.------ For example, 'encodeByteStringWith' works directly on the underlying byte--- array and uses some tricks to reduce the number of variables in its inner--- loop. Its efficiency is exploited for implementing the @filter@ and @map@--- functions in "Data.ByteString.Lazy" as------ > import qualified Data.ByteString.Builder.Prim as P--- >--- > filter :: (Word8 -> Bool) -> ByteString -> ByteString--- > filter p = toLazyByteString . encodeLazyByteStringWithB write--- > where--- > write = P.condB p P.word8 P.emptyB--- >--- > map :: (Word8 -> Word8) -> ByteString -> ByteString--- > map f = toLazyByteString . encodeLazyByteStringWithB (E.word8 E.#. f)------ Compared to earlier versions of @filter@ and @map@ on lazy 'L.ByteString's,--- these versions use a more efficient inner loop and have the additional--- advantage that they always result in well-chunked 'L.ByteString's; i.e, they--- also perform automatic defragmentation.------ We can also use 'E.Encoding's to improve the efficiency of the following--- 'renderString' function from our UTF-8 CSV table encoding example in--- "Data.ByteString.Builder".------ > renderString :: String -> Builder--- > renderString cs = charUtf8 '"' <> foldMap escape cs <> charUtf8 '"'--- > where--- > escape '\\' = charUtf8 '\\' <> charUtf8 '\\'--- > escape '\"' = charUtf8 '\\' <> charUtf8 '\"'--- > escape c = charUtf8 c------ The idea is to save on 'mappend's by implementing a 'E.Encoding' that escapes--- characters and using 'encodeListWith', which implements writing a list of--- values with a tighter inner loop and no 'mappend'.------ > import Data.ByteString.Builder.Extra -- assume these--- > import Data.ByteString.Builder.Prim -- imports are present--- > ( BoundedPrim, encodeIf, (<#>), (#.) )--- > import Data.ByteString.Builder.Prim.Utf8 (char)--- >--- > renderString :: String -> Builder--- > renderString cs =--- > charUtf8 '"' <> encodeListWithB escapedUtf8 cs <> charUtf8 '"'--- > where--- > escapedUtf8 :: BoundedPrim Char--- > escapedUtf8 =--- > encodeIf (== '\\') (char <#> char #. const ('\\', '\\')) $--- > encodeIf (== '\"') (char <#> char #. const ('\\', '\"')) $--- > char------ This 'Builder' considers a buffer with less than 8 free bytes as full. As--- all functions are inlined, the compiler is able to optimize the constant--- 'E.Encoding's as two sequential 'poke's. Compared to the first implementation of--- 'renderString' this implementation is 1.7x faster.-----}-{--Internally, 'Builder's are buffer-fill operations that are-given a continuation buffer-fill operation and a buffer-range to be filled.-A 'Builder' first checks if the buffer-range is large enough. If that's-the case, the 'Builder' writes the sequences of bytes to the buffer and-calls its continuation. Otherwise, it returns a signal that it requires a-new buffer together with a continuation to be called on this new buffer.-Ignoring the rare case of a full buffer-range, the execution cost of a-'Builder' consists of three parts:-- 1. The time taken to read the parameters; i.e., the buffer-fill- operation to call after the 'Builder' is done and the buffer-range to- fill.-- 2. The time taken to check for the size of the buffer-range.-- 3. The time taken for the actual encoding.--We can reduce cost (1) by ensuring that fewer buffer-fill function calls are-required. We can reduce cost (2) by fusing buffer-size checks of sequential-writes. For example, when escaping a 'String' using 'renderString', it would-be sufficient to check before encoding a character that at least 8 bytes are-free. We can reduce cost (3) by implementing better primitive 'Builder's.-For example, 'renderCell' builds an intermediate list containing the decimal-representation of an 'Int'. Implementing a direct decimal encoding of 'Int's-to memory would be more efficient, as it requires fewer buffer-size checks-and less allocation. It is also a planned extension of this library.--The first two cost reductions are supported for user code through functions-in "Data.ByteString.Builder.Extra". There, we continue the above example-and drop the generation time to 0.8ms by implementing 'renderString' more-cleverly. The third reduction requires meddling with the internals of-'Builder's and is not recomended in code outside of this library. However,-patches to this library are very welcome.--}-module Data.ByteString.Builder.Prim.Extra (-- -- * Base-128, variable-length binary encodings- {- |-There are many options for implementing a base-128 (i.e, 7-bit),-variable-length encoding. The encoding implemented here is the one used by-Google's protocol buffer library-<http://code.google.com/apis/protocolbuffers/docs/encoding.html#varints>. This-encoding can be implemented efficiently and provides the desired property that-small positive integers result in short sequences of bytes. It is intended to-be used for the new default binary serialization format of the differently-sized 'Word' types. It works as follows.--The most-significant bit (MSB) of each output byte indicates whether-there is a following byte (MSB set to 1) or it is the last byte (MSB set to 0).-The remaining 7-bits are used to encode the input starting with the least-significant 7-bit group of the input (i.e., a little-endian ordering of the-7-bit groups is used).--For example, the value @1 :: Int@ is encoded as @[0x01]@. The value-@128 :: Int@, whose binary representation is @1000 0000@, is encoded as-@[0x80, 0x01]@; i.e., the first byte has its MSB set and the least significant-7-bit group is @000 0000@, the second byte has its MSB not set (it is the last-byte) and its 7-bit group is @000 0001@.--}- word8Var- , word16Var- , word32Var- , word64Var- , wordVar--{- |-The following encodings work by casting the signed integer to the equally sized-unsigned integer. This works well for positive integers, but for negative-integers it always results in the longest possible sequence of bytes,-as their MSB is (by definition) always set.--}-- , int8Var- , int16Var- , int32Var- , int64Var- , intVar--{- |-Positive and negative integers of small magnitude can be encoded compactly- using the so-called ZigZag encoding- (<http://code.google.com/apis/protocolbuffers/docs/encoding.html#types>).-The /ZigZag encoding/ uses- even numbers to encode the postive integers and- odd numbers to encode the negative integers.-For example,- @0@ is encoded as @0@, @-1@ as @1@, @1@ as @2@, @-2@ as @3@, @2@ as @4@, and- so on.-Its efficient implementation uses some bit-level magic.-For example--@-zigZag32 :: 'Int32' -> 'Word32'-zigZag32 n = fromIntegral ((n \`shiftL\` 1) \`xor\` (n \`shiftR\` 31))-@--Note that the 'shiftR' is an arithmetic shift that performs sign extension.-The ZigZag encoding essentially swaps the LSB with the MSB and additionally-inverts all bits if the MSB is set.--The following encodings implement the combintion of ZigZag encoding- together with the above base-128, variable length encodings.-They are intended to become the the new default binary serialization format of- the differently sized 'Int' types.--}- , int8VarSigned- , int16VarSigned- , int32VarSigned- , int64VarSigned- , intVarSigned--- -- * Chunked / size-prefixed encodings-{- |-Some encodings like ASN.1 BER <http://en.wikipedia.org/wiki/Basic_Encoding_Rules>-or Google's protocol buffers <http://code.google.com/p/protobuf/> require-encoded data to be prefixed with its length. The simple method to achieve this-is to encode the data first into a separate buffer, compute the length of the-encoded data, write it to the current output buffer, and append the separate-buffers. The drawback of this method is that it requires a ...--}- , size- , sizeBound- -- , withSizeFB- -- , withSizeBB- , encodeWithSize-- , encodeChunked-- , wordVarFixedBound- , wordHexFixedBound- , wordDecFixedBound-- , word64VarFixedBound- , word64HexFixedBound- , word64DecFixedBound-- ) where--import Data.ByteString.Builder.Internal-import Data.ByteString.Builder.Prim.Internal.UncheckedShifts-import Data.ByteString.Builder.Prim.Internal.Base16 (lowerTable, encode4_as_8)--import qualified Data.ByteString as S-import qualified Data.ByteString.Internal as S-import qualified Data.ByteString.Lazy.Internal as L--import Data.Monoid-import Data.List (unfoldr) -- HADDOCK ONLY-import Data.Char (chr, ord)-import Control.Monad ((<=<), unless)--import Data.ByteString.Builder.Prim.Internal hiding (size, sizeBound)-import qualified Data.ByteString.Builder.Prim.Internal as I (size, sizeBound)-import Data.ByteString.Builder.Prim.Binary-import Data.ByteString.Builder.Prim.ASCII-import Data.ByteString.Builder.Prim--import Foreign----------------------------------------------------------------------------------- Adapting 'size' for the public interface.----------------------------------------------------------------------------------- | The size of the sequence of bytes generated by this 'FixedPrim'.-size :: FixedPrim a -> Word-size = fromIntegral . I.size---- | The bound on the size of the sequence of bytes generated by this--- 'BoundedPrim'.-sizeBound :: BoundedPrim a -> Word-sizeBound = fromIntegral . I.sizeBound------------------------------------------------------------------------------------ Base-128 Variable-Length Encodings---------------------------------------------------------------------------------{-# INLINE encodeBase128 #-}-encodeBase128- :: forall a b. (Integral a, Bits a, Storable b, Integral b, Num b)- => (a -> Int -> a) -> BoundedPrim b-encodeBase128 shiftr =- -- We add 6 because we require the result of (`div` 7) to be rounded up.- boundedEncoding ((8 * sizeOf (undefined :: b) + 6) `div` 7) (io . fromIntegral)- where- io !x !op- | x' == 0 = do poke8 (x .&. 0x7f)- return $! op `plusPtr` 1- | otherwise = do poke8 ((x .&. 0x7f) .|. 0x80)- io x' (op `plusPtr` 1)- where- x' = x `shiftr` 7- poke8 = poke op . fromIntegral---- | Base-128, variable length encoding of a 'Word8'.-{-# INLINE word8Var #-}-word8Var :: BoundedPrim Word8-word8Var = encodeBase128 shiftr_w---- | Base-128, variable length encoding of a 'Word16'.-{-# INLINE word16Var #-}-word16Var :: BoundedPrim Word16-word16Var = encodeBase128 shiftr_w---- | Base-128, variable length encoding of a 'Word32'.-{-# INLINE word32Var #-}-word32Var :: BoundedPrim Word32-word32Var = encodeBase128 shiftr_w32---- | Base-128, variable length encoding of a 'Word64'.-{-# INLINE word64Var #-}-word64Var :: BoundedPrim Word64-word64Var = encodeBase128 shiftr_w64---- | Base-128, variable length encoding of a 'Word'.-{-# INLINE wordVar #-}-wordVar :: BoundedPrim Word-wordVar = encodeBase128 shiftr_w----- | Base-128, variable length encoding of an 'Int8'.--- Use 'int8VarSigned' for encoding negative numbers.-{-# INLINE int8Var #-}-int8Var :: BoundedPrim Int8-int8Var = fromIntegral >$< word8Var---- | Base-128, variable length encoding of an 'Int16'.--- Use 'int16VarSigned' for encoding negative numbers.-{-# INLINE int16Var #-}-int16Var :: BoundedPrim Int16-int16Var = fromIntegral >$< word16Var---- | Base-128, variable length encoding of an 'Int32'.--- Use 'int32VarSigned' for encoding negative numbers.-{-# INLINE int32Var #-}-int32Var :: BoundedPrim Int32-int32Var = fromIntegral >$< word32Var---- | Base-128, variable length encoding of an 'Int64'.--- Use 'int64VarSigned' for encoding negative numbers.-{-# INLINE int64Var #-}-int64Var :: BoundedPrim Int64-int64Var = fromIntegral >$< word64Var---- | Base-128, variable length encoding of an 'Int'.--- Use 'intVarSigned' for encoding negative numbers.-{-# INLINE intVar #-}-intVar :: BoundedPrim Int-intVar = fromIntegral >$< wordVar--{-# INLINE zigZag #-}-zigZag :: (Storable a, Bits a) => a -> a-zigZag x = (x `shiftL` 1) `xor` (x `shiftR` (8 * sizeOf x - 1))---- | Base-128, variable length, ZigZag encoding of an 'Int'.-{-# INLINE int8VarSigned #-}-int8VarSigned :: BoundedPrim Int8-int8VarSigned = zigZag >$< int8Var---- | Base-128, variable length, ZigZag encoding of an 'Int16'.-{-# INLINE int16VarSigned #-}-int16VarSigned :: BoundedPrim Int16-int16VarSigned = zigZag >$< int16Var---- | Base-128, variable length, ZigZag encoding of an 'Int32'.-{-# INLINE int32VarSigned #-}-int32VarSigned :: BoundedPrim Int32-int32VarSigned = zigZag >$< int32Var---- | Base-128, variable length, ZigZag encoding of an 'Int64'.-{-# INLINE int64VarSigned #-}-int64VarSigned :: BoundedPrim Int64-int64VarSigned = zigZag >$< int64Var---- | Base-128, variable length, ZigZag encoding of an 'Int'.-{-# INLINE intVarSigned #-}-intVarSigned :: BoundedPrim Int-intVarSigned = zigZag >$< intVar------------------------------------------------------------------------------------- Chunked Encoding Transformer----------------------------------------------------------------------------------- | /Heavy inlining./-{-# INLINE encodeChunked #-}-encodeChunked- :: Word -- ^ Minimal free-size- -> (Word64 -> FixedPrim Word64)- -- ^ Given a sizeBound on the maximal encodable size this function must return- -- a fixed-size encoding for encoding all smaller size.- -> (BoundedPrim Word64)- -- ^ An encoding for terminating a chunk of the given size.- -> Builder- -- ^ Inner Builder to transform- -> Builder- -- ^ 'Put' with chunked encoding.-encodeChunked minFree mkBeforeFE afterBE =- fromPut . putChunked minFree mkBeforeFE afterBE . putBuilder---- | /Heavy inlining./-{-# INLINE putChunked #-}-putChunked- :: Word -- ^ Minimal free-size- -> (Word64 -> FixedPrim Word64)- -- ^ Given a sizeBound on the maximal encodable size this function must return- -- a fixed-size encoding for encoding all smaller size.- -> (BoundedPrim Word64)- -- ^ Encoding a directly inserted chunk.- -> Put a- -- ^ Inner Put to transform- -> Put a- -- ^ 'Put' with chunked encoding.-putChunked minFree0 mkBeforeFE afterBE p =- put encodingStep- where- minFree, reservedAfter, maxReserved, minBufferSize :: Int- minFree = fromIntegral $ max 1 minFree0 -- sanitize and convert to Int-- -- reserved space must be computed for maximum buffer size to cover for all- -- sizes of the actually returned buffer.- reservedAfter = I.sizeBound afterBE- maxReserved = I.size (mkBeforeFE maxBound) + reservedAfter- minBufferSize = minFree + maxReserved-- encodingStep k =- fill (runPut p)- where- fill innerStep !(BufferRange op ope)- | outRemaining < minBufferSize =- return $! bufferFull minBufferSize op (fill innerStep)- | otherwise = do- fillWithBuildStep innerStep doneH fullH insertChunksH brInner- where- outRemaining = ope `minusPtr` op- beforeFE = mkBeforeFE $ fromIntegral outRemaining- reservedBefore = I.size beforeFE-- opInner = op `plusPtr` reservedBefore- opeInner = ope `plusPtr` (-reservedAfter)- brInner = BufferRange opInner opeInner-- wrapChunk :: Ptr Word8 -> IO (Ptr Word8)- wrapChunk !opInner'- | innerSize == 0 = return op -- no data written => no chunk to wrap- | otherwise = do- runF beforeFE innerSize op- runB afterBE innerSize opInner'- where- innerSize = fromIntegral $ opInner' `minusPtr` opInner-- doneH opInner' x = do- op' <- wrapChunk opInner'- let !br' = BufferRange op' ope- k x br'-- fullH opInner' minSize nextInnerStep = do- op' <- wrapChunk opInner'- return $! bufferFull- (max minBufferSize (minSize + maxReserved))- op'- (fill nextInnerStep)-- insertChunksH opInner' n lbsC nextInnerStep- | n == 0 = do -- flush- op' <- wrapChunk opInner'- return $! insertChunks op' 0 id (fill nextInnerStep)-- | otherwise = do -- insert non-empty bytestring- op' <- wrapChunk opInner'- let !br' = BufferRange op' ope- runBuilderWith chunkB (fill nextInnerStep) br'- where- nU = fromIntegral n- chunkB =- primFixed (mkBeforeFE nU) nU `mappend`- lazyByteStringC n lbsC `mappend`- primBounded afterBE nU----- | /Heavy inlining./ Prefix a 'Builder' with the size of the--- sequence of bytes that it denotes.------ This function is optimized for streaming use. It tries to prefix the size--- without copying the output. This is achieved by reserving space for the--- maximum size to be encoded. This succeeds if the output is smaller than--- the current free buffer size, which is guaranteed to be at least @8kb@.------ If the output does not fit into the current free buffer size,--- the method falls back to encoding the data to a separate lazy bytestring,--- computing the size, and encoding the size before inserting the chunks of--- the separate lazy bytestring.-{-# INLINE encodeWithSize #-}-encodeWithSize- ::- Word- -- ^ Inner buffer-size.- -> (Word64 -> FixedPrim Word64)- -- ^ Given a bound on the maximal size to encode, this function must return- -- a fixed-size encoding for all smaller sizes.- -> Builder- -- ^ 'Put' to prefix with the length of its sequence of bytes.- -> Builder-encodeWithSize innerBufSize mkSizeFE =- fromPut . putWithSize innerBufSize mkSizeFE . putBuilder---- | Prefix a 'Put' with the size of its written data.-{-# INLINE putWithSize #-}-putWithSize- :: forall a.- Word- -- ^ Buffer-size for inner driver.- -> (Word64 -> FixedPrim Word64)- -- ^ Encoding the size for the fallback case.- -> Put a- -- ^ 'Put' to prefix with the length of its sequence of bytes.- -> Put a-putWithSize innerBufSize mkSizeFE innerP =- put $ encodingStep- where- -- | The minimal free size is such that we can encode any size.- minFree = I.size $ mkSizeFE maxBound-- encodingStep :: (forall r. (a -> BuildStep r) -> BuildStep r)- encodingStep k =- fill (runPut innerP)- where- fill :: BuildStep a -> BufferRange -> IO (BuildSignal r)- fill innerStep !(BufferRange op ope)- | outRemaining < minFree =- return $! bufferFull minFree op (fill innerStep)- | otherwise = do- fillWithBuildStep innerStep doneH fullH insertChunksH brInner- where- outRemaining = ope `minusPtr` op- sizeFE = mkSizeFE $ fromIntegral outRemaining- reservedBefore = I.size sizeFE- reservedAfter = minFree - reservedBefore-- -- leave enough free space such that all sizes can be encodded.- startInner = op `plusPtr` reservedBefore- opeInner = ope `plusPtr` (negate reservedAfter)- brInner = BufferRange startInner opeInner-- fastPrefixSize :: Ptr Word8 -> IO (Ptr Word8)- fastPrefixSize !opInner'- | innerSize == 0 = do runB (toB $ mkSizeFE 0) 0 op- | otherwise = do runF (sizeFE) innerSize op- return opInner'- where- innerSize = fromIntegral $ opInner' `minusPtr` startInner-- slowPrefixSize :: Ptr Word8 -> Builder -> BuildStep a -> IO (BuildSignal r)- slowPrefixSize opInner' bInner nextStep = do- (x, chunks, payLenChunks) <- toLBS $ runBuilderWith bInner nextStep-- let -- length of payload data in current buffer- payLenCur = opInner' `minusPtr` startInner- -- length of whole payload- payLen = fromIntegral payLenCur + fromIntegral payLenChunks- -- encoder for payload length- sizeFE' = mkSizeFE payLen- -- start of payload in current buffer with the payload- -- length encoded before- startInner' = op `plusPtr` I.size sizeFE'-- -- move data in current buffer out of the way, if required- unless (startInner == startInner') $- moveBytes startInner' startInner payLenCur- -- encode payload length at start of the buffer- runF sizeFE' payLen op- -- TODO: If we were to change the CIOS definition such that it also- -- returns the last buffer for writing, we could also fill the- -- last buffer with 'k' and return the signal, once it is- -- filled, therefore avoiding unfilled space.- return $ insertChunks (startInner' `plusPtr` payLenCur)- payLenChunks- chunks- (k x)- where- toLBS = runCIOSWithLength <=<- buildStepToCIOSUntrimmedWith (fromIntegral innerBufSize)-- doneH :: Ptr Word8 -> a -> IO (BuildSignal r)- doneH opInner' x = do- op' <- fastPrefixSize opInner'- let !br' = BufferRange op' ope- k x br'-- fullH :: Ptr Word8 -> Int -> BuildStep a -> IO (BuildSignal r)- fullH opInner' minSize nextInnerStep =- slowPrefixSize opInner' (ensureFree minSize) nextInnerStep-- insertChunksH :: Ptr Word8 -> Int64 -> LazyByteStringC- -> BuildStep a -> IO (BuildSignal r)- insertChunksH opInner' n lbsC nextInnerStep =- slowPrefixSize opInner' (lazyByteStringC n lbsC) nextInnerStep----- | Run a 'ChunkIOStream' and gather its results and their length.-runCIOSWithLength :: ChunkIOStream a -> IO (a, LazyByteStringC, Int64)-runCIOSWithLength =- go 0 id- where- go !l lbsC (Finished x) = return (x, lbsC, l)- go !l lbsC (YieldC n lbsC' io) = io >>= go (l + n) (lbsC . lbsC')- go !l lbsC (Yield1 bs io) =- io >>= go (l + fromIntegral (S.length bs)) (lbsC . L.Chunk bs)---- | Run a 'BuildStep' using the untrimmed strategy.-buildStepToCIOSUntrimmedWith :: Int -> BuildStep a -> IO (ChunkIOStream a)-buildStepToCIOSUntrimmedWith bufSize =- buildStepToCIOS (untrimmedStrategy bufSize bufSize)- (return . Finished)---------------------------------------------------------------------------- Padded versions of encodings for streamed prefixing of output sizes-------------------------------------------------------------------------{-# INLINE appsUntilZero #-}-appsUntilZero :: (Eq a, Num a) => (a -> a) -> a -> Int-appsUntilZero f x0 =- count 0 x0- where- count !n 0 = n- count !n x = count (succ n) (f x)---{-# INLINE genericVarFixedBound #-}-genericVarFixedBound :: (Eq b, Show b, Bits b, Num a, Integral b)- => (b -> a -> b) -> b -> FixedPrim b-genericVarFixedBound shiftRight bound =- fixedEncoding n0 io- where- n0 = max 1 $ appsUntilZero (`shiftRight` 7) bound-- io !x0 !op- | x0 > bound = error err- | otherwise = loop 0 x0- where- err = "genericVarFixedBound: value " ++ show x0 ++ " > bound " ++ show bound- loop !n !x- | n0 <= n + 1 = do poke8 (x .&. 0x7f)- | otherwise = do poke8 ((x .&. 0x7f) .|. 0x80)- loop (n + 1) (x `shiftRight` 7)- where- poke8 = pokeElemOff op n . fromIntegral--{-# INLINE wordVarFixedBound #-}-wordVarFixedBound :: Word -> FixedPrim Word-wordVarFixedBound = genericVarFixedBound shiftr_w--{-# INLINE word64VarFixedBound #-}-word64VarFixedBound :: Word64 -> FixedPrim Word64-word64VarFixedBound = genericVarFixedBound shiftr_w64----- Somehow this function doesn't really make sense, as the bound must be--- greater when interpreted as an unsigned integer. These conversions and--- decisions should be left to the user.------{-# INLINE intVarFixed #-}---intVarFixed :: Size -> FixedPrim Size---intVarFixed bound = fromIntegral >$< wordVarFixed (fromIntegral bound)--{-# INLINE genHexFixedBound #-}-genHexFixedBound :: (Num a, Bits a, Integral a)- => (a -> Int -> a) -> Char -> a -> FixedPrim a-genHexFixedBound shiftr padding0 bound =- fixedEncoding n0 io- where- n0 = max 1 $ appsUntilZero (`shiftr` 4) bound-- padding = fromIntegral (ord padding0) :: Word8-- io !x0 !op0 =- loop (op0 `plusPtr` n0) x0- where- loop !op !x = do- let !op' = op `plusPtr` (-1)- poke op' =<< encode4_as_8 lowerTable (fromIntegral $ x .&. 0xf)- let !x' = x `shiftr` 4- unless (op' <= op0) $- if x' == 0- then pad (op' `plusPtr` (-1))- else loop op' x'-- pad !op- | op < op0 = return ()- | otherwise = poke op padding >> pad (op `plusPtr` (-1))---{-# INLINE wordHexFixedBound #-}-wordHexFixedBound :: Char -> Word -> FixedPrim Word-wordHexFixedBound = genHexFixedBound shiftr_w--{-# INLINE word64HexFixedBound #-}-word64HexFixedBound :: Char -> Word64 -> FixedPrim Word64-word64HexFixedBound = genHexFixedBound shiftr_w64---- | Note: Works only for positive numbers.-{-# INLINE genDecFixedBound #-}-genDecFixedBound :: (Num a, Bits a, Integral a)- => Char -> a -> FixedPrim a-genDecFixedBound padding0 bound =- fixedEncoding n0 io- where- n0 = max 1 $ appsUntilZero (`div` 10) bound-- padding = fromIntegral (ord padding0) :: Word8-- io !x0 !op0 =- loop (op0 `plusPtr` n0) x0- where- loop !op !x = do- let !op' = op `plusPtr` (-1)- !x' = x `div` 10- poke op' ((fromIntegral $ (x - x' * 10) + 48) :: Word8)- unless (op' <= op0) $- if x' == 0- then pad (op' `plusPtr` (-1))- else loop op' x'-- pad !op- | op < op0 = return ()- | otherwise = poke op padding >> pad (op `plusPtr` (-1))--{-# INLINE wordDecFixedBound #-}-wordDecFixedBound :: Char -> Word -> FixedPrim Word-wordDecFixedBound = genDecFixedBound--{-# INLINE word64DecFixedBound #-}-word64DecFixedBound :: Char -> Word64 -> FixedPrim Word64-word64DecFixedBound = genDecFixedBound-
Data/ByteString/Builder/Prim/Internal.hs view
@@ -1,4 +1,7 @@ {-# LANGUAGE ScopedTypeVariables, CPP, BangPatterns #-}+#if __GLASGOW_HASKELL__ >= 701+{-# LANGUAGE Unsafe #-}+#endif {-# OPTIONS_HADDOCK hide #-} -- | -- Copyright : 2010-2011 Simon Meier, 2010 Jasper van der Jeugt@@ -26,7 +29,7 @@ -- * Fixed-size builder primitives Size , FixedPrim- , fixedEncoding+ , fixedPrim , size , runF @@ -39,7 +42,7 @@ -- * Bounded-size builder primitives , BoundedPrim- , boundedEncoding+ , boudedPrim , sizeBound , runB @@ -145,30 +148,30 @@ -- | A builder primitive that always results in a sequence of bytes of a -- pre-determined, fixed size.-data FixedPrim a = FE {-# UNPACK #-} !Int (a -> Ptr Word8 -> IO ())+data FixedPrim a = FP {-# UNPACK #-} !Int (a -> Ptr Word8 -> IO ()) -fixedEncoding :: Int -> (a -> Ptr Word8 -> IO ()) -> FixedPrim a-fixedEncoding = FE+fixedPrim :: Int -> (a -> Ptr Word8 -> IO ()) -> FixedPrim a+fixedPrim = FP -- | The size of the sequences of bytes generated by this 'FixedPrim'. {-# INLINE CONLIKE size #-} size :: FixedPrim a -> Int-size (FE l _) = l+size (FP l _) = l {-# INLINE CONLIKE runF #-} runF :: FixedPrim a -> a -> Ptr Word8 -> IO ()-runF (FE _ io) = io+runF (FP _ io) = io -- | The 'FixedPrim' that always results in the zero-length sequence. {-# INLINE CONLIKE emptyF #-} emptyF :: FixedPrim a-emptyF = FE 0 (\_ _ -> return ())+emptyF = FP 0 (\_ _ -> return ()) -- | Encode a pair by encoding its first component and then its second component. {-# INLINE CONLIKE pairF #-} pairF :: FixedPrim a -> FixedPrim b -> FixedPrim (a, b)-pairF (FE l1 io1) (FE l2 io2) =- FE (l1 + l2) (\(x1,x2) op -> io1 x1 op >> io2 x2 (op `plusPtr` l1))+pairF (FP l1 io1) (FP l2 io2) =+ FP (l1 + l2) (\(x1,x2) op -> io1 x1 op >> io2 x2 (op `plusPtr` l1)) -- | Change a primitives such that it first applies a function to the value -- to be encoded.@@ -181,12 +184,12 @@ -- >contramapF f . contramapF g = contramapF (g . f) {-# INLINE CONLIKE contramapF #-} contramapF :: (b -> a) -> FixedPrim a -> FixedPrim b-contramapF f (FE l io) = FE l (\x op -> io (f x) op)+contramapF f (FP l io) = FP l (\x op -> io (f x) op) -- | Convert a 'FixedPrim' to a 'BoundedPrim'. {-# INLINE CONLIKE toB #-} toB :: FixedPrim a -> BoundedPrim a-toB (FE l io) = BE l (\x op -> io x op >> (return $! op `plusPtr` l))+toB (FP l io) = BP l (\x op -> io x op >> (return $! op `plusPtr` l)) -- | Lift a 'FixedPrim' to a 'BoundedPrim'. {-# INLINE CONLIKE liftFixedToBounded #-}@@ -195,12 +198,12 @@ {-# INLINE CONLIKE storableToF #-} storableToF :: forall a. Storable a => FixedPrim a-storableToF = FE (sizeOf (undefined :: a)) (\x op -> poke (castPtr op) x)+storableToF = FP (sizeOf (undefined :: a)) (\x op -> poke (castPtr op) x) {- {-# INLINE CONLIKE liftIOF #-} liftIOF :: FixedPrim a -> FixedPrim (IO a)-liftIOF (FE l io) = FE l (\xWrapped op -> do x <- xWrapped; io x op)+liftIOF (FP l io) = FP l (\xWrapped op -> do x <- xWrapped; io x op) -} ------------------------------------------------------------------------------@@ -209,19 +212,19 @@ -- | A builder primitive that always results in sequence of bytes that is no longer -- than a pre-determined bound.-data BoundedPrim a = BE {-# UNPACK #-} !Int (a -> Ptr Word8 -> IO (Ptr Word8))+data BoundedPrim a = BP {-# UNPACK #-} !Int (a -> Ptr Word8 -> IO (Ptr Word8)) -- | The bound on the size of sequences of bytes generated by this 'BoundedPrim'. {-# INLINE CONLIKE sizeBound #-} sizeBound :: BoundedPrim a -> Int-sizeBound (BE b _) = b+sizeBound (BP b _) = b -boundedEncoding :: Int -> (a -> Ptr Word8 -> IO (Ptr Word8)) -> BoundedPrim a-boundedEncoding = BE+boudedPrim :: Int -> (a -> Ptr Word8 -> IO (Ptr Word8)) -> BoundedPrim a+boudedPrim = BP {-# INLINE CONLIKE runB #-} runB :: BoundedPrim a -> a -> Ptr Word8 -> IO (Ptr Word8)-runB (BE _ io) = io+runB (BP _ io) = io -- | Change a 'BoundedPrim' such that it first applies a function to the -- value to be encoded.@@ -234,18 +237,18 @@ -- >contramapB f . contramapB g = contramapB (g . f) {-# INLINE CONLIKE contramapB #-} contramapB :: (b -> a) -> BoundedPrim a -> BoundedPrim b-contramapB f (BE b io) = BE b (\x op -> io (f x) op)+contramapB f (BP b io) = BP b (\x op -> io (f x) op) -- | The 'BoundedPrim' that always results in the zero-length sequence. {-# INLINE CONLIKE emptyB #-} emptyB :: BoundedPrim a-emptyB = BE 0 (\_ op -> return op)+emptyB = BP 0 (\_ op -> return op) -- | Encode a pair by encoding its first component and then its second component. {-# INLINE CONLIKE pairB #-} pairB :: BoundedPrim a -> BoundedPrim b -> BoundedPrim (a, b)-pairB (BE b1 io1) (BE b2 io2) =- BE (b1 + b2) (\(x1,x2) op -> io1 x1 op >>= io2 x2)+pairB (BP b1 io1) (BP b2 io2) =+ BP (b1 + b2) (\(x1,x2) op -> io1 x1 op >>= io2 x2) -- | Encode an 'Either' value using the first 'BoundedPrim' for 'Left' -- values and the second 'BoundedPrim' for 'Right' values.@@ -260,8 +263,8 @@ -- @ {-# INLINE CONLIKE eitherB #-} eitherB :: BoundedPrim a -> BoundedPrim b -> BoundedPrim (Either a b)-eitherB (BE b1 io1) (BE b2 io2) =- BE (max b1 b2)+eitherB (BP b1 io1) (BP b2 io2) =+ BP (max b1 b2) (\x op -> case x of Left x1 -> io1 x1 op; Right x2 -> io2 x2 op) -- | Conditionally select a 'BoundedPrim'.@@ -275,87 +278,3 @@ condB :: (a -> Bool) -> BoundedPrim a -> BoundedPrim a -> BoundedPrim a condB p be1 be2 = contramapB (\x -> if p x then Left x else Right x) (eitherB be1 be2)---{--{-# INLINE withSizeFB #-}-withSizeFB :: (Word -> FixedPrim Word) -> BoundedPrim a -> BoundedPrim a-withSizeFB feSize (BE b io) =- BE (lSize + b)- (\x op0 -> do let !op1 = op0 `plusPtr` lSize- op2 <- io x op1- ioSize (fromIntegral $ op2 `minusPtr` op1) op0- return op2)- where- FE lSize ioSize = feSize (fromIntegral b)---{-# INLINE withSizeBB #-}-withSizeBB :: BoundedPrim Word -> BoundedPrim a -> BoundedPrim a-withSizeBB (BE bSize ioSize) (BE b io) =- BE (bSize + 2*b)- (\x op0 -> do let !opTmp = op0 `plusPtr` (bSize + b)- opTmp' <- io x opTmp- let !s = opTmp' `minusPtr` opTmp- op1 <- ioSize (fromIntegral s) op0- copyBytes op1 opTmp s- return $! op1 `plusPtr` s)--{-# INLINE CONLIKE liftIOB #-}-liftIOB :: BoundedPrim a -> BoundedPrim (IO a)-liftIOB (BE l io) = BE l (\xWrapped op -> do x <- xWrapped; io x op)--}----------------------------------------------------------------------------------- Builder primitives from 'ByteString's.---------------------------------------------------------------------------------{---- | A 'FixedPrim' that always results in the same byte sequence given as a--- strict 'S.ByteString'. We can use this primitive to insert fixed ...-{-# INLINE CONLIKE constByteStringF #-}-constByteStringF :: S.ByteString -> FixedPrim ()-constByteStringF bs =- FE len io- where- (S.PS fp off len) = bs- io _ op = do- copyBytes op (unsafeForeignPtrToPtr fp `plusPtr` off) len- touchForeignPtr fp---- | Encode a fixed-length prefix of a strict 'S.ByteString' as-is. We can use--- this function to-{-# INLINE byteStringPrefixB #-}-byteStringTakeB :: Int -- ^ Length of the prefix. It should be smaller than- -- 100 bytes, as otherwise- -> BoundedPrim S.ByteString-byteStringTakeB n0 =- BE n io- where- n = max 0 n0 -- sanitize-- io (S.PS fp off len) op = do- let !s = min len n- copyBytes op (unsafeForeignPtrToPtr fp `plusPtr` off) s- touchForeignPtr fp- return $! op `plusPtr` s--}--{---httpChunkedTransfer :: Builder -> Builder-httpChunkedTransfer =- encodeChunked 32 (word64HexFixedBound '0')- ((\_ -> ('\r',('\n',('\r','\n')))) >$< char8x4)- where- char8x4 = toB (char8 >*< char8 >*< char8 >*< char8)----chunked :: Builder -> Builder-chunked = encodeChunked 16 word64VarFixedBound emptyB---}---
Data/ByteString/Builder/Prim/Internal/Base16.hs view
@@ -17,26 +17,27 @@ -- module Data.ByteString.Builder.Prim.Internal.Base16 ( EncodingTable- -- , upperTable , lowerTable- , encode4_as_8 , encode8_as_16h- -- , encode8_as_8_8 ) where import qualified Data.ByteString as S import qualified Data.ByteString.Internal as S #if MIN_VERSION_base(4,4,0)+#if MIN_VERSION_base(4,7,0)+import Foreign+#else import Foreign hiding (unsafePerformIO, unsafeForeignPtrToPtr)+#endif import Foreign.ForeignPtr.Unsafe (unsafeForeignPtrToPtr) import System.IO.Unsafe (unsafePerformIO) #else import Foreign #endif --- Creating the encoding tables--------------------------------+-- Creating the encoding table+------------------------------ -- TODO: Use table from C implementation. @@ -56,19 +57,6 @@ where ix = unsafeIndex alphabet -{--{-# NOINLINE upperAlphabet #-}-upperAlphabet :: EncodingTable-upperAlphabet =- tableFromList $ map (fromIntegral . fromEnum) $ ['0'..'9'] ++ ['A'..'F']---- | The encoding table for hexadecimal values with upper-case characters;--- e.g., DEADBEEF.-{-# NOINLINE upperTable #-}-upperTable :: EncodingTable-upperTable = unsafePerformIO $ base16EncodingTable upperAlphabet--}- {-# NOINLINE lowerAlphabet #-} lowerAlphabet :: EncodingTable lowerAlphabet =@@ -80,19 +68,6 @@ lowerTable :: EncodingTable lowerTable = unsafePerformIO $ base16EncodingTable lowerAlphabet ---- Encoding nibbles and octets----------------------------------- | Encode a nibble as an octet.------ > encode4_as_8 lowerTable 10 = fromIntegral (char 'a')----{-# INLINE encode4_as_8 #-}-encode4_as_8 :: EncodingTable -> Word8 -> IO Word8-encode4_as_8 table x = unsafeIndex table (2 * fromIntegral x + 1)--- TODO: Use a denser table to reduce cache utilization.- -- | Encode an octet as 16bit word comprising both encoded nibbles ordered -- according to the host endianness. Writing these 16bit to memory will write -- the nibbles in the correct order (i.e. big-endian).@@ -100,17 +75,3 @@ encode8_as_16h :: EncodingTable -> Word8 -> IO Word16 encode8_as_16h (EncodingTable table) = peekElemOff (castPtr $ unsafeForeignPtrToPtr table) . fromIntegral--{---- | Encode an octet as a big-endian ordered tuple of octets; i.e.,------ > encode8_as_8_8 lowerTable 10--- > = (fromIntegral (chr '0'), fromIntegral (chr 'a'))----{-# INLINE encode8_as_8_8 #-}-encode8_as_8_8 :: EncodingTable -> Word8 -> IO (Word8, Word8)-encode8_as_8_8 table x =- (,) <$> unsafeIndex table i <*> unsafeIndex table (i + 1)- where- i = 2 * fromIntegral x--}
Data/ByteString/Builder/Prim/Internal/Floating.hs view
@@ -35,7 +35,7 @@ encodeFloatViaWord32F w32fe | size w32fe < sizeOf (undefined :: Float) = error $ "encodeFloatViaWord32F: encoding not wide enough"- | otherwise = fixedEncoding (size w32fe) $ \x op -> do+ | otherwise = fixedPrim (size w32fe) $ \x op -> do poke (castPtr op) x x' <- peek (castPtr op) runF w32fe x' op@@ -48,7 +48,7 @@ encodeDoubleViaWord64F w64fe | size w64fe < sizeOf (undefined :: Float) = error $ "encodeDoubleViaWord64F: encoding not wide enough"- | otherwise = fixedEncoding (size w64fe) $ \x op -> do+ | otherwise = fixedPrim (size w64fe) $ \x op -> do poke (castPtr op) x x' <- peek (castPtr op) runF w64fe x' op
Data/ByteString/Builder/Prim/Internal/UncheckedShifts.hs view
@@ -98,7 +98,12 @@ caseWordSize_32_64 :: a -- Value to use for 32-bit 'Word's -> a -- Value to use for 64-bit 'Word's -> a-caseWordSize_32_64 f32 f64 = case bitSize (undefined :: Word) of+caseWordSize_32_64 f32 f64 =+#if MIN_VERSION_base(4,7,0)+ case finiteBitSize (undefined :: Word) of+#else+ case bitSize (undefined :: Word) of+#endif 32 -> f32 64 -> f64 s -> error $ "caseWordSize_32_64: unsupported Word bit-size " ++ show s
Data/ByteString/Char8.hs view
@@ -284,16 +284,7 @@ -- bottleneck. pack :: String -> ByteString pack = packChars--#if !defined(__GLASGOW_HASKELL__)-{-# INLINE [1] pack #-}--{-# RULES-"ByteString pack/packAddress" forall s .- pack (unpackCString# s) = inlinePerformIO (B.unsafePackAddress s)- #-}--#endif+{-# INLINE pack #-} -- | /O(n)/ Converts a 'ByteString' to a 'String'. unpack :: ByteString -> [Char]
Data/ByteString/Internal.hs view
@@ -2,13 +2,16 @@ #if __GLASGOW_HASKELL__ {-# LANGUAGE UnliftedFFITypes, MagicHash, UnboxedTuples, DeriveDataTypeable #-}+#if __GLASGOW_HASKELL__ >= 701+{-# LANGUAGE Unsafe #-} #endif+#endif {-# OPTIONS_HADDOCK hide #-} -- | -- Module : Data.ByteString.Internal -- Copyright : (c) Don Stewart 2006-2008--- (c) Duncan Coutts 2006-2011+-- (c) Duncan Coutts 2006-2012 -- License : BSD-style -- Maintainer : dons00@gmail.com, duncan@community.haskell.org -- Stability : unstable@@ -32,6 +35,9 @@ packChars, packUptoLenChars, unsafePackLenChars, unpackBytes, unpackAppendBytesLazy, unpackAppendBytesStrict, unpackChars, unpackAppendCharsLazy, unpackAppendCharsStrict,+#if defined(__GLASGOW_HASKELL__)+ unsafePackAddress,+#endif -- * Low level imperative construction create, -- :: Int -> (Ptr Word8 -> IO ()) -> IO ByteString@@ -112,6 +118,12 @@ #ifdef __GLASGOW_HASKELL__ import GHC.Base (realWorld#,unsafeChr)+#if MIN_VERSION_base(4,4,0)+import GHC.CString (unpackCString#)+#else+import GHC.Base (unpackCString#)+#endif+import GHC.Prim (Addr#) #if __GLASGOW_HASKELL__ >= 611 import GHC.IO (IO(IO)) #else@@ -128,7 +140,8 @@ #endif #ifdef __GLASGOW_HASKELL__-import GHC.ForeignPtr (mallocPlainForeignPtrBytes)+import GHC.ForeignPtr (newForeignPtr_, mallocPlainForeignPtrBytes)+import GHC.Ptr (Ptr(..), castPtr) #else import Foreign.ForeignPtr (mallocForeignPtrBytes) #endif@@ -170,10 +183,12 @@ -- ----------------------------------------------------------------------------- --- | A space-efficient representation of a Word8 vector, supporting many--- efficient operations. A 'ByteString' contains 8-bit characters only.+-- | A space-efficient representation of a 'Word8' vector, supporting many+-- efficient operations. ----- Instances of Eq, Ord, Read, Show, Data, Typeable+-- A 'ByteString' contains 8-bit bytes, or by using the operations from+-- "Data.ByteString.Char8" it can be interpreted as containing 8-bit+-- characters. -- data ByteString = PS {-# UNPACK #-} !(ForeignPtr Word8) -- payload {-# UNPACK #-} !Int -- offset@@ -226,6 +241,15 @@ packChars :: [Char] -> ByteString packChars cs = unsafePackLenChars (List.length cs) cs +#if defined(__GLASGOW_HASKELL__)+{-# INLINE [0] packChars #-}++{-# RULES+"ByteString packChars/packAddress" forall s .+ packChars (unpackCString# s) = inlinePerformIO (unsafePackAddress s)+ #-}+#endif+ unsafePackLenBytes :: Int -> [Word8] -> ByteString unsafePackLenBytes len xs0 = unsafeCreate len $ \p -> go p xs0@@ -240,6 +264,39 @@ go !_ [] = return () go !p (c:cs) = poke p (c2w c) >> go (p `plusPtr` 1) cs +#if defined(__GLASGOW_HASKELL__)+-- | /O(n)/ Pack a null-terminated sequence of bytes, pointed to by an+-- Addr\# (an arbitrary machine address assumed to point outside the+-- garbage-collected heap) into a @ByteString@. A much faster way to+-- create an Addr\# is with an unboxed string literal, than to pack a+-- boxed string. A unboxed string literal is compiled to a static @char+-- []@ by GHC. Establishing the length of the string requires a call to+-- @strlen(3)@, so the Addr# must point to a null-terminated buffer (as+-- is the case with "string"# literals in GHC). Use 'unsafePackAddressLen'+-- if you know the length of the string statically.+--+-- An example:+--+-- > literalFS = unsafePackAddress "literal"#+--+-- This function is /unsafe/. If you modify the buffer pointed to by the+-- original Addr# this modification will be reflected in the resulting+-- @ByteString@, breaking referential transparency.+--+-- Note this also won't work if your Addr# has embedded '\0' characters in+-- the string, as @strlen@ will return too short a length.+--+unsafePackAddress :: Addr# -> IO ByteString+unsafePackAddress addr# = do+ p <- newForeignPtr_ (castPtr cstr)+ l <- c_strlen cstr+ return $ PS p 0 (fromIntegral l)+ where+ cstr :: CString+ cstr = Ptr addr#+{-# INLINE unsafePackAddress #-}+#endif+ packUptoLenBytes :: Int -> [Word8] -> (ByteString, [Word8]) packUptoLenBytes len xs0 = unsafeCreateUptoN' len $ \p -> go p len xs0@@ -498,7 +555,7 @@ {-# INLINE c2w #-} -- | Selects words corresponding to white-space characters in the Latin-1 range--- ordered by frequency. +-- ordered by frequency. isSpaceWord8 :: Word8 -> Bool isSpaceWord8 w = w == 0x20 ||@@ -538,7 +595,7 @@ #endif -- ------------------------------------------------------------------------ +-- -- Standard C functions --
Data/ByteString/Lazy.hs view
@@ -34,7 +34,7 @@ -- strict ones. -- -- The recomended way to assemble lazy ByteStrings from smaller parts--- is to use the builder monoid from "Data.ByteString.Lazy.Builder".+-- is to use the builder monoid from "Data.ByteString.Builder". -- -- This module is intended to be imported @qualified@, to avoid name -- clashes with "Prelude" functions. eg.@@ -491,7 +491,6 @@ -- | 'foldl1' is a variant of 'foldl' that has no starting value -- argument, and thus must be applied to non-empty 'ByteStrings'.--- This function is subject to array fusion. foldl1 :: (Word8 -> Word8 -> Word8) -> ByteString -> Word8 foldl1 _ Empty = errorEmptyList "foldl1" foldl1 f (Chunk c cs) = foldl f (S.unsafeHead c) (Chunk (S.unsafeTail c) cs)
Data/ByteString/Lazy/Builder/ASCII.hs view
@@ -9,6 +9,16 @@ -- module Data.ByteString.Lazy.Builder.ASCII ( module Data.ByteString.Builder+, byteStringHexFixed+, lazyByteStringHexFixed ) where import Data.ByteString.Builder+import qualified Data.ByteString as S+import qualified Data.ByteString.Lazy as L++byteStringHexFixed :: S.ByteString -> Builder+byteStringHexFixed = byteStringHex++lazyByteStringHexFixed :: L.ByteString -> Builder+lazyByteStringHexFixed = lazyByteStringHex
Data/ByteString/Lazy/Internal.hs view
@@ -1,7 +1,10 @@ {-# LANGUAGE CPP, ForeignFunctionInterface, BangPatterns #-} #if __GLASGOW_HASKELL__ {-# LANGUAGE DeriveDataTypeable #-}+#if __GLASGOW_HASKELL__ >= 701+{-# LANGUAGE Unsafe #-} #endif+#endif {-# OPTIONS_HADDOCK hide #-} -- |@@ -69,10 +72,12 @@ import Data.Generics (Data(..), mkNorepType) #endif --- | A space-efficient representation of a Word8 vector, supporting many--- efficient operations. A 'ByteString' contains 8-bit characters only.+-- | A space-efficient representation of a 'Word8' vector, supporting many+-- efficient operations. ----- Instances of Eq, Ord, Read, Show, Data, Typeable+-- A lazy 'ByteString' contains 8-bit bytes, or by using the operations+-- from "Data.ByteString.Lazy.Char8" it can be interpreted as containing+-- 8-bit characters. -- data ByteString = Empty | Chunk {-# UNPACK #-} !S.ByteString ByteString
+ Data/ByteString/Short.hs view
@@ -0,0 +1,85 @@+{-# LANGUAGE CPP #-}+#if __GLASGOW_HASKELL__ >= 701+{-# LANGUAGE Trustworthy #-}+#endif++-- |+-- Module : Data.ByteString.Short+-- Copyright : (c) Duncan Coutts 2012-2013+-- License : BSD-style+--+-- Maintainer : duncan@community.haskell.org+-- Stability : stable+-- Portability : ghc only+-- +-- A compact representation suitable for storing short byte strings in memory.+--+-- In typical use cases it can be imported alongside "Data.ByteString", e.g.+--+-- > import qualified Data.ByteString as B+-- > import qualified Data.ByteString.Short as B+-- > (ShortByteString, toShort, fromShort)+--+-- Other 'ShortByteString' operations clash with "Data.ByteString" or "Prelude"+-- functions however, so they should be imported @qualified@ with a different+-- alias e.g.+--+-- > import qualified Data.ByteString.Short as B.Short+--+module Data.ByteString.Short (++ -- * The @ShortByteString@ type++ ShortByteString,++ -- ** Memory overhead+ -- | With GHC, the memory overheads are as follows, expressed in words and+ -- in bytes (words are 4 and 8 bytes on 32 or 64bit machines respectively).+ --+ -- * 'ByteString' unshared: 9 words; 36 or 72 bytes.+ --+ -- * 'ByteString' shared substring: 5 words; 20 or 40 bytes.+ --+ -- * 'ShortByteString': 4 words; 16 or 32 bytes.+ --+ -- For the string data itself, both 'ShortByteString' and 'ByteString' use+ -- one byte per element, rounded up to the nearest word. For example,+ -- including the overheads, a length 10 'ShortByteString' would take+ -- @16 + 12 = 28@ bytes on a 32bit platform and @32 + 16 = 48@ bytes on a+ -- 64bit platform.+ --+ -- These overheads can all be reduced by 1 word (4 or 8 bytes) when the+ -- 'ShortByteString' or 'ByteString' is unpacked into another constructor.+ --+ -- For example:+ --+ -- > data ThingId = ThingId {-# UNPACK #-} !Int+ -- > {-# UNPACK #-} !ShortByteString+ --+ -- This will take @1 + 1 + 3@ words (the @ThingId@ constructor ++ -- unpacked @Int@ + unpacked @ShortByteString@), plus the words for the+ -- string data.+ + -- ** Heap fragmentation+ -- | With GHC, the 'ByteString' representation uses /pinned/ memory,+ -- meaning it cannot be moved by the GC. This is usually the right thing to+ -- do for larger strings, but for small strings using pinned memory can+ -- lead to heap fragmentation which wastes space. The 'ShortByteString'+ -- type (and the @Text@ type from the @text@ package) use /unpinned/ memory+ -- so they do not contribute to heap fragmentation. In addition, with GHC,+ -- small unpinned strings are allocated in the same way as normal heap+ -- allocations, rather than in a separate pinned area.++ -- * Conversions+ toShort,+ fromShort,+ pack,+ unpack,++ -- * Other operations+ empty, null, length, index,+ ) where++import Data.ByteString.Short.Internal+import Prelude ()+
+ Data/ByteString/Short/Internal.hs view
@@ -0,0 +1,590 @@+{-# LANGUAGE DeriveDataTypeable, CPP, BangPatterns, RankNTypes,+ ForeignFunctionInterface, MagicHash, UnboxedTuples,+ UnliftedFFITypes #-}+{-# OPTIONS_GHC -fno-warn-name-shadowing #-}+#if __GLASGOW_HASKELL__ >= 701+{-# LANGUAGE Unsafe #-}+#endif+{-# OPTIONS_HADDOCK hide #-}++-- |+-- Module : Data.ByteString.Short.Internal+-- Copyright : (c) Duncan Coutts 2012-2013+-- License : BSD-style+--+-- Maintainer : duncan@community.haskell.org+-- Stability : stable+-- Portability : ghc only+-- +-- Internal representation of ShortByteString+--+module Data.ByteString.Short.Internal (++ -- * The @ShortByteString@ type and representation+ ShortByteString(..),++ -- * Conversions+ toShort,+ fromShort,+ pack,+ unpack,++ -- * Other operations+ empty, null, length, index, unsafeIndex,++ -- * Low level operations+ createFromPtr, copyToPtr+ ) where++import Data.ByteString.Internal (ByteString(..), inlinePerformIO)++import Data.Typeable (Typeable)+import Data.Data (Data(..), mkNoRepType)+import Data.Monoid (Monoid(..))+import Data.String (IsString(..))+import Control.DeepSeq (NFData(..))+import qualified Data.List as List (length)+#if MIN_VERSION_base(4,7,0)+import Foreign.C.Types (CSize(..), CInt(..))+#elif MIN_VERSION_base(4,4,0)+import Foreign.C.Types (CSize(..), CInt(..), CLong(..))+#else+import Foreign.C.Types (CSize, CInt, CLong)+#endif+import Foreign.Ptr+import Foreign.ForeignPtr (touchForeignPtr)+#if MIN_VERSION_base(4,5,0)+import Foreign.ForeignPtr.Unsafe (unsafeForeignPtrToPtr)+#else+import Foreign.ForeignPtr (unsafeForeignPtrToPtr)+#endif++#if MIN_VERSION_base(4,5,0)+import qualified GHC.Exts+#endif+import GHC.Exts ( Int(I#), Int#, Ptr(Ptr), Addr#, Char(C#)+ , State#, RealWorld+ , ByteArray#, MutableByteArray#+ , newByteArray#+#if MIN_VERSION_base(4,6,0)+ , newPinnedByteArray#+ , byteArrayContents#+ , unsafeCoerce#+#endif+#if MIN_VERSION_base(4,3,0)+ , sizeofByteArray#+#endif+ , indexWord8Array#, indexCharArray#+ , writeWord8Array#, writeCharArray#+ , unsafeFreezeByteArray# )+import GHC.IO+#if MIN_VERSION_base(4,6,0)+import GHC.ForeignPtr (ForeignPtr(ForeignPtr), ForeignPtrContents(PlainPtr))+#else+import GHC.ForeignPtr (mallocPlainForeignPtrBytes)+#endif+import GHC.ST (ST(ST), runST)+import GHC.Word++import Prelude ( Eq(..), Ord(..), Ordering(..), Read(..), Show(..)+ , ($), error, (++)+ , Bool(..), (&&), otherwise+ , (+), (-), fromIntegral+ , return )+++-- | A compact representation of a 'Word8' vector.+--+-- It has a lower memory overhead than a 'ByteString' and and does not+-- contribute to heap fragmentation. It can be converted to or from a+-- 'ByteString' (at the cost of copying the string data). It supports very few+-- other operations.+--+-- It is suitable for use as an internal representation for code that needs+-- to keep many short strings in memory, but it /should not/ be used as an+-- interchange type. That is, it should not generally be used in public APIs.+-- The 'ByteString' type is usually more suitable for use in interfaces; it is+-- more flexible and it supports a wide range of operations.+--+data ShortByteString = SBS ByteArray#+#if !(MIN_VERSION_base(4,3,0))+ Int -- ^ Prior to ghc-7.0.x, 'ByteArray#'s reported+ -- their length rounded up to the nearest word.+ -- This means we have to store the true length+ -- separately, wasting a word.+#define LEN(x) (x)+#else+#define _len /* empty */+#define LEN(x) /* empty */+#endif+ deriving Typeable++-- The ByteArray# representation is always word sized and aligned but with a+-- known byte length. Our representation choice for ShortByteString is to leave+-- the 0--3 trailing bytes undefined. This means we can use word-sized writes,+-- but we have to be careful with reads, see equateBytes and compareBytes below.+++instance Eq ShortByteString where+ (==) = equateBytes++instance Ord ShortByteString where+ compare = compareBytes++instance Monoid ShortByteString where+ mempty = empty+ mappend = append+ mconcat = concat++instance NFData ShortByteString++instance Show ShortByteString where+ showsPrec p ps r = showsPrec p (unpackChars ps) r++instance Read ShortByteString where+ readsPrec p str = [ (packChars x, y) | (x, y) <- readsPrec p str ]++instance IsString ShortByteString where+ fromString = packChars++instance Data ShortByteString where+ gfoldl f z txt = z packBytes `f` (unpackBytes txt)+ toConstr _ = error "Data.ByteString.Short.ShortByteString.toConstr"+ gunfold _ _ = error "Data.ByteString.Short.ShortByteString.gunfold"+#if MIN_VERSION_base(4,2,0)+ dataTypeOf _ = mkNoRepType "Data.ByteString.Short.ShortByteString"+#else+ dataTypeOf _ = mkNorepType "Data.ByteString.Short.ShortByteString"+#endif++------------------------------------------------------------------------+-- Simple operations++-- | /O(1)/. The empty 'ShortByteString'.+empty :: ShortByteString+empty = create 0 (\_ -> return ())++-- | /O(1)/ The length of a 'ShortByteString'.+length :: ShortByteString -> Int+#if MIN_VERSION_base(4,3,0)+length (SBS barr#) = I# (sizeofByteArray# barr#)+#else+length (SBS _ len) = len+#endif++-- | /O(1)/ Test whether a 'ShortByteString' is empty.+null :: ShortByteString -> Bool+null sbs = length sbs == 0++-- | /O(1)/ 'ShortByteString' index (subscript) operator, starting from 0. +index :: ShortByteString -> Int -> Word8+index sbs i+ | i >= 0 && i < length sbs = unsafeIndex sbs i+ | otherwise = indexError sbs i++unsafeIndex :: ShortByteString -> Int -> Word8+unsafeIndex sbs = indexWord8Array (asBA sbs)++indexError :: ShortByteString -> Int -> a+indexError sbs i =+ error $ "Data.ByteString.Short.index: error in array index; " ++ show i+ ++ " not in range [0.." ++ show (length sbs) ++ ")"+++------------------------------------------------------------------------+-- Internal utils++asBA :: ShortByteString -> BA+asBA (SBS ba# _len) = BA# ba#++create :: Int -> (forall s. MBA s -> ST s ()) -> ShortByteString+create len fill =+ runST (do+ mba <- newByteArray len+ fill mba+ BA# ba# <- unsafeFreezeByteArray mba+ return (SBS ba# LEN(len)))+{-# INLINE create #-}++------------------------------------------------------------------------+-- Conversion to and from ByteString++-- | /O(n)/. Convert a 'ByteString' into a 'ShortByteString'.+--+-- This makes a copy, so does not retain the input string.+--+toShort :: ByteString -> ShortByteString+toShort !bs = unsafeDupablePerformIO (toShortIO bs)++toShortIO :: ByteString -> IO ShortByteString+toShortIO (PS fptr off len) = do+ mba <- stToIO (newByteArray len)+ let ptr = unsafeForeignPtrToPtr fptr+ stToIO (copyAddrToByteArray (ptr `plusPtr` off) mba 0 len)+ touchForeignPtr fptr+ BA# ba# <- stToIO (unsafeFreezeByteArray mba)+ return (SBS ba# LEN(len))+++-- | /O(n)/. Convert a 'ShortByteString' into a 'ByteString'.+--+fromShort :: ShortByteString -> ByteString+fromShort !sbs = unsafeDupablePerformIO (fromShortIO sbs)++fromShortIO :: ShortByteString -> IO ByteString+fromShortIO sbs = do+#if MIN_VERSION_base(4,6,0)+ let len = length sbs+ mba@(MBA# mba#) <- stToIO (newPinnedByteArray len)+ stToIO (copyByteArray (asBA sbs) 0 mba 0 len)+ let fp = ForeignPtr (byteArrayContents# (unsafeCoerce# mba#))+ (PlainPtr mba#)+ return (PS fp 0 len)+#else+ -- Before base 4.6 ForeignPtrContents is not exported from GHC.ForeignPtr+ -- so we cannot get direct access to the mbarr#+ let len = length sbs+ fptr <- mallocPlainForeignPtrBytes len+ let ptr = unsafeForeignPtrToPtr fptr+ stToIO (copyByteArrayToAddr (asBA sbs) 0 ptr len)+ touchForeignPtr fptr+ return (PS fptr 0 len)+#endif+++------------------------------------------------------------------------+-- Packing and unpacking from lists++-- | /O(n)/. Convert a list into a 'ShortByteString'+pack :: [Word8] -> ShortByteString+pack = packBytes++-- | /O(n)/. Convert a 'ShortByteString' into a list.+unpack :: ShortByteString -> [Word8]+unpack = unpackBytes++packChars :: [Char] -> ShortByteString+packChars cs = packLenChars (List.length cs) cs++packBytes :: [Word8] -> ShortByteString+packBytes cs = packLenBytes (List.length cs) cs++packLenChars :: Int -> [Char] -> ShortByteString+packLenChars len cs0 =+ create len (\mba -> go mba 0 cs0)+ where+ go :: MBA s -> Int -> [Char] -> ST s ()+ go !_ !_ [] = return ()+ go !mba !i (c:cs) = do+ writeCharArray mba i c+ go mba (i+1) cs++packLenBytes :: Int -> [Word8] -> ShortByteString+packLenBytes len ws0 =+ create len (\mba -> go mba 0 ws0)+ where+ go :: MBA s -> Int -> [Word8] -> ST s ()+ go !_ !_ [] = return ()+ go !mba !i (w:ws) = do+ writeWord8Array mba i w+ go mba (i+1) ws++-- Unpacking bytestrings into lists effeciently is a tradeoff: on the one hand+-- we would like to write a tight loop that just blats the list into memory, on+-- the other hand we want it to be unpacked lazily so we don't end up with a+-- massive list data structure in memory.+--+-- Our strategy is to combine both: we will unpack lazily in reasonable sized+-- chunks, where each chunk is unpacked strictly.+--+-- unpackChars does the lazy loop, while unpackAppendBytes and+-- unpackAppendChars do the chunks strictly.++unpackChars :: ShortByteString -> [Char]+unpackChars bs = unpackAppendCharsLazy bs []++unpackBytes :: ShortByteString -> [Word8]+unpackBytes bs = unpackAppendBytesLazy bs []++-- Why 100 bytes you ask? Because on a 64bit machine the list we allocate+-- takes just shy of 4k which seems like a reasonable amount.+-- (5 words per list element, 8 bytes per word, 100 elements = 4000 bytes)++unpackAppendCharsLazy :: ShortByteString -> [Char] -> [Char]+unpackAppendCharsLazy sbs cs0 =+ go 0 (length sbs) cs0+ where+ sz = 100++ go off len cs+ | len <= sz = unpackAppendCharsStrict sbs off len cs+ | otherwise = unpackAppendCharsStrict sbs off sz remainder+ where remainder = go (off+sz) (len-sz) cs++unpackAppendBytesLazy :: ShortByteString -> [Word8] -> [Word8]+unpackAppendBytesLazy sbs ws0 =+ go 0 (length sbs) ws0+ where+ sz = 100++ go off len ws+ | len <= sz = unpackAppendBytesStrict sbs off len ws+ | otherwise = unpackAppendBytesStrict sbs off sz remainder+ where remainder = go (off+sz) (len-sz) ws++-- For these unpack functions, since we're unpacking the whole list strictly we+-- build up the result list in an accumulator. This means we have to build up+-- the list starting at the end. So our traversal starts at the end of the+-- buffer and loops down until we hit the sentinal:++unpackAppendCharsStrict :: ShortByteString -> Int -> Int -> [Char] -> [Char]+unpackAppendCharsStrict !sbs off len cs =+ go (off-1) (off-1 + len) cs+ where+ go !sentinal !i !acc+ | i == sentinal = acc+ | otherwise = let !c = indexCharArray (asBA sbs) i+ in go sentinal (i-1) (c:acc)++unpackAppendBytesStrict :: ShortByteString -> Int -> Int -> [Word8] -> [Word8]+unpackAppendBytesStrict !sbs off len ws =+ go (off-1) (off-1 + len) ws+ where+ go !sentinal !i !acc+ | i == sentinal = acc+ | otherwise = let !w = indexWord8Array (asBA sbs) i+ in go sentinal (i-1) (w:acc)+++------------------------------------------------------------------------+-- Eq and Ord implementations++equateBytes :: ShortByteString -> ShortByteString -> Bool+equateBytes sbs1 sbs2 =+ let !len1 = length sbs1+ !len2 = length sbs2+ in len1 == len2+ && 0 == inlinePerformIO (memcmp_ByteArray (asBA sbs1) (asBA sbs2) len1)++compareBytes :: ShortByteString -> ShortByteString -> Ordering+compareBytes sbs1 sbs2 =+ let !len1 = length sbs1+ !len2 = length sbs2+ !len = min len1 len2+ in case inlinePerformIO (memcmp_ByteArray (asBA sbs1) (asBA sbs2) len) of+ i | i < 0 -> LT+ | i > 0 -> GT+ | len2 > len1 -> LT+ | len2 < len1 -> GT+ | otherwise -> EQ+++------------------------------------------------------------------------+-- Appending and concatenation++append :: ShortByteString -> ShortByteString -> ShortByteString+append src1 src2 =+ let !len1 = length src1+ !len2 = length src2+ in create (len1 + len2) $ \dst -> do+ copyByteArray (asBA src1) 0 dst 0 len1+ copyByteArray (asBA src2) 0 dst len1 len2++concat :: [ShortByteString] -> ShortByteString+concat sbss =+ create (totalLen 0 sbss) (\dst -> copy dst 0 sbss)+ where+ totalLen !acc [] = acc+ totalLen !acc (sbs: sbss) = totalLen (acc + length sbs) sbss++ copy :: MBA s -> Int -> [ShortByteString] -> ST s ()+ copy !_ !_ [] = return ()+ copy !dst !off (src : sbss) = do+ let !len = length src+ copyByteArray (asBA src) 0 dst off len+ copy dst (off + len) sbss+++------------------------------------------------------------------------+-- Exported low level operations++copyToPtr :: ShortByteString -- ^ source data+ -> Int -- ^ offset into source+ -> Ptr a -- ^ destination+ -> Int -- ^ number of bytes to copy+ -> IO ()+copyToPtr src off dst len =+ stToIO $+ copyByteArrayToAddr (asBA src) off dst len++createFromPtr :: Ptr a -- ^ source data+ -> Int -- ^ number of bytes to copy+ -> IO ShortByteString+createFromPtr !ptr len =+ stToIO $ do+ mba <- newByteArray len+ copyAddrToByteArray ptr mba 0 len+ BA# ba# <- unsafeFreezeByteArray mba+ return (SBS ba# LEN(len))+++------------------------------------------------------------------------+-- Primop wrappers++data BA = BA# ByteArray#+data MBA s = MBA# (MutableByteArray# s)++indexCharArray :: BA -> Int -> Char+indexCharArray (BA# ba#) (I# i#) = C# (indexCharArray# ba# i#)++indexWord8Array :: BA -> Int -> Word8+indexWord8Array (BA# ba#) (I# i#) = W8# (indexWord8Array# ba# i#)++newByteArray :: Int -> ST s (MBA s)+newByteArray (I# len#) =+ ST $ \s -> case newByteArray# len# s of+ (# s, mba# #) -> (# s, MBA# mba# #)++#if MIN_VERSION_base(4,6,0)+newPinnedByteArray :: Int -> ST s (MBA s)+newPinnedByteArray (I# len#) =+ ST $ \s -> case newPinnedByteArray# len# s of+ (# s, mba# #) -> (# s, MBA# mba# #)+#endif++unsafeFreezeByteArray :: MBA s -> ST s BA+unsafeFreezeByteArray (MBA# mba#) =+ ST $ \s -> case unsafeFreezeByteArray# mba# s of+ (# s, ba# #) -> (# s, BA# ba# #)++writeCharArray :: MBA s -> Int -> Char -> ST s ()+writeCharArray (MBA# mba#) (I# i#) (C# c#) =+ ST $ \s -> case writeCharArray# mba# i# c# s of+ s -> (# s, () #)++writeWord8Array :: MBA s -> Int -> Word8 -> ST s ()+writeWord8Array (MBA# mba#) (I# i#) (W8# w#) =+ ST $ \s -> case writeWord8Array# mba# i# w# s of+ s -> (# s, () #)++copyAddrToByteArray :: Ptr a -> MBA RealWorld -> Int -> Int -> ST RealWorld ()+copyAddrToByteArray (Ptr src#) (MBA# dst#) (I# dst_off#) (I# len#) =+ ST $ \s -> case copyAddrToByteArray# src# dst# dst_off# len# s of+ s -> (# s, () #)++copyByteArrayToAddr :: BA -> Int -> Ptr a -> Int -> ST RealWorld ()+copyByteArrayToAddr (BA# src#) (I# src_off#) (Ptr dst#) (I# len#) =+ ST $ \s -> case copyByteArrayToAddr# src# src_off# dst# len# s of+ s -> (# s, () #)++copyByteArray :: BA -> Int -> MBA s -> Int -> Int -> ST s ()+copyByteArray (BA# src#) (I# src_off#) (MBA# dst#) (I# dst_off#) (I# len#) =+ ST $ \s -> case copyByteArray# src# src_off# dst# dst_off# len# s of+ s -> (# s, () #)+++------------------------------------------------------------------------+-- FFI imports++memcmp_ByteArray :: BA -> BA -> Int -> IO CInt+memcmp_ByteArray (BA# ba1#) (BA# ba2#) len =+ c_memcmp_ByteArray ba1# ba2# (fromIntegral len)++foreign import ccall unsafe "string.h memcmp"+ c_memcmp_ByteArray :: ByteArray# -> ByteArray# -> CSize -> IO CInt+++------------------------------------------------------------------------+-- Primop replacements++copyAddrToByteArray# :: Addr#+ -> MutableByteArray# RealWorld -> Int#+ -> Int#+ -> State# RealWorld -> State# RealWorld++copyByteArrayToAddr# :: ByteArray# -> Int#+ -> Addr#+ -> Int#+ -> State# RealWorld -> State# RealWorld++copyByteArray# :: ByteArray# -> Int#+ -> MutableByteArray# s -> Int#+ -> Int#+ -> State# s -> State# s++#if MIN_VERSION_base(4,7,0)++-- These exist as real primops in ghc-7.8, and for before that we use+-- FFI to C memcpy.+copyAddrToByteArray# = GHC.Exts.copyAddrToByteArray#+copyByteArrayToAddr# = GHC.Exts.copyByteArrayToAddr#++#else++copyAddrToByteArray# src dst dst_off len s =+ unIO_ (memcpy_AddrToByteArray dst (clong dst_off) src 0 (csize len)) s++copyAddrToByteArray0 :: Addr# -> MutableByteArray# s -> Int#+ -> State# RealWorld -> State# RealWorld+copyAddrToByteArray0 src dst len s =+ unIO_ (memcpy_AddrToByteArray0 dst src (csize len)) s++{-# INLINE [0] copyAddrToByteArray# #-}+{-# RULES "copyAddrToByteArray# dst_off=0"+ forall src dst len s.+ copyAddrToByteArray# src dst 0# len s+ = copyAddrToByteArray0 src dst len s #-}++foreign import ccall unsafe "fpstring.h fps_memcpy_offsets"+ memcpy_AddrToByteArray :: MutableByteArray# s -> CLong -> Addr# -> CLong -> CSize -> IO ()++foreign import ccall unsafe "string.h memcpy"+ memcpy_AddrToByteArray0 :: MutableByteArray# s -> Addr# -> CSize -> IO ()+++copyByteArrayToAddr# src src_off dst len s =+ unIO_ (memcpy_ByteArrayToAddr dst 0 src (clong src_off) (csize len)) s++copyByteArrayToAddr0 :: ByteArray# -> Addr# -> Int#+ -> State# RealWorld -> State# RealWorld+copyByteArrayToAddr0 src dst len s =+ unIO_ (memcpy_ByteArrayToAddr0 dst src (csize len)) s++{-# INLINE [0] copyByteArrayToAddr# #-}+{-# RULES "copyByteArrayToAddr# src_off=0"+ forall src dst len s.+ copyByteArrayToAddr# src 0# dst len s+ = copyByteArrayToAddr0 src dst len s #-}++foreign import ccall unsafe "fpstring.h fps_memcpy_offsets"+ memcpy_ByteArrayToAddr :: Addr# -> CLong -> ByteArray# -> CLong -> CSize -> IO ()++foreign import ccall unsafe "string.h memcpy"+ memcpy_ByteArrayToAddr0 :: Addr# -> ByteArray# -> CSize -> IO ()+++unIO_ :: IO () -> State# RealWorld -> State# RealWorld+unIO_ io s = case unIO io s of (# s, _ #) -> s++clong :: Int# -> CLong+clong i# = fromIntegral (I# i#)++csize :: Int# -> CSize+csize i# = fromIntegral (I# i#)+#endif++#if MIN_VERSION_base(4,5,0)+copyByteArray# = GHC.Exts.copyByteArray#+#else+copyByteArray# src src_off dst dst_off len s =+ unST_ (unsafeIOToST+ (memcpy_ByteArray dst (clong dst_off) src (clong src_off) (csize len))) s+ where+ unST (ST st) = st+ unST_ st s = case unST st s of (# s, _ #) -> s++foreign import ccall unsafe "fpstring.h fps_memcpy_offsets"+ memcpy_ByteArray :: MutableByteArray# s -> CLong+ -> ByteArray# -> CLong -> CSize -> IO ()+#endif+
Data/ByteString/Unsafe.hs view
@@ -150,40 +150,9 @@ #if defined(__GLASGOW_HASKELL__)--- | /O(n)/ Pack a null-terminated sequence of bytes, pointed to by an--- Addr\# (an arbitrary machine address assumed to point outside the--- garbage-collected heap) into a @ByteString@. A much faster way to--- create an Addr\# is with an unboxed string literal, than to pack a--- boxed string. A unboxed string literal is compiled to a static @char--- []@ by GHC. Establishing the length of the string requires a call to--- @strlen(3)@, so the Addr# must point to a null-terminated buffer (as--- is the case with "string"# literals in GHC). Use 'unsafePackAddressLen'--- if you know the length of the string statically.------ An example:------ > literalFS = unsafePackAddress "literal"#------ This function is /unsafe/. If you modify the buffer pointed to by the--- original Addr# this modification will be reflected in the resulting--- @ByteString@, breaking referential transparency.------ Note this also won't work if you Add# has embedded '\0' characters in--- the string (strlen will fail).----unsafePackAddress :: Addr# -> IO ByteString-unsafePackAddress addr# = do- p <- newForeignPtr_ (castPtr cstr)- l <- c_strlen cstr- return $ PS p 0 (fromIntegral l)- where- cstr :: CString- cstr = Ptr addr#-{-# INLINE unsafePackAddress #-}- -- | /O(1)/ 'unsafePackAddressLen' provides constant-time construction of--- 'ByteStrings' which is ideal for string literals. It packs a sequence--- of bytes into a 'ByteString', given a raw 'Addr#' to the string, and+-- 'ByteString's, which is ideal for string literals. It packs a sequence+-- of bytes into a @ByteString@, given a raw 'Addr#' to the string, and -- the length of the string. -- -- This function is /unsafe/ in two ways:@@ -196,7 +165,7 @@ -- reflected in resulting @ByteString@, breaking referential -- transparency. ----- If in doubt, don't use these functions.+-- If in doubt, don't use this function. -- unsafePackAddressLen :: Int -> Addr# -> IO ByteString unsafePackAddressLen len addr# = do@@ -325,7 +294,7 @@ -- | /O(1) construction/ Use a @ByteString@ with a function requiring a -- @CStringLen@.--- +-- -- This function does zero copying, and merely unwraps a @ByteString@ to -- appear as a @CStringLen@. It is /unsafe/: --
− bench/BenchAll.hs
@@ -1,243 +0,0 @@-{-# LANGUAGE PackageImports, ScopedTypeVariables, BangPatterns #-}--- |--- Copyright : (c) 2011 Simon Meier--- License : BSD3-style (see LICENSE)------ Maintainer : Simon Meier <iridcode@gmail.com>--- Stability : experimental--- Portability : tested on GHC only------ Benchmark all 'Builder' functions.-module Main (main) where--import Prelude hiding (words)-import Criterion.Main-import Data.Foldable (foldMap)--import qualified Data.ByteString as S-import qualified Data.ByteString.Lazy as L--import Data.ByteString.Builder-import Data.ByteString.Builder.ASCII-import Data.ByteString.Builder.Prim- ( FixedPrim, BoundedPrim, (>$<) )-import qualified Data.ByteString.Builder.Prim as P-import qualified Data.ByteString.Builder.Prim.Internal as PI--import Foreign----------------------------------------------------------------------------------- Benchmark support---------------------------------------------------------------------------------countToZero :: Int -> Maybe (Int, Int)-countToZero 0 = Nothing-countToZero n = Just (n, n - 1)------------------------------------------------------------------------------------ Benchmark----------------------------------------------------------------------------------- input data (NOINLINE to ensure memoization)--------------------------------------------------- | Few-enough repetitions to avoid making GC too expensive.-nRepl :: Int-nRepl = 10000--{-# NOINLINE intData #-}-intData :: [Int]-intData = [1..nRepl]---- Half of the integers inside the range of an Int and half of them outside.-{-# NOINLINE integerData #-}-integerData :: [Integer]-integerData = map (\x -> fromIntegral x + fromIntegral (maxBound - nRepl `div` 2)) intData--{-# NOINLINE floatData #-}-floatData :: [Float]-floatData = map (\x -> (3.14159 * fromIntegral x) ^ (3 :: Int)) intData--{-# NOINLINE doubleData #-}-doubleData :: [Double]-doubleData = map (\x -> (3.14159 * fromIntegral x) ^ (3 :: Int)) intData--{-# NOINLINE byteStringData #-}-byteStringData :: S.ByteString-byteStringData = S.pack $ map fromIntegral intData--{-# NOINLINE lazyByteStringData #-}-lazyByteStringData :: L.ByteString-lazyByteStringData = case S.splitAt (nRepl `div` 2) byteStringData of- (bs1, bs2) -> L.fromChunks [bs1, bs2]----- benchmark wrappers------------------------{-# INLINE benchB #-}-benchB :: String -> a -> (a -> Builder) -> Benchmark-benchB name x b =- bench (name ++" (" ++ show nRepl ++ ")") $- whnf (L.length . toLazyByteString . b) x--{-# INLINE benchBInts #-}-benchBInts :: String -> ([Int] -> Builder) -> Benchmark-benchBInts name = benchB name intData---- | Benchmark a 'FixedPrim'. Full inlining to enable specialization.-{-# INLINE benchFE #-}-benchFE :: String -> FixedPrim Int -> Benchmark-benchFE name = benchBE name . P.liftFixedToBounded---- | Benchmark a 'BoundedPrim'. Full inlining to enable specialization.-{-# INLINE benchBE #-}-benchBE :: String -> BoundedPrim Int -> Benchmark-benchBE name e =- bench (name ++" (" ++ show nRepl ++ ")") $ benchIntEncodingB nRepl e---- We use this construction of just looping through @n,n-1,..,1@ to ensure that--- we measure the speed of the encoding and not the speed of generating the--- values to be encoded.-{-# INLINE benchIntEncodingB #-}-benchIntEncodingB :: Int -- ^ Maximal 'Int' to write- -> BoundedPrim Int -- ^ 'BoundedPrim' to execute- -> IO () -- ^ 'IO' action to benchmark-benchIntEncodingB n0 w- | n0 <= 0 = return ()- | otherwise = do- fpbuf <- mallocForeignPtrBytes (n0 * PI.sizeBound w)- withForeignPtr fpbuf (loop n0) >> return ()- where- loop !n !op- | n <= 0 = return op- | otherwise = PI.runB w n op >>= loop (n - 1)------ benchmarks----------------sanityCheckInfo :: [String]-sanityCheckInfo =- [ "Sanity checks:"- , " lengths of input data: " ++ show- [ length intData, length floatData, length doubleData, length integerData- , S.length byteStringData, fromIntegral (L.length lazyByteStringData)- ]- ]--main :: IO ()-main = do- mapM_ putStrLn sanityCheckInfo- putStrLn ""- Criterion.Main.defaultMain- [ bgroup "Data.ByteString.Builder"- [ bgroup "Encoding wrappers"- [ benchBInts "foldMap word8" $- foldMap (word8 . fromIntegral)- , benchBInts "primMapListFixed word8" $- P.primMapListFixed (fromIntegral >$< P.word8)- , benchB "primUnfoldrFixed word8" nRepl $- P.primUnfoldrFixed (fromIntegral >$< P.word8) countToZero- , benchB "primMapByteStringFixed word8" byteStringData $- P.primMapByteStringFixed P.word8- , benchB "primMapLazyByteStringFixed word8" lazyByteStringData $- P.primMapLazyByteStringFixed P.word8- ]-- , bgroup "Non-bounded encodings"- [ benchB "foldMap floatDec" floatData $ foldMap floatDec- , benchB "foldMap doubleDec" doubleData $ foldMap doubleDec- , benchB "foldMap integerDec" integerData $ foldMap integerDec- , benchB "byteStringHex" byteStringData $ byteStringHex- , benchB "lazyByteStringHex" lazyByteStringData $ lazyByteStringHex- ]- ]-- , bgroup "Data.ByteString.Builder.Prim"- [ benchFE "char7" $ toEnum >$< P.char7- , benchFE "char8" $ toEnum >$< P.char8- , benchBE "charUtf8" $ toEnum >$< P.charUtf8-- -- binary encoding- , benchFE "int8" $ fromIntegral >$< P.int8- , benchFE "word8" $ fromIntegral >$< P.word8-- -- big-endian- , benchFE "int16BE" $ fromIntegral >$< P.int16BE- , benchFE "int32BE" $ fromIntegral >$< P.int32BE- , benchFE "int64BE" $ fromIntegral >$< P.int64BE-- , benchFE "word16BE" $ fromIntegral >$< P.word16BE- , benchFE "word32BE" $ fromIntegral >$< P.word32BE- , benchFE "word64BE" $ fromIntegral >$< P.word64BE-- , benchFE "floatBE" $ fromIntegral >$< P.floatBE- , benchFE "doubleBE" $ fromIntegral >$< P.doubleBE-- -- little-endian- , benchFE "int16LE" $ fromIntegral >$< P.int16LE- , benchFE "int32LE" $ fromIntegral >$< P.int32LE- , benchFE "int64LE" $ fromIntegral >$< P.int64LE-- , benchFE "word16LE" $ fromIntegral >$< P.word16LE- , benchFE "word32LE" $ fromIntegral >$< P.word32LE- , benchFE "word64LE" $ fromIntegral >$< P.word64LE-- , benchFE "floatLE" $ fromIntegral >$< P.floatLE- , benchFE "doubleLE" $ fromIntegral >$< P.doubleLE-- -- host-dependent- , benchFE "int16Host" $ fromIntegral >$< P.int16Host- , benchFE "int32Host" $ fromIntegral >$< P.int32Host- , benchFE "int64Host" $ fromIntegral >$< P.int64Host- , benchFE "intHost" $ fromIntegral >$< P.intHost-- , benchFE "word16Host" $ fromIntegral >$< P.word16Host- , benchFE "word32Host" $ fromIntegral >$< P.word32Host- , benchFE "word64Host" $ fromIntegral >$< P.word64Host- , benchFE "wordHost" $ fromIntegral >$< P.wordHost-- , benchFE "floatHost" $ fromIntegral >$< P.floatHost- , benchFE "doubleHost" $ fromIntegral >$< P.doubleHost- ]-- , bgroup "Data.ByteString.Builder.Prim.ASCII"- [- -- decimal number- benchBE "int8Dec" $ fromIntegral >$< P.int8Dec- , benchBE "int16Dec" $ fromIntegral >$< P.int16Dec- , benchBE "int32Dec" $ fromIntegral >$< P.int32Dec- , benchBE "int64Dec" $ fromIntegral >$< P.int64Dec- , benchBE "intDec" $ fromIntegral >$< P.intDec-- , benchBE "word8Dec" $ fromIntegral >$< P.word8Dec- , benchBE "word16Dec" $ fromIntegral >$< P.word16Dec- , benchBE "word32Dec" $ fromIntegral >$< P.word32Dec- , benchBE "word64Dec" $ fromIntegral >$< P.word64Dec- , benchBE "wordDec" $ fromIntegral >$< P.wordDec-- -- hexadecimal number- , benchBE "word8Hex" $ fromIntegral >$< P.word8Hex- , benchBE "word16Hex" $ fromIntegral >$< P.word16Hex- , benchBE "word32Hex" $ fromIntegral >$< P.word32Hex- , benchBE "word64Hex" $ fromIntegral >$< P.word64Hex- , benchBE "wordHex" $ fromIntegral >$< P.wordHex-- -- fixed-width hexadecimal numbers- , benchFE "int8HexFixed" $ fromIntegral >$< P.int8HexFixed- , benchFE "int16HexFixed" $ fromIntegral >$< P.int16HexFixed- , benchFE "int32HexFixed" $ fromIntegral >$< P.int32HexFixed- , benchFE "int64HexFixed" $ fromIntegral >$< P.int64HexFixed-- , benchFE "word8HexFixed" $ fromIntegral >$< P.word8HexFixed- , benchFE "word16HexFixed" $ fromIntegral >$< P.word16HexFixed- , benchFE "word32HexFixed" $ fromIntegral >$< P.word32HexFixed- , benchFE "word64HexFixed" $ fromIntegral >$< P.word64HexFixed-- , benchFE "floatHexFixed" $ fromIntegral >$< P.floatHexFixed- , benchFE "doubleHexFixed" $ fromIntegral >$< P.doubleHexFixed- ]- ]
− bench/BoundsCheckFusion.hs
@@ -1,127 +0,0 @@-{-# LANGUAGE PackageImports, ScopedTypeVariables, BangPatterns #-}--- |--- Copyright : (c) 2011 Simon Meier--- License : BSD3-style (see LICENSE)------ Maintainer : Simon Meier <iridcode@gmail.com>--- Stability : experimental--- Portability : tested on GHC only------ Benchmark that the bounds checks fuse.-module Main (main) where--import Prelude hiding (words)-import Criterion.Main-import Data.Monoid-import Data.Foldable (foldMap)--import qualified Data.ByteString as S-import qualified Data.ByteString.Lazy as L--import Data.ByteString.Builder-import Data.ByteString.Builder.Extra-import Data.ByteString.Builder.Prim- ( FixedPrim, BoundedPrim, (>$<), (>*<) )-import qualified Data.ByteString.Builder.Prim as P-import qualified Data.ByteString.Builder.Internal as I-import qualified Data.ByteString.Builder.Prim.Internal as I--import Foreign----------------------------------------------------------------------------------- Benchmark support---------------------------------------------------------------------------------countToZero :: Int -> Maybe (Int, Int)-countToZero 0 = Nothing-countToZero n = Just (n, n - 1)------------------------------------------------------------------------------------ Benchmark----------------------------------------------------------------------------------- input data (NOINLINE to ensure memoization)--------------------------------------------------- | Few-enough repetitions to avoid making GC too expensive.-nRepl :: Int-nRepl = 10000--{-# NOINLINE intData #-}-intData :: [Int]-intData = [1..nRepl]---- benchmark wrappers------------------------{-# INLINE benchB #-}-benchB :: String -> a -> (a -> Builder) -> Benchmark-benchB name x b =- bench (name ++" (" ++ show nRepl ++ ")") $- whnf (L.length . toLazyByteString . b) x--{-# INLINE benchBInts #-}-benchBInts :: String -> ([Int] -> Builder) -> Benchmark-benchBInts name = benchB name intData----- benchmarks----------------sanityCheckInfo :: [String]-sanityCheckInfo =- [ "Sanity checks:"- , " lengths of input data: " ++ show- [ length intData ]- ]--main :: IO ()-main = do- mapM_ putStrLn sanityCheckInfo- putStrLn ""- Criterion.Main.defaultMain- [ bgroup "Data.ByteString.Lazy.Builder"- [ -- benchBInts "foldMap intHost" $- -- foldMap (intHost . fromIntegral)--{-- benchBInts "mapM_ (\\x -> intHost x `mappend` intHost x)" $- foldMap ((\x -> intHost x `mappend` intHost x)-- , benchBInts "foldMap (\\x -> intHost x `mappend` intHost x)" $- foldMap (\x -> intHost x `mappend` intHost x)--}-- benchBInts "foldMap (left-assoc)" $- foldMap (\x -> (stringUtf8 "s" `mappend` intHost x) `mappend` intHost x)-- , benchBInts "foldMap (right-assoc)" $- foldMap (\x -> intHost x `mappend` (intHost x `mappend` stringUtf8 "s"))-- , benchBInts "foldMap [manually fused, left-assoc]" $- foldMap (\x -> stringUtf8 "s" `mappend` P.primBounded (P.liftFixedToBounded $ P.intHost >*< P.intHost) (x, x))-- , benchBInts "foldMap [manually fused, right-assoc]" $- foldMap (\x -> P.primBounded (P.liftFixedToBounded $ P.intHost >*< P.intHost) (x, x) `mappend` stringUtf8 "s")-- -- , benchBInts "encodeListWithF intHost" $- -- P.encodeListWithF (fromIntegral >$< P.intHost)- ]- ]--{-# RULES--"append/encodeWithB" forall w1 w2 x1 x2.- I.append (P.primBounded w1 x1) (P.primBounded w2 x2)- = P.primBounded (I.pairB w1 w2) (x1, x2)--"append/encodeWithB/assoc_r" forall w1 w2 x1 x2 b.- I.append (P.primBounded w1 x1) (I.append (P.primBounded w2 x2) b)- = I.append (P.primBounded (I.pairB w1 w2) (x1, x2)) b--"append/encodeWithB/assoc_l" forall w1 w2 x1 x2 b.- I.append (I.append b (P.primBounded w1 x1)) (P.primBounded w2 x2)- = I.append b (P.primBounded (I.pairB w1 w2) (x1, x2))- #-}-
bytestring.cabal view
@@ -1,5 +1,5 @@ Name: bytestring-Version: 0.10.2.0+Version: 0.10.4.0 Synopsis: Fast, compact, strict and lazy byte strings with a list interface Description: An efficient compact, immutable byte string type (both strict and lazy)@@ -7,7 +7,7 @@ . The 'ByteString' type represents sequences of bytes or 8-bit characters. It is suitable for high performance use, both in terms of large data- quantities, or high speed requirements. The 'ByteStrin'g functions follow+ quantities, or high speed requirements. The 'ByteString' functions follow the same style as Haskell\'s ordinary lists, so it is easy to convert code from using 'String' to 'ByteString'. .@@ -28,6 +28,10 @@ in an ad-hoc way by repeated concatenation. This is ideal for fast serialisation or pretty printing. .+ There is also a 'ShortByteString' type which has a lower memory overhead+ and can can be converted to or from a 'ByteString', but supports very few+ other operations. It is suitable for keeping many short strings in memory.+ . 'ByteString's are not designed for Unicode. For Unicode strings you should use the 'Text' type from the @text@ package. .@@ -40,26 +44,35 @@ License-file: LICENSE Category: Data Copyright: Copyright (c) Don Stewart 2005-2009,- (c) Duncan Coutts 2006-2012,+ (c) Duncan Coutts 2006-2013, (c) David Roundy 2003-2005, (c) Jasper Van der Jeugt 2010,- (c) Simon Meier 2010-2011.+ (c) Simon Meier 2010-2013. Author: Don Stewart, Duncan Coutts Maintainer: Don Stewart <dons00@gmail.com>, Duncan Coutts <duncan@community.haskell.org>-Bug-reports: dons00@gmail.com,- duncan@community.haskell.org-Tested-With: GHC==7.6.1, GHC==7.4.1, GHC==7.0.4, GHC==6.12.3+Homepage: https://github.com/haskell/bytestring+Bug-reports: https://github.com/haskell/bytestring/issues+Tested-With: GHC==7.8.1, GHC==7.6.3, GHC==7.4.2, GHC==7.0.4, GHC==6.12.3 Build-Type: Simple-Cabal-Version: >= 1.8+Cabal-Version: >= 1.10 extra-source-files: README TODO source-repository head- type: darcs- location: http://darcs.haskell.org/bytestring/+ type: git+ location: https://github.com/haskell/bytestring +source-repository this+ type: git+ location: https://github.com/haskell/bytestring+ tag: 0.10.4.0++flag integer-simple+ description: Use the simple integer library instead of GMP+ default: False+ library build-depends: base >= 4.2 && < 5, ghc-prim, deepseq @@ -70,6 +83,8 @@ Data.ByteString.Lazy Data.ByteString.Lazy.Char8 Data.ByteString.Lazy.Internal+ Data.ByteString.Short+ Data.ByteString.Short.Internal Data.ByteString.Builder Data.ByteString.Builder.Extra@@ -92,7 +107,8 @@ Data.ByteString.Builder.Prim.Internal.UncheckedShifts Data.ByteString.Builder.Prim.Internal.Base16 - extensions: CPP,+ default-language: Haskell98+ other-extensions: CPP, ForeignFunctionInterface, BangPatterns UnliftedFFITypes,@@ -100,8 +116,15 @@ UnboxedTuples, DeriveDataTypeable ScopedTypeVariables- Rank2Types+ RankNTypes NamedFieldPuns+-- if impl(ghc >= 7.2)+-- other-extensions: Trustworthy, Unsafe+ -- older ghc had issues with language pragmas guarded by cpp+ if impl(ghc < 7)+ default-extensions: CPP, MagicHash, UnboxedTuples,+ DeriveDataTypeable, BangPatterns,+ NamedFieldPuns ghc-options: -Wall -O2@@ -115,7 +138,17 @@ includes: fpstring.h install-includes: fpstring.h + -- flags for the decimal integer serialization code+ if impl(ghc >= 6.11)+ if !flag(integer-simple)+ cpp-options: -DINTEGER_GMP+ build-depends: integer-gmp >= 0.2 + if impl(ghc >= 6.9) && impl(ghc < 6.11)+ cpp-options: -DINTEGER_GMP+ build-depends: integer >= 0.1 && < 0.2++ -- QC properties, with GHC RULES disabled test-suite prop-compiled type: exitcode-stdio-1.0@@ -130,13 +163,12 @@ include-dirs: include ghc-options: -fwarn-unused-binds -fno-enable-rewrite-rules- extensions: BangPatterns- UnliftedFFITypes,- MagicHash,- UnboxedTuples,- DeriveDataTypeable- ScopedTypeVariables- NamedFieldPuns+ default-language: Haskell98+ -- older ghc had issues with language pragmas guarded by cpp+ if impl(ghc < 7)+ default-extensions: CPP, MagicHash, UnboxedTuples,+ DeriveDataTypeable, BangPatterns,+ NamedFieldPuns test-suite test-builder type: exitcode-stdio-1.0@@ -145,7 +177,6 @@ other-modules: Data.ByteString.Builder.Tests Data.ByteString.Builder.Prim.Tests Data.ByteString.Builder.Prim.TestUtils- Data.ByteString.Builder.Prim.Extra TestFramework build-depends: base, ghc-prim,@@ -153,20 +184,17 @@ QuickCheck >= 2.4 && < 3, byteorder == 1.0.*, dlist == 0.5.*,- directory >= 1.0 && < 1.2,+ directory, mtl >= 2.0 && < 2.2 ghc-options: -Wall -fwarn-tabs - extensions: CPP, ForeignFunctionInterface- UnliftedFFITypes,- MagicHash,- UnboxedTuples,- DeriveDataTypeable- ScopedTypeVariables- Rank2Types- BangPatterns- NamedFieldPuns+ default-language: Haskell98+ -- older ghc had issues with language pragmas guarded by cpp+ if impl(ghc < 7)+ default-extensions: CPP, MagicHash, UnboxedTuples,+ DeriveDataTypeable, BangPatterns,+ NamedFieldPuns c-sources: cbits/fpstring.c cbits/itoa.c@@ -174,47 +202,3 @@ includes: fpstring.h install-includes: fpstring.h -benchmark bench-builder-all- type: exitcode-stdio-1.0- hs-source-dirs: . bench- main-is: BenchAll.hs- build-depends: base, deepseq, ghc-prim,- criterion- c-sources: cbits/fpstring.c- cbits/itoa.c- include-dirs: include- ghc-options: -O2- -fmax-simplifier-iterations=10- -fdicts-cheap- -fspec-constr-count=6--benchmark bench-builder-boundscheck- type: exitcode-stdio-1.0- hs-source-dirs: . bench- main-is: BoundsCheckFusion.hs- build-depends: base, deepseq, ghc-prim,- criterion- c-sources: cbits/fpstring.c- cbits/itoa.c- include-dirs: include- ghc-options: -O2- -fmax-simplifier-iterations=10- -fdicts-cheap- -fspec-constr-count=6---- Sadly we cannot use benchmark bench-builder-csv currently because it--- depends on both text and binary, which both depend on bytestring--- which gives cabal fits about cyclic dependencies.--- type: exitcode-stdio-1.0--- hs-source-dirs: . bench--- main-is: CSV.hs--- build-depends: base, deepseq, ghc-prim,--- text, binary,--- criterion--- c-sources: cbits/fpstring.c--- cbits/itoa.c--- include-dirs: include--- ghc-options: -O2--- -fmax-simplifier-iterations=10--- -fdicts-cheap--- -fspec-constr-count=6
cbits/fpstring.c view
@@ -80,3 +80,11 @@ ++c; return c; }++/* This wrapper is here so that we can copy a sub-range of a ByteArray#.+ We cannot construct a pointer to the interior of an unpinned ByteArray#,+ except by doing an unsafe ffi call, and adjusting the pointer C-side. */+void * fps_memcpy_offsets(void *dst, unsigned long dst_off,+ const void *src, unsigned long src_off, size_t n) {+ return memcpy(dst + dst_off, src + src_off, n);+}
cbits/itoa.c view
@@ -9,7 +9,7 @@ // Decimal Encoding /////////////////// -const char* digits = "0123456789abcdef";+static const char* digits = "0123456789abcdef"; // signed integers char* _hs_bytestring_int_dec (int x, char* buf)@@ -127,6 +127,50 @@ *buf++ = c; } return next_free;+}+++// Padded, decimal, positive integers for the decimal output of bignums+///////////////////////////////////////////////////////////////////////++// Padded (9 digits), decimal, positive int:+// We will use it with numbers that fit in 31 bits; i.e., numbers smaller than+// 10^9, as "31 * log 2 / log 10 = 9.33"+void _hs_bytestring_int_dec_padded9 (int x, char* buf)+{+ const int max_width_int32_dec = 9;+ char* ptr = buf + max_width_int32_dec;+ int x_tmp;++ // encode positive number as little-endian decimal+ do {+ x_tmp = x;+ x /= 10;+ *(--ptr) = digits[x_tmp - x * 10];+ } while ( x );++ // pad beginning+ while (buf < ptr) { *(--ptr) = '0'; }+}++// Padded (19 digits), decimal, positive long long int:+// We will use it with numbers that fit in 63 bits; i.e., numbers smaller than+// 10^18, as "63 * log 2 / log 10 = 18.96"+void _hs_bytestring_long_long_int_dec_padded18 (long long int x, char* buf)+{+ const int max_width_int64_dec = 18;+ char* ptr = buf + max_width_int64_dec;+ long long int x_tmp;++ // encode positive number as little-endian decimal+ do {+ x_tmp = x;+ x /= 10;+ *(--ptr) = digits[x_tmp - x * 10];+ } while ( x );++ // pad beginning+ while (buf < ptr) { *(--ptr) = '0'; } }
tests/Properties.hs view
@@ -1,4 +1,4 @@-{-# LANGUAGE ScopedTypeVariables, BangPatterns #-}+{-# LANGUAGE CPP, ScopedTypeVariables, BangPatterns #-} -- -- Must have rules off, otherwise the fusion rules will replace the rhs -- with the lhs, and we only end up testing lhs == lhs@@ -41,6 +41,7 @@ import qualified Data.ByteString.Internal as P import qualified Data.ByteString.Unsafe as P import qualified Data.ByteString.Char8 as C+import qualified Data.ByteString.Short as Short import qualified Data.ByteString.Lazy.Char8 as LC import qualified Data.ByteString.Lazy.Char8 as D@@ -50,7 +51,12 @@ import Rules import QuickCheckUtils+#if defined(HAVE_TEST_FRAMEWORK)+import Test.Framework+import Test.Framework.Providers.QuickCheck2+#else import TestFramework+#endif toInt64 :: Int -> Int64 toInt64 = fromIntegral@@ -959,7 +965,7 @@ _ -> Nothing prop_foldl1BB xs a = ((foldl (\x c -> if c == a then x else c:x) [] xs)) ==- (P.unpack $ P.foldl (\x c -> if c == a then x else c `P.cons` x) P.empty (P.pack xs)) + (P.unpack $ P.foldl (\x c -> if c == a then x else c `P.cons` x) P.empty (P.pack xs)) prop_foldl2BB xs = P.foldl (\xs c -> c `P.cons` xs) P.empty (P.pack xs) == P.reverse (P.pack xs) prop_foldr1BB xs a = ((foldr (\c x -> if c == a then x else c:x) [] xs)) ==@@ -1725,15 +1731,104 @@ (const $ do z <- D.readFile f return (z==(x `D.append` y))) -prop_packAddress = C.pack "this is a test" +prop_packAddress = C.pack "this is a test" ==- C.pack "this is a test" + C.pack "this is a test" prop_isSpaceWord8 (w :: Word8) = isSpace c == P.isSpaceChar8 c where c = chr (fromIntegral w)- + ------------------------------------------------------------------------+-- ByteString.Short+--++prop_short_pack_unpack xs =+ (Short.unpack . Short.pack) xs == xs+prop_short_toShort_fromShort bs =+ (Short.fromShort . Short.toShort) bs == bs++prop_short_toShort_unpack bs =+ (Short.unpack . Short.toShort) bs == P.unpack bs+prop_short_pack_fromShort xs =+ (Short.fromShort . Short.pack) xs == P.pack xs++prop_short_empty =+ Short.empty == Short.toShort P.empty+ && Short.empty == Short.pack []+ && Short.null (Short.toShort P.empty)+ && Short.null (Short.pack [])+ && Short.null Short.empty++prop_short_null_toShort bs =+ P.null bs == Short.null (Short.toShort bs)+prop_short_null_pack xs =+ null xs == Short.null (Short.pack xs)++prop_short_length_toShort bs =+ P.length bs == Short.length (Short.toShort bs)+prop_short_length_pack xs =+ length xs == Short.length (Short.pack xs)++prop_short_index_pack xs =+ all (\i -> Short.pack xs `Short.index` i == xs !! i)+ [0 .. length xs - 1]+prop_short_index_toShort bs =+ all (\i -> Short.toShort bs `Short.index` i == bs `P.index` i)+ [0 .. P.length bs - 1]++prop_short_eq xs ys =+ (xs == ys) == (Short.pack xs == Short.pack ys)+prop_short_ord xs ys =+ (xs `compare` ys) == (Short.pack xs `compare` Short.pack ys)++prop_short_mappend_empty_empty =+ Short.empty `mappend` Short.empty == Short.empty+prop_short_mappend_empty xs =+ Short.empty `mappend` Short.pack xs == Short.pack xs+ && Short.pack xs `mappend` Short.empty == Short.pack xs+prop_short_mappend xs ys =+ (xs `mappend` ys) == Short.unpack (Short.pack xs `mappend` Short.pack ys)+prop_short_mconcat xss =+ mconcat xss == Short.unpack (mconcat (map Short.pack xss))++prop_short_fromString s =+ fromString s == Short.fromShort (fromString s)++prop_short_show xs =+ show (Short.pack xs) == show (map P.w2c xs)+prop_short_show' xs =+ show (Short.pack xs) == show (P.pack xs)++prop_short_read xs =+ read (show (Short.pack xs)) == Short.pack xs+++short_tests =+ [ testProperty "pack/unpack" prop_short_pack_unpack+ , testProperty "toShort/fromShort" prop_short_toShort_fromShort+ , testProperty "toShort/unpack" prop_short_toShort_unpack+ , testProperty "pack/fromShort" prop_short_pack_fromShort+ , testProperty "empty" prop_short_empty+ , testProperty "null/toShort" prop_short_null_toShort+ , testProperty "null/pack" prop_short_null_pack+ , testProperty "length/toShort" prop_short_length_toShort+ , testProperty "length/pack" prop_short_length_pack+ , testProperty "index/pack" prop_short_index_pack+ , testProperty "index/toShort" prop_short_index_toShort+ , testProperty "Eq" prop_short_eq+ , testProperty "Ord" prop_short_ord+ , testProperty "mappend/empty/empty" prop_short_mappend_empty_empty+ , testProperty "mappend/empty" prop_short_mappend_empty+ , testProperty "mappend" prop_short_mappend+ , testProperty "mconcat" prop_short_mconcat+ , testProperty "fromString" prop_short_fromString+ , testProperty "show" prop_short_show+ , testProperty "show'" prop_short_show'+ , testProperty "read" prop_short_read+ ]++------------------------------------------------------------------------ -- The entry point main :: IO ()@@ -1751,6 +1846,7 @@ ++ bb_tests ++ ll_tests ++ io_tests+ ++ short_tests ++ rules --@@ -2475,3 +2571,4 @@ , testProperty "concatMap" prop_concatMap , testProperty "isSpace" prop_isSpaceWord8 ]+
tests/Rules.hs view
@@ -1,3 +1,5 @@+{-# LANGUAGE CPP #-}+ module Rules where -- -- Tests to ensure rules are firing.@@ -11,7 +13,12 @@ import Data.Char import QuickCheckUtils++#if defined(HAVE_TEST_FRAMEWORK)+import Test.Framework.Providers.QuickCheck2+#else import TestFramework+#endif prop_break_C x = C.break ((==) x) `eq1` break ((==) x)
tests/TestFramework.hs view
@@ -1,6 +1,6 @@ -- | -- Copyright : (c) 2011 Duncan Coutts--- +-- -- test-framework stub API -- -- Currently we cannot use the nice test-framework package for this testsuite@@ -46,6 +46,9 @@ maxSuccess = n --chatty = ... if we want to increase verbosity }++assertBool :: String -> Bool -> Bool+assertBool _ = id testCase :: String -> Bool -> Test testCase name tst = [(name, runPlainTest)]
tests/builder/Data/ByteString/Builder/Prim/TestUtils.hs view
@@ -1,4 +1,4 @@-{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE CPP, ScopedTypeVariables #-} -- | -- Copyright : (c) 2011 Simon Meier -- License : BSD3-style (see LICENSE)@@ -82,9 +82,15 @@ #endif import System.ByteOrder-import Unsafe.Coerce (unsafeCoerce) +#if defined(HAVE_TEST_FRAMEWORK)+import Test.HUnit (assertBool)+import Test.Framework+import Test.Framework.Providers.HUnit+import Test.Framework.Providers.QuickCheck2+#else import TestFramework+#endif import Test.QuickCheck (Arbitrary(..)) -- Helper functions@@ -95,9 +101,9 @@ testBoundedProperty :: forall a. (Arbitrary a, Show a, Bounded a) => String -> (a -> Bool) -> Test testBoundedProperty name p = testGroup name- [ testProperty "arbitrary" p- , testCase "bounds" $ p (minBound :: a)- && p (maxBound :: a)+ [ testProperty name p+ , testCase (name ++ " minBound") $ assertBool "minBound" (p (minBound :: a))+ , testCase (name ++ " maxBound") $ assertBool "minBound" (p (maxBound :: a)) ] -- | Quote a 'String' nicely.@@ -348,27 +354,15 @@ double_list :: (Word64 -> [Word8]) -> Double -> [Word8] double_list f = f . coerceDoubleToWord64 --- Note that the following use of unsafeCoerce is not guaranteed to be--- safe on GHC 7.0 and less. The reason is probably the following ticket:------ http://hackage.haskell.org/trac/ghc/ticket/4092------ However, that only applies if the value is loaded in a register. We--- avoid this by coercing only boxed values and ensuring that they--- remain boxed using a NOINLINE pragma.------- | Super unsafe coerce a 'Float' to a 'Word32'. We have to explicitly mask--- out the higher bits in case we are working on a 64-bit machine.+-- | Convert a 'Float' to a 'Word32'. {-# NOINLINE coerceFloatToWord32 #-} coerceFloatToWord32 :: Float -> Word32-coerceFloatToWord32 = (.&. maxBound) . unsafeCoerce+coerceFloatToWord32 x = unsafePerformIO (with x (peek . castPtr)) --- | Super unsafe coerce a 'Double' to a 'Word64'. Currently, there are no--- > 64 bit machines supported by GHC. But we just play it safe.+-- | Convert a 'Double' to a 'Word64'. {-# NOINLINE coerceDoubleToWord64 #-} coerceDoubleToWord64 :: Double -> Word64-coerceDoubleToWord64 = (.&. maxBound) . unsafeCoerce+coerceDoubleToWord64 x = unsafePerformIO (with x (peek . castPtr)) -- | Parse a variable length encoding parseVar :: (Num a, Bits a) => [Word8] -> (a, [Word8])@@ -381,5 +375,3 @@ | otherwise = first add (go ws) where add x = (x `shiftL` 7) .|. (fromIntegral w .&. 0x7f)--
tests/builder/Data/ByteString/Builder/Prim/Tests.hs view
@@ -1,4 +1,4 @@-{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE CPP, ScopedTypeVariables #-} -- | -- Copyright : (c) 2011 Simon Meier@@ -12,21 +12,17 @@ module Data.ByteString.Builder.Prim.Tests (tests) where -import Control.Arrow (first)- import Data.Char (ord) import qualified Data.ByteString.Lazy as L import Data.ByteString.Builder import qualified Data.ByteString.Builder.Prim as BP-import qualified Data.ByteString.Builder.Prim.Extra as BP import Data.ByteString.Builder.Prim.TestUtils -import Numeric (showHex)--import Foreign-+#if defined(HAVE_TEST_FRAMEWORK)+import Test.Framework+#else import TestFramework-import Test.QuickCheck (Arbitrary)+#endif tests :: [Test]@@ -80,132 +76,9 @@ , testF "floatHost" (float_list hostEndian_list) BP.floatHost , testF "doubleHost" (double_list hostEndian_list) BP.doubleHost-- , testBoundedB "word8Var" genVar_list BP.word8Var- , testBoundedB "word16Var" genVar_list BP.word16Var- , testBoundedB "word32Var" genVar_list BP.word32Var- , testBoundedB "word64Var" genVar_list BP.word64Var- , testBoundedB "wordVar" genVar_list BP.wordVar-- , testBoundedB "int8Var" int8Var_list BP.int8Var- , testBoundedB "int16Var" int16Var_list BP.int16Var- , testBoundedB "int32Var" int32Var_list BP.int32Var- , testBoundedB "int64Var" int64Var_list BP.int64Var- , testBoundedB "intVar" intVar_list BP.intVar-- , testBoundedB "int8VarSigned" (int8Var_list . zigZag) BP.int8VarSigned- , testBoundedB "int16VarSigned" (int16Var_list . zigZag) BP.int16VarSigned- , testBoundedB "int32VarSigned" (int32Var_list . zigZag) BP.int32VarSigned- , testBoundedB "int64VarSigned" (int64Var_list . zigZag) BP.int64VarSigned- , testBoundedB "intVarSigned" (intVar_list . zigZag) BP.intVarSigned-- , testGroup "parseable"- [ prop_zigZag_parseable "int8VarSigned" unZigZagInt8 BP.int8VarSigned- , prop_zigZag_parseable "int16VarSigned" unZigZagInt16 BP.int16VarSigned- , prop_zigZag_parseable "int32VarSigned" unZigZagInt32 BP.int32VarSigned- , prop_zigZag_parseable "int64VarSigned" unZigZagInt64 BP.int64VarSigned- , prop_zigZag_parseable "intVarSigned" unZigZagInt BP.intVarSigned- ]-- , testFixedBoundF "wordVarFixedBound" wordVarFixedBound_list BP.wordVarFixedBound- , testFixedBoundF "word64VarFixedBound" word64VarFixedBound_list BP.word64VarFixedBound- ] --- Variable length encodings--------------------------------- | Variable length encoding.-genVar_list :: (Ord a, Num a, Bits a, Integral a) => a -> [Word8]-genVar_list x- | x <= 0x7f = sevenBits : []- | otherwise = (sevenBits .|. 0x80) : genVar_list (x `shiftR` 7)- where- sevenBits = fromIntegral x .&. 0x7f--int8Var_list :: Int8 -> [Word8]-int8Var_list = genVar_list . (fromIntegral :: Int8 -> Word8)--int16Var_list :: Int16 -> [Word8]-int16Var_list = genVar_list . (fromIntegral :: Int16 -> Word16)--int32Var_list :: Int32 -> [Word8]-int32Var_list = genVar_list . (fromIntegral :: Int32 -> Word32)--int64Var_list :: Int64 -> [Word8]-int64Var_list = genVar_list . (fromIntegral :: Int64 -> Word64)--intVar_list :: Int -> [Word8]-intVar_list = genVar_list . (fromIntegral :: Int -> Word)----- | The so-called \"zig-zag\" encoding from Google's protocol buffers.--- It maps integers of small magnitude to naturals of small--- magnitude by encoding negative integers as odd naturals and positive--- integers as even naturals.------ For example: @0 -> 0, -1 -> 1, 1 -> 2, -2 -> 3, 2 -> 4, ...@------ PRE: 'a' must be a signed integer type.-zigZag :: (Storable a, Bits a) => a -> a-zigZag x = (x `shiftL` 1) `xor` (x `shiftR` (8 * sizeOf x - 1))----- | Reversing the zigZag encoding.------ PRE: 'a' must be an unsigned integer type.------ forall x. fromIntegral x ==--- unZigZag ((fromIntegral :: IntX -> WordX) (zigZag x))----unZigZag :: (Storable a, Num a, Bits a) => a -> a-unZigZag x = (x `shiftR` 1) `xor` negate (x .&. 1)--unZigZagInt8 :: Int8 -> Int8-unZigZagInt8 = (fromIntegral :: Word8 -> Int8) . unZigZag . fromIntegral--unZigZagInt16 :: Int16 -> Int16-unZigZagInt16 = (fromIntegral :: Word16 -> Int16) . unZigZag . fromIntegral--unZigZagInt32 :: Int32 -> Int32-unZigZagInt32 = (fromIntegral :: Word32 -> Int32) . unZigZag . fromIntegral--unZigZagInt64 :: Int64 -> Int64-unZigZagInt64 = (fromIntegral :: Word64 -> Int64) . unZigZag . fromIntegral--unZigZagInt :: Int -> Int-unZigZagInt = (fromIntegral :: Word -> Int) . unZigZag . fromIntegral---- | Check that the 'intVarSigned' encodings are parseable.-prop_zigZag_parseable :: (Arbitrary t, Num b, Bits b, Show t, Eq t)- => String -> (b -> t) -> BP.BoundedPrim t -> Test-prop_zigZag_parseable name unZig be =- compareImpls name (\x -> (x, [])) (first unZig . parseVar . evalB be)---- | Variable length encoding to a fixed number of bytes (pad / truncate).-genVarFixedBound_list :: (Ord a, Num a, Bits a, Integral a)- => Int- -> a -> [Word8]-genVarFixedBound_list n x- | n <= 1 = sevenBits : []- | otherwise = (sevenBits .|. 0x80) : genVarFixedBound_list (n - 1) (x `shiftR` 7)- where- sevenBits = fromIntegral x .&. 0x7f--wordVarFixedBound_list :: Word -> Word -> [Word8]-wordVarFixedBound_list bound = genVarFixedBound_list (length $ genVar_list bound)--word64VarFixedBound_list :: Word64 -> Word64 -> [Word8]-word64VarFixedBound_list bound = genVarFixedBound_list (length $ genVar_list bound)---- Somehow this function doesn't really make sense, as the bound must be--- greater when interpreted as an unsigned integer.------ intVarFixedBound_list :: Int -> Int -> [Word8]--- intVarFixedBound_list bound = wordVarFixedBound_list (fromIntegral bound) . fromIntegral-- ------------------------------------------------------------------------------ -- Latin-1 aka Char8 ------------------------------------------------------------------------------@@ -253,45 +126,9 @@ , testF "floatHexFixed" floatHexFixed_list BP.floatHexFixed , testF "doubleHexFixed" doubleHexFixed_list BP.doubleHexFixed-- , testFixedBoundF "wordDecFixedBound"- (genDecFixedBound_list 'x') (BP.wordDecFixedBound 'x')-- , testFixedBoundF "word64DecFixedBound"- (genDecFixedBound_list 'x') (BP.word64DecFixedBound 'x')-- , testFixedBoundF "wordHexFixedBound"- (genHexFixedBound_list 'x') (BP.wordHexFixedBound 'x')-- , testFixedBoundF "word64HexFixedBound"- (genHexFixedBound_list 'x') (BP.word64HexFixedBound 'x') ] --- | PRE: positive bound and value.-genDecFixedBound_list :: (Show a, Integral a)- => Char -- ^ Padding character.- -> a -- ^ Max value to be encoded.- -> a -- ^ Value to encode.- -> [Word8]-genDecFixedBound_list padChar bound =- encodeASCII . pad . show- where- n = length $ show bound- pad cs = replicate (n - length cs) padChar ++ cs --- | PRE: positive bound and value.-genHexFixedBound_list :: (Show a, Integral a)- => Char -- ^ Padding character.- -> a -- ^ Max value to be encoded.- -> a -- ^ Value to encode.- -> [Word8]-genHexFixedBound_list padChar bound =- encodeASCII . pad . (`showHex` "")- where- n = length $ (`showHex` "") bound- pad cs = replicate (n - length cs) padChar ++ cs-- ------------------------------------------------------------------------------ -- UTF-8 ------------------------------------------------------------------------------@@ -329,9 +166,3 @@ encViaBuilder = BP.primMapListBounded $ maybeB (BP.liftFixedToBounded $ (\_ -> 112) BP.>$< BP.word8) (ord BP.>$< (BP.liftFixedToBounded $ BP.intHost))------
tests/builder/Data/ByteString/Builder/Tests.hs view
@@ -18,7 +18,7 @@ import Control.Monad.State import Control.Monad.Writer -import Foreign (Word, Word8, Word64, minusPtr)+import Foreign (Word, Word8, minusPtr) import System.IO.Unsafe (unsafePerformIO) import Data.Char (ord, chr)@@ -28,18 +28,15 @@ import qualified Data.ByteString as S import qualified Data.ByteString.Internal as S import qualified Data.ByteString.Lazy as L+import qualified Data.ByteString.Short as Sh import Data.ByteString.Builder import Data.ByteString.Builder.Extra-import Data.ByteString.Builder.ASCII import Data.ByteString.Builder.Internal (Put, putBuilder, fromPut) import qualified Data.ByteString.Builder.Internal as BI import qualified Data.ByteString.Builder.Prim as BP-import qualified Data.ByteString.Builder.Prim.Extra as BP import Data.ByteString.Builder.Prim.TestUtils -import Numeric (readHex)- import Control.Exception (evaluate) import System.IO (openTempFile, hPutStr, hClose, hSetBinaryMode) #if MIN_VERSION_base(4,2,0)@@ -48,7 +45,13 @@ import System.Directory import Foreign (ForeignPtr, withForeignPtr, castPtr) +#if defined(HAVE_TEST_FRAMEWORK)+import Test.Framework+import Test.Framework.Providers.QuickCheck2+#else import TestFramework+#endif+ import Test.QuickCheck ( Arbitrary(..), oneof, choose, listOf, elements ) import Test.QuickCheck.Property@@ -182,6 +185,7 @@ data Action = SBS Mode S.ByteString | LBS Mode L.ByteString+ | ShBS Sh.ShortByteString | W8 Word8 | W8S [Word8] | String String@@ -207,6 +211,7 @@ renderAction (SBS _ bs) = tell $ D.fromList $ S.unpack bs renderAction (LBS Hex lbs) = tell $ foldMap hexWord8 $ L.unpack lbs renderAction (LBS _ lbs) = tell $ renderLBS lbs+ renderAction (ShBS sbs) = tell $ D.fromList $ Sh.unpack sbs renderAction (W8 w) = tell $ return w renderAction (W8S ws) = tell $ D.fromList ws renderAction (String cs) = tell $ foldMap (D.fromList . charUtf8_list) cs@@ -234,6 +239,7 @@ buildAction (LBS Copy lbs) = lift $ putBuilder $ lazyByteStringCopy lbs buildAction (LBS Insert lbs) = lift $ putBuilder $ lazyByteStringInsert lbs buildAction (LBS (Threshold i) lbs) = lift $ putBuilder $ lazyByteStringThreshold i lbs+buildAction (ShBS sbs) = lift $ putBuilder $ shortByteString sbs buildAction (W8 w) = lift $ putBuilder $ word8 w buildAction (W8S ws) = lift $ putBuilder $ BP.primMapListFixed BP.word8 ws buildAction (String cs) = lift $ putBuilder $ stringUtf8 cs@@ -295,6 +301,7 @@ arbitrary = oneof [ SBS <$> arbitrary <*> arbitrary , LBS <$> arbitrary <*> arbitrary+ , ShBS . Sh.toShort <$> arbitrary , W8 <$> arbitrary , W8S <$> listOf arbitrary -- ensure that larger character codes are also tested@@ -314,6 +321,8 @@ shrink (LBS m lbs) = (LBS <$> shrink m <*> pure lbs) <|> (LBS <$> pure m <*> shrink lbs)+ shrink (ShBS sbs) =+ ShBS . Sh.toShort <$> shrink (Sh.fromShort sbs) shrink (W8 w) = W8 <$> shrink w shrink (W8S ws) = W8S <$> shrink ws shrink (String cs) = String <$> shrink cs@@ -353,22 +362,6 @@ testsEncodingToBuilder = [ test_encodeUnfoldrF , test_encodeUnfoldrB-- , compareImpls "encodeSize/Chunked/Size/Chunked (recipe)"- (testBuilder id)- (- parseChunks parseHexLen .- parseSizePrefix parseHexLen .- parseChunks parseVar .- parseSizePrefix parseHexLen .- testBuilder (- prefixHexSize .- encodeVar .- prefixHexSize .- encodeHex- )- )- ] @@ -399,73 +392,6 @@ go (c:cs) = Just (c, cs) --- Chunked encoding and size prefix--------------------------------------testBuilder :: (Builder -> Builder) -> Recipe -> L.ByteString-testBuilder f recipe =- toLBS (f b)- where- (b, toLBS) = recipeComponents $ clearTail recipe- -- need to remove tail of recipe to have a tighter- -- check on encodeWithSize- clearTail (Recipe how firstSize otherSize _ as) =- Recipe how firstSize otherSize L.empty as---- | Chunked encoding using base-128, variable-length encoding for the--- chunk-size.-encodeVar :: Builder -> Builder-encodeVar =- (`mappend` BP.primFixed BP.word8 0)- . (BP.encodeChunked 5 BP.word64VarFixedBound BP.emptyB)---- | Chunked encoding using 0-padded, space-terminated hexadecimal numbers--- for encoding the chunk-size.-encodeHex :: Builder -> Builder-encodeHex =- (`mappend` BP.primFixed (hexLen 0) 0)- . (BP.encodeChunked 7 hexLen BP.emptyB)--hexLen :: Word64 -> BP.FixedPrim Word64-hexLen bound =- (\x -> (x, ' ')) BP.>$< (BP.word64HexFixedBound '0' bound BP.>*< BP.char8)--parseHexLen :: [Word8] -> (Int, [Word8])-parseHexLen ws = case span (/= 32) ws of- (lenWS, 32:ws') -> case readHex (map (chr . fromIntegral) lenWS) of- [(len, [])] -> (len, ws')- _ -> error $ "hex parse failed: " ++ show ws- (_, _) -> error $ "unterminated hex-length:" ++ show ws--parseChunks :: ([Word8] -> (Int, [Word8])) -> L.ByteString -> L.ByteString-parseChunks parseLen =- L.pack . go . L.unpack- where- go ws- | chunkLen == 0 = rest- | chunkLen <= length ws' = chunk ++ go rest- | otherwise = error $ "too few bytes: " ++ show ws- where- (chunkLen, ws') = parseLen ws- (chunk, rest) = splitAt chunkLen ws'----- | Prefix with size. We use an inner buffer size of 77 (almost primes are good) to--- get several buffer full signals.-prefixHexSize :: Builder -> Builder-prefixHexSize = BP.encodeWithSize 77 hexLen--parseSizePrefix :: ([Word8] -> (Int, [Word8])) -> L.ByteString -> L.ByteString-parseSizePrefix parseLen =- L.pack . go . L.unpack- where- go ws- | len <= length ws' = take len ws'- | otherwise = error $ "too few bytes: " ++ show (len, ws, ws')- where- (len, ws') = parseLen ws-- ------------------------------------------------------------------------------ -- Testing the Put monad ------------------------------------------------------------------------------@@ -644,7 +570,7 @@ , testBuilderConstr "word64Dec" dec_list word64Dec , testBuilderConstr "wordDec" dec_list wordDec - , testBuilderConstr "integerDec" dec_list integerDec+ , testBuilderConstr "integerDec" (dec_list . enlarge) (integerDec . enlarge) , testBuilderConstr "floatDec" dec_list floatDec , testBuilderConstr "doubleDec" dec_list doubleDec @@ -667,6 +593,8 @@ , testBuilderConstr "floatHexFixed" floatHexFixed_list floatHexFixed , testBuilderConstr "doubleHexFixed" doubleHexFixed_list doubleHexFixed ]+ where+ enlarge (n, e) = n ^ (abs (e `mod` (50 :: Integer))) testsChar8 :: [Test] testsChar8 =
tests/builder/TestSuite.hs view
@@ -1,11 +1,13 @@+{-# LANGUAGE CPP #-} module Main where ---import Test.Framework (defaultMain, Test, testGroup)- import qualified Data.ByteString.Builder.Tests import qualified Data.ByteString.Builder.Prim.Tests+#if defined(HAVE_TEST_FRAMEWORK)+import Test.Framework (defaultMain, Test, testGroup)+#else import TestFramework-+#endif main :: IO () main = defaultMain tests@@ -18,4 +20,3 @@ , testGroup "Data.ByteString.Lazy.Builder.BasicEncoding" Data.ByteString.Builder.Prim.Tests.tests ]-