diff --git a/Data/Aeson/Encode.hs b/Data/Aeson/Encode.hs --- a/Data/Aeson/Encode.hs +++ b/Data/Aeson/Encode.hs @@ -17,22 +17,20 @@ import Blaze.ByteString.Builder import Blaze.ByteString.Builder.Char.Utf8 +import Data.Aeson.Encode.Number (fromNumber) import Data.Aeson.Types (ToJSON(..), Value(..)) -import Data.Attoparsec.Number (Number(..)) import Data.Monoid (mappend) import Numeric (showHex) import qualified Data.ByteString.Lazy.Char8 as L import qualified Data.Map as M import qualified Data.Text as T import qualified Data.Vector as V -import qualified Text.Show.ByteString as S -- | Encode a JSON value to a 'Builder'. fromValue :: Value -> Builder fromValue Null = fromByteString "null" fromValue (Bool b) = fromByteString $ if b then "true" else "false" -fromValue (Number (I n)) = fromLazyByteString (S.show n) -fromValue (Number (D n)) = fromLazyByteString (S.show n) +fromValue (Number n) = fromNumber n fromValue (String s) = string s fromValue (Array v) | V.null v = fromByteString "[]" diff --git a/Data/Aeson/Encode/Double.hs b/Data/Aeson/Encode/Double.hs new file mode 100644 --- /dev/null +++ b/Data/Aeson/Encode/Double.hs @@ -0,0 +1,122 @@ +{-# LANGUAGE BangPatterns, CPP, MagicHash, OverloadedStrings, UnboxedTuples #-} + +-- Module: Data.Aeson.Encode.Number +-- Copyright: (c) 2011 MailRank, Inc. +-- License: Apache +-- Maintainer: Bryan O'Sullivan +-- Stability: experimental +-- Portability: portable +-- +-- Efficiently serialize a Double as a lazy 'L.ByteString'. + +module Data.Aeson.Encode.Double + ( + double + ) where + +import Blaze.ByteString.Builder (Builder, fromByteString) +import Blaze.ByteString.Builder.Char8 (fromChar) +import Data.Aeson.Encode.Int (digit, int, minus) +import Data.ByteString.Char8 () +import Data.Monoid (mappend, mconcat, mempty) +import qualified Data.Vector as V + +-- The code below is originally from GHC.Float, but has been optimised +-- in quite a few ways. + +data T = T [Int] {-# UNPACK #-} !Int + +double :: Double -> Builder +double f + | isNaN f = fromByteString "NaN" + | isInfinite f = fromByteString $ + if f < 0 then "-Infinity" else "Infinity" + | f < 0 || isNegativeZero f = minus `mappend` goGeneric (floatToDigits (-f)) + | otherwise = goGeneric (floatToDigits f) + where + goGeneric p@(T _ e) + | e < 0 || e > 7 = goExponent p + | otherwise = goFixed p + goExponent (T is e) = + case is of + [] -> error "putFormattedFloat" + [0] -> fromByteString "0.0e0" + [d] -> digit d `mappend` fromByteString ".0e" `mappend` int (e-1) + (d:ds) -> digit d `mappend` fromChar '.' `mappend` digits ds `mappend` + fromChar 'e' `mappend` int (e-1) + goFixed (T is e) + | e <= 0 = fromChar '0' `mappend` fromChar '.' `mappend` + mconcat (replicate (-e) (fromChar '0')) `mappend` + digits is + | otherwise = let g 0 rs = fromChar '.' `mappend` mk0 rs + g n [] = fromChar '0' `mappend` g (n-1) [] + g n (r:rs) = digit r `mappend` g (n-1) rs + in g e is + mk0 [] = fromChar '0' + mk0 rs = digits rs + +digits :: [Int] -> Builder +digits (d:ds) = digit d `mappend` digits ds +digits _ = mempty +{-# INLINE digits #-} + +floatToDigits :: Double -> T +floatToDigits 0 = T [0] 0 +floatToDigits x = T (reverse rds) k + where + (f0, e0) = decodeFloat x + (minExp0, _) = floatRange (undefined::Double) + p = floatDigits x + b = floatRadix x + minExp = minExp0 - p -- the real minimum exponent + -- Haskell requires that f be adjusted so denormalized numbers + -- will have an impossibly low exponent. Adjust for this. + (# f, e #) = + let n = minExp - e0 in + if n > 0 then (# f0 `div` (b^n), e0+n #) else (# f0, e0 #) + (# r, s, mUp, mDn #) = + if e >= 0 + then let be = b^ e + in if f == b^(p-1) + then (# f*be*b*2, 2*b, be*b, b #) + else (# f*be*2, 2, be, be #) + else if e > minExp && f == b^(p-1) + then (# f*b*2, b^(-e+1)*2, b, 1 #) + else (# f*2, b^(-e)*2, 1, 1 #) + k = fixup k0 + where + k0 | b == 2 = (p - 1 + e0) * 3 `div` 10 + -- logBase 10 2 is slightly bigger than 3/10 so the following + -- will err on the low side. Ignoring the fraction will make + -- it err even more. Haskell promises that p-1 <= logBase b f + -- < p. + | otherwise = ceiling ((log (fromInteger (f+1) :: Double) + + fromIntegral e * log (fromInteger b)) / log 10) + fixup n + | n >= 0 = if r + mUp <= exp10 n * s then n else fixup (n+1) + | otherwise = if exp10 (-n) * (r + mUp) <= s then n else fixup (n+1) + + gen ds !rn !sN !mUpN !mDnN = + let (dn0, rn') = (rn * 10) `divMod` sN + mUpN' = mUpN * 10 + mDnN' = mDnN * 10 + !dn = fromInteger dn0 + !dn' = dn + 1 + in case (# rn' < mDnN', rn' + mUpN' > sN #) of + (# True, False #) -> dn : ds + (# False, True #) -> dn' : ds + (# True, True #) -> if rn' * 2 < sN then dn : ds else dn' : ds + (# False, False #) -> gen (dn:ds) rn' sN mUpN' mDnN' + + rds | k >= 0 = gen [] r (s * exp10 k) mUp mDn + | otherwise = gen [] (r * bk) s (mUp * bk) (mDn * bk) + where bk = exp10 (-k) + +exp10 :: Int -> Integer +exp10 n + | n >= 0 && n < maxExpt = V.unsafeIndex expts n + | otherwise = 10 ^ n + where expts = V.generate maxExpt (10^) + {-# NOINLINE expts #-} + maxExpt = 17 +{-# INLINE exp10 #-} diff --git a/Data/Aeson/Encode/Int.hs b/Data/Aeson/Encode/Int.hs new file mode 100644 --- /dev/null +++ b/Data/Aeson/Encode/Int.hs @@ -0,0 +1,34 @@ +{-# LANGUAGE BangPatterns, CPP, MagicHash, UnboxedTuples #-} + +-- Module: Data.Aeson.Encode.Int +-- Copyright: (c) 2011 MailRank, Inc. +-- License: Apache +-- Maintainer: Bryan O'Sullivan +-- Stability: experimental +-- Portability: portable +-- +-- Efficiently serialize an integral JSON value as a lazy 'L.ByteString'. + +module Data.Aeson.Encode.Int + ( + digit + , int + , minus + ) where + +import Blaze.ByteString.Builder (Builder, fromWord8) +import Data.Monoid (mappend) + +int :: Int -> Builder +int i + | i < 0 = minus `mappend` go (-i) + | otherwise = go i + where + go n | n < 10 = digit n + | otherwise = go (n `rem` 10) `mappend` digit (n `quot` 10) + +digit :: Int -> Builder +digit n = fromWord8 $! fromIntegral n + 48 + +minus :: Builder +minus = fromWord8 45 diff --git a/Data/Aeson/Encode/Number.hs b/Data/Aeson/Encode/Number.hs new file mode 100644 --- /dev/null +++ b/Data/Aeson/Encode/Number.hs @@ -0,0 +1,100 @@ +{-# LANGUAGE BangPatterns, CPP, MagicHash, UnboxedTuples #-} + +-- Module: Data.Aeson.Encode.Number +-- Copyright: (c) 2011 MailRank, Inc. +-- License: Apache +-- Maintainer: Bryan O'Sullivan +-- Stability: experimental +-- Portability: portable +-- +-- Efficiently serialize a numeric JSON value as a lazy 'L.ByteString'. + +module Data.Aeson.Encode.Number + ( + fromNumber + ) where + +import Data.Monoid (mappend, mempty) +import Data.Attoparsec.Number (Number(..)) +import Data.Aeson.Encode.Double +import Data.Aeson.Encode.Int +import Blaze.ByteString.Builder +import GHC.Base (quotInt, remInt) +import GHC.Num (quotRemInteger) +import GHC.Types (Int(..)) + +#ifdef __GLASGOW_HASKELL__ +# if __GLASGOW_HASKELL__ < 611 +import GHC.Integer.Internals +# else +import GHC.Integer.GMP.Internals +# endif +#endif + +#ifdef INTEGER_GMP +# define PAIR(a,b) (# a,b #) +#else +# define PAIR(a,b) (a,b) +#endif + +fromNumber :: Number -> Builder +fromNumber (I i) = integer i +fromNumber (D d) = double d + +integer :: Integer -> Builder +integer (S# i#) = int (I# i#) +integer i + | i < 0 = minus `mappend` go (-i) + | otherwise = go i + where + go n | n < maxInt = int (fromInteger n) + | otherwise = putH (splitf (maxInt * maxInt) n) + + splitf p n + | p > n = [n] + | otherwise = splith p (splitf (p*p) n) + + splith p (n:ns) = case n `quotRemInteger` p of + PAIR(q,r) | q > 0 -> q : r : splitb p ns + | otherwise -> r : splitb p ns + splith _ _ = error "splith: the impossible happened." + + splitb p (n:ns) = case n `quotRemInteger` p of + PAIR(q,r) -> q : r : splitb p ns + splitb _ _ = [] + +data T = T !Integer !Int + +fstT :: T -> Integer +fstT (T a _) = a + +maxInt :: Integer +maxDigits :: Int +T maxInt maxDigits = + until ((>mi) . (*10) . fstT) (\(T n d) -> T (n*10) (d+1)) (T 10 1) + where mi = fromIntegral (maxBound :: Int) + +putH :: [Integer] -> Builder +putH (n:ns) = case n `quotRemInteger` maxInt of + PAIR(x,y) + | q > 0 -> int q `mappend` pblock r `mappend` putB ns + | otherwise -> int r `mappend` putB ns + where q = fromInteger x + r = fromInteger y +putH _ = error "putH: the impossible happened" + +putB :: [Integer] -> Builder +putB (n:ns) = case n `quotRemInteger` maxInt of + PAIR(x,y) -> pblock q `mappend` pblock r `mappend` putB ns + where q = fromInteger x + r = fromInteger y +putB _ = mempty + +pblock :: Int -> Builder +pblock = go maxDigits + where + go !d !n + | d == 1 = digit n + | otherwise = go (d-1) q `mappend` digit r + where q = n `quotInt` 10 + r = n `remInt` 10 diff --git a/Data/Aeson/Parser.hs b/Data/Aeson/Parser.hs --- a/Data/Aeson/Parser.hs +++ b/Data/Aeson/Parser.hs @@ -79,6 +79,8 @@ doubleQuote, backslash :: Word8 doubleQuote = 34 backslash = 92 +{-# INLINE backslash #-} +{-# INLINE doubleQuote #-} jstring :: Parser Text jstring = A.word8 doubleQuote *> jstring_ @@ -92,14 +94,11 @@ else Just (c == backslash) _ <- A.word8 doubleQuote if backslash `B.elem` s - then decodeUtf8 <$> reparse unescape s + then case Z.parse unescape s of + Right r -> return (decodeUtf8 r) + Left err -> fail err else return (decodeUtf8 s) {-# INLINE jstring_ #-} - -reparse :: Z.Parser a -> ByteString -> Parser a -reparse p s = case Z.parse p s of - Right r -> return r - Left err -> fail err unescape :: Z.Parser ByteString unescape = toByteString <$> go mempty where diff --git a/aeson.cabal b/aeson.cabal --- a/aeson.cabal +++ b/aeson.cabal @@ -1,5 +1,5 @@ name: aeson -version: 0.3.1.1 +version: 0.3.2.0 license: BSD3 license-file: LICENSE category: Text, Web, JSON @@ -21,38 +21,44 @@ (2.66GHz Core i7), for mostly-English tweets from Twitter's JSON search API: . - * 854 bytes: 21054 msg\/sec (17.1 MB/sec) + * English, 854 bytes: 29029 msg\/sec (23.6 MB/sec) . - * 6.4 KB: 4545 msg\/sec (28.6 MB/sec) + * English, 6.4 KB: 6407 msg\/sec (40.3 MB/sec) . - * 31.2 KB: 856 msg\/sec (26.1 MB/sec) + * English, 31.2 KB: 1265 msg\/sec (38.8 MB/sec) . - * 61.5 KB: 403 msg\/sec (24.2 MB/sec) + * English, 61.5 KB: 585 msg\/sec (35.2 MB/sec) . Handling heavily-escaped text is a little more work. Here is parsing performance with Japanese tweets, where much of the text is entirely Unicode-escaped: . - * 14.6 KB: 1250 msg\/sec (17.9 MB/sec) + * Japanese, 14.6 KB: 2227 msg\/sec (31.9 MB/sec) . - * 44.1 KB: 363 msg\/sec (15.6 MB/sec) + * Japanese, 44.1 KB: 671 msg\/sec (29.6 MB/sec) . Encoding performance on the same machine and data: . - * 854 bytes: 10647 msg\/sec (8.7 MB/sec) + * English, 854 bytes: 43439 msg\/sec (35.4 MB/sec) . - * 6.4 KB: 2098 msg\/sec (13.2 MB/sec) + * English, 6.4 KB: 7127 msg\/sec (44.8 MB/sec) . - * 31.2 KB: 422 msg\/sec (12.9 MB/sec) + * Engish, 61.5 KB: 765 msg\/sec (46.0 MB/sec) . - * 61.5 KB: 219 msg\/sec (13.2 MB/sec) + * Japanese, 14.6 KB: 4727 msg\/sec (67.5 MB/sec) . + * Japanese, 44.1 KB: 1505 msg\/sec (64.8 MB/sec) + . + With GHC 7.0.2, the story is mixed: parsing is 20-40% slower than + GHC 6.12.3, while encoding performance ranges from about the same + to twice as fast (on numeric data). + . (A note on naming: in Greek mythology, Aeson was the father of Jason.) extra-source-files: README.markdown + benchmarks/AesonEncode.hs benchmarks/AesonParse.hs - benchmarks/EncodeFile.hs benchmarks/JsonParse.hs benchmarks/Makefile benchmarks/ReadFile.hs @@ -83,6 +89,9 @@ Data.Aeson.Types other-modules: + Data.Aeson.Encode.Double + Data.Aeson.Encode.Int + Data.Aeson.Encode.Number Data.Aeson.Functions build-depends: @@ -93,7 +102,9 @@ bytestring-show, containers, deepseq, + ghc-prim, hashable, + integer-gmp, monads-fd, old-locale, syb, @@ -107,6 +118,14 @@ ghc-prof-options: -auto-all ghc-options: -Wall + + if impl(ghc >= 6.11) + cpp-options: -DINTEGER_GMP + build-depends: integer-gmp >= 0.2 && < 0.3 + + if impl(ghc >= 6.9) && impl(ghc < 6.11) + cpp-options: -DINTEGER_GMP + build-depends: integer >= 0.1 && < 0.2 source-repository head type: git diff --git a/benchmarks/AesonEncode.hs b/benchmarks/AesonEncode.hs new file mode 100644 --- /dev/null +++ b/benchmarks/AesonEncode.hs @@ -0,0 +1,44 @@ +{-# LANGUAGE BangPatterns, OverloadedStrings #-} + +import Control.Exception +import Control.Monad +import Data.Aeson +import Data.Aeson.Encode +import Data.Aeson.Parser +import Data.Attoparsec +import Data.Time.Clock +import System.Environment (getArgs) +import System.IO +import qualified Data.ByteString as B +import qualified Data.ByteString.Lazy as L +import qualified Data.ByteString.Lazy.Internal as L +import Control.DeepSeq + +instance NFData L.ByteString where + rnf = go + where go (L.Chunk _ cs) = go cs + go L.Empty = () + {-# INLINE rnf #-} + +main = do + (cnt:args) <- getArgs + let count = read cnt :: Int + forM_ args $ \arg -> bracket (openFile arg ReadMode) hClose $ \h -> do + putStrLn $ arg ++ ":" + let refill = B.hGet h 16384 + result <- parseWith refill json =<< refill + r <- case result of + Done _ r -> return r + _ -> fail $ "failed to read " ++ show arg + start <- getCurrentTime + let loop !n r + | n >= count = return () + | otherwise = {-# SCC "loop" #-} do + case result of + Done _ r -> rnf (encode r) `seq` loop (n+1) r + _ -> error $ "failed to read " ++ show arg + loop 0 r + delta <- flip diffUTCTime start `fmap` getCurrentTime + let rate = fromIntegral count / (fromRational . toRational) delta :: Double + putStrLn $ " " ++ show delta + putStrLn $ " " ++ show (round rate) ++ " per second" diff --git a/benchmarks/AesonParse.hs b/benchmarks/AesonParse.hs --- a/benchmarks/AesonParse.hs +++ b/benchmarks/AesonParse.hs @@ -27,5 +27,7 @@ Done _ r -> loop (good+1) bad _ -> loop good (bad+1) (good, _) <- loop 0 0 - end <- getCurrentTime - putStrLn $ " " ++ show good ++ " good, " ++ show (diffUTCTime end start) + delta <- flip diffUTCTime start `fmap` getCurrentTime + putStrLn $ " " ++ show good ++ " good, " ++ show delta + let rate = fromIntegral count / (fromRational . toRational) delta :: Double + putStrLn $ " " ++ show (round rate) ++ " per second" diff --git a/benchmarks/EncodeFile.hs b/benchmarks/EncodeFile.hs deleted file mode 100644 --- a/benchmarks/EncodeFile.hs +++ /dev/null @@ -1,32 +0,0 @@ -{-# LANGUAGE BangPatterns, OverloadedStrings #-} - -import Control.Exception -import Control.Monad -import Data.Aeson -import Data.Aeson.Encode -import Data.Aeson.Parser -import Data.Attoparsec -import Data.Time.Clock -import System.Environment (getArgs) -import System.IO -import qualified Data.ByteString as B -import qualified Data.ByteString.Lazy as L - -main = do - (cnt:args) <- getArgs - let count = read cnt :: Int - forM_ args $ \arg -> bracket (openFile arg ReadMode) hClose $ \h -> do - putStrLn $ arg ++ ":" - start <- getCurrentTime - let loop !n - | n >= count = return () - | otherwise = {-# SCC "loop" #-} do - hSeek h AbsoluteSeek 0 - let refill = B.hGet h 16384 - result <- parseWith refill json =<< refill - case result of - Done _ r -> L.length (encode r) `seq` loop (n+1) - _ -> error $ "failed to read " ++ show arg - loop 0 - end <- getCurrentTime - putStrLn $ " " ++ show (diffUTCTime end start) diff --git a/benchmarks/Makefile b/benchmarks/Makefile --- a/benchmarks/Makefile +++ b/benchmarks/Makefile @@ -1,7 +1,7 @@ ghc := ghc ghcflags := -O -binaries := AesonParse EncodeFile JsonParse +binaries := AesonParse AesonEncode JsonParse all: $(binaries) $(binaries:%=%_p)