diff --git a/Data/BufferBuilder.hs b/Data/BufferBuilder.hs --- a/Data/BufferBuilder.hs +++ b/Data/BufferBuilder.hs @@ -1,11 +1,43 @@ {-# LANGUAGE OverloadedStrings, MagicHash, UnboxedTuples, BangPatterns, GeneralizedNewtypeDeriving #-} -module Data.BufferBuilder - ( BufferBuilder +{-| +A library for efficiently building up a buffer of data. When given data +known to be strict, use of BufferBuilder compiles directly into a series +of efficient C function calls. +-} +module Data.BufferBuilder ( + + -- * The BufferBuilder Monad + BufferBuilder , runBufferBuilder + + -- * Appending bytes and byte strings , appendByte , appendChar8 , appendBS + , appendLBS + , appendLiteral + , unsafeAppendLiteralN + + -- * Appending bytes and byte strings, truncated to 7 bits + , appendByte7 + , appendChar7 + , appendBS7 + , appendLiteral7 + , unsafeAppendLiteralN7 + + -- * UTF-8 encoding + , appendCharUtf8 + , appendStringUtf8 + + -- * Printing numbers + , appendDecimalSignedInt + , appendDecimalDouble + + -- * JSON escaping + , appendEscapedJson + , appendEscapedJsonLiteral + , appendEscapedJsonText ) where import GHC.Base @@ -17,34 +49,62 @@ import Foreign.Marshal.Alloc import qualified Data.ByteString as BS import qualified Data.ByteString.Internal as BS +import qualified Data.ByteString.Lazy as BSL import Control.Monad.Reader +import Control.Applicative (Applicative) -data BWHandle' -type BWHandle = Ptr BWHandle' +import Data.Text () -- Show +import Data.Text.Internal (Text (..)) +import Data.Text.Array (Array (..)) -foreign import ccall unsafe "bw_new" bw_new :: Int -> IO BWHandle -foreign import ccall unsafe "&bw_free" bw_free :: FunPtr (BWHandle -> IO ()) -foreign import ccall unsafe "bw_append_byte" bw_append_byte :: BWHandle -> Word8 -> IO () -foreign import ccall unsafe "bw_append_bs" bw_append_bs :: BWHandle -> Int -> (Ptr Word8) -> IO () -foreign import ccall unsafe "bw_get_size" bw_get_size :: BWHandle -> IO Int -foreign import ccall unsafe "bw_trim_and_release_address" bw_trim_and_release_address :: BWHandle -> IO (Ptr Word8) +data Handle' +type Handle = Ptr Handle' --- | BufferBuilder sequences actions that append to an implicit, +foreign import ccall unsafe "strlen" c_strlen :: Ptr Word8 -> IO Int +foreign import ccall unsafe "bw_new" bw_new :: Int -> IO Handle +foreign import ccall unsafe "&bw_free" bw_free :: FunPtr (Handle -> IO ()) +foreign import ccall unsafe "bw_get_size" bw_get_size :: Handle -> IO Int +foreign import ccall unsafe "bw_trim_and_release_address" bw_trim_and_release_address :: Handle -> IO (Ptr Word8) + +foreign import ccall unsafe "bw_append_byte" bw_append_byte :: Handle -> Word8 -> IO () +foreign import ccall unsafe "bw_append_char_utf8" bw_append_char_utf8 :: Handle -> Char -> IO () +foreign import ccall unsafe "bw_append_bs" bw_append_bs :: Handle -> Int -> Ptr Word8 -> IO () +foreign import ccall unsafe "bw_append_bsz" bw_append_bsz :: Handle -> Ptr Word8 -> IO () + +foreign import ccall unsafe "bw_append_byte7" bw_append_byte7 :: Handle -> Word8 -> IO () +foreign import ccall unsafe "bw_append_bs7" bw_append_bs7 :: Handle -> Int -> Ptr Word8 -> IO () +foreign import ccall unsafe "bw_append_bsz7" bw_append_bsz7 :: Handle -> Ptr Word8 -> IO () + +foreign import ccall unsafe "bw_append_decimal_signed_int" bw_append_decimal_signed_int :: Handle -> Int -> IO () +foreign import ccall unsafe "bw_append_decimal_double" bw_append_decimal_double :: Handle -> Double -> IO () + +foreign import ccall unsafe "bw_append_json_escaped" bw_append_json_escaped :: Handle -> Int -> Ptr Word8 -> IO () +foreign import ccall unsafe "bw_append_json_escaped_utf16" bw_append_json_escaped_utf16 :: Handle -> Int -> Ptr Word16 -> IO () + +-- | BufferBuilder is the type of a monadic action that appends to an implicit, -- growable buffer. Use 'runBufferBuilder' to extract the resulting --- buffer as a 'BS.ByteString' -newtype BufferBuilder a = BB (ReaderT BWHandle IO a) - deriving (Functor, Monad, MonadReader BWHandle) +-- buffer as a 'BS.ByteString'. +newtype BufferBuilder a = BB (ReaderT Handle IO a) + deriving (Functor, Applicative, Monad, MonadReader Handle) inBW :: IO a -> BufferBuilder a inBW = BB . lift +{-# INLINE inBW #-} +withHandle :: (Handle -> IO ()) -> BufferBuilder () +withHandle action = do + h <- ask + inBW $ action h +{-# INLINE withHandle #-} + initialCapacity :: Int -initialCapacity = 48 +initialCapacity = 20480 -- why 48? it's only 6 64-bit words... yet many small strings should fit. -- some quantitative analysis would be good. -- an option to set the initial capacity would be better. :) --- | Runs a BufferBuilder and extracts its resulting contents as a 'BS.ByteString' +-- | Run a sequence of 'BufferBuilder' actions and extract the resulting +-- buffer as a 'BS.ByteString'. runBufferBuilder :: BufferBuilder () -> BS.ByteString runBufferBuilder = unsafeDupablePerformIO . runBufferBuilderIO initialCapacity @@ -61,12 +121,10 @@ touchForeignPtr handleFP return bs - -appendByte :: Word8 -- ^ byte to append to the buffer. - -> BufferBuilder () -appendByte b = do - h <- ask - inBW $ bw_append_byte h b +-- | Append a single byte to the output buffer. To append multiple bytes in sequence and +-- avoid redundant bounds checks, consider using 'appendBS', 'appendLiteral', or 'unsafeAppendLiteralN'. +appendByte :: Word8 -> BufferBuilder () +appendByte b = withHandle $ \h -> bw_append_byte h b {-# INLINE appendByte #-} c2w :: Char -> Word8 @@ -74,16 +132,136 @@ {-# INLINE c2w #-} -- | Appends a character to the buffer, truncating it to the bottom 8 bits. -appendChar8 :: Char -- ^ character to append to the buffer - -> BufferBuilder () +appendChar8 :: Char -> BufferBuilder () appendChar8 = appendByte . c2w {-# INLINE appendChar8 #-} --- | Appends a ByteString to the buffer. -appendBS :: BS.ByteString -- ^ 'BS.ByteString' to append - -> BufferBuilder () -appendBS !(BS.PS (ForeignPtr addr _) offset len) = do - h <- ask - inBW $ bw_append_bs h len (plusPtr (Ptr addr) offset) +-- | Appends a 'BS.ByteString' to the buffer. When appending constant, hardcoded strings, to +-- avoid a CAF and the costs of its associated tag check and indirect jump, use +-- 'appendLiteral' or 'unsafeAppendLiteralN' instead. +appendBS :: BS.ByteString -> BufferBuilder () +appendBS !(BS.PS fp offset len) = + withHandle $ \h -> + withForeignPtr fp $ \addr -> + bw_append_bs h len (plusPtr addr offset) {-# INLINE appendBS #-} +-- | Appends a lazy 'BSL.ByteString' to the buffer. This function operates by traversing +-- the lazy 'BSL.ByteString' chunks, appending each in turn. +appendLBS :: BSL.ByteString -> BufferBuilder () +appendLBS lbs = mapM_ appendBS $ BSL.toChunks lbs +{-# INLINABLE appendLBS #-} + +-- | Appends a zero-terminated MagicHash string literal. Use this function instead of +-- 'appendBS' for string constants. For example: +-- +-- > appendLiteral "true"# +-- +-- If the length of the string literal is known, calling +-- 'unsafeAppendLiteralN' is faster, as 'unsafeAppendLiteralN' avoids a strlen +-- operation which has nontrivial cost in some benchmarks. +appendLiteral :: Addr# -> BufferBuilder () +appendLiteral addr = + withHandle $ \h -> + bw_append_bsz h (Ptr addr) +{-# INLINE appendLiteral #-} + +-- | Appends a MagicHash string literal with a known length. Use this when the +-- string literal's length is known. For example: +-- +-- > unsafeAppendLiteralN 4 "true"# +-- +-- Per byte, this is the fastest append function. It amounts to a C function call +-- with two constant arguments. The C function checks to see if it needs to grow +-- the buffer and then it simply calls memcpy. +-- +-- __WARNING__: passing an incorrect length value is likely to cause an access +-- violation or worse. +unsafeAppendLiteralN :: Int -> Addr# -> BufferBuilder () +unsafeAppendLiteralN len addr = + withHandle $ \h -> + bw_append_bs h len (Ptr addr) +{-# INLINE unsafeAppendLiteralN #-} + + +-- 7-bit truncation + +appendByte7 :: Word8 -> BufferBuilder () +appendByte7 b = withHandle $ \h -> bw_append_byte7 h b +{-# INLINE appendByte7 #-} + +appendChar7 :: Char -> BufferBuilder () +appendChar7 = appendByte7 . c2w +{-# INLINE appendChar7 #-} + +appendBS7 :: BS.ByteString -> BufferBuilder () +appendBS7 !(BS.PS fp offset len) = + withHandle $ \h -> + withForeignPtr fp $ \addr -> + bw_append_bs7 h len (plusPtr addr offset) +{-# INLINE appendBS7 #-} + +appendLiteral7 :: Addr# -> BufferBuilder () +appendLiteral7 addr = + withHandle $ \h -> + bw_append_bsz7 h (Ptr addr) +{-# INLINE appendLiteral7 #-} + +unsafeAppendLiteralN7 :: Int -> Addr# -> BufferBuilder () +unsafeAppendLiteralN7 len addr = + withHandle $ \h -> + bw_append_bs7 h len (Ptr addr) +{-# INLINE unsafeAppendLiteralN7 #-} + +-- Encoding UTF-8 + +-- | Appends a UTF-8-encoded 'Char' to the buffer. +appendCharUtf8 :: Char -> BufferBuilder () +appendCharUtf8 c = withHandle $ \h -> bw_append_char_utf8 h c +{-# INLINE appendCharUtf8 #-} + +-- | Appends a UTF-8-encoded 'String' to the buffer. The best way to improve performance here +-- is to use 'BS.ByteString' or 'Text' instead of 'String'. +appendStringUtf8 :: String -> BufferBuilder () +appendStringUtf8 = mapM_ appendCharUtf8 +{-# INLINABLE appendStringUtf8 #-} + + +-- Printing Numbers + +-- | Appends a decimal integer, just like calling printf("%d", ...) +appendDecimalSignedInt :: Int -> BufferBuilder () +appendDecimalSignedInt i = + withHandle $ \h -> + bw_append_decimal_signed_int h i +{-# INLINE appendDecimalSignedInt #-} + +-- | Appends a decimal double, just like calling printf("%f", ...) +appendDecimalDouble :: Double -> BufferBuilder () +appendDecimalDouble d = + withHandle $ \h -> + bw_append_decimal_double h d +{-# INLINE appendDecimalDouble #-} + + +-- Encoding JSON + +appendEscapedJson :: BS.ByteString -> BufferBuilder () +appendEscapedJson !(BS.PS (ForeignPtr addr _) offset len) = + withHandle $ \h -> + bw_append_json_escaped h len (plusPtr (Ptr addr) offset) +{-# INLINE appendEscapedJson #-} + +appendEscapedJsonLiteral :: Addr# -> BufferBuilder () +appendEscapedJsonLiteral addr = + withHandle $ \h -> do + len <- c_strlen (Ptr addr) + bw_append_json_escaped h len (Ptr addr) +{-# INLINE appendEscapedJsonLiteral #-} + +appendEscapedJsonText :: Text -> BufferBuilder () +appendEscapedJsonText !(Text arr ofs len) = + let byteArray = aBA arr + in withHandle $ \h -> + bw_append_json_escaped_utf16 h len (Ptr (byteArrayContents# byteArray) `plusPtr` ofs) +{-# INLINE appendEscapedJsonText #-} diff --git a/Data/BufferBuilder/Json.hs b/Data/BufferBuilder/Json.hs new file mode 100644 --- /dev/null +++ b/Data/BufferBuilder/Json.hs @@ -0,0 +1,324 @@ +{-# LANGUAGE GeneralizedNewtypeDeriving, FlexibleInstances, FlexibleContexts #-} +{-# LANGUAGE OverloadedStrings, MagicHash, BangPatterns, UndecidableInstances #-} + +{-| +A library for efficiently building up a valid JSON document. + +The difference between "Data.BufferBuilder.Json" and the excellent +"Data.Aeson" is that Aeson represents the JSON document as an +in-memory tree structure before encoding it into bytes. This module, +on the other hand, represents each value as an action that writes its +representation directly into the output buffer. At the cost of +reduced flexibility, this results in significantly improved encoding +performance. At the time of this writing, encoding a custom record +type into JSON using this module was almost 5x faster than using +Aeson. + +This module is built on top of "Data.Utf8Builder". +-} +module Data.BufferBuilder.Json + ( + -- * Encoding Values + Value + , ToJson (..) + , encodeJson + + -- * Objects + , ObjectBuilder + , emptyObject + , (.=) + , (.=#) + + -- * Arrays + , array + + -- * Null + , nullValue + + -- * Unsafe + , unsafeAppendBS + , unsafeAppendUtf8Builder + ) where + +import GHC.Base +import Foreign.Storable +import Control.Monad (when, forM_) +import Data.BufferBuilder.Utf8 (Utf8Builder) +import qualified Data.BufferBuilder.Utf8 as UB +import Data.ByteString (ByteString) +import Data.Monoid +import Data.Text (Text) +import Data.Foldable (Foldable, foldMap) +import qualified Data.Vector as Vector +import qualified Data.Vector.Generic as GVector +import qualified Data.Vector.Primitive as VP +import qualified Data.Vector.Storable as VS +import qualified Data.Vector.Unboxed as VU +import qualified Data.HashMap.Strict as HashMap + +-- | Represents a JSON value. +-- +-- 'Value's are built up from either 'ToJson' instances or +-- from primitives like 'emptyObject', 'array', and 'null'. +-- +-- In special cases, or when performance is of utmost importance, the +-- unsafe functions 'unsafeAppendBS' and 'unsafeAppendUtf8Builder' are +-- available. +-- +-- Internally, Value encodes an action or sequence of actions that append +-- JSON-encoded text to the underlying 'Utf8Builder'. +newtype Value = Value { utf8Builder :: Utf8Builder () } + +-- | The class of types that can be converted to JSON values. See +-- 'ObjectBuilder' for an example of writing a 'ToJson' instance for a +-- custom data type. +-- +-- 'ToJson' instances are provided for many common types. For +-- example, to create a JSON array, call 'toJson' on a list or 'Vector.Vector'. +-- To create a JSON object, call 'toJson' on a 'HashMap.HashMap'. +class ToJson a where + toJson :: a -> Value + +---- General JSON value support + +-- | Encode a value into a 'ByteString' containing valid UTF-8-encoded JSON. +-- The argument value must have a corresponding 'ToJson' instance. +-- +-- __WARNING__: There are three cases where the resulting 'ByteString' may not contain +-- legal JSON: +-- +-- * An unsafe function was used to encode a JSON value. +-- * The root value is not an object or array, as the JSON specification requires. +-- * An object has multiple keys with the same value. For maximum efficiency, +-- 'ObjectBuilder' does not check key names for uniqueness, so it's possible to +-- construct objects with duplicate keys. +encodeJson :: ToJson a => a -> ByteString +encodeJson = UB.runUtf8Builder . utf8Builder . toJson +{-# INLINE encodeJson #-} + +---- Objects + +-- | Builds a JSON object. +-- +-- An 'ObjectBuilder' builds one or more key-value pairs of a JSON object. They are constructed with the '.=' operator and +-- combined with 'Data.Monoid.<>'. +-- +-- To turn an 'ObjectBuilder' into a 'Value', use its 'ToJson' class instance. +-- +-- @ +-- data Friend = Friend +-- { fId :: !Int +-- , fName :: !Text +-- } deriving (Eq, Show) +-- +-- instance ToJson Friend where +-- toJson friend = toJson $ +-- "id" .= fId friend +-- <> "name" .= fName friend +-- @ +-- +-- __WARNING__: 'ObjectBuilder' does not check uniqueness of object +-- keys. If two keys with the same value are inserted, then the +-- resulting JSON document will be illegal. +data ObjectBuilder = NoPair | Pair !(Utf8Builder ()) + +instance Monoid ObjectBuilder where + {-# INLINE mempty #-} + mempty = NoPair + + {-# INLINE mappend #-} + mappend NoPair a = a + mappend a NoPair = a + mappend (Pair a) (Pair b) = Pair $ do + a + UB.appendChar7 ',' + b + +instance ToJson ObjectBuilder where + {-# INLINE toJson #-} + toJson NoPair = Value $ do + UB.appendChar7 '{' + UB.appendChar7 '}' + + toJson (Pair a) = Value $ do + UB.appendChar7 '{' + a + UB.appendChar7 '}' + +-- | A 'Value' that produces the empty object. +emptyObject :: Value +emptyObject = toJson NoPair +{-# INLINE emptyObject #-} + +-- | Create an 'ObjectBuilder' from a key and a value. +(.=) :: ToJson a => Text -> a -> ObjectBuilder +a .= b = Pair $ do + UB.appendEscapedJsonText a + UB.appendChar7 ':' + utf8Builder $ toJson b +infixr 8 .= +{-# INLINE (.=) #-} + +-- | Create an 'ObjectBuilder' from a key and a value. The key is an +-- ASCII-7, unescaped, zero-terminated 'Addr#'. +-- +-- __WARNING__: This function is unsafe. If the key is NOT +-- zero-terminated, then an access violation might result. If the key +-- is not a sequence of unescaped ASCII characters, the resulting JSON +-- document will be illegal. +-- +-- This function is provided for maximum performance in the common +-- case that object keys are ASCII-7. It achieves performance by +-- avoiding the CAF for a Text literal and avoiding the need to +-- transcode UTF-16 to UTF-8 and escape. +-- +-- To use this function, the calling source file must have the +-- MagicHash extension enabled. +-- +-- @ +-- data Friend = Friend +-- { fId :: !Int +-- , fName :: !Text +-- } deriving (Eq, Show) +-- +-- instance ToJson Friend where +-- toJson friend = toJson $ +-- "id"\# .=\# fId friend +-- <> "name"\# .=\# fName friend +-- @ +(.=#) :: ToJson a => Addr# -> a -> ObjectBuilder +a .=# b = Pair $ do + UB.appendEscapedJsonLiteral a + UB.appendChar7 ':' + utf8Builder $ toJson b +infixr 8 .=# +{-# INLINE (.=#) #-} + + +{-# INLINE writePair #-} +writePair :: ToJson a => (Text, a) -> Utf8Builder () +writePair (key, value) = do + UB.appendEscapedJsonText key + UB.appendChar7 ':' + utf8Builder $ toJson value + +instance ToJson a => ToJson (HashMap.HashMap Text a) where + {-# INLINABLE toJson #-} + toJson hm = Value $ do + UB.appendChar7 '{' + case HashMap.toList hm of + [] -> UB.appendChar7 '}' + (x:xs) -> do + writePair x + forM_ xs $ \p -> do + UB.appendChar7 ',' + writePair p + UB.appendChar7 '}' + +---- Arrays + +-- | Serialize any 'Foldable' as a JSON array. This is generally +-- slower than directly calling 'toJson' on a list or 'Vector.Vector', +-- but it will convert any 'Foldable' type into an array. +array :: (Foldable t, ToJson a) => t a -> Value +array collection = Value $ do + UB.appendChar7 '[' + -- HACK: ObjectBuilder is not "type correct" but it has exactly the behaviour we want for this function. + case foldMap (Pair . utf8Builder . toJson) collection of + NoPair -> return () + (Pair b) -> b + UB.appendChar7 ']' +{-# INLINABLE array #-} + +instance ToJson a => ToJson [a] where + {-# INLINABLE toJson #-} + toJson !ls = Value $ do + UB.appendChar7 '[' + case ls of + [] -> UB.appendChar7 ']' + x:xs -> do + utf8Builder $ toJson x + forM_ xs $ \(!e) -> do + UB.appendChar7 ',' + utf8Builder $ toJson e + UB.appendChar7 ']' + +instance ToJson a => ToJson (Vector.Vector a) where + {-# INLINABLE toJson #-} + toJson = vector + +instance (Storable a, ToJson a) => ToJson (VS.Vector a) where + {-# INLINABLE toJson #-} + toJson = vector + +instance (VP.Prim a, ToJson a) => ToJson (VP.Vector a) where + {-# INLINABLE toJson #-} + toJson = vector + +instance (GVector.Vector VU.Vector a, ToJson a) => ToJson (VU.Vector a) where + {-# INLINABLE toJson #-} + toJson = vector + +{-# INLINABLE vector #-} +vector :: (GVector.Vector v a, ToJson a) => v a -> Value +vector !vec = Value $ do + UB.appendChar7 '[' + let len = GVector.length vec + when (len /= 0) $ do + utf8Builder $ toJson (vec `GVector.unsafeIndex` 0) + GVector.forM_ (GVector.tail vec) $ \e -> do + UB.appendChar7 ',' + utf8Builder $ toJson e + UB.appendChar7 ']' + + +---- + +-- | Represents a JSON "null". +nullValue :: Value +nullValue = Value $ UB.unsafeAppendLiteralN 4 "null"# +{-# INLINE nullValue #-} + +---- Common JSON instances + +instance ToJson Value where + {-# INLINE toJson #-} + toJson = id + +instance ToJson Bool where + {-# INLINE toJson #-} + toJson True = Value $ UB.unsafeAppendLiteralN 4 "true"# + toJson False = Value $ UB.unsafeAppendLiteralN 5 "false"# + +instance ToJson a => ToJson (Maybe a) where + {-# INLINE toJson #-} + toJson m = case m of + Nothing -> Value $ UB.unsafeAppendLiteralN 4 "null"# + Just a -> toJson a + +instance ToJson Text where + {-# INLINE toJson #-} + toJson txt = Value $ UB.appendEscapedJsonText txt + +instance ToJson Double where + {-# INLINE toJson #-} + toJson a = Value $ UB.appendDecimalDouble a + +instance ToJson Int where + {-# INLINE toJson #-} + toJson a = Value $ UB.appendDecimalSignedInt a + + +---- Unsafe functions + +-- | Unsafely append a string into a JSON document. +-- This function does /not/ escape, quote, or otherwise decorate the string in any way. +-- This function is /unsafe/ because you can trivially use it to generate illegal JSON. +unsafeAppendBS :: ByteString -> Value +unsafeAppendBS bs = Value $ UB.unsafeAppendBS bs + +-- | Unsafely append a 'Utf8Builder' into a JSON document. +-- This function does not escape, quote, or decorate the string in any way. +-- This function is /unsafe/ because you can trivially use it to generate illegal JSON. +unsafeAppendUtf8Builder :: Utf8Builder () -> Value +unsafeAppendUtf8Builder utf8b = Value utf8b diff --git a/Data/BufferBuilder/Utf8.hs b/Data/BufferBuilder/Utf8.hs new file mode 100644 --- /dev/null +++ b/Data/BufferBuilder/Utf8.hs @@ -0,0 +1,174 @@ +{-# LANGUAGE GeneralizedNewtypeDeriving, MagicHash, BangPatterns #-} + +{-| +A library for efficiently building up a buffer of UTF-8-encoded text. If only +safe functions are used, the resulting 'ByteString' is guaranteed to be valid +UTF-8. + +To run a sequence of Utf8Builder actions and retrieve the resulting buffer, use +'runUtf8Builder'. + +In special situations, for maximum performance, unsafe functions are +also provided. The unsafe functions do not guarantee the buffer is +correct UTF-8. + +This module is built on top of "Data.BufferBuilder". +-} +module Data.BufferBuilder.Utf8 ( + + -- * The Utf8Builder Monad + Utf8Builder + , runUtf8Builder + + -- * Text encoding + , appendText + , appendString + , appendChar + + -- * ASCII-7 + , appendByte7 + , appendChar7 + , appendBS7 + , appendLiteral7 + + -- * Printing numbers + , appendDecimalSignedInt + , appendDecimalDouble + + -- * Escaped JSON + , appendEscapedJson + , appendEscapedJsonLiteral + , appendEscapedJsonText + + -- * Unsafe append operations + , unsafeAppendByte + , unsafeAppendChar8 + , unsafeAppendLiteral + , unsafeAppendLiteralN + , unsafeAppendBS + ) where + +import GHC.Base +import GHC.Word +import Control.Applicative +import Data.ByteString (ByteString) +import Data.BufferBuilder (BufferBuilder) +import qualified Data.BufferBuilder as BB +import Data.Text (Text) +import Data.Text.Encoding (encodeUtf8) + +newtype Utf8Builder a = Utf8Builder { unBuilder :: BufferBuilder a } + deriving (Functor, Applicative, Monad) + +-- | Run a sequence of 'Utf8Builder' actions and extracting the resulting +-- buffer as a 'ByteString'. +runUtf8Builder :: Utf8Builder () -> ByteString +runUtf8Builder a = BB.runBufferBuilder $ unBuilder a +{-# INLINE runUtf8Builder #-} + + +-- Text encoding + +-- TODO: optimize appendText with custom UTF-16 -> UTF-8 encoder in C + +-- | Encodes the given 'Text' in UTF-8, appending it to the buffer. +appendText :: Text -> Utf8Builder () +appendText a = Utf8Builder $ BB.appendBS $ encodeUtf8 a +{-# INLINE appendText #-} + +-- | Encodes the given 'String' in UTF-8, appending it to the buffer. +appendString :: String -> Utf8Builder () +appendString s = mapM_ appendChar s +{-# INLINABLE appendString #-} + +-- | Encodes a single 'Char' in UTF-8, appending it to the buffer. +appendChar :: Char -> Utf8Builder () +appendChar c = Utf8Builder $ BB.appendCharUtf8 c +{-# INLINE appendChar #-} + + +-- ASCII-7 + +-- | Appends the bottom 7 bits of a byte to the buffer. +appendByte7 :: Word8 -> Utf8Builder () +appendByte7 = Utf8Builder . BB.appendByte7 +{-# INLINE appendByte7 #-} + +-- | Appends the bottom 7 bits of a 'Char' to the buffer. +appendChar7 :: Char -> Utf8Builder () +appendChar7 = Utf8Builder . BB.appendChar7 +{-# INLINE appendChar7 #-} + +-- | Appends the given ByteString to the buffer, taking the bottom +-- 7 bits of each byte. +appendBS7 :: ByteString -> Utf8Builder () +appendBS7 = Utf8Builder . BB.appendBS7 +{-# INLINE appendBS7 #-} + +-- | Appends the zero-terminated byte string at the given address +-- to the buffer, taking the bottom 7 bits of each byte. +appendLiteral7 :: Addr# -> Utf8Builder () +appendLiteral7 addr = Utf8Builder $ BB.appendLiteral7 addr +{-# INLINE appendLiteral7 #-} + + +-- Printing numbers + +appendDecimalSignedInt :: Int -> Utf8Builder () +appendDecimalSignedInt a = Utf8Builder $ BB.appendDecimalSignedInt a +{-# INLINE appendDecimalSignedInt #-} + +appendDecimalDouble :: Double -> Utf8Builder () +appendDecimalDouble d = Utf8Builder $ BB.appendDecimalDouble d +{-# INLINE appendDecimalDouble #-} + + +-- Escaped JSON + +appendEscapedJsonLiteral :: Addr# -> Utf8Builder () +appendEscapedJsonLiteral addr = Utf8Builder $ BB.appendEscapedJsonLiteral addr + +appendEscapedJson :: ByteString -> Utf8Builder () +appendEscapedJson a = Utf8Builder $ BB.appendEscapedJson a +{-# INLINE appendEscapedJson #-} + +appendEscapedJsonText :: Text -> Utf8Builder () +appendEscapedJsonText txt = Utf8Builder $ BB.appendEscapedJsonText txt +{-# INLINE appendEscapedJsonText #-} + + +-- Unsafe + +-- | Directly append a byte into the UTF-8 code stream. Incorrect use of +-- this function can result in invalid UTF-8. +unsafeAppendByte :: Word8 -> Utf8Builder () +unsafeAppendByte = Utf8Builder . BB.appendByte +{-# INLINE unsafeAppendByte #-} + +-- | Directly append the bottom 8 bits of the given character to the UTF-8 +-- code stream. Incorrect use of this function can result in invalid UTF-8. +unsafeAppendChar8 :: Char -> Utf8Builder () +unsafeAppendChar8 = Utf8Builder . BB.appendChar8 +{-# INLINE unsafeAppendChar8 #-} + +-- | Directly append the zero-terminated byte sequence pointed to by +-- the given address. Be careful that the referenced byte sequence +-- contains valid UTF-8. +unsafeAppendLiteral :: Addr# -> Utf8Builder () +unsafeAppendLiteral addr = Utf8Builder $ BB.appendLiteral addr +{-# INLINE unsafeAppendLiteral #-} + +-- | Directly append the given byte sequence pointed to by the given address. +-- Be careful that the referenced byte sequence contains valid UTF-8. +-- +-- __WARNING__: passing an incorrect length value is likely to cause an access +-- violation or worse. +unsafeAppendLiteralN :: Int -> Addr# -> Utf8Builder () +unsafeAppendLiteralN !len addr = Utf8Builder $ BB.unsafeAppendLiteralN len addr +{-# INLINE unsafeAppendLiteralN #-} + +-- | Directly append the given 'ByteString' to the output buffer. +-- Be careful that the referenced 'ByteString' contains valid UTF-8. +unsafeAppendBS :: ByteString -> Utf8Builder () +unsafeAppendBS a = Utf8Builder $ BB.appendBS a +{-# INLINE unsafeAppendBS #-} diff --git a/LICENSE b/LICENSE --- a/LICENSE +++ b/LICENSE @@ -1,4 +1,4 @@ -Copyright (c) 2015, IMVU, Chad Austin +Copyright (c) 2015, IMVU, Chad Austin, Andy Friesen All rights reserved. diff --git a/bench/Bench.hs b/bench/Bench.hs --- a/bench/Bench.hs +++ b/bench/Bench.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE OverloadedStrings, BangPatterns, RecordWildCards #-} +{-# LANGUAGE OverloadedStrings, BangPatterns, RecordWildCards, MagicHash #-} import Data.ByteString (ByteString) import Criterion.Main @@ -39,6 +39,26 @@ appendChar8 '#' appendBS "hashyhashyhashy" +buildURLLiterals :: Int -> ByteString +buildURLLiterals times = runBufferBuilder $ do + replicateM_ times $ do + -- literals avoid the CAFs for ByteString constants + unsafeAppendLiteralN 4 "http"# + unsafeAppendLiteralN 3 "://"# + unsafeAppendLiteralN 11 "example.com"# + appendChar8 '/' + unsafeAppendLiteralN 18 "the/path/goes/here"# + appendChar8 '?' + unsafeAppendLiteralN 3 "key"# + appendChar8 '=' + unsafeAppendLiteralN 5 "value"# + appendChar8 '?' + unsafeAppendLiteralN 8 "otherkey"# + appendChar8 '=' + unsafeAppendLiteralN 10 "othervalue"# + appendChar8 '#' + unsafeAppendLiteralN 15 "hashyhashyhashy"# + data Record = Record { f1 :: !ByteString , f2 :: !ByteString @@ -74,4 +94,5 @@ main :: IO () main = defaultMain [ bench "buildURL" $ nf buildURL 10 + , bench "buildURLLiterals" $ nf buildURLLiterals 10 , bench "encodeRecord" $ nf encodeType recordValue ] diff --git a/bench/JsonBench.hs b/bench/JsonBench.hs new file mode 100644 --- /dev/null +++ b/bench/JsonBench.hs @@ -0,0 +1,289 @@ +{-# LANGUAGE OverloadedStrings, RecordWildCards #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE MagicHash #-} + +module Main (main) where + +import Criterion + +import Criterion.Main + +import Data.Monoid ((<>)) + +import qualified Data.ByteString as BS +import qualified Data.ByteString.Lazy as BSL + +import qualified Data.BufferBuilder.Json as Json +import Data.Text (Text) +import qualified Data.Aeson as Aeson +import Data.Aeson ((.:)) +import qualified Data.Vector as Vector +import Control.DeepSeq (NFData (..), force) +import qualified Data.Vector.Unboxed as UnboxedVector + +data EyeColor = Green | Blue | Brown + deriving (Eq, Show) +data Gender = Male | Female + deriving (Eq, Show) +data Fruit = Apple | Strawberry | Banana + deriving (Eq, Show) +data Friend = Friend + { fId :: !Int + , fName :: !Text + } deriving (Eq, Show) + +data User = User + { uId :: !Text + , uIndex :: !Int + , uGuid :: !Text + , uIsActive :: !Bool + , uBalance :: !Text + , uPicture :: !Text + , uAge :: !Int + , uEyeColor :: !EyeColor + , uName :: !Text + , uGender :: !Gender + , uCompany :: !Text + , uEmail :: !Text + , uPhone :: !Text + , uAddress :: !Text + , uAbout :: !Text + , uRegistered :: !Text -- UTCTime? + , uLatitude :: !Double + , uLongitude :: !Double + , uTags :: ![Text] + , uFriends :: ![Friend] + , uGreeting :: !Text + , uFavouriteFruit :: !Fruit + } deriving (Eq, Show) + +instance NFData EyeColor +instance NFData Gender +instance NFData Fruit + +instance NFData Friend where + rnf Friend {..} = (rnf fId) `seq` (rnf fName) `seq` () + +instance NFData User where + rnf User {..} = (rnf uId) `seq` (rnf uIndex) `seq` (rnf uGuid) `seq` (rnf uIsActive) `seq` (rnf uBalance) `seq` (rnf uPicture) `seq` (rnf uAge) `seq` (rnf uEyeColor) `seq` (rnf uName) `seq` (rnf uGender) `seq` (rnf uCompany) `seq` (rnf uEmail) `seq` (rnf uPhone) `seq` (rnf uAddress) `seq` (rnf uAbout) `seq` (rnf uRegistered) `seq` (rnf uLatitude) `seq` (rnf uLongitude) `seq` (rnf uTags) `seq` (rnf uFriends) `seq` (rnf uGreeting) `seq` (rnf uFavouriteFruit) `seq` () + +eyeColorTable :: [(Text, EyeColor)] +eyeColorTable = [("brown", Brown), ("green", Green), ("blue", Blue)] + +genderTable :: [(Text, Gender)] +genderTable = [("male", Male), ("female", Female)] + +fruitTable :: [(Text, Fruit)] +fruitTable = [("apple", Apple), ("strawberry", Strawberry), ("banana", Banana)] + +enumFromJson :: Monad m => String -> [(Text, enum)] -> (json -> m Text) -> json -> m enum +enumFromJson enumName table extract v = do + s <- extract v + case lookup s table of + Just r -> return r + Nothing -> fail $ "Bad " ++ enumName ++ ": " ++ show s + +--- Aeson instances --- + +instance Aeson.FromJSON EyeColor where + parseJSON = enumFromJson "EyeColor" eyeColorTable Aeson.parseJSON + +instance Aeson.FromJSON Gender where + parseJSON = enumFromJson "Gender" genderTable Aeson.parseJSON + +instance Aeson.FromJSON Fruit where + parseJSON = enumFromJson "Fruit" fruitTable Aeson.parseJSON + +instance Aeson.FromJSON Friend where + parseJSON = Aeson.withObject "Friend" $ \o -> do + fId <- o .: "id" + fName <- o .: "name" + return Friend {..} + +instance Aeson.FromJSON User where + parseJSON = Aeson.withObject "User" $ \o -> do + uId <- o .: "_id" + uIndex <- o .: "index" + uGuid <- o .: "guid" + uIsActive <- o .: "isActive" + uBalance <- o .: "balance" + uPicture <- o .: "picture" + uAge <- o .: "age" + uEyeColor <- o .: "eyeColor" + uName <- o .: "name" + uGender <- o .: "gender" + uCompany <- o .: "company" + uEmail <- o .: "email" + uPhone <- o .: "phone" + uAddress <- o .: "address" + uAbout <- o .: "about" + uRegistered <- o .: "registered" + uLatitude <- o .: "latitude" + uLongitude <- o .: "longitude" + uTags <- o .: "tags" + uFriends <- o .: "friends" + uGreeting <- o .: "greeting" + uFavouriteFruit <- o .: "favoriteFruit" + return User {..} + +instance Aeson.ToJSON EyeColor where + toJSON ec = Aeson.toJSON $ case ec of + Green -> "green" :: Text + Blue -> "blue" + Brown -> "brown" + +instance Aeson.ToJSON Gender where + toJSON g = Aeson.toJSON $ case g of + Male -> "male" :: Text + Female -> "female" + +instance Aeson.ToJSON Fruit where + toJSON f = Aeson.toJSON $ case f of + Apple -> "apple" :: Text + Banana -> "banana" + Strawberry -> "strawberry" + +instance Aeson.ToJSON Friend where + toJSON Friend {..} = Aeson.object + [ "id" Aeson..= fId + , "name" Aeson..= fName + ] + +instance Aeson.ToJSON User where + toJSON User{..} = Aeson.object + [ "_id" Aeson..= uId + , "index" Aeson..= uIndex + , "guid" Aeson..= uGuid + , "isActive" Aeson..= uIsActive + , "balance" Aeson..= uBalance + , "picture" Aeson..= uPicture + , "age" Aeson..= uAge + , "eyeColor" Aeson..= uEyeColor + , "name" Aeson..= uName + , "gender" Aeson..= uGender + , "company" Aeson..= uCompany + , "email" Aeson..= uEmail + , "phone" Aeson..= uPhone + , "address" Aeson..= uAddress + , "about" Aeson..= uAbout + , "registered" Aeson..= uRegistered + , "latitude" Aeson..= uLatitude + , "longitude" Aeson..= uLongitude + , "tags" Aeson..= uTags + , "friends" Aeson..= uFriends + , "greeting" Aeson..= uGreeting + , "favoriteFruit" Aeson..= uFavouriteFruit + ] + +--- BufferBuilder instances --- + +instance Json.ToJson EyeColor where + toJson ec = Json.toJson $ case ec of + Green -> "green" :: Text + Blue -> "blue" + Brown -> "brown" + +instance Json.ToJson Gender where + toJson g = Json.toJson $ case g of + Male -> "male" :: Text + Female -> "female" + +instance Json.ToJson Fruit where + toJson f = Json.toJson $ case f of + Apple -> "apple" :: Text + Strawberry -> "strawberry" + Banana -> "banana" + +instance Json.ToJson Friend where + toJson Friend{..} = Json.toJson $ + "_id" Json..= fId + <> "name" Json..= fName + +instance Json.ToJson User where + toJson User{..} = Json.toJson $ + "_id"# Json..=# uId + <> "index"# Json..=# uIndex + <> "guid"# Json..=# uGuid + <> "isActive"# Json..=# uIsActive + <> "balance"# Json..=# uBalance + <> "picture"# Json..=# uPicture + <> "age"# Json..=# uAge + <> "eyeColor"# Json..=# uEyeColor + <> "name"# Json..=# uName + <> "gender"# Json..=# uGender + <> "company"# Json..=# uCompany + <> "email"# Json..=# uEmail + <> "phone"# Json..=# uPhone + <> "address"# Json..=# uAddress + <> "about"# Json..=# uAbout + <> "registered"# Json..=# uRegistered + <> "latitude"# Json..=# uLatitude + <> "longitude"# Json..=# uLongitude + <> "tags"# Json..=# uTags + <> "friends"# Json..=# uFriends + <> "greeting"# Json..=# uGreeting + <> "favoriteFruit"# Json..=# uFavouriteFruit + +encodeUserNaively :: User -> Json.Value +encodeUserNaively User{..} = + Json.toJson $ + "_id" Json..= uId + <> "index" Json..= uIndex + <> "guid" Json..= uGuid + <> "isActive" Json..= uIsActive + <> "balance" Json..= uBalance + <> "picture" Json..= uPicture + <> "age" Json..= uAge + <> "eyeColor" Json..= uEyeColor + <> "name" Json..= uName + <> "gender" Json..= uGender + <> "company" Json..= uCompany + <> "email" Json..= uEmail + <> "phone" Json..= uPhone + <> "address" Json..= uAddress + <> "about" Json..= uAbout + <> "registered" Json..= uRegistered + <> "latitude" Json..= uLatitude + <> "longitude" Json..= uLongitude + <> "tags" Json..= uTags + <> "friends" Json..= uFriends + <> "greeting" Json..= uGreeting + <> "favoriteFruit" Json..= uFavouriteFruit +--- --- + +main :: IO () +main = do + content <- BS.readFile "test.json" + let lazyContent = force $ BSL.fromChunks [content] + + let parsedUserList :: [User] + Just parsedUserList = Aeson.decode lazyContent + + defaultMain [ bgroup "vector" + [ bench "vector bool" $ nf Json.encodeJson (Vector.replicate 100000 True) + , bench "vector int" $ nf Json.encodeJson (Vector.replicate 100000 (1234 :: Int)) + , bench "vector text" $ nf Json.encodeJson (Vector.replicate 100000 ("hello world" :: Text)) + ] + , bgroup "list-foldable" + [ bench "list-foldable bool" $ nf (Json.encodeJson . Json.array) (replicate 100000 True) + , bench "list-foldable int" $ nf (Json.encodeJson . Json.array) (replicate 100000 (1234 :: Int)) + , bench "list-foldable text" $ nf (Json.encodeJson . Json.array) (replicate 100000 ("hello world" :: Text)) + ] + , bgroup "list" + [ bench "list bool" $ nf Json.encodeJson (replicate 100000 True) + , bench "list int" $ nf Json.encodeJson (replicate 100000 (1234 :: Int)) + , bench "list text" $ nf Json.encodeJson (replicate 100000 ("hello world" :: Text)) + ] + , bgroup "render" + [ bench "bufferbuilder" $ nf Json.encodeJson parsedUserList + , bench "aeson" $ nf Aeson.encode parsedUserList + ] + , bgroup "addr vs text keys" + [ bench "addr" $ nf Json.encodeJson parsedUserList + , bench "text" $ nf Json.encodeJson $ fmap encodeUserNaively parsedUserList + ] + , bgroup "breakout" + [ bench "Vector" $ nf Json.encodeJson (Vector.fromList $! [0..65535] :: Vector.Vector Int) + , bench "Vector.Unboxed" $ nf Json.encodeJson (UnboxedVector.fromList $! [0..65535] :: UnboxedVector.Vector Int) + ] + ] diff --git a/bench/TinyJson.hs b/bench/TinyJson.hs new file mode 100644 --- /dev/null +++ b/bench/TinyJson.hs @@ -0,0 +1,28 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE MagicHash #-} + +module Main where + +import Data.Text +import Data.BufferBuilder.Json +import qualified Data.ByteString.Char8 as BSC8 + +data TinyRecord = TR + { name :: !Text + , number :: !Int + } + +instance ToJson TinyRecord where + toJson !TR{..} = toJson $ + "name" .= (9::Int) + -- <> "number" .= number + +a :: TinyRecord +a = TR "Bob" 9 + +main :: IO () +main = do + let !b = encodeJson a + putStrLn $ BSC8.unpack b diff --git a/bench/TinyJson2.hs b/bench/TinyJson2.hs new file mode 100644 --- /dev/null +++ b/bench/TinyJson2.hs @@ -0,0 +1,17 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE MagicHash #-} + +module Main where + +import Data.BufferBuilder.Json +import qualified Data.ByteString.Char8 as BSC8 +import Data.Vector.Unboxed (Vector) +import qualified Data.Vector.Unboxed as Vector + +main :: IO () +main = do + let !v = Vector.fromList [1, 2, 3, 4] :: Vector Int + let !b = encodeJson v + putStrLn $ BSC8.unpack b diff --git a/branchlut.cpp b/branchlut.cpp new file mode 100644 --- /dev/null +++ b/branchlut.cpp @@ -0,0 +1,275 @@ +/** + */ + +#include +#include + +static const char gDigitsLut[200] = { + '0','0','0','1','0','2','0','3','0','4','0','5','0','6','0','7','0','8','0','9', + '1','0','1','1','1','2','1','3','1','4','1','5','1','6','1','7','1','8','1','9', + '2','0','2','1','2','2','2','3','2','4','2','5','2','6','2','7','2','8','2','9', + '3','0','3','1','3','2','3','3','3','4','3','5','3','6','3','7','3','8','3','9', + '4','0','4','1','4','2','4','3','4','4','4','5','4','6','4','7','4','8','4','9', + '5','0','5','1','5','2','5','3','5','4','5','5','5','6','5','7','5','8','5','9', + '6','0','6','1','6','2','6','3','6','4','6','5','6','6','6','7','6','8','6','9', + '7','0','7','1','7','2','7','3','7','4','7','5','7','6','7','7','7','8','7','9', + '8','0','8','1','8','2','8','3','8','4','8','5','8','6','8','7','8','8','8','9', + '9','0','9','1','9','2','9','3','9','4','9','5','9','6','9','7','9','8','9','9' +}; + +// Branching for different cases (forward) +// Use lookup table of two digits + +size_t u32toa_branchlut(uint32_t value, char* buffer) { + char* start = buffer; + + if (value < 10000) { + const uint32_t d1 = (value / 100) << 1; + const uint32_t d2 = (value % 100) << 1; + + if (value >= 1000) + *buffer++ = gDigitsLut[d1]; + if (value >= 100) + *buffer++ = gDigitsLut[d1 + 1]; + if (value >= 10) + *buffer++ = gDigitsLut[d2]; + *buffer++ = gDigitsLut[d2 + 1]; + } + else if (value < 100000000) { + // value = bbbbcccc + const uint32_t b = value / 10000; + const uint32_t c = value % 10000; + + const uint32_t d1 = (b / 100) << 1; + const uint32_t d2 = (b % 100) << 1; + + const uint32_t d3 = (c / 100) << 1; + const uint32_t d4 = (c % 100) << 1; + + if (value >= 10000000) + *buffer++ = gDigitsLut[d1]; + if (value >= 1000000) + *buffer++ = gDigitsLut[d1 + 1]; + if (value >= 100000) + *buffer++ = gDigitsLut[d2]; + *buffer++ = gDigitsLut[d2 + 1]; + + *buffer++ = gDigitsLut[d3]; + *buffer++ = gDigitsLut[d3 + 1]; + *buffer++ = gDigitsLut[d4]; + *buffer++ = gDigitsLut[d4 + 1]; + } + else { + // value = aabbbbcccc in decimal + + const uint32_t a = value / 100000000; // 1 to 42 + value %= 100000000; + + if (a >= 10) { + const unsigned i = a << 1; + *buffer++ = gDigitsLut[i]; + *buffer++ = gDigitsLut[i + 1]; + } + else + *buffer++ = '0' + static_cast(a); + + const uint32_t b = value / 10000; // 0 to 9999 + const uint32_t c = value % 10000; // 0 to 9999 + + const uint32_t d1 = (b / 100) << 1; + const uint32_t d2 = (b % 100) << 1; + + const uint32_t d3 = (c / 100) << 1; + const uint32_t d4 = (c % 100) << 1; + + *buffer++ = gDigitsLut[d1]; + *buffer++ = gDigitsLut[d1 + 1]; + *buffer++ = gDigitsLut[d2]; + *buffer++ = gDigitsLut[d2 + 1]; + *buffer++ = gDigitsLut[d3]; + *buffer++ = gDigitsLut[d3 + 1]; + *buffer++ = gDigitsLut[d4]; + *buffer++ = gDigitsLut[d4 + 1]; + } + return buffer - start; +} + +size_t i32toa_branchlut(int32_t value, char* buffer) { + size_t length = 0; + if (value < 0) { + ++length; + *buffer++ = '-'; + value = -value; + } + + return length + u32toa_branchlut(static_cast(value), buffer); +} + +size_t u64toa_branchlut(uint64_t value, char* buffer) { + char* start = buffer; + if (value < 100000000) { + uint32_t v = static_cast(value); + if (v < 10000) { + const uint32_t d1 = (v / 100) << 1; + const uint32_t d2 = (v % 100) << 1; + + if (v >= 1000) + *buffer++ = gDigitsLut[d1]; + if (v >= 100) + *buffer++ = gDigitsLut[d1 + 1]; + if (v >= 10) + *buffer++ = gDigitsLut[d2]; + *buffer++ = gDigitsLut[d2 + 1]; + } + else { + // value = bbbbcccc + const uint32_t b = v / 10000; + const uint32_t c = v % 10000; + + const uint32_t d1 = (b / 100) << 1; + const uint32_t d2 = (b % 100) << 1; + + const uint32_t d3 = (c / 100) << 1; + const uint32_t d4 = (c % 100) << 1; + + if (value >= 10000000) + *buffer++ = gDigitsLut[d1]; + if (value >= 1000000) + *buffer++ = gDigitsLut[d1 + 1]; + if (value >= 100000) + *buffer++ = gDigitsLut[d2]; + *buffer++ = gDigitsLut[d2 + 1]; + + *buffer++ = gDigitsLut[d3]; + *buffer++ = gDigitsLut[d3 + 1]; + *buffer++ = gDigitsLut[d4]; + *buffer++ = gDigitsLut[d4 + 1]; + } + } + else if (value < 10000000000000000) { + const uint32_t v0 = static_cast(value / 100000000); + const uint32_t v1 = static_cast(value % 100000000); + + const uint32_t b0 = v0 / 10000; + const uint32_t c0 = v0 % 10000; + + const uint32_t d1 = (b0 / 100) << 1; + const uint32_t d2 = (b0 % 100) << 1; + + const uint32_t d3 = (c0 / 100) << 1; + const uint32_t d4 = (c0 % 100) << 1; + + const uint32_t b1 = v1 / 10000; + const uint32_t c1 = v1 % 10000; + + const uint32_t d5 = (b1 / 100) << 1; + const uint32_t d6 = (b1 % 100) << 1; + + const uint32_t d7 = (c1 / 100) << 1; + const uint32_t d8 = (c1 % 100) << 1; + + if (value >= 1000000000000000) + *buffer++ = gDigitsLut[d1]; + if (value >= 100000000000000) + *buffer++ = gDigitsLut[d1 + 1]; + if (value >= 10000000000000) + *buffer++ = gDigitsLut[d2]; + if (value >= 1000000000000) + *buffer++ = gDigitsLut[d2 + 1]; + if (value >= 100000000000) + *buffer++ = gDigitsLut[d3]; + if (value >= 10000000000) + *buffer++ = gDigitsLut[d3 + 1]; + if (value >= 1000000000) + *buffer++ = gDigitsLut[d4]; + if (value >= 100000000) + *buffer++ = gDigitsLut[d4 + 1]; + + *buffer++ = gDigitsLut[d5]; + *buffer++ = gDigitsLut[d5 + 1]; + *buffer++ = gDigitsLut[d6]; + *buffer++ = gDigitsLut[d6 + 1]; + *buffer++ = gDigitsLut[d7]; + *buffer++ = gDigitsLut[d7 + 1]; + *buffer++ = gDigitsLut[d8]; + *buffer++ = gDigitsLut[d8 + 1]; + } + else { + const uint32_t a = static_cast(value / 10000000000000000); // 1 to 1844 + value %= 10000000000000000; + + if (a < 10) + *buffer++ = '0' + static_cast(a); + else if (a < 100) { + const uint32_t i = a << 1; + *buffer++ = gDigitsLut[i]; + *buffer++ = gDigitsLut[i + 1]; + } + else if (a < 1000) { + *buffer++ = '0' + static_cast(a / 100); + + const uint32_t i = (a % 100) << 1; + *buffer++ = gDigitsLut[i]; + *buffer++ = gDigitsLut[i + 1]; + } + else { + const uint32_t i = (a / 100) << 1; + const uint32_t j = (a % 100) << 1; + *buffer++ = gDigitsLut[i]; + *buffer++ = gDigitsLut[i + 1]; + *buffer++ = gDigitsLut[j]; + *buffer++ = gDigitsLut[j + 1]; + } + + const uint32_t v0 = static_cast(value / 100000000); + const uint32_t v1 = static_cast(value % 100000000); + + const uint32_t b0 = v0 / 10000; + const uint32_t c0 = v0 % 10000; + + const uint32_t d1 = (b0 / 100) << 1; + const uint32_t d2 = (b0 % 100) << 1; + + const uint32_t d3 = (c0 / 100) << 1; + const uint32_t d4 = (c0 % 100) << 1; + + const uint32_t b1 = v1 / 10000; + const uint32_t c1 = v1 % 10000; + + const uint32_t d5 = (b1 / 100) << 1; + const uint32_t d6 = (b1 % 100) << 1; + + const uint32_t d7 = (c1 / 100) << 1; + const uint32_t d8 = (c1 % 100) << 1; + + *buffer++ = gDigitsLut[d1]; + *buffer++ = gDigitsLut[d1 + 1]; + *buffer++ = gDigitsLut[d2]; + *buffer++ = gDigitsLut[d2 + 1]; + *buffer++ = gDigitsLut[d3]; + *buffer++ = gDigitsLut[d3 + 1]; + *buffer++ = gDigitsLut[d4]; + *buffer++ = gDigitsLut[d4 + 1]; + *buffer++ = gDigitsLut[d5]; + *buffer++ = gDigitsLut[d5 + 1]; + *buffer++ = gDigitsLut[d6]; + *buffer++ = gDigitsLut[d6 + 1]; + *buffer++ = gDigitsLut[d7]; + *buffer++ = gDigitsLut[d7 + 1]; + *buffer++ = gDigitsLut[d8]; + *buffer++ = gDigitsLut[d8 + 1]; + } + + return buffer - start; +} + +size_t i64toa_branchlut(int64_t value, char* buffer) { + size_t length = 0; + if (value < 0) { + ++length; + *buffer++ = '-'; + value = -value; + } + + return length + u64toa_branchlut(static_cast(value), buffer); +} diff --git a/buffer-builder.cabal b/buffer-builder.cabal --- a/buffer-builder.cabal +++ b/buffer-builder.cabal @@ -1,9 +1,9 @@ name: buffer-builder -version: 0.1.0.0 +version: 0.2.0.0 synopsis: Library for efficiently building up buffers, one piece at a time description: - 'BufferBuilder' is an efficient library for incrementally building + "Data.BufferBuilder" is an efficient library for incrementally building up 'ByteString's, one chunk at a time. Early benchmarks show it is over twice as fast as ByteString Builder, primarily because 'BufferBuilder' is built upon an ST-style restricted monad and @@ -15,15 +15,15 @@ its associated indirect jumps and stack traffic only occur when BufferBuilder is asked to append a non-strict ByteString. . - I benchmarked four major implementations and benchmarked with the buildURL benchmark: + I benchmarked four approaches with a URL encoding benchmark: . - * State monad, concatenating ByteStrings: __6.98 us__ + * State monad, concatenating ByteStrings: 6.98 us . - * State monad, ByteString Builder: __2.48 us__ + * State monad, ByteString Builder: 2.48 us . - * Crazy explicit RealWorld baton passing with unboxed state: __28.94 us__ (GHC generated really awful code for this, but see the revision history for the technique) + * Crazy explicit RealWorld baton passing with unboxed state: 28.94 us (GHC generated really awful code for this, but see the revision history for the technique) . - * C + FFI + ReaderT: __1.11 us__ + * C + FFI + ReaderT: 1.11 us . Using BufferBuilder is very simple: . @@ -33,13 +33,15 @@ > BB.appendBS "http" > BB.appendChar8 '/' > BB.appendBS "//" - + . + This package also provides "Data.BufferBuilder.Utf8" for generating UTF-8 buffers + and "Data.BufferBuilder.Json" for encoding data structures into JSON. license: BSD3 license-file: LICENSE -author: Chad Austin +author: Chad Austin, Andy Friesen maintainer: chad@chadaustin.me -copyright: IMVU Inc., Chad Austin +copyright: IMVU Inc., Chad Austin, Andy Friesen category: Data build-type: Simple stability: experimental @@ -49,15 +51,20 @@ library exposed-modules: Data.BufferBuilder + Data.BufferBuilder.Utf8 + Data.BufferBuilder.Json build-depends: base ==4.* , bytestring , mtl + , text + , vector + , unordered-containers default-language: Haskell2010 ghc-options: -O2 -Wall - c-sources: buffer.cpp + c-sources: buffer.cpp branchlut.cpp cc-options: -O2 -Wall test-suite tests @@ -69,19 +76,74 @@ build-depends: base ==4.* , buffer-builder + , text , tasty , tasty-hunit , tasty-th + , tasty-quickcheck , HUnit + , text + , vector + , bytestring + , attoparsec + , aeson benchmark bench type: exitcode-stdio-1.0 main-is: Bench.hs hs-source-dirs: bench default-language: Haskell2010 - ghc-options: -O2 -Wall -ddump-ds -ddump-simpl -ddump-stg -ddump-opt-cmm -ddump-asm -ddump-to-file + ghc-options: -O2 -Wall + --ghc-options: -ddump-ds -ddump-simpl -ddump-stg -ddump-opt-cmm -ddump-asm -ddump-to-file build-depends: base ==4.* , bytestring , buffer-builder , criterion + +benchmark json-bench + type: exitcode-stdio-1.0 + main-is: JsonBench.hs + hs-source-dirs: bench + default-language: Haskell2010 + ghc-options: -O2 -Wall + --ghc-options: -ddump-ds -ddump-simpl -ddump-stg -ddump-opt-cmm -ddump-asm -ddump-to-file + build-depends: base + , buffer-builder + , aeson + , bytestring + , text + , deepseq + , vector + , criterion + , vector + +test-suite tinyjson + type: exitcode-stdio-1.0 + main-is: TinyJson.hs + hs-source-dirs: bench + default-language: Haskell2010 + ghc-options: -O2 -Wall + --ghc-options: -ddump-ds -ddump-simpl -ddump-stg -ddump-opt-cmm -ddump-asm -ddump-to-file + build-depends: base + , buffer-builder + , aeson + , bytestring + , text + , deepseq + , criterion + +test-suite tinyjson2 + type: exitcode-stdio-1.0 + main-is: TinyJson2.hs + hs-source-dirs: bench + default-language: Haskell2010 + ghc-options: -O2 -Wall + --ghc-options: -ddump-ds -ddump-simpl -ddump-stg -ddump-opt-cmm -ddump-asm -ddump-to-file + build-depends: base + , buffer-builder + , aeson + , bytestring + , deepseq + , criterion + , vector diff --git a/buffer.cpp b/buffer.cpp --- a/buffer.cpp +++ b/buffer.cpp @@ -2,15 +2,49 @@ #include #include #include +#include +#include "branchlut.h" + const size_t TRIM_THRESHOLD = 8192; // minimum number of bytes saved to trim +/* + * Append utf8, ASCII7, raw bytes, utf16 + * JSON encode utf8, ascii7, utf16 + */ + +#if defined(__clang__) + #define BW_NOINLINE __attribute__((noinline)) +#elif defined(__GNUC__) + #define BW_NOINLINE __attribute__((noinline)) +#else + #define BW_NOINLINE +#endif + namespace { struct BufferWriter { unsigned char* data; size_t size; size_t capacity; }; + + BW_NOINLINE void actuallyGrow(BufferWriter* bw, size_t amount) { + size_t newCapacity = bw->capacity; + do { + newCapacity *= 2; + } while (newCapacity < bw->size + amount); + + unsigned char* newData = reinterpret_cast(realloc(bw->data, newCapacity)); + assert(newData); + bw->data = newData; + bw->capacity = newCapacity; + } + + inline void grow(BufferWriter* bw, size_t amount) { + if (bw->size + amount > bw->capacity) { + actuallyGrow(bw, amount); + } + } } // assumes malloc will not fail @@ -32,37 +66,6 @@ free(bw); } -extern "C" void bw_append_byte(BufferWriter* bw, unsigned char byte) { - assert(bw->data); - if (bw->size >= bw->capacity) { - size_t newCapacity = bw->capacity * 2; - unsigned char* nd = reinterpret_cast(realloc(bw->data, newCapacity)); - assert(nd); - bw->data = nd; - bw->capacity = newCapacity; - } - - bw->data[bw->size] = byte; - bw->size += 1; -} - -extern "C" void bw_append_bs(BufferWriter* bw, size_t size, unsigned char* data) { - assert(bw->data); - if (bw->size + size > bw->capacity) { - size_t newCapacity = bw->capacity * 2; - while (bw->size + size > newCapacity) { - newCapacity *= 2; - } - unsigned char* nd = reinterpret_cast(realloc(bw->data, newCapacity)); - assert(nd); - bw->data = nd; - bw->capacity = newCapacity; - } - - memcpy(bw->data + bw->size, data, size); - bw->size += size; -} - extern "C" size_t bw_get_size(BufferWriter* bw) { return bw->size; } @@ -83,3 +86,204 @@ return data; } +extern "C" void bw_append_byte(BufferWriter* bw, unsigned char byte) { + assert(bw->data); + grow(bw, 1); + bw->data[bw->size] = byte; + bw->size += 1; +} + +extern "C" void bw_append_char_utf8(BufferWriter* bw, uint32_t c) { + assert(bw->data); + grow(bw, 4); + + size_t size = bw->size; + unsigned char* data = bw->data + size; + + if (c <= 0x7F) { + data[0] = static_cast(c); + size += 1; + } else if (c <= 0x7FF) { + data[0] = static_cast(0xC0 | (c >> 6)); + data[1] = static_cast(0x80 | (c & 0x3F)); + size += 2; + } else if (c <= 0xFFFF) { + data[0] = static_cast(0xE0 | (c >> 12)); + data[1] = static_cast(0x80 | ((c >> 6) & 0x3F)); + data[2] = static_cast(0x80 | (c & 0x3F)); + size += 3; + } else if (c <= 0x1FFFFF) { + data[0] = static_cast(0xF0 | (c >> 18)); + data[1] = static_cast(0x80 | ((c >> 12) & 0x3F)); + data[2] = static_cast(0x80 | ((c >> 6) & 0x3F)); + data[3] = static_cast(0x80 | (c & 0x3F)); + size += 4; + } else { + // Unicode characters out of this range are illegal... + // should we assert? or just ignore... + } + bw->size = size; +} + +extern "C" void bw_append_bs(BufferWriter* bw, size_t size, const unsigned char* data) { + assert(bw->data); + grow(bw, size); + + memcpy(bw->data + bw->size, data, size); + bw->size += size; +} + +extern "C" void bw_append_bsz(BufferWriter* bw, const unsigned char* data) { + bw_append_bs(bw, strlen(reinterpret_cast(data)), data); +} + +extern "C" void bw_append_byte7(BufferWriter* bw, unsigned char byte) { + assert(bw->data); + grow(bw, 1); + bw->data[bw->size] = byte & 0x7F; + bw->size += 1; +} + +extern "C" void bw_append_bs7(BufferWriter* bw, size_t size, const unsigned char* data) { + assert(bw->data); + grow(bw, size); + + unsigned char* out = bw->data + bw->size; + for (size_t i = 0; i < size; ++i) { + out[i] = data[i] & 0x7F; + } + bw->size += size; +} + +extern "C" void bw_append_bsz7(BufferWriter* bw, const unsigned char* data) { + bw_append_bs7(bw, strlen(reinterpret_cast(data)), data); +} + +extern "C" void bw_append_json_escaped(BufferWriter* bw, size_t size, const unsigned char* data) { + assert(bw->data); + grow(bw, 2 + size * 2); + + unsigned char* dest = bw->data + bw->size; + *dest++ = '\"'; + + size_t i = 0; + while (i < size) { + switch (data[i]) { + case '\n': *dest++ = '\\'; *dest++ = 'n'; break; + case '\r': *dest++ = '\\'; *dest++ = 'r'; break; + case '\t': *dest++ = '\\'; *dest++ = 't'; break; + case '\\': *dest++ = '\\'; *dest++ = '\\'; break; + case '\"': *dest++ = '\\'; *dest++ = '\"'; break; + default: *dest++ = data[i]; + } + ++i; + } + + *dest++ = '\"'; + bw->size = dest - bw->data; +} + +extern "C" void bw_append_decimal_signed_int(BufferWriter* bw, int64_t i) { + assert(bw->data); + grow(bw, 32); // enough + + unsigned used = i64toa_branchlut(i, reinterpret_cast(bw->data + bw->size)); + bw->size += used; +} + +extern "C" void bw_append_decimal_double(BufferWriter* bw, double d) { + assert(bw->data); + grow(bw, 30); // ??? + + size_t used = sprintf(reinterpret_cast(bw->data + bw->size), "%f", d); + bw->size += used; +} + +// From +extern "C" void bw_encode_utf8(uint8_t **destp, const uint16_t *src, size_t srcoff, size_t srclen) { + const uint16_t *srcend; + uint8_t *dest = *destp; + + src += srcoff; + srcend = src + srclen; + + ascii: +#if defined(__x86_64__) + while (srcend - src >= 4) { + uint64_t w = *((uint64_t *) src); + + if (w & 0xFF80FF80FF80FF80ULL) { + if (!(w & 0x000000000000FF80ULL)) { + *dest++ = w & 0xFFFF; + src++; + if (!(w & 0x00000000FF800000ULL)) { + *dest++ = (w >> 16) & 0xFFFF; + src++; + if (!(w & 0x0000FF8000000000ULL)) { + *dest++ = (w >> 32) & 0xFFFF; + src++; + } + } + } + break; + } + *dest++ = w & 0xFFFF; + *dest++ = (w >> 16) & 0xFFFF; + *dest++ = (w >> 32) & 0xFFFF; + *dest++ = w >> 48; + src += 4; + } +#endif + +#if defined(__i386__) + while (srcend - src >= 2) { + uint32_t w = *((uint32_t *) src); + + if (w & 0xFF80FF80) + break; + *dest++ = w & 0xFFFF; + *dest++ = w >> 16; + src += 2; + } +#endif + + while (src < srcend) { + uint16_t w = *src++; + + if (w <= 0x7F) { + *dest++ = w; + /* An ASCII byte is likely to begin a run of ASCII bytes. + Falling back into the fast path really helps performance. */ + goto ascii; + } + else if (w <= 0x7FF) { + *dest++ = (w >> 6) | 0xC0; + *dest++ = (w & 0x3f) | 0x80; + } + else if (w < 0xD800 || w > 0xDBFF) { + *dest++ = (w >> 12) | 0xE0; + *dest++ = ((w >> 6) & 0x3F) | 0x80; + *dest++ = (w & 0x3F) | 0x80; + } else { + uint32_t c = ((((uint32_t) w) - 0xD800) << 10) + + (((uint32_t) *src++) - 0xDC00) + 0x10000; + *dest++ = (c >> 18) | 0xF0; + *dest++ = ((c >> 12) & 0x3F) | 0x80; + *dest++ = ((c >> 6) & 0x3F) | 0x80; + *dest++ = (c & 0x3F) | 0x80; + } + } + + *destp = dest; +} + +extern "C" void bw_append_json_escaped_utf16(BufferWriter* bw, size_t size, unsigned short* words) { + unsigned char* utf8 = reinterpret_cast(malloc(size * 4)); + unsigned char* utf8end = utf8; + + bw_encode_utf8(&utf8end, words, 0, size); + + bw_append_json_escaped(bw, utf8end - utf8, utf8); + + free(utf8); +} diff --git a/test/Main.hs b/test/Main.hs --- a/test/Main.hs +++ b/test/Main.hs @@ -1,29 +1,17 @@ -{-# LANGUAGE TemplateHaskell, OverloadedStrings #-} +{-# LANGUAGE TemplateHaskell, OverloadedStrings, MagicHash #-} import Test.Tasty -import Test.Tasty.TH -import Test.Tasty.HUnit -import Data.BufferBuilder -case_append_bytes :: Assertion -case_append_bytes = do - let result = runBufferBuilder $ do - appendChar8 'f' - appendChar8 'o' - appendChar8 'o' - assertEqual "matches" "foo" result - -case_append_string :: Assertion -case_append_string = do - let result = runBufferBuilder $ do - appendChar8 'f' - appendChar8 'o' - appendChar8 'o' - appendBS "bar" - assertEqual "matches" "foobar" result +import qualified BufferTest +import qualified Utf8Test +import qualified JsonTest -tests :: TestTree -tests = $(testGroupGenerator) +allTests :: TestTree +allTests = testGroup "all tests" + [ BufferTest.tests + , Utf8Test.tests + , JsonTest.tests + ] main :: IO () -main = defaultMain tests +main = defaultMain allTests