git.iko.soy/typeable/aeson
on master help sign in
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%.

commitde53914bd5689f3c1a83bb29d3f8bfa1b6c83b09 authorBas van Dijk <v.dijk.bas@gmail.com> dateSat 26 Nov 2011, 15:35 (15 years ago) parenta9000a3
2 files changed+91−24
compare with master
unifiedsplit
Data/Aeson/Types/Class.hs+46−24 benchmarks/AesonTuples.hs+45
Data/Aeson/Types/Class.hs+46−24
@@ -71,6 +71,7 @@ import qualified Data.Vector.Generic as VG
7171import qualified Data.Vector.Primitive as VP
7272import qualified Data.Vector.Storable as VS
7373import qualified Data.Vector.Unboxed as VU
74+import qualified Data.Vector.Mutable as VM ( unsafeNew, unsafeWrite )
7475
7576#ifdef GENERICS
7677import GHC.Generics
@@ -622,45 +623,66 @@ instance FromJSON UTCTime where
622623 {-# INLINE parseJSON #-}
623624
624625instance (ToJSON a, ToJSON b) => ToJSON (a,b) where
625− toJSON (a,b) = toJSON [toJSON a, toJSON b]
626+ toJSON (a,b) = Array $ V.create $ do
627+ mv <- VM.unsafeNew 2
628+ VM.unsafeWrite mv 0 (toJSON a)
629+ VM.unsafeWrite mv 1 (toJSON b)
630+ return mv
626631 {-# INLINE toJSON #-}
627632
628633instance (FromJSON a, FromJSON b) => FromJSON (a,b) where
629− parseJSON (Array ab) =
630− case V.toList ab of
631− [a,b] -> (,) <$> parseJSON a <*> parseJSON b
632− _ -> fail $ "cannot unpack array of length " ++
633− show (V.length ab) ++ " into a pair"
634− parseJSON v = typeMismatch "(a,b)" v
634+ parseJSON (Array ab)
635+ | n == 2 = (,) <$> parseJSON (V.unsafeIndex ab 0)
636+ <*> parseJSON (V.unsafeIndex ab 1)
637+ | otherwise = fail $ "cannot unpack array of length " ++
638+ show n ++ " into a pair"
639+ where
640+ n = V.length ab
641+ parseJSON v = typeMismatch "(a,b)" v
635642 {-# INLINE parseJSON #-}
636643
637644instance (ToJSON a, ToJSON b, ToJSON c) => ToJSON (a,b,c) where
638− toJSON (a,b,c) = toJSON [toJSON a, toJSON b, toJSON c]
645+ toJSON (a,b,c) = Array $ V.create $ do
646+ mv <- VM.unsafeNew 3
647+ VM.unsafeWrite mv 0 (toJSON a)
648+ VM.unsafeWrite mv 1 (toJSON b)
649+ VM.unsafeWrite mv 2 (toJSON c)
650+ return mv
639651 {-# INLINE toJSON #-}
640652
641653instance (FromJSON a, FromJSON b, FromJSON c) => FromJSON (a,b,c) where
642− parseJSON (Array abc) =
643− case V.toList abc of
644− [a,b,c] -> (,,) <$> parseJSON a <*> parseJSON b <*> parseJSON c
645− _ -> fail $ "cannot unpack array of length " ++
646− show (V.length abc) ++ " into a 3-tuple"
647− parseJSON v = typeMismatch "(a,b,c)" v
654+ parseJSON (Array abc)
655+ | n == 3 = (,,) <$> parseJSON (V.unsafeIndex abc 0)
656+ <*> parseJSON (V.unsafeIndex abc 1)
657+ <*> parseJSON (V.unsafeIndex abc 2)
658+ | otherwise = fail $ "cannot unpack array of length " ++
659+ show n ++ " into a 3-tuple"
660+ where
661+ n = V.length abc
662+ parseJSON v = typeMismatch "(a,b,c)" v
648663 {-# INLINE parseJSON #-}
649664
650665instance (ToJSON a, ToJSON b, ToJSON c, ToJSON d) => ToJSON (a,b,c,d) where
651− toJSON (a,b,c,d) = toJSON [toJSON a, toJSON b, toJSON c, toJSON d]
666+ toJSON (a,b,c,d) = Array $ V.create $ do
667+ mv <- VM.unsafeNew 4
668+ VM.unsafeWrite mv 0 (toJSON a)
669+ VM.unsafeWrite mv 1 (toJSON b)
670+ VM.unsafeWrite mv 2 (toJSON c)
671+ VM.unsafeWrite mv 3 (toJSON d)
672+ return mv
652673 {-# INLINE toJSON #-}
653674
654675instance (FromJSON a, FromJSON b, FromJSON c, FromJSON d) => FromJSON (a,b,c,d) where
655− parseJSON (Array abcd) =
656− case V.toList abcd of
657− [a,b,c,d] -> (,,,) <$> parseJSON a
658− <*> parseJSON b
659− <*> parseJSON c
660− <*> parseJSON d
661− _ -> fail $ "cannot unpack array of length " ++
662− show (V.length abcd) ++ " into a 4-tuple"
663− parseJSON v = typeMismatch "(a,b,c,d)" v
676+ parseJSON (Array abcd)
677+ | n == 4 = (,,,) <$> parseJSON (V.unsafeIndex abcd 0)
678+ <*> parseJSON (V.unsafeIndex abcd 1)
679+ <*> parseJSON (V.unsafeIndex abcd 2)
680+ <*> parseJSON (V.unsafeIndex abcd 3)
681+ | otherwise = fail $ "cannot unpack array of length " ++
682+ show n ++ " into a 4-tuple"
683+ where
684+ n = V.length abcd
685+ parseJSON v = typeMismatch "(a,b,c,d)" v
664686 {-# INLINE parseJSON #-}
665687
666688instance ToJSON a => ToJSON (Dual a) where
benchmarks/AesonTuples.hsnew file+45
@@ -0,0 +1,45 @@
1+module Main where
2+
3+--------------------------------------------------------------------------------
4+
5+import Criterion.Main
6+import Control.DeepSeq (deepseq)
7+import Data.Aeson
8+
9+--------------------------------------------------------------------------------
10+
11+type FJ a = Value -> Result a
12+
13+type T2 = (Int, Int)
14+type T3 = (Int, Int, Int)
15+type T4 = (Int, Int, Int, Int)
16+
17+t2 :: T2
18+t2 = (1, 2)
19+
20+t3 :: T3
21+t3 = (1, 2, 3)
22+
23+t4 :: T4
24+t4 = (1, 2, 3, 4)
25+
26+main :: IO ()
27+main = let v2 = toJSON t2
28+ v3 = toJSON t3
29+ v4 = toJSON t4
30+ in t2 `deepseq` t3 `deepseq` t4 `deepseq`
31+ v2 `deepseq` v3 `deepseq` v4 `deepseq`
32+ defaultMain
33+ [ bgroup "t2"
34+ [ bench "toJSON" (nf toJSON t2)
35+ , bench "fromJSON" (nf (fromJSON :: FJ T2) v2)
36+ ]
37+ , bgroup "t3"
38+ [ bench "toJSON" (nf toJSON t3)
39+ , bench "fromJSON" (nf (fromJSON :: FJ T3) v3)
40+ ]
41+ , bgroup "t4"
42+ [ bench "toJSON" (nf toJSON t4)
43+ , bench "fromJSON" (nf (fromJSON :: FJ T4) v4)
44+ ]
45+ ]