diff --git a/Data/ByteString/FastBuilder.hs b/Data/ByteString/FastBuilder.hs new file mode 100644 --- /dev/null +++ b/Data/ByteString/FastBuilder.hs @@ -0,0 +1,129 @@ +-- | An efficient implementation of ByteString builder. +-- +-- In many cases, this module works as a drop-in replacement for +-- Data.ByteString.Builder, and should improve speed. However, one caveat +-- applies: when using 'toLazyByteString', if you consume the result +-- in a bound thread, performance degrades significantly. See the +-- documentation for 'toLazyByteString' for details. +-- +-- Sometimes performance can be greatly improved by inserting calls to +-- 'rebuild' to your program. See the documentation for 'rebuild' for +-- details. +module Data.ByteString.FastBuilder + ( + -- * The type + + Builder + + -- * Running a builder + , toLazyByteString + , toLazyByteStringWith + , toStrictByteString + , hPutBuilder + + -- * Performance tuning + , rebuild + + -- * Basic builders + , primBounded + , primFixed + , byteString + , byteStringInsert + , byteStringCopy + , byteStringThreshold + + -- * Single byte + , int8 + , word8 + + -- * Little endian + , int16LE + , int32LE + , int64LE + + , word16LE + , word32LE + , word64LE + + , floatLE + , doubleLE + + -- * Big endian + , int16BE + , int32BE + , int64BE + + , word16BE + , word32BE + , word64BE + + , floatBE + , doubleBE + + -- * Host-dependent size and byte order, non-portable + , intHost + , int16Host + , int32Host + , int64Host + + , wordHost + , word16Host + , word32Host + , word64Host + + , floatHost + , doubleHost + + -- * Decimal + , intDec + , int8Dec + , int16Dec + , int32Dec + , int64Dec + + , wordDec + , word8Dec + , word16Dec + , word32Dec + , word64Dec + + , integerDec + , floatDec + , doubleDec + + -- * Hexadecimal + , wordHex + , word8Hex + , word16Hex + , word32Hex + , word64Hex + + -- * Fixed-width hexadecimal + , int8HexFixed + , int16HexFixed + , int32HexFixed + , int64HexFixed + + , word8HexFixed + , word16HexFixed + , word32HexFixed + , word64HexFixed + + , floatHexFixed + , doubleHexFixed + + -- * UTF-8 + , charUtf8 + , stringUtf8 + + -- * ASCII + , char7 + , string7 + + -- * ISO-8859-1 + , char8 + , string8 + ) where + +import Data.ByteString.FastBuilder.Internal +import Data.ByteString.FastBuilder.Internal.Prim diff --git a/Data/ByteString/FastBuilder/Internal.hs b/Data/ByteString/FastBuilder/Internal.hs new file mode 100644 --- /dev/null +++ b/Data/ByteString/FastBuilder/Internal.hs @@ -0,0 +1,731 @@ +{-# LANGUAGE MagicHash #-} +{-# LANGUAGE UnboxedTuples #-} +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE DeriveFunctor #-} +{-# LANGUAGE RankNTypes #-} + +-- | This is an internal module; its interface is unstable. +module Data.ByteString.FastBuilder.Internal + ( + -- * Builder and related types + Builder(..) + , BuilderArg(..) + , DataSink(..) + , DynamicSink(..) + , Queue(..) + , Request(..) + , Response(..) + + -- * Internally used exceptions + , SuspendBuilderException(..) + , ChunkOverflowException(..) + + -- * Builder building blocks + , Builder_ + , BuildM(..) + , toBuilder_ + , fromBuilder_ + , mkBuilder + , useBuilder + , getSink + , getCur + , getEnd + , setCur + , setEnd + + -- * Running builders + , runBuilder + , toLazyByteString + , toLazyByteStringWith + , toStrictByteString + , hPutBuilder + + -- * Basic builders + , primBounded + , primFixed + , primMapListBounded + , primMapListFixed + , byteString + , byteStringThreshold + , byteStringCopy + , byteStringCopyNoCheck + , byteStringInsert + , unsafeCString + , ensureBytes + , getBytes + + -- * Performance tuning + , rebuild + ) where + +import Control.Concurrent (forkIOWithUnmask, myThreadId) +import Control.Concurrent.MVar +import qualified Control.Exception as E +import Control.Monad +import qualified Data.ByteString as S +import qualified Data.ByteString.Internal as S +import qualified Data.ByteString.Unsafe as S +import qualified Data.ByteString.Lazy as L +import Data.IORef +import Data.Monoid +import Data.String +import Data.Word +import Foreign.C.String +import Foreign.C.Types +import Foreign.ForeignPtr +import Foreign.ForeignPtr.Unsafe +import Foreign.Marshal.Utils +import Foreign.Ptr +import qualified System.IO as IO +import System.IO.Unsafe + +import GHC.Exts (Addr#, State#, RealWorld, Ptr(..), Int(..), Int#) +import GHC.Magic (oneShot) +import GHC.IO (IO(..)) +import GHC.CString (unpackCString#) + +import qualified Data.ByteString.Builder.Prim as P +import qualified Data.ByteString.Builder.Prim.Internal as PI +import qualified Data.ByteString.Builder.Extra as X + +-- | 'Builder' is an auxiliary type for efficiently generating a long +-- 'L.ByteString'. It is isomorphic to lazy 'L.ByteString', but offers +-- constant-time concatanation via '<>'. +-- +-- Use 'toLazyByteString' to turn a 'Builder' into a 'L.ByteString' +newtype Builder = Builder + { unBuilder + :: BuilderArg -> State# RealWorld -> (# Addr#, Addr#, State# RealWorld #) + } + -- It takes and returns two pointers, "cur" and "end". "cur" points to + -- the next location to put bytes to, and "end" points to the end of the + -- buffer. + +-- | This datatype exists only to work around the limitation that 'oneShot' +-- cannot work with unboxed argument types. +data BuilderArg = BuilderArg + DataSink + {-# UNPACK #-} !(Ptr Word8) -- "cur" pointer + {-# UNPACK #-} !(Ptr Word8) -- "end" pointer + +instance Monoid Builder where + mempty = Builder $ \(BuilderArg _ (Ptr cur) (Ptr end)) s -> (# cur, end, s #) + {-# INLINE mempty #-} + mappend (Builder a) (Builder b) = Builder $ \(BuilderArg dex (Ptr cur) (Ptr end)) s -> + case a (BuilderArg dex (Ptr cur) (Ptr end)) s of + (# cur', end', s' #) -> b (BuilderArg dex (Ptr cur') (Ptr end')) s' + {-# INLINE mappend #-} + mconcat xs = foldr mappend mempty xs + {-# INLINE mconcat #-} + +-- | 'fromString' = 'stringUtf8' +instance IsString Builder where + fromString = builderFromString + {-# INLINE fromString #-} + +-- | Specifies where bytes generated by a builder go. +data DataSink + = DynamicSink !(IORef DynamicSink) + -- ^ The destination of data changes while the builder is running. + | GrowingBuffer !(IORef (ForeignPtr Word8)) + -- ^ Bytes are accumulated in a contiguous buffer. + | HandleSink !IO.Handle !(IORef Queue) + -- ^ Bytes are first accumulated in the 'Queue', then flushed to the + -- 'IO.Handle'. + +-- | Variable-destination cases. +data DynamicSink + = ThreadedSink !(MVar Request) !(MVar Response) + -- ^ Bytes are sent to another thread. + | BoundedGrowingBuffer {-# UNPACK #-} !(ForeignPtr Word8) !Int{-bound-} + -- ^ Bytes are accumulated in a contiguous buffer until the + -- size limit is reached. After that, the destination switches + -- to a 'ThreadedSink'. + +-- | A mutable buffer. The 'Int' specifies where the data start. +data Queue = Queue !(ForeignPtr Word8) !Int{-start-} + +-- | A request from the driver thread to the builder thread. +data Request + = Request {-# UNPACK #-} !(Ptr Word8) {-# UNPACK #-} !(Ptr Word8) + +-- | A response from the builder thread to the driver thread. +data Response + = Error E.SomeException + -- ^ A synchronous exception was thrown by the builder + | Done !(Ptr Word8) + -- ^ The builder thread has completed. + | MoreBuffer !(Ptr Word8) !Int + -- ^ The builder thread has finished generating one chunk, + -- and waits for another request with the specified minimum size. + | InsertByteString !(Ptr Word8) !S.ByteString + -- ^ The builder thread has partially filled the current chunk, + -- and wants to emit the bytestring to be included in the final + -- output. + deriving (Show) + +---------------------------------------------------------------- +-- Internally used exceptions + +-- | Used in the implementation of 'toLazyByteString'. This is an exception +-- thrown by the consumer thread to itself when it has finished filling the +-- first chunk of the output. After this, a thread will be forked, and the +-- execution of the builder will be resumed in the new thread, using +-- 'ThreadedSink'. +data ChunkOverflowException + = ChunkOverflowException + !S.ByteString !(MVar Request) !(MVar Response) !Int + +instance Show ChunkOverflowException where + show (ChunkOverflowException buf _ _ req) = + "ChunkOverflowException " ++ show buf ++ " _ _ " ++ show req + +instance E.Exception ChunkOverflowException + +-- | Used in the implementation of 'toLazyByteString'. This is a message sent +-- from the consumer thread to the builder thread, requesting the builder +-- thread to temporarily pause execution. Later, the consumer thread may +-- request resumption by filling the 'MVar'. +data SuspendBuilderException = SuspendBuilderException !(MVar ()) + +instance Show SuspendBuilderException where + show _ = "SuspendBuilderException" + +instance E.Exception SuspendBuilderException + +---------------------------------------------------------------- +-- Builder building blocks + +-- | An internal type that is isomorphic to 'Builder'. This is a +-- maximaly efficient representation for NOINLINE functions. +type Builder_ + = DataSink -> Addr# -> Addr# -> State# RealWorld + -> (# Addr#, Addr#, State# RealWorld #) + +-- | Convert a 'Builder' into a 'Builder_'. +toBuilder_ :: Builder -> Builder_ +toBuilder_ (Builder f) dex cur end s = f (BuilderArg dex (Ptr cur) (Ptr end)) s + +-- | Convert a 'Builder_' into a 'Builder'. +fromBuilder_ :: Builder_ -> Builder +fromBuilder_ f = Builder $ \(BuilderArg dex (Ptr cur) (Ptr end)) s -> f dex cur end s + +-- | An internal type for making it easier to define builders. A value of +-- @'BuildM' a@ can do everything a 'Builder' can do, and in addition, +-- returns a value of type @a@ upon completion. +newtype BuildM a = BuildM { runBuildM :: (a -> Builder) -> Builder } + deriving (Functor) + +instance Applicative BuildM where + pure = return + (<*>) = ap + +instance Monad BuildM where + return x = BuildM $ \k -> k x + {-# INLINE return #-} + BuildM b >>= f = BuildM $ \k -> b $ \r -> runBuildM (f r) k + {-# INLINE (>>=) #-} + +-- | Create a builder from a BuildM. +mkBuilder :: BuildM () -> Builder +mkBuilder (BuildM bb) = bb $ \_ -> mempty +{-# INLINE mkBuilder #-} + +-- | Embed a builder in the BuildM context. +useBuilder :: Builder -> BuildM () +useBuilder b = BuildM $ \k -> b <> k () +{-# INLINE useBuilder #-} + +-- | Get the 'DataSink'. +getSink :: BuildM DataSink +getSink = BuildM $ \k -> Builder $ \(BuilderArg dex cur end) s -> + unBuilder (k dex) (BuilderArg dex cur end) s + +-- | Get the current pointer. +getCur :: BuildM (Ptr Word8) +getCur = BuildM $ \k -> Builder $ \(BuilderArg dex cur end) s -> + unBuilder (k cur) (BuilderArg dex cur end) s + +-- | Get the end-of-buffer pointer. +getEnd :: BuildM (Ptr Word8) +getEnd = BuildM $ \k -> Builder $ \(BuilderArg dex cur end) s -> + unBuilder (k end) (BuilderArg dex cur end) s + +-- | Set the current pointer. +setCur :: Ptr Word8 -> BuildM () +setCur p = BuildM $ \k -> Builder $ \(BuilderArg dex _ end) s -> + unBuilder (k ()) (BuilderArg dex p end) s + +-- | Set the end-of-buffer pointer. +setEnd :: Ptr Word8 -> BuildM () +setEnd p = BuildM $ \k -> Builder $ \(BuilderArg dex cur _) s -> + unBuilder (k ()) (BuilderArg dex cur p) s + +-- | Perform IO. +io :: IO a -> BuildM a +io (IO x) = BuildM $ \k -> Builder $ \ba s -> case x s of + (# s', val #) -> unBuilder (k val) ba s' + +---------------------------------------------------------------- +-- +-- Running builders. + +-- | Run a builder. +runBuilder :: Builder -> DataSink -> Ptr Word8 -> Ptr Word8 -> IO (Ptr Word8) +runBuilder (Builder f) sink !cur !end = IO $ \s -> + case f (BuilderArg sink cur end) s of + (# cur', _, s' #) -> (# s', Ptr cur' #) + +-- | Turn a 'Builder' into a lazy 'L.ByteString'. +-- +-- __Performance hint__: when the resulting 'L.ByteString' does not fit +-- in one chunk, this function forks a thread. Due to this, the performance +-- degrades sharply if you use this function from a bound thread. Note in +-- particular that the main thread is a bound thread when you use @ghc +-- -threaded@. +-- +-- To avoid this problem, do one of these: +-- +-- * Make sure the resulting 'L.ByteString' is consumed in an unbound +-- thread. Consider using 'runInUnboundThread' for this. +-- * Use other function to run the 'Builder' instead. Functions that don't +-- return a lazy 'L.ByteString' do not have this issue. +-- * Link your program without @-threaded@. +toLazyByteString :: Builder -> L.ByteString +toLazyByteString = toLazyByteStringWith 100 32768 + +-- | Like 'toLazyByteString', but allows the user to specify the initial +-- and the subsequent desired buffer sizes. +toLazyByteStringWith :: Int -> Int -> Builder -> L.ByteString + +-- The implementation employs a two-phase strategy to minimize the overhead: +-- +-- 0. Fill the first chunk in a single-threaded way. Start from 'initialSize'- +-- sized buffer and double the size whenever the buffer is full. This uses a +-- 'BoundedGrowingBuffer' sink. +-- +-- 1. If the first chunk is big enough and the builder still hasn't finished, +-- suspend the execution of the builder, fork a new thread and resume +-- execution of the builder in the new thread, using a 'ThreadedSink'. +toLazyByteStringWith !initialSize !maxSize builder = unsafePerformIO $ do + fptr <- mallocForeignPtrBytes initialSize + sink <- newIORef $ BoundedGrowingBuffer fptr maxSize + let !base = unsafeForeignPtrToPtr fptr + let + finalPtr = unsafeDupablePerformIO $ + -- The use of unsafeDupablePerformIO is safe here, because at any given + -- time, at most one thread can be attempting to evaluate this finalPtr + -- thunk. + runBuilder builder (DynamicSink sink) base (base `plusPtr` initialSize) + {-# NOINLINE finalPtr #-} + + loop thunk = do + -- Pass around `thunk` as an argument, otherwise GHC 7.10.1 inlines it + -- despite the NOINLINE pragma. + r <- E.try $ E.evaluate thunk + case r of + Right p -> do + BoundedGrowingBuffer finalFptr _ <- readIORef sink + let !finalBase = unsafeForeignPtrToPtr finalFptr + return $! L.fromStrict $ + S.fromForeignPtr finalFptr 0 (p `minusPtr` finalBase) + Left ex + | Just (ChunkOverflowException chunk reqV respV minSize) + <- E.fromException ex + -> do + let rest = continueBuilderThreaded reqV respV minSize maxSize thunk + return $ L.fromChunks $ + if S.null chunk then rest else chunk : rest + | otherwise -> do + -- Here, there is no way to tell whether 'ex' is an asynchronous + -- exception or not. We re-throw is as if it were async. This is + -- a safe assumption, because if it is actually a synchronous + -- exception, it will be re-thrown when we try to resume + -- the evaluation of 'thunk'. + myTid <- myThreadId + E.throwTo myTid ex + + loop thunk + + loop finalPtr + +-- | Continue a suspended builder using threads. +continueBuilderThreaded + :: MVar Request -> MVar Response -> Int -> Int -> Ptr Word8 + -> [S.ByteString] +continueBuilderThreaded !reqV !respV !initialSize !maxSize thunk = + makeChunks (max maxSize initialSize) maxSize $ toBufferWriter reqV respV thunk + +-- | Run the given suspended builder using a new thread. +toBufferWriter :: MVar Request -> MVar Response -> Ptr Word8 -> X.BufferWriter +toBufferWriter !reqV !respV thunk buf0 sz0 = E.mask_ $ do + writer Nothing buf0 sz0 + where + writer !maybeBuilderTid !buf !sz = do + putMVar reqV $ Request buf (buf `plusPtr` sz) + -- Fork after putMVar, in order to minimize the chance that + -- the new thread is scheduled on a different CPU. + builderTid <- case maybeBuilderTid of + Just t -> return t + Nothing -> forkIOWithUnmask $ \u -> + builderThreadWithUnmask u respV thunk + resp <- wait builderTid + let go cur next = return(written, next) + where !written = cur `minusPtr` buf + case resp of + Error ex -> E.throwIO ex + Done cur -> go cur X.Done + MoreBuffer cur k -> go cur $ X.More k $ writer (Just builderTid) + InsertByteString cur str -> go cur $ X.Chunk str $ writer (Just builderTid) + + wait !builderTid = do + r <- E.try $ takeMVar respV + case r of + Right resp -> return resp + Left exn -> do + -- exn must be an async exception, because takeMVar throws no + -- synchronous exceptions. + resumeVar <- newEmptyMVar + E.throwTo builderTid $ SuspendBuilderException resumeVar + thisTid <- myThreadId + E.throwTo thisTid (exn :: E.SomeException) + + -- A thunk containing this computation has been resumed. + -- Resume the builder thread, and retry. + putMVar resumeVar () + wait builderTid + +-- | The body of the builder thread. +builderThreadWithUnmask + :: (forall a. IO a -> IO a) -> MVar Response -> Ptr Word8 + -> IO () +builderThreadWithUnmask unmask !respV thunk = loop + where + loop = do + r <- E.try $ unmask $ E.evaluate thunk + case r of + Right p -> putMVar respV $ Done p + Left ex + | Just (SuspendBuilderException lock) <- E.fromException ex + -> do takeMVar lock; loop + | otherwise -> putMVar respV $ Error ex + +-- | Run a 'X.BufferWriter'. +makeChunks :: Int -> Int -> X.BufferWriter -> [S.ByteString] +makeChunks !initialBufSize maxBufSize = go initialBufSize + where + go !bufSize w = unsafePerformIO $ do + fptr <- S.mallocByteString bufSize + (written, next) <- withForeignPtr fptr $ \buf -> w buf bufSize + let rest = case next of + X.Done -> [] + X.More reqSize w' -> go (max reqSize maxBufSize) w' + X.Chunk chunk w' -> chunk : go maxBufSize w' + -- TODO: don't throw away the remaining part of the buffer + return $ if written == 0 + then rest + else S.fromForeignPtr fptr 0 written : rest + +-- | Turn a 'Builder' into a strict 'S.ByteString'. +toStrictByteString :: Builder -> S.ByteString +toStrictByteString builder = unsafePerformIO $ do + let cap = 100 + fptr <- mallocForeignPtrBytes cap + bufferRef <- newIORef fptr + let !base = unsafeForeignPtrToPtr fptr + cur <- runBuilder builder (GrowingBuffer bufferRef) base (base `plusPtr` cap) + endFptr <- readIORef bufferRef + let !written = cur `minusPtr` unsafeForeignPtrToPtr endFptr + return $ S.fromForeignPtr endFptr 0 written + +-- | Output a 'Builder' to a 'IO.Handle'. +hPutBuilder :: IO.Handle -> Builder -> IO () +hPutBuilder !h builder = do + let cap = 100 + fptr <- mallocForeignPtrBytes cap + qRef <- newIORef $ Queue fptr 0 + let !base = unsafeForeignPtrToPtr fptr + cur <- runBuilder builder (HandleSink h qRef) base (base `plusPtr` cap) + flushQueue h qRef cur + +---------------------------------------------------------------- +-- builders + +-- | Turn a 'String' into a 'Builder', using UTF-8, +builderFromString :: String -> Builder +builderFromString = primMapListBounded P.charUtf8 +{-# NOINLINE[0] builderFromString #-} + +{-# RULES "FastBuilder: builderFromString/unpackCString#" + forall addr. + builderFromString (unpackCString# addr) = unsafeCString (Ptr addr) + #-} + +-- | Turn a value of type @a@ into a 'Builder', using the given 'PI.BoundedPrim'. +primBounded :: PI.BoundedPrim a -> a -> Builder +primBounded prim !x = mappend (ensureBytes $ PI.sizeBound prim) $ mkBuilder $ do + cur <- getCur + cur' <- io $ PI.runB prim x cur + setCur cur' +{-# INLINE primBounded #-} + +-- | Turn a value of type @a@ into a 'Builder', using the given 'PI.FixedPrim'. +primFixed :: PI.FixedPrim a -> a -> Builder +primFixed prim x = primBounded (PI.toB prim) x +{-# INLINE primFixed #-} + +-- | Turn a list of values of type @a@ into a 'Builder', using the given +-- 'PI.BoundedPrim'. +primMapListBounded :: PI.BoundedPrim a -> [a] -> Builder +primMapListBounded prim = \xs -> mconcat $ map (primBounded prim) xs +{-# INLINE primMapListBounded #-} + +-- | Turn a list of values of type @a@ into a 'Builder', using the given +-- 'PI.FixedPrim'. +primMapListFixed :: PI.FixedPrim a -> [a] -> Builder +primMapListFixed prim = \xs -> primMapListBounded (PI.toB prim) xs +{-# INLINE primMapListFixed #-} + +-- | Turn a 'S.ByteString' to a 'Builder'. +byteString :: S.ByteString -> Builder +byteString = byteStringThreshold maximalCopySize +{-# INLINE byteString #-} + +maximalCopySize :: Int +maximalCopySize = 2 * X.smallChunkSize + +-- | Turn a 'S.ByteString' to a 'Builder'. If the size of the 'S.ByteString' +-- is larger than the given threshold, avoid copying it as much +-- as possible. +byteStringThreshold :: Int -> S.ByteString -> Builder +byteStringThreshold th bstr = rebuild $ + if S.length bstr >= th + then byteStringInsert bstr + else byteStringCopy bstr + +-- | Turn a 'S.ByteString' to a 'Builder'. The 'S.ByteString' will be copied +-- to the buffer, regardless of the size. +byteStringCopy :: S.ByteString -> Builder +byteStringCopy !bstr = + -- TODO: this is suboptimal; should keep using the same buffer size. + ensureBytes (S.length bstr) <> byteStringCopyNoCheck bstr + +-- | Like 'byteStringCopy', but assumes that the current buffer is large enough. +byteStringCopyNoCheck :: S.ByteString -> Builder +byteStringCopyNoCheck !bstr = mkBuilder $ do + cur <- getCur + io $ S.unsafeUseAsCString bstr $ \ptr -> + copyBytes cur (castPtr ptr) len + setCur $ cur `plusPtr` len + where + !len = S.length bstr + +-- | Turn a 'S.ByteString' to a 'Builder'. When possible, the given +-- 'S.ByteString' will not be copied, and inserted directly into the output +-- instead. +byteStringInsert :: S.ByteString -> Builder +byteStringInsert !bstr = fromBuilder_ $ byteStringInsert_ bstr + +-- | The body of the 'byteStringInsert', worker-wrappered manually. +byteStringInsert_ :: S.ByteString -> Builder_ +byteStringInsert_ bstr = toBuilder_ $ mkBuilder $ do + sink <- getSink + case sink of + DynamicSink dRef -> do + dyn <- io $ readIORef dRef + case dyn of + ThreadedSink reqV respV -> do + cur <- getCur + io $ putMVar respV $ InsertByteString cur bstr + handleRequest reqV + BoundedGrowingBuffer fptr bound -> do + r <- remainingBytes + when (r < S.length bstr) $ + growBufferBounded dRef fptr bound (S.length bstr) + -- TODO: insert rather than copy if the first chunk + -- is full. + useBuilder $ byteStringCopyNoCheck bstr + GrowingBuffer bufRef -> do + r <- remainingBytes + when (r < S.length bstr) $ + growBuffer bufRef (S.length bstr) + useBuilder $ byteStringCopyNoCheck bstr + HandleSink h queueRef -> do + cur <- getCur + io $ flushQueue h queueRef cur + io $ S.hPut h bstr +{-# NOINLINE byteStringInsert_ #-} + +-- | Turn a C String into a 'Builder'. The behavior is undefined if the given +-- 'CString' does not point to a constant null-terminated string. +unsafeCString :: CString -> Builder +unsafeCString cstr = rebuild $ let + !len = fromIntegral $ c_pure_strlen cstr + in + mappend (ensureBytes len) $ mkBuilder $ do + cur <- getCur + io $ copyBytes cur (castPtr cstr) len + setCur $ cur `plusPtr` len + +foreign import ccall unsafe "strlen" c_pure_strlen :: CString -> CSize + +-- | @'ensureBytes' n@ ensures that at least @n@ bytes of free space is +-- available in the current buffer, by allocating a new buffer when +-- necessary. +ensureBytes :: Int -> Builder +ensureBytes !n = mkBuilder $ do + r <- remainingBytes + when (r < n) $ useBuilder $ getBytes n +{-# INLINE ensureBytes #-} + +-- | @'getBytes' n@ allocates a new buffer, containing at least @n@ bytes. +getBytes :: Int -> Builder +getBytes (I# n) = fromBuilder_ (getBytes_ n) + +-- | The body of the 'getBytes' function, worker-wrappered manually. +getBytes_ :: Int# -> Builder_ +getBytes_ n = toBuilder_ $ mkBuilder $ do + sink <- getSink + case sink of + DynamicSink dRef -> do + dyn <- io $ readIORef dRef + case dyn of + ThreadedSink reqV respV -> do + cur <- getCur + io $ putMVar respV $ MoreBuffer cur $ I# n + handleRequest reqV + BoundedGrowingBuffer fptr bound -> + growBufferBounded dRef fptr bound (I# n) + GrowingBuffer bufRef -> growBuffer bufRef (I# n) + HandleSink h queueRef -> do + cur <- getCur + io $ flushQueue h queueRef cur + switchQueue queueRef $ max 4096 (I# n) +{-# NOINLINE getBytes_ #-} + +-- | Return the remaining size of the current buffer, in bytes. +remainingBytes :: BuildM Int +remainingBytes = minusPtr <$> getEnd <*> getCur +{-# INLINE remainingBytes #-} + +---------------------------------------------------------------- +-- Performance tuning + +-- | @'rebuild' b@ is equivalent to @b@, but it allows GHC to assume +-- that @b@ will be run at most once. This can enable various +-- optimizations that greately improves performance. +-- +-- There are two types of typical situations where a use of 'rebuild' +-- is often a win: +-- +-- * When constructing a builder using a recursive function. e.g. +-- @rebuild $ foldr ...@. +-- * When constructing a builder using a conditional expression. e.g. +-- @rebuild $ case x of ... @ +rebuild :: Builder -> Builder +rebuild (Builder f) = Builder $ oneShot (\ !arg s -> f arg s) + +---------------------------------------------------------------- +-- ThreadedSink + +-- | Wait for a request, and switch to a new buffer. +handleRequest :: MVar Request -> BuildM () +handleRequest reqV = do + Request newCur newEnd <- io $ takeMVar reqV + setCur newCur + setEnd newEnd + +---------------------------------------------------------------- +-- GrowingBuffer + +-- | @growBuffer bufRef req@ reallocates the buffer, growing it +-- by at least @req@. +growBuffer :: IORef (ForeignPtr Word8) -> Int -> BuildM () +growBuffer !bufRef !req = do + cur <- getCur + end <- getCur + fptr <- io $ readIORef bufRef + let !base = unsafeForeignPtrToPtr fptr + let !size = cur `minusPtr` base + let !cap = end `minusPtr` base + let !newCap = cap + max cap req + newFptr <- io $ mallocForeignPtrBytes newCap + let !newBase = unsafeForeignPtrToPtr newFptr + setCur $ newBase `plusPtr` size + setEnd $ newBase `plusPtr` newCap + io $ do + copyBytes newBase base size + touchForeignPtr fptr + touchForeignPtr newFptr + writeIORef bufRef newFptr +{-# INLINE growBuffer #-} + +---------------------------------------------------------------- +-- HandleSink + +-- | Put the content of the 'Queue' to the 'IO.Handle', and empty +-- the 'Queue'. +flushQueue :: IO.Handle -> IORef Queue -> Ptr Word8 -> IO () +flushQueue !h !qRef !cur = do + Queue fptr start <- readIORef qRef + let !end = cur `minusPtr` unsafeForeignPtrToPtr fptr + when (end > start) $ do + S.hPut h $ S.fromForeignPtr fptr start (end - start) + writeIORef qRef $ Queue fptr end + +-- | @switchQueue qRef minSize@ discards the old 'Queue' and sets up +-- a new empty 'Queue' of at least @minSize@ large. If the old 'Queue' +-- is large enough, it is re-used. +switchQueue :: IORef Queue -> Int -> BuildM () +switchQueue !qRef !minSize = do + end <- getCur + Queue fptr _ <- io $ readIORef qRef + let !base = unsafeForeignPtrToPtr fptr + let !cap = end `minusPtr` base + newFptr <- if minSize <= cap + then return fptr + else io $ mallocForeignPtrBytes minSize + let !newBase = unsafeForeignPtrToPtr newFptr + io $ writeIORef qRef $ Queue newFptr 0 + setCur newBase + setEnd $ newBase `plusPtr` max minSize cap + +---------------------------------------------------------------- +-- BoundedGrowingBuffer + +-- | @growBufferBounded dRef fptr bound req@ reallocates the buffer, growing it +-- by at least @req@. If the buffer size would exceed @bound@, it instead +-- interrupts execution by throwing a 'ChunkOverflowException', and switches +-- to a 'ThreadedSink'. +growBufferBounded + :: IORef DynamicSink -> ForeignPtr Word8 -> Int -> Int -> BuildM () +growBufferBounded !dRef !fptr !bound !req = do + cur <- getCur + end <- getCur + let !base = unsafeForeignPtrToPtr fptr + let !size = cur `minusPtr` base + let !cap = end `minusPtr` base + let !newCap = cap + max cap req + if bound < newCap + then chunkOverflow dRef req $ S.fromForeignPtr fptr 0 size + else do + newFptr <- io $ mallocForeignPtrBytes newCap + let !newBase = unsafeForeignPtrToPtr newFptr + setCur $ newBase `plusPtr` size + setEnd $ newBase `plusPtr` newCap + io $ do + copyBytes newBase base size + touchForeignPtr fptr + touchForeignPtr newFptr + writeIORef dRef $ BoundedGrowingBuffer newFptr bound +{-# INLINE growBufferBounded #-} + +-- | Throw a 'ChunkOverflowException' and switches to a 'ThreadedSink'. +chunkOverflow :: IORef DynamicSink -> Int -> S.ByteString -> BuildM () +chunkOverflow !dRef !minSize !chunk = do + myTid <- io $ myThreadId + reqV <- io $ newEmptyMVar + respV <- io $ newEmptyMVar + io $ E.throwTo myTid $ ChunkOverflowException chunk reqV respV minSize + io $ writeIORef dRef $ ThreadedSink reqV respV + handleRequest reqV diff --git a/Data/ByteString/FastBuilder/Internal/Prim.hs b/Data/ByteString/FastBuilder/Internal/Prim.hs new file mode 100644 --- /dev/null +++ b/Data/ByteString/FastBuilder/Internal/Prim.hs @@ -0,0 +1,89 @@ +{-# LANGUAGE CPP #-} + +-- | This is an internal module; its interface is unstable. +module Data.ByteString.FastBuilder.Internal.Prim where + +import Data.ByteString.FastBuilder.Internal +import qualified Data.ByteString.Builder.Prim as P +import Data.Int +import Data.Word + +# define WRAP_WITH(typ, name, def) name :: typ -> Builder; name = def; {-# INLINE name #-} +# define WRAP_F(type,name) WRAP_WITH(type,name,primFixed P.name) +# define WRAP_B(type,name) WRAP_WITH(type,name,primBounded P.name) +# define WRAP_SHOW7(type,name) WRAP_WITH(type,name,string7 . show) + +WRAP_F(Int,intHost) +WRAP_F(Int8,int8) +WRAP_F(Int16,int16LE) +WRAP_F(Int16,int16BE) +WRAP_F(Int16,int16Host) +WRAP_F(Int32,int32LE) +WRAP_F(Int32,int32BE) +WRAP_F(Int32,int32Host) +WRAP_F(Int64,int64LE) +WRAP_F(Int64,int64BE) +WRAP_F(Int64,int64Host) + +WRAP_F(Word,wordHost) +WRAP_F(Word8,word8) +WRAP_F(Word16,word16LE) +WRAP_F(Word16,word16BE) +WRAP_F(Word16,word16Host) +WRAP_F(Word32,word32LE) +WRAP_F(Word32,word32BE) +WRAP_F(Word32,word32Host) +WRAP_F(Word64,word64LE) +WRAP_F(Word64,word64BE) +WRAP_F(Word64,word64Host) + +WRAP_F(Float,floatLE) +WRAP_F(Float,floatBE) +WRAP_F(Float,floatHost) +WRAP_F(Double,doubleLE) +WRAP_F(Double,doubleBE) +WRAP_F(Double,doubleHost) + +WRAP_B(Int,intDec) +WRAP_B(Int8,int8Dec) +WRAP_B(Int16,int16Dec) +WRAP_B(Int32,int32Dec) +WRAP_B(Int64,int64Dec) + +WRAP_B(Word,wordDec) +WRAP_B(Word8,word8Dec) +WRAP_B(Word16,word16Dec) +WRAP_B(Word32,word32Dec) +WRAP_B(Word64,word64Dec) + +WRAP_B(Word,wordHex) +WRAP_B(Word8,word8Hex) +WRAP_B(Word16,word16Hex) +WRAP_B(Word32,word32Hex) +WRAP_B(Word64,word64Hex) + +WRAP_F(Int8,int8HexFixed) +WRAP_F(Int16,int16HexFixed) +WRAP_F(Int32,int32HexFixed) +WRAP_F(Int64,int64HexFixed) + +WRAP_F(Word8,word8HexFixed) +WRAP_F(Word16,word16HexFixed) +WRAP_F(Word32,word32HexFixed) +WRAP_F(Word64,word64HexFixed) + +WRAP_F(Float,floatHexFixed) +WRAP_F(Double,doubleHexFixed) + +WRAP_F(Char,char7) +WRAP_WITH(String,string7,primMapListFixed P.char7) + +WRAP_F(Char,char8) +WRAP_WITH(String,string8,primMapListFixed P.char8) + +WRAP_B(Char,charUtf8) +WRAP_WITH(String,stringUtf8,primMapListBounded P.charUtf8) + +WRAP_SHOW7(Integer,integerDec) +WRAP_SHOW7(Double,floatDec) +WRAP_SHOW7(Double,doubleDec) diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,121 @@ +Creative Commons Legal Code + +CC0 1.0 Universal + + CREATIVE COMMONS CORPORATION IS NOT A LAW FIRM AND DOES NOT PROVIDE + LEGAL SERVICES. DISTRIBUTION OF THIS DOCUMENT DOES NOT CREATE AN + ATTORNEY-CLIENT RELATIONSHIP. CREATIVE COMMONS PROVIDES THIS + INFORMATION ON AN "AS-IS" BASIS. CREATIVE COMMONS MAKES NO WARRANTIES + REGARDING THE USE OF THIS DOCUMENT OR THE INFORMATION OR WORKS + PROVIDED HEREUNDER, AND DISCLAIMS LIABILITY FOR DAMAGES RESULTING FROM + THE USE OF THIS DOCUMENT OR THE INFORMATION OR WORKS PROVIDED + HEREUNDER. + +Statement of Purpose + +The laws of most jurisdictions throughout the world automatically confer +exclusive Copyright and Related Rights (defined below) upon the creator +and subsequent owner(s) (each and all, an "owner") of an original work of +authorship and/or a database (each, a "Work"). + +Certain owners wish to permanently relinquish those rights to a Work for +the purpose of contributing to a commons of creative, cultural and +scientific works ("Commons") that the public can reliably and without fear +of later claims of infringement build upon, modify, incorporate in other +works, reuse and redistribute as freely as possible in any form whatsoever +and for any purposes, including without limitation commercial purposes. +These owners may contribute to the Commons to promote the ideal of a free +culture and the further production of creative, cultural and scientific +works, or to gain reputation or greater distribution for their Work in +part through the use and efforts of others. + +For these and/or other purposes and motivations, and without any +expectation of additional consideration or compensation, the person +associating CC0 with a Work (the "Affirmer"), to the extent that he or she +is an owner of Copyright and Related Rights in the Work, voluntarily +elects to apply CC0 to the Work and publicly distribute the Work under its +terms, with knowledge of his or her Copyright and Related Rights in the +Work and the meaning and intended legal effect of CC0 on those rights. + +1. Copyright and Related Rights. A Work made available under CC0 may be +protected by copyright and related or neighboring rights ("Copyright and +Related Rights"). Copyright and Related Rights include, but are not +limited to, the following: + + i. the right to reproduce, adapt, distribute, perform, display, + communicate, and translate a Work; + ii. moral rights retained by the original author(s) and/or performer(s); +iii. publicity and privacy rights pertaining to a person's image or + likeness depicted in a Work; + iv. rights protecting against unfair competition in regards to a Work, + subject to the limitations in paragraph 4(a), below; + v. rights protecting the extraction, dissemination, use and reuse of data + in a Work; + vi. database rights (such as those arising under Directive 96/9/EC of the + European Parliament and of the Council of 11 March 1996 on the legal + protection of databases, and under any national implementation + thereof, including any amended or successor version of such + directive); and +vii. other similar, equivalent or corresponding rights throughout the + world based on applicable law or treaty, and any national + implementations thereof. + +2. Waiver. To the greatest extent permitted by, but not in contravention +of, applicable law, Affirmer hereby overtly, fully, permanently, +irrevocably and unconditionally waives, abandons, and surrenders all of +Affirmer's Copyright and Related Rights and associated claims and causes +of action, whether now known or unknown (including existing as well as +future claims and causes of action), in the Work (i) in all territories +worldwide, (ii) for the maximum duration provided by applicable law or +treaty (including future time extensions), (iii) in any current or future +medium and for any number of copies, and (iv) for any purpose whatsoever, +including without limitation commercial, advertising or promotional +purposes (the "Waiver"). Affirmer makes the Waiver for the benefit of each +member of the public at large and to the detriment of Affirmer's heirs and +successors, fully intending that such Waiver shall not be subject to +revocation, rescission, cancellation, termination, or any other legal or +equitable action to disrupt the quiet enjoyment of the Work by the public +as contemplated by Affirmer's express Statement of Purpose. + +3. Public License Fallback. Should any part of the Waiver for any reason +be judged legally invalid or ineffective under applicable law, then the +Waiver shall be preserved to the maximum extent permitted taking into +account Affirmer's express Statement of Purpose. In addition, to the +extent the Waiver is so judged Affirmer hereby grants to each affected +person a royalty-free, non transferable, non sublicensable, non exclusive, +irrevocable and unconditional license to exercise Affirmer's Copyright and +Related Rights in the Work (i) in all territories worldwide, (ii) for the +maximum duration provided by applicable law or treaty (including future +time extensions), (iii) in any current or future medium and for any number +of copies, and (iv) for any purpose whatsoever, including without +limitation commercial, advertising or promotional purposes (the +"License"). The License shall be deemed effective as of the date CC0 was +applied by Affirmer to the Work. Should any part of the License for any +reason be judged legally invalid or ineffective under applicable law, such +partial invalidity or ineffectiveness shall not invalidate the remainder +of the License, and in such case Affirmer hereby affirms that he or she +will not (i) exercise any of his or her remaining Copyright and Related +Rights in the Work or (ii) assert any associated claims and causes of +action with respect to the Work, in either case contrary to Affirmer's +express Statement of Purpose. + +4. Limitations and Disclaimers. + + a. No trademark or patent rights held by Affirmer are waived, abandoned, + surrendered, licensed or otherwise affected by this document. + b. Affirmer offers the Work as-is and makes no representations or + warranties of any kind concerning the Work, express, implied, + statutory or otherwise, including without limitation warranties of + title, merchantability, fitness for a particular purpose, non + infringement, or the absence of latent or other defects, accuracy, or + the present or absence of errors, whether or not discoverable, all to + the greatest extent permissible under applicable law. + c. Affirmer disclaims responsibility for clearing rights of other persons + that may apply to the Work or any use thereof, including without + limitation any person's Copyright and Related Rights in the Work. + Further, Affirmer disclaims responsibility for obtaining any necessary + consents, permissions or other rights required for any use of the + Work. + d. Affirmer understands and acknowledges that Creative Commons is not a + party to this document and has no duty or obligation with respect to + this CC0 or use of the Work. diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/benchmarks/aeson/Bstr.hs b/benchmarks/aeson/Bstr.hs new file mode 100644 --- /dev/null +++ b/benchmarks/aeson/Bstr.hs @@ -0,0 +1,7 @@ +{-# LANGUAGE CPP #-} +#define LIB Data.ByteString.Builder +#define NAME Bstr +#include "template.hs" + +rebuild :: Builder -> Builder +rebuild = id diff --git a/benchmarks/aeson/Fast.hs b/benchmarks/aeson/Fast.hs new file mode 100644 --- /dev/null +++ b/benchmarks/aeson/Fast.hs @@ -0,0 +1,4 @@ +{-# LANGUAGE CPP #-} +#define LIB Data.ByteString.FastBuilder +#define NAME Fast +#include "template.hs" diff --git a/benchmarks/aeson/HashMapExts.hs b/benchmarks/aeson/HashMapExts.hs new file mode 100644 --- /dev/null +++ b/benchmarks/aeson/HashMapExts.hs @@ -0,0 +1,37 @@ +{-# LANGUAGE QuasiQuotes #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE MagicHash #-} +{-# LANGUAGE UnboxedTuples #-} +module HashMapExts where + +import qualified Data.HashMap.Strict as H +import Data.Monoid +import GHC.Exts (Array#, sizeofArray#, indexArray#, Int(..)) +import Unsafe.TrueName (quasiName) + +import HashMapNames + +foldMapWithKey :: (Monoid m) => (k -> a -> m) -> H.HashMap k a -> m +foldMapWithKey f = go + where + go hm = case hm of + [quasiName|Empty ''H.HashMap|] -> mempty + [quasiName|BitmapIndexed ''H.HashMap _ ary|] -> foldMapArray go ary + [quasiName|Full ''H.HashMap ary|] -> foldMapArray go ary + [quasiName|Collision ''H.HashMap _ ary|] -> foldMapArray leaf ary + [quasiName|Leaf ''H.HashMap _ l|] -> leaf l + + leaf $(lPat "k" "v") = f k v +{-# INLINE foldMapWithKey #-} + +foldMapArray :: (Monoid m) => (a -> m) -> $(arrayType) a -> m +foldMapArray f $(arrayPat "arr") = foldMapArray' f arr + +foldMapArray' :: (Monoid m) => (a -> m) -> Array# a -> m +foldMapArray' f arr = go 0 + where + go k@(I# k#) + | k >= I# (sizeofArray# arr) = mempty + | otherwise = case indexArray# arr k# of + (# v #) -> f v <> go (k + 1) +{-# INLINE foldMapArray' #-} diff --git a/benchmarks/aeson/HashMapNames.hs b/benchmarks/aeson/HashMapNames.hs new file mode 100644 --- /dev/null +++ b/benchmarks/aeson/HashMapNames.hs @@ -0,0 +1,27 @@ +{-# LANGUAGE TemplateHaskell #-} +module HashMapNames where + +import qualified Data.HashMap.Strict as H +import Language.Haskell.TH +import Unsafe.TrueName (trueName) + +lPat :: String -> String -> Q Pat +lPat a b = do + leafConName <- trueName "Leaf" ''H.HashMap + leafTyName <- trueName "Leaf" leafConName + lName <- trueName "L" leafTyName + conP lName [varP (mkName a), varP (mkName b)] + +arrayTypeName :: Q Name +arrayTypeName = do + fullConName <- trueName "Full" ''H.HashMap + trueName "Array" fullConName + +arrayType :: Q Type +arrayType = conT =<< arrayTypeName + +arrayPat :: String -> Q Pat +arrayPat a = do + arrayTyName <- arrayTypeName + arrayConName <- trueName "Array" arrayTyName + conP arrayConName [varP (mkName a)] diff --git a/benchmarks/aeson/main.hs b/benchmarks/aeson/main.hs new file mode 100644 --- /dev/null +++ b/benchmarks/aeson/main.hs @@ -0,0 +1,17 @@ +import qualified Fast as F +import qualified Bstr as B +import Control.Concurrent +import Control.DeepSeq +import Criterion.Main +import Data.Aeson (decode', encode) +import qualified Data.ByteString.Lazy as L + +main :: IO () +main = runInUnboundThread $ do + Just json <- decode' <$> L.readFile "../aeson/benchmarks/json-data/twitter100.json" + rnf json `seq` return () + defaultMain + [ bench "fast" $ nf F.valueToLazyByteString json + , bench "bstr" $ nf B.valueToLazyByteString json + , bench "aeson" $ nf encode json + ] diff --git a/benchmarks/vector.hs b/benchmarks/vector.hs new file mode 100644 --- /dev/null +++ b/benchmarks/vector.hs @@ -0,0 +1,73 @@ +{-# LANGUAGE DeriveFunctor #-} +import Control.Concurrent +import Control.Monad +import Criterion.Main +import Data.Monoid +import qualified Data.Vector.Unboxed as U +import Data.Word +import qualified System.IO as IO + +import qualified Data.ByteString.Builder as Bstr +import qualified Data.ByteString.FastBuilder as Fast + +main :: IO () +main = runInUnboundThread $ do + h <- IO.openFile "/dev/null" IO.WriteMode + let + size sz vec = bgroup sz + [ bench "lazy/fast" $ nf (Fast.toLazyByteString . fastVector) vec + , bench "lazy/bstr" $ nf (Bstr.toLazyByteString . bstrVector) vec + , bench "strict/fast" $ nf (Fast.toStrictByteString . fastVector) vec + , bench "io/fast" $ whnfIO $ Fast.hPutBuilder h $ fastVector vec + , bench "io/bstr" $ whnfIO $ Bstr.hPutBuilder h $ bstrVector vec + ] + vec10 `seq` vec100 `seq` vec1000 `seq` vec10000 `seq` defaultMain + [ size "10" vec10 + , size "100" vec100 + , size "1000" vec1000 + , size "10000" vec10000 + ] + +type Item = (Bool, Word32) + +fastVector :: U.Vector Item -> Fast.Builder +fastVector = Fast.rebuild . my_foldr step mempty + where + step (b, w) rest = Fast.word8 (if b then 1 else 0) <> Fast.word32LE w <> rest + +bstrVector :: U.Vector Item -> Bstr.Builder +bstrVector = my_foldr step mempty + where + step (b, w) rest = Bstr.word8 (if b then 1 else 0) <> Bstr.word32LE w <> rest + +vec10 :: U.Vector Item +vec10 = makeItems 10 + +vec100 :: U.Vector Item +vec100 = makeItems 100 + +vec1000 :: U.Vector Item +vec1000 = makeItems 1000 + +vec10000 :: U.Vector Item +vec10000 = makeItems 10000 + +makeItems :: Int -> U.Vector Item +makeItems n = U.generate n $ \i -> + (mod i 3 == 0, fromIntegral i + 100) + +data Box a = Box a + deriving Functor +instance Applicative Box where + pure = return + (<*>) = ap +instance Monad Box where + return = Box + Box a >>= f = f a + +my_foldr :: (U.Unbox a) => (a -> r -> r) -> r -> U.Vector a -> r +my_foldr f z = go + where + go v + | U.null v = z + | otherwise = f (U.unsafeHead v) $ go (U.unsafeTail v) diff --git a/fast-builder.cabal b/fast-builder.cabal new file mode 100644 --- /dev/null +++ b/fast-builder.cabal @@ -0,0 +1,53 @@ +name: fast-builder +version: 0.0.0.0 +synopsis: Fast ByteString Builder +description: An efficient implementation of ByteString builder. It should be faster than + the standard implementation in most cases. +homepage: http://github.com/takano-akio/fast-builder +license: PublicDomain +license-file: LICENSE +author: Takano Akio +maintainer: aljee@hyper.cx +-- copyright: +category: Data +build-type: Simple +-- extra-source-files: +cabal-version: >=1.10 + +library + exposed-modules: Data.ByteString.FastBuilder, + Data.ByteString.FastBuilder.Internal + other-modules: Data.ByteString.FastBuilder.Internal.Prim + + -- other-extensions: + build-depends: base ==4.8.0.0, bytestring >= 0.10.6.0, ghc-prim + -- hs-source-dirs: + default-language: Haskell2010 + ghc-options: -Wall -g + +benchmark aeson + type: exitcode-stdio-1.0 + main-is: main.hs + hs-source-dirs: benchmarks/aeson + other-modules: Fast, Bstr, HashMapExts, HashMapNames + build-depends: base, fast-builder, aeson, criterion, bytestring, scientific, text, vector, deepseq, unordered-containers, ghc-prim, true-name, template-haskell + ghc-options: -fsimpl-tick-factor=120 + ghc-options: -Wall -threaded -g -rtsopts + +benchmark vector + type: exitcode-stdio-1.0 + main-is: vector.hs + hs-source-dirs: benchmarks + build-depends: base, fast-builder, criterion, bytestring, vector, deepseq + ghc-options: -Wall -threaded -g -rtsopts -eventlog + +test-suite prop + type: exitcode-stdio-1.0 + main-is: prop.hs + hs-source-dirs: tests + build-depends: base, fast-builder, bytestring, QuickCheck, stm, process + ghc-options: -Wall -g -rtsopts + +source-repository head + type: git + location: https://github.com/takano-akio/fast-builder.git diff --git a/tests/prop.hs b/tests/prop.hs new file mode 100644 --- /dev/null +++ b/tests/prop.hs @@ -0,0 +1,202 @@ +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} + +module Main where + +import Control.Concurrent +import Control.Concurrent.STM +import qualified Control.Exception as E +import Control.Monad +import qualified Data.ByteString as BS +import qualified Data.ByteString.Lazy as BSL +import Data.Monoid +import Data.Typeable +import Data.Word +import qualified System.IO as IO +import System.IO.Unsafe +import qualified System.Process as Process +import System.Timeout +import qualified Test.QuickCheck as QC + +import Data.ByteString.FastBuilder + +data BuilderTree + = Leaf BuilderPrim + | Mappend BuilderTree BuilderTree + deriving (Show) + +data BuilderPrim + = BP_Word8 !Word8 + | BP_Word64le !Word64 + | BP_ByteString !BS.ByteString + | BP_Empty + deriving (Show) + +instance QC.Arbitrary BuilderTree where + arbitrary = QC.sized $ \size -> + if size == 0 + then return (Leaf BP_Empty) + else QC.oneof + [ Leaf <$> QC.arbitrary + , QC.scale (`div` 2) $ Mappend <$> QC.arbitrary <*> QC.arbitrary + ] + +instance QC.Arbitrary BuilderPrim where + arbitrary = QC.oneof + [ BP_Word8 <$> QC.arbitrary + , BP_Word64le <$> QC.arbitrary + , BP_ByteString . BS.pack <$> QC.arbitrary + , pure BP_Empty + ] + +data Driver + = ToLazyByteString + | ToLazyByteStringWith_10 + | ToStrictByteString + | HPutBuilder + deriving (Show, Enum, Bounded) + +instance QC.Arbitrary Driver where + arbitrary = QC.arbitraryBoundedEnum + +newtype TestException = TextException Int + deriving (Show, Eq, Typeable, QC.Arbitrary) + +instance E.Exception TestException + +runBuilder :: Driver -> Builder -> BS.ByteString +runBuilder ToLazyByteString = BSL.toStrict . toLazyByteString +runBuilder ToLazyByteStringWith_10 = + BSL.toStrict . toLazyByteStringWith 10 10 +runBuilder ToStrictByteString = toStrictByteString +runBuilder HPutBuilder = \b -> unsafePerformIO $ do + (readH, writeH) <- Process.createPipe + hPutBuilder writeH b + IO.hClose writeH + BS.hGetContents readH + +mkBuilder :: BuilderTree -> Builder +mkBuilder = go + where + go (Leaf p) = prim p + go (Mappend a b) = go a <> go b + + prim (BP_Word8 w) = word8 w + prim (BP_Word64le w) = word64LE w + prim (BP_ByteString bs) = byteString bs + prim BP_Empty = mempty + +buildWithBuilder :: Driver -> BuilderTree -> BS.ByteString +buildWithBuilder drv = runBuilder drv . mkBuilder + +buildWithList :: BuilderTree -> BS.ByteString +buildWithList = BS.pack . ($[]) . go + where + go (Leaf p) = prim p + go (Mappend a b) = go a . go b + + prim (BP_Word8 w) = (w:) + prim (BP_Word64le w) = (list++) + where + list = take 8 $ map fromIntegral $ iterate (`div` 256) w + prim (BP_ByteString bs) = (BS.unpack bs ++) + prim BP_Empty = id + +errorBuilder :: TestException -> Builder +errorBuilder ex = mempty <> E.throw ex +{-# NOINLINE errorBuilder #-} + +asyncExnBuilder :: ThreadId -> TestException -> Builder +asyncExnBuilder tid ex = mempty <> unsafePerformIO act + where + act = do + E.throwTo tid ex + return mempty +{-# NOINLINE asyncExnBuilder #-} + +nonterminatingBuilder :: TVar Bool -> Builder +nonterminatingBuilder inBlock = mempty <> unsafePerformIO act + where + act = do + atomically $ writeTVar inBlock True + loop 0 + `E.finally` atomically (writeTVar inBlock False) + + loop k + | k < (0::Integer) = return mempty + | otherwise = loop $ k + 1 +{-# NOINLINE nonterminatingBuilder #-} + +tryEvaluate :: a -> IO (Either TestException a) +tryEvaluate = E.try . E.evaluate + +-- | Builder's semantics matches the reference implementation. +prop_builderTree :: Driver -> BuilderTree -> Bool +prop_builderTree drv tree = buildWithBuilder drv tree == buildWithList tree + +-- | When a Builder throws a synchronous exception, the exception should come +-- out unchanged from the driver. Evaluating the result again should repeat +-- the same exception. +prop_syncException + :: TestException + -> Driver + -> BuilderTree + -> BuilderTree + -> QC.Property +prop_syncException ex drv before after = QC.ioProperty $ do + r <- tryEvaluate bstr + r1 <- tryEvaluate bstr + return $ (r, r1) == (Left ex, Left ex) + where + bstr = runBuilder drv $ + mkBuilder before <> errorBuilder ex <> mkBuilder after + +-- | When a Builder is interrupted by an asynchronous exception, the exception +-- should come out unchanged from the driver. Evaluating the result again +-- should then succeed. +prop_asyncException + :: TestException + -> Driver + -> BuilderTree + -> BuilderTree + -> QC.Property +prop_asyncException ex drv before after = QC.ioProperty $ do + tid <- myThreadId + let + bstr = runBuilder drv $ + mkBuilder before <> asyncExnBuilder tid ex <> mkBuilder after + r <- tryEvaluate bstr + r1 <- tryEvaluate bstr + return $ (r, r1) == (Left ex, Right $ buildWithList (Mappend before after)) + +-- | When a non-terminating Builder is interrupted by an asynchronous exception, +-- it should be killed, rather than keep running forever. +prop_asyncExceptionInterrupts + :: TestException + -> Driver + -> BuilderTree + -> BuilderTree + -> QC.Property +prop_asyncExceptionInterrupts ex drv before after = QC.ioProperty $ do + inNontermV <- newTVarIO False + tid <- myThreadId + let + bstr = runBuilder drv $ + mkBuilder before <> nonterminatingBuilder inNontermV <> mkBuilder after + _ <- forkIO $ do + atomically $ guard =<< readTVar inNontermV + E.throwTo tid ex + r <- tryEvaluate bstr + r1 <- timeout 100000 $ atomically $ guard . not =<< readTVar inNontermV + return $ (r, r1) == (Left ex, Just ()) + +return [] + +main :: IO () +main = do + True <- $(QC.forAllProperties) $ \prop -> do + r <- QC.quickCheckWithResult QC.stdArgs{ QC.chatty = False } prop + print r + return r + return ()