diff --git a/Data/ByteString.hs b/Data/ByteString.hs --- a/Data/ByteString.hs +++ b/Data/ByteString.hs @@ -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 -> diff --git a/Data/ByteString/Builder.hs b/Data/ByteString/Builder.hs --- a/Data/ByteString/Builder.hs +++ b/Data/ByteString/Builder.hs @@ -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 diff --git a/Data/ByteString/Builder/ASCII.hs b/Data/ByteString/Builder/ASCII.hs --- a/Data/ByteString/Builder/ASCII.hs +++ b/Data/ByteString/Builder/ASCII.hs @@ -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 +-- . 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 diff --git a/Data/ByteString/Builder/Extra.hs b/Data/ByteString/Builder/Extra.hs --- a/Data/ByteString/Builder/Extra.hs +++ b/Data/ByteString/Builder/Extra.hs @@ -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 + ------------------------------------------------------------------------------ diff --git a/Data/ByteString/Builder/Internal.hs b/Data/ByteString/Builder/Internal.hs --- a/Data/ByteString/Builder/Internal.hs +++ b/Data/ByteString/Builder/Internal.hs @@ -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 (). +-- +-- @ +--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 diff --git a/Data/ByteString/Builder/Prim.hs b/Data/ByteString/Builder/Prim.hs --- a/Data/ByteString/Builder/Prim.hs +++ b/Data/ByteString/Builder/Prim.hs @@ -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. . ) 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 --} diff --git a/Data/ByteString/Builder/Prim/ASCII.hs b/Data/ByteString/Builder/Prim/ASCII.hs --- a/Data/ByteString/Builder/Prim/ASCII.hs +++ b/Data/ByteString/Builder/Prim/ASCII.hs @@ -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. diff --git a/Data/ByteString/Builder/Prim/Binary.hs b/Data/ByteString/Builder/Prim/Binary.hs --- a/Data/ByteString/Builder/Prim/Binary.hs +++ b/Data/ByteString/Builder/Prim/Binary.hs @@ -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) diff --git a/Data/ByteString/Builder/Prim/Extra.hs b/Data/ByteString/Builder/Prim/Extra.hs deleted file mode 100644 --- a/Data/ByteString/Builder/Prim/Extra.hs +++ /dev/null @@ -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 -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 (). 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 -. 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 - (). -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 -or Google's protocol buffers 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 - diff --git a/Data/ByteString/Builder/Prim/Internal.hs b/Data/ByteString/Builder/Prim/Internal.hs --- a/Data/ByteString/Builder/Prim/Internal.hs +++ b/Data/ByteString/Builder/Prim/Internal.hs @@ -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 - --} - - - diff --git a/Data/ByteString/Builder/Prim/Internal/Base16.hs b/Data/ByteString/Builder/Prim/Internal/Base16.hs --- a/Data/ByteString/Builder/Prim/Internal/Base16.hs +++ b/Data/ByteString/Builder/Prim/Internal/Base16.hs @@ -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 --} diff --git a/Data/ByteString/Builder/Prim/Internal/Floating.hs b/Data/ByteString/Builder/Prim/Internal/Floating.hs --- a/Data/ByteString/Builder/Prim/Internal/Floating.hs +++ b/Data/ByteString/Builder/Prim/Internal/Floating.hs @@ -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 diff --git a/Data/ByteString/Builder/Prim/Internal/UncheckedShifts.hs b/Data/ByteString/Builder/Prim/Internal/UncheckedShifts.hs --- a/Data/ByteString/Builder/Prim/Internal/UncheckedShifts.hs +++ b/Data/ByteString/Builder/Prim/Internal/UncheckedShifts.hs @@ -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 diff --git a/Data/ByteString/Char8.hs b/Data/ByteString/Char8.hs --- a/Data/ByteString/Char8.hs +++ b/Data/ByteString/Char8.hs @@ -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] diff --git a/Data/ByteString/Internal.hs b/Data/ByteString/Internal.hs --- a/Data/ByteString/Internal.hs +++ b/Data/ByteString/Internal.hs @@ -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 -- diff --git a/Data/ByteString/Lazy.hs b/Data/ByteString/Lazy.hs --- a/Data/ByteString/Lazy.hs +++ b/Data/ByteString/Lazy.hs @@ -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) diff --git a/Data/ByteString/Lazy/Builder/ASCII.hs b/Data/ByteString/Lazy/Builder/ASCII.hs --- a/Data/ByteString/Lazy/Builder/ASCII.hs +++ b/Data/ByteString/Lazy/Builder/ASCII.hs @@ -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 diff --git a/Data/ByteString/Lazy/Internal.hs b/Data/ByteString/Lazy/Internal.hs --- a/Data/ByteString/Lazy/Internal.hs +++ b/Data/ByteString/Lazy/Internal.hs @@ -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 diff --git a/Data/ByteString/Short.hs b/Data/ByteString/Short.hs new file mode 100644 --- /dev/null +++ b/Data/ByteString/Short.hs @@ -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 () + diff --git a/Data/ByteString/Short/Internal.hs b/Data/ByteString/Short/Internal.hs new file mode 100644 --- /dev/null +++ b/Data/ByteString/Short/Internal.hs @@ -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 + diff --git a/Data/ByteString/Unsafe.hs b/Data/ByteString/Unsafe.hs --- a/Data/ByteString/Unsafe.hs +++ b/Data/ByteString/Unsafe.hs @@ -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/: -- diff --git a/bench/BenchAll.hs b/bench/BenchAll.hs deleted file mode 100644 --- a/bench/BenchAll.hs +++ /dev/null @@ -1,243 +0,0 @@ -{-# LANGUAGE PackageImports, ScopedTypeVariables, BangPatterns #-} --- | --- Copyright : (c) 2011 Simon Meier --- License : BSD3-style (see LICENSE) --- --- Maintainer : Simon Meier --- 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 - ] - ] diff --git a/bench/BoundsCheckFusion.hs b/bench/BoundsCheckFusion.hs deleted file mode 100644 --- a/bench/BoundsCheckFusion.hs +++ /dev/null @@ -1,127 +0,0 @@ -{-# LANGUAGE PackageImports, ScopedTypeVariables, BangPatterns #-} --- | --- Copyright : (c) 2011 Simon Meier --- License : BSD3-style (see LICENSE) --- --- Maintainer : Simon Meier --- 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)) - #-} - diff --git a/bytestring.cabal b/bytestring.cabal --- a/bytestring.cabal +++ b/bytestring.cabal @@ -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 , Duncan Coutts -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 diff --git a/cbits/fpstring.c b/cbits/fpstring.c --- a/cbits/fpstring.c +++ b/cbits/fpstring.c @@ -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); +} diff --git a/cbits/itoa.c b/cbits/itoa.c --- a/cbits/itoa.c +++ b/cbits/itoa.c @@ -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'; } } diff --git a/tests/Properties.hs b/tests/Properties.hs --- a/tests/Properties.hs +++ b/tests/Properties.hs @@ -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 ] + diff --git a/tests/Rules.hs b/tests/Rules.hs --- a/tests/Rules.hs +++ b/tests/Rules.hs @@ -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) diff --git a/tests/TestFramework.hs b/tests/TestFramework.hs --- a/tests/TestFramework.hs +++ b/tests/TestFramework.hs @@ -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)] diff --git a/tests/builder/Data/ByteString/Builder/Prim/TestUtils.hs b/tests/builder/Data/ByteString/Builder/Prim/TestUtils.hs --- a/tests/builder/Data/ByteString/Builder/Prim/TestUtils.hs +++ b/tests/builder/Data/ByteString/Builder/Prim/TestUtils.hs @@ -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) - - diff --git a/tests/builder/Data/ByteString/Builder/Prim/Tests.hs b/tests/builder/Data/ByteString/Builder/Prim/Tests.hs --- a/tests/builder/Data/ByteString/Builder/Prim/Tests.hs +++ b/tests/builder/Data/ByteString/Builder/Prim/Tests.hs @@ -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)) - - - - - - diff --git a/tests/builder/Data/ByteString/Builder/Tests.hs b/tests/builder/Data/ByteString/Builder/Tests.hs --- a/tests/builder/Data/ByteString/Builder/Tests.hs +++ b/tests/builder/Data/ByteString/Builder/Tests.hs @@ -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 = diff --git a/tests/builder/TestSuite.hs b/tests/builder/TestSuite.hs --- a/tests/builder/TestSuite.hs +++ b/tests/builder/TestSuite.hs @@ -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 ] -