Commits

Bryan O'Sullivan committed 2646e69 Merge

Merge pull request #46 from basvandijk/optimizations

Optimizations

  • Participants
  • Parent commits 870bb8b, 4167699

Comments (0)

Files changed (3)

File Data/Aeson/TH.hs

               'object' [T.pack \"Unary\" .= 'toJSON' arg1]
           Product arg1 arg2 arg3 ->
               'object' [ T.pack \"Product\"
-                       .= 'toJSON' [ 'toJSON' arg1
-                                 , 'toJSON' arg2
-                                 , 'toJSON' arg3
-                                 ]
+                       .= ('Array' $ 'V.create' $ do
+                             mv <- 'VM.unsafeNew' 3
+                             'VM.unsafeWrite' mv 0 ('toJSON' arg1)
+                             'VM.unsafeWrite' mv 1 ('toJSON' arg2)
+                             'VM.unsafeWrite' mv 2 ('toJSON' arg3)
+                             return mv)
                      ]
           Record arg1 arg2 arg3 ->
               'object' [ T.pack \"Record\"
                            , length, map, zip, genericLength
                            )
 import Data.Maybe          ( Maybe(Nothing, Just) )
-import Prelude             ( String, (-), Integer, error )
+import Prelude             ( String, (-), Integer, fromIntegral, error )
 import Text.Printf         ( printf )
 import Text.Show           ( show )
 #if __GLASGOW_HASKELL__ < 700
 -- from text:
 import qualified Data.Text as T ( Text, pack, unpack )
 -- from vector:
-import qualified Data.Vector as V ( unsafeIndex, null, length )
-
+import qualified Data.Vector as V ( unsafeIndex, null, length, create )
+import qualified Data.Vector.Mutable as VM ( unsafeNew, unsafeWrite )
 
 
 --------------------------------------------------------------------------------
 -- instance 'ToJSON' Foo where
 --      'toJSON' =
 --          \value -> case value of
---                      Foo arg1 arg2 -> 'toJSON' ['toJSON' arg1, 'toJSON' arg2]
+--                      Foo arg1 arg2 -> 'Array' $ 'V.create' $ do
+--                        mv <- 'VM.unsafeNew' 2
+--                        'VM.unsafeWrite' mv 0 ('toJSON' arg1)
+--                        'VM.unsafeWrite' mv 1 ('toJSON' arg2)
+--                        return mv
 -- @
 deriveToJSON :: (String -> String)
              -- ^ Function to change field names.
           []
 -- Polyadic constructors with special case for unary constructors.
 encodeArgs withExp _ (NormalC conName ts) = do
-    args <- mapM newName ["arg" ++ show n | (_, n) <- zip ts [1 :: Integer ..]]
-    let js = case [[e|toJSON|] `appE` varE arg | arg <- args] of
-               -- Single argument is directly converted.
-               [e] -> e
-               -- Multiple arguments are converted to a JSON array.
-               es  -> [e|toJSON|] `appE` listE es
+    let len = length ts
+    args <- mapM newName ["arg" ++ show n | n <- [1..len]]
+    js <- case [[e|toJSON|] `appE` varE arg | arg <- args] of
+            -- Single argument is directly converted.
+            [e] -> return e
+            -- Multiple arguments are converted to a JSON array.
+            es  -> do
+              mv <- newName "mv"
+              let newMV = bindS (varP mv)
+                                ([e|VM.unsafeNew|] `appE`
+                                  litE (integerL $ fromIntegral len))
+                  stmts = [ noBindS $
+                              [e|VM.unsafeWrite|] `appE`
+                                (varE mv) `appE`
+                                  litE (integerL ix) `appE`
+                                    e
+                          | (ix, e) <- zip [(0::Integer)..] es
+                          ]
+                  ret = noBindS $ [e|return|] `appE` varE mv
+              return $ [e|Array|] `appE`
+                         ([e|V.create|] `appE`
+                           doE (newMV:stmts++[ret]))
     match (conP conName $ map varP args)
           (normalB $ withExp js)
           []

File Data/Aeson/Types/Generic.hs

 import Data.Aeson.Types.Class
 import Data.Aeson.Types.Internal
 import Data.Text (pack, unpack)
+import Data.DList (DList, toList)
+import Data.Monoid (mappend)
 import GHC.Generics
+import Control.Monad.ST (ST)
 import qualified Data.HashMap.Strict as H
 import qualified Data.Text as T
 import qualified Data.Vector as V
+import qualified Data.Vector.Mutable as VM
 
 --------------------------------------------------------------------------------
 -- Generic toJSON
     gToJSON = consToJSON . unM1
     {-# INLINE gToJSON #-}
 
-instance (GProductToValues a, GProductToValues b) => GToJSON (a :*: b) where
-    gToJSON = toJSON . toList . gProductToValues
+instance ( GProductToValues a, GProductToValues b
+         , ProductSize      a, ProductSize      b) => GToJSON (a :*: b) where
+    gToJSON p = Array $ V.create $ do
+                  mv <- VM.unsafeNew lenProduct
+                  gProductToValues mv 0 lenProduct p
+                  return mv
+        where
+          lenProduct = unTagged2 (productSize :: Tagged2 (a :*: b) Int)
     {-# INLINE gToJSON #-}
 
 instance (GObject a, GObject b) => GToJSON (a :+: b) where
     gRecordToPairs :: f a -> DList Pair
 
 instance (GRecordToPairs a, GRecordToPairs b) => GRecordToPairs (a :*: b) where
-    gRecordToPairs (a :*: b) = gRecordToPairs a `append` gRecordToPairs b
+    gRecordToPairs (a :*: b) = gRecordToPairs a `mappend` gRecordToPairs b
     {-# INLINE gRecordToPairs #-}
 
 instance (Selector s, GToJSON a) => GRecordToPairs (S1 s a) where
-    gRecordToPairs m1 = singleton (pack (selName m1), gToJSON (unM1 m1))
+    gRecordToPairs m1 = pure (pack (selName m1), gToJSON (unM1 m1))
     {-# INLINE gRecordToPairs #-}
 
 --------------------------------------------------------------------------------
 
 class GProductToValues f where
-    gProductToValues :: f a -> DList Value
+    gProductToValues :: VM.MVector s Value -> Int -> Int -> f a -> ST s ()
 
 instance (GProductToValues a, GProductToValues b) => GProductToValues (a :*: b) where
-    gProductToValues (a :*: b) = gProductToValues a `append` gProductToValues b
+    gProductToValues mv ix len (a :*: b) = do gProductToValues mv ix  lenL a
+                                              gProductToValues mv ixR lenR b
+        where
+          lenL = len `shiftR` 1
+          ixR  = ix + lenL
+          lenR = len - lenL
     {-# INLINE gProductToValues #-}
 
 instance (GToJSON a) => GProductToValues a where
-    gProductToValues = singleton . gToJSON
+    gProductToValues mv ix _ = VM.unsafeWrite mv ix . gToJSON
     {-# INLINE gProductToValues #-}
 
 --------------------------------------------------------------------------------
 instance IsRecord U1 False
 
 --------------------------------------------------------------------------------
-
-type DList a = [a] -> [a]
-
-toList :: DList a -> [a]
-toList = ($ [])
-{-# INLINE toList #-}
-
-singleton :: a -> DList a
-singleton = (:)
-{-# INLINE singleton #-}
-
-append :: DList a -> DList a -> DList a
-append = (.)
-{-# INLINE append #-}
-
---------------------------------------------------------------------------------
 
   if impl(ghc >= 7.2.1)
     cpp-options: -DGENERICS
-    build-depends: ghc-prim >= 0.2
+    build-depends: ghc-prim >= 0.2, dlist >= 0.2
     other-modules:
       Data.Aeson.Types.Generic