git.iko.soy/typeable/aeson
on master help sign in
Merge pull request #46 from basvandijk/optimizations

Optimizations

commitb3694962d63d5fd36f46059526d0d52bef389f0e authorBryan O'Sullivan <bos@serpentine.com> dateTue 29 Nov 2011, 09:28 (15 years ago) parenta9000a3ab30765
3 files changed+59−38
compare with master
unifiedsplit
Data/Aeson/TH.hs+36−14 Data/Aeson/Types/Generic.hs+22−23 aeson.cabal+1−1
Data/Aeson/TH.hs+36−14
@@ -52,10 +52,12 @@ instance 'ToJSON' a => 'ToJSON' (D a) where
5252 'object' [T.pack \"Unary\" .= 'toJSON' arg1]
5353 Product arg1 arg2 arg3 ->
5454 'object' [ T.pack \"Product\"
55− .= 'toJSON' [ 'toJSON' arg1
56− , 'toJSON' arg2
57− , 'toJSON' arg3
58− ]
55+ .= ('Array' $ 'V.create' $ do
56+ mv <- 'VM.unsafeNew' 3
57+ 'VM.unsafeWrite' mv 0 ('toJSON' arg1)
58+ 'VM.unsafeWrite' mv 1 ('toJSON' arg2)
59+ 'VM.unsafeWrite' mv 2 ('toJSON' arg3)
60+ return mv)
5961 ]
6062 Record arg1 arg2 arg3 ->
6163 'object' [ T.pack \"Record\"
@@ -164,7 +166,7 @@ import Data.List ( (++), foldl, foldl', intercalate
164166 , length, map, zip, genericLength
165167 )
166168import Data.Maybe ( Maybe(Nothing, Just) )
167−import Prelude ( String, (-), Integer, error )
169+import Prelude ( String, (-), Integer, fromIntegral, error )
168170import Text.Printf ( printf )
169171import Text.Show ( show )
170172#if __GLASGOW_HASKELL__ < 700
@@ -178,8 +180,8 @@ import Language.Haskell.TH
178180-- from text:
179181import qualified Data.Text as T ( Text, pack, unpack )
180182-- from vector:
181−import qualified Data.Vector as V ( unsafeIndex, null, length )
182−
183+import qualified Data.Vector as V ( unsafeIndex, null, length, create )
184+import qualified Data.Vector.Mutable as VM ( unsafeNew, unsafeWrite )
183185
184186
185187--------------------------------------------------------------------------------
@@ -231,7 +233,11 @@ The above (ToJSON a) constraint is not necessary and perhaps undesirable.
231233-- instance 'ToJSON' Foo where
232234-- 'toJSON' =
233235-- \value -> case value of
234−-- Foo arg1 arg2 -> 'toJSON' ['toJSON' arg1, 'toJSON' arg2]
236+-- Foo arg1 arg2 -> 'Array' $ 'V.create' $ do
237+-- mv <- 'VM.unsafeNew' 2
238+-- 'VM.unsafeWrite' mv 0 ('toJSON' arg1)
239+-- 'VM.unsafeWrite' mv 1 ('toJSON' arg2)
240+-- return mv
235241-- @
236242deriveToJSON :: (String -> String)
237243 -- ^ Function to change field names.
@@ -327,12 +333,28 @@ encodeArgs withExp _ (NormalC conName []) =
327333 []
328334-- Polyadic constructors with special case for unary constructors.
329335encodeArgs withExp _ (NormalC conName ts) = do
330− args <- mapM newName ["arg" ++ show n | (_, n) <- zip ts [1 :: Integer ..]]
331− let js = case [[e|toJSON|] `appE` varE arg | arg <- args] of
332− -- Single argument is directly converted.
333− [e] -> e
334− -- Multiple arguments are converted to a JSON array.
335− es -> [e|toJSON|] `appE` listE es
336+ let len = length ts
337+ args <- mapM newName ["arg" ++ show n | n <- [1..len]]
338+ js <- case [[e|toJSON|] `appE` varE arg | arg <- args] of
339+ -- Single argument is directly converted.
340+ [e] -> return e
341+ -- Multiple arguments are converted to a JSON array.
342+ es -> do
343+ mv <- newName "mv"
344+ let newMV = bindS (varP mv)
345+ ([e|VM.unsafeNew|] `appE`
346+ litE (integerL $ fromIntegral len))
347+ stmts = [ noBindS $
348+ [e|VM.unsafeWrite|] `appE`
349+ (varE mv) `appE`
350+ litE (integerL ix) `appE`
351+ e
352+ | (ix, e) <- zip [(0::Integer)..] es
353+ ]
354+ ret = noBindS $ [e|return|] `appE` varE mv
355+ return $ [e|Array|] `appE`
356+ ([e|V.create|] `appE`
357+ doE (newMV:stmts++[ret]))
336358 match (conP conName $ map varP args)
337359 (normalB $ withExp js)
338360 []
Data/Aeson/Types/Generic.hs+22−23
@@ -30,10 +30,14 @@ import Data.Bits (shiftR)
3030import Data.Aeson.Types.Class
3131import Data.Aeson.Types.Internal
3232import Data.Text (pack, unpack)
33+import Data.DList (DList, toList)
34+import Data.Monoid (mappend)
3335import GHC.Generics
36+import Control.Monad.ST (ST)
3437import qualified Data.HashMap.Strict as H
3538import qualified Data.Text as T
3639import qualified Data.Vector as V
40+import qualified Data.Vector.Mutable as VM
3741
3842--------------------------------------------------------------------------------
3943-- Generic toJSON
@@ -54,8 +58,14 @@ instance (ConsToJSON a) => GToJSON (C1 c a) where
5458 gToJSON = consToJSON . unM1
5559 {-# INLINE gToJSON #-}
5660
57−instance (GProductToValues a, GProductToValues b) => GToJSON (a :*: b) where
58− gToJSON = toJSON . toList . gProductToValues
61+instance ( GProductToValues a, GProductToValues b
62+ , ProductSize a, ProductSize b) => GToJSON (a :*: b) where
63+ gToJSON p = Array $ V.create $ do
64+ mv <- VM.unsafeNew lenProduct
65+ gProductToValues mv 0 lenProduct p
66+ return mv
67+ where
68+ lenProduct = unTagged2 (productSize :: Tagged2 (a :*: b) Int)
5969 {-# INLINE gToJSON #-}
6070
6171instance (GObject a, GObject b) => GToJSON (a :+: b) where
@@ -88,24 +98,29 @@ class GRecordToPairs f where
8898 gRecordToPairs :: f a -> DList Pair
8999
90100instance (GRecordToPairs a, GRecordToPairs b) => GRecordToPairs (a :*: b) where
91− gRecordToPairs (a :*: b) = gRecordToPairs a `append` gRecordToPairs b
101+ gRecordToPairs (a :*: b) = gRecordToPairs a `mappend` gRecordToPairs b
92102 {-# INLINE gRecordToPairs #-}
93103
94104instance (Selector s, GToJSON a) => GRecordToPairs (S1 s a) where
95− gRecordToPairs m1 = singleton (pack (selName m1), gToJSON (unM1 m1))
105+ gRecordToPairs m1 = pure (pack (selName m1), gToJSON (unM1 m1))
96106 {-# INLINE gRecordToPairs #-}
97107
98108--------------------------------------------------------------------------------
99109
100110class GProductToValues f where
101− gProductToValues :: f a -> DList Value
111+ gProductToValues :: VM.MVector s Value -> Int -> Int -> f a -> ST s ()
102112
103113instance (GProductToValues a, GProductToValues b) => GProductToValues (a :*: b) where
104− gProductToValues (a :*: b) = gProductToValues a `append` gProductToValues b
114+ gProductToValues mv ix len (a :*: b) = do gProductToValues mv ix lenL a
115+ gProductToValues mv ixR lenR b
116+ where
117+ lenL = len `shiftR` 1
118+ ixR = ix + lenL
119+ lenR = len - lenL
105120 {-# INLINE gProductToValues #-}
106121
107122instance (GToJSON a) => GProductToValues a where
108− gProductToValues = singleton . gToJSON
123+ gProductToValues mv ix _ = VM.unsafeWrite mv ix . gToJSON
109124 {-# INLINE gProductToValues #-}
110125
111126--------------------------------------------------------------------------------
@@ -267,19 +282,3 @@ instance IsRecord (K1 i c) True
267282instance IsRecord U1 False
268283
269284--------------------------------------------------------------------------------
270−
271−type DList a = [a] -> [a]
272−
273−toList :: DList a -> [a]
274−toList = ($ [])
275−{-# INLINE toList #-}
276−
277−singleton :: a -> DList a
278−singleton = (:)
279−{-# INLINE singleton #-}
280−
281−append :: DList a -> DList a -> DList a
282−append = (.)
283−{-# INLINE append #-}
284−
285−--------------------------------------------------------------------------------
aeson.cabal+1−1
@@ -120,7 +120,7 @@ library
120120
121121 if impl(ghc >= 7.2.1)
122122 cpp-options: -DGENERICS
123− build-depends: ghc-prim >= 0.2
123+ build-depends: ghc-prim >= 0.2, dlist >= 0.2
124124 other-modules:
125125 Data.Aeson.Types.Generic
126126