Skip to content

HTTPS clone URL

Subversion checkout URL

You can clone with HTTPS or Subversion.

Download ZIP

Loading…

More efficient ToJSON and FromJSON instances for tuples #48

Merged
merged 1 commit into from

3 participants

@basvandijk
Collaborator

toJSON previously converted a tuple into a list and then converted that list into a vector. I now run a ST computation that creates a mutable vector of the correct size and fills it with the right Values. This improves performance by 45%.

fromJSON previously converted the vector into a list and then pattern matched that list so that the elements could be parsed. I now index the vector directly so we don't need to create a list. This improved performance by 20%.

@basvandijk basvandijk More efficient ToJSON and FromJSON instances for tuples
toJSON previously converted a tuple into a list and
then converted that list into a vector.
I now run a ST computation that creates a mutable vector of the correct size
and fills it with the right Values.
This improves performance by 45%.

fromJSON previously converted the vector into a list and
then pattern matched that list so that the elements could be parsed.
I now index the vector directly so we don't need to create a list.
This improved performance by 20%.
1f235b4
@bos
Owner
@hvr

@basvandijk nice... are you planning on porting this optimization over to the TH-generated instances? :-)

update: nevermind, I just saw the other pull-request C:-)

@bos bos merged commit 042a6bc into from
@bos
Owner

Once again - thanks, @basvandijk!

Sign up for free to join this conversation on GitHub. Already have an account? Sign in to comment
Commits on Nov 26, 2011
  1. @basvandijk

    More efficient ToJSON and FromJSON instances for tuples

    basvandijk authored
    toJSON previously converted a tuple into a list and
    then converted that list into a vector.
    I now run a ST computation that creates a mutable vector of the correct size
    and fills it with the right Values.
    This improves performance by 45%.
    
    fromJSON previously converted the vector into a list and
    then pattern matched that list so that the elements could be parsed.
    I now index the vector directly so we don't need to create a list.
    This improved performance by 20%.
This page is out of date. Refresh to see the latest.
Showing with 91 additions and 24 deletions.
  1. +46 −24 Data/Aeson/Types/Class.hs
  2. +45 −0 benchmarks/AesonTuples.hs
View
70 Data/Aeson/Types/Class.hs
@@ -71,6 +71,7 @@ import qualified Data.Vector.Generic as VG
import qualified Data.Vector.Primitive as VP
import qualified Data.Vector.Storable as VS
import qualified Data.Vector.Unboxed as VU
+import qualified Data.Vector.Mutable as VM ( unsafeNew, unsafeWrite )
#ifdef GENERICS
import GHC.Generics
@@ -622,45 +623,66 @@ instance FromJSON UTCTime where
{-# INLINE parseJSON #-}
instance (ToJSON a, ToJSON b) => ToJSON (a,b) where
- toJSON (a,b) = toJSON [toJSON a, toJSON b]
+ toJSON (a,b) = Array $ V.create $ do
+ mv <- VM.unsafeNew 2
+ VM.unsafeWrite mv 0 (toJSON a)
+ VM.unsafeWrite mv 1 (toJSON b)
+ return mv
{-# INLINE toJSON #-}
instance (FromJSON a, FromJSON b) => FromJSON (a,b) where
- parseJSON (Array ab) =
- case V.toList ab of
- [a,b] -> (,) <$> parseJSON a <*> parseJSON b
- _ -> fail $ "cannot unpack array of length " ++
- show (V.length ab) ++ " into a pair"
- parseJSON v = typeMismatch "(a,b)" v
+ parseJSON (Array ab)
+ | n == 2 = (,) <$> parseJSON (V.unsafeIndex ab 0)
+ <*> parseJSON (V.unsafeIndex ab 1)
+ | otherwise = fail $ "cannot unpack array of length " ++
+ show n ++ " into a pair"
+ where
+ n = V.length ab
+ parseJSON v = typeMismatch "(a,b)" v
{-# INLINE parseJSON #-}
instance (ToJSON a, ToJSON b, ToJSON c) => ToJSON (a,b,c) where
- toJSON (a,b,c) = toJSON [toJSON a, toJSON b, toJSON c]
+ toJSON (a,b,c) = Array $ V.create $ do
+ mv <- VM.unsafeNew 3
+ VM.unsafeWrite mv 0 (toJSON a)
+ VM.unsafeWrite mv 1 (toJSON b)
+ VM.unsafeWrite mv 2 (toJSON c)
+ return mv
{-# INLINE toJSON #-}
instance (FromJSON a, FromJSON b, FromJSON c) => FromJSON (a,b,c) where
- parseJSON (Array abc) =
- case V.toList abc of
- [a,b,c] -> (,,) <$> parseJSON a <*> parseJSON b <*> parseJSON c
- _ -> fail $ "cannot unpack array of length " ++
- show (V.length abc) ++ " into a 3-tuple"
- parseJSON v = typeMismatch "(a,b,c)" v
+ parseJSON (Array abc)
+ | n == 3 = (,,) <$> parseJSON (V.unsafeIndex abc 0)
+ <*> parseJSON (V.unsafeIndex abc 1)
+ <*> parseJSON (V.unsafeIndex abc 2)
+ | otherwise = fail $ "cannot unpack array of length " ++
+ show n ++ " into a 3-tuple"
+ where
+ n = V.length abc
+ parseJSON v = typeMismatch "(a,b,c)" v
{-# INLINE parseJSON #-}
instance (ToJSON a, ToJSON b, ToJSON c, ToJSON d) => ToJSON (a,b,c,d) where
- toJSON (a,b,c,d) = toJSON [toJSON a, toJSON b, toJSON c, toJSON d]
+ toJSON (a,b,c,d) = Array $ V.create $ do
+ mv <- VM.unsafeNew 4
+ VM.unsafeWrite mv 0 (toJSON a)
+ VM.unsafeWrite mv 1 (toJSON b)
+ VM.unsafeWrite mv 2 (toJSON c)
+ VM.unsafeWrite mv 3 (toJSON d)
+ return mv
{-# INLINE toJSON #-}
instance (FromJSON a, FromJSON b, FromJSON c, FromJSON d) => FromJSON (a,b,c,d) where
- parseJSON (Array abcd) =
- case V.toList abcd of
- [a,b,c,d] -> (,,,) <$> parseJSON a
- <*> parseJSON b
- <*> parseJSON c
- <*> parseJSON d
- _ -> fail $ "cannot unpack array of length " ++
- show (V.length abcd) ++ " into a 4-tuple"
- parseJSON v = typeMismatch "(a,b,c,d)" v
+ parseJSON (Array abcd)
+ | n == 4 = (,,,) <$> parseJSON (V.unsafeIndex abcd 0)
+ <*> parseJSON (V.unsafeIndex abcd 1)
+ <*> parseJSON (V.unsafeIndex abcd 2)
+ <*> parseJSON (V.unsafeIndex abcd 3)
+ | otherwise = fail $ "cannot unpack array of length " ++
+ show n ++ " into a 4-tuple"
+ where
+ n = V.length abcd
+ parseJSON v = typeMismatch "(a,b,c,d)" v
{-# INLINE parseJSON #-}
instance ToJSON a => ToJSON (Dual a) where
View
45 benchmarks/AesonTuples.hs
@@ -0,0 +1,45 @@
+module Main where
+
+--------------------------------------------------------------------------------
+
+import Criterion.Main
+import Control.DeepSeq (deepseq)
+import Data.Aeson
+
+--------------------------------------------------------------------------------
+
+type FJ a = Value -> Result a
+
+type T2 = (Int, Int)
+type T3 = (Int, Int, Int)
+type T4 = (Int, Int, Int, Int)
+
+t2 :: T2
+t2 = (1, 2)
+
+t3 :: T3
+t3 = (1, 2, 3)
+
+t4 :: T4
+t4 = (1, 2, 3, 4)
+
+main :: IO ()
+main = let v2 = toJSON t2
+ v3 = toJSON t3
+ v4 = toJSON t4
+ in t2 `deepseq` t3 `deepseq` t4 `deepseq`
+ v2 `deepseq` v3 `deepseq` v4 `deepseq`
+ defaultMain
+ [ bgroup "t2"
+ [ bench "toJSON" (nf toJSON t2)
+ , bench "fromJSON" (nf (fromJSON :: FJ T2) v2)
+ ]
+ , bgroup "t3"
+ [ bench "toJSON" (nf toJSON t3)
+ , bench "fromJSON" (nf (fromJSON :: FJ T3) v3)
+ ]
+ , bgroup "t4"
+ [ bench "toJSON" (nf toJSON t4)
+ , bench "fromJSON" (nf (fromJSON :: FJ T4) v4)
+ ]
+ ]
Something went wrong with that request. Please try again.