[commit: packages/binary] master: Split GBinary into GBinaryGet and GBinaryPut, speeds up compilation. (c641061)
git at git.haskell.org
git at git.haskell.org
Sun Dec 20 21:16:27 UTC 2015
Repository : ssh://git@git.haskell.org/binary
On branch : master
Link : http://git.haskell.org/packages/binary.git/commitdiff/c641061fcf7886968218d25b7141bd7e0b60303a
>---------------------------------------------------------------
commit c641061fcf7886968218d25b7141bd7e0b60303a
Author: Edward Z. Yang <ezyang at cs.stanford.edu>
Date: Thu Dec 17 17:05:29 2015 -0800
Split GBinary into GBinaryGet and GBinaryPut, speeds up compilation.
Consider:
{-# LANGUAGE DeriveGeneric #-}
module A where
import Data.Binary
import GHC.Generics
data T = T
() () () () () () () () () ()
() () () () () () () () () ()
() () () () () () () () () ()
() () () () () () () () () ()
() () () () () () () () () ()
() () () () () () () () () ()
() () () () () () () () () ()
() () () () () () () () () ()
() () () () () () () () () ()
() () () () () () () () () ()
deriving Generic
instance Binary T
Without this patch, on GHC 7.10.2, building this -O2 takes 6.7s. With
this patch, it takes 1.7s. Amazing. (There are modest improvements
with other versions of GHC too.)
Signed-off-by: Edward Z. Yang <ezyang at cs.stanford.edu>
>---------------------------------------------------------------
c641061fcf7886968218d25b7141bd7e0b60303a
src/Data/Binary.hs | 6 ++++--
src/Data/Binary/Class.hs | 15 +++++++++++----
src/Data/Binary/Generic.hs | 41 +++++++++++++++++++++++++++++------------
3 files changed, 44 insertions(+), 18 deletions(-)
diff --git a/src/Data/Binary.hs b/src/Data/Binary.hs
index bb25ee5..9f8bed7 100644
--- a/src/Data/Binary.hs
+++ b/src/Data/Binary.hs
@@ -30,7 +30,8 @@
-- If the specifics of the data format is not important to you, for example,
-- you are more interested in serializing and deserializing values than
-- in which format will be used, it is possible to derive 'Binary'
--- instances using the generic support. See 'GBinary'.
+-- instances using the generic support. See 'GBinaryGet' and
+-- 'GBinaryPut'.
--
-- If you have specific requirements about the encoding format, you can use
-- the encoding and decoding primitives directly, see the modules
@@ -48,7 +49,8 @@ module Data.Binary (
#ifdef GENERICS
-- * Generic support
-- $generics
- , GBinary(..)
+ , GBinaryGet(..)
+ , GBinaryPut(..)
#endif
-- * The Get and Put monads
diff --git a/src/Data/Binary/Class.hs b/src/Data/Binary/Class.hs
index ffb9734..2e6e19a 100644
--- a/src/Data/Binary/Class.hs
+++ b/src/Data/Binary/Class.hs
@@ -36,7 +36,8 @@ module Data.Binary.Class (
#ifdef GENERICS
-- * Support for generics
- , GBinary(..)
+ , GBinaryGet(..)
+ , GBinaryPut(..)
#endif
) where
@@ -98,8 +99,14 @@ import Data.Version (Version(..))
------------------------------------------------------------------------
#ifdef GENERICS
-class GBinary f where
+-- Factored into two classes because this makes GHC optimize the
+-- instances faster. This doesn't matter for builds of binary,
+-- but it matters a lot for end-users who write 'instance Binary T'.
+-- See also: https://ghc.haskell.org/trac/ghc/ticket/9630
+class GBinaryPut f where
gput :: f t -> Put
+
+class GBinaryGet f where
gget :: Get (f t)
#endif
@@ -127,10 +134,10 @@ class Binary t where
get :: Get t
#ifdef GENERICS
- default put :: (Generic t, GBinary (Rep t)) => t -> Put
+ default put :: (Generic t, GBinaryPut (Rep t)) => t -> Put
put = gput . from
- default get :: (Generic t, GBinary (Rep t)) => Get t
+ default get :: (Generic t, GBinaryGet (Rep t)) => Get t
get = to `fmap` gget
#endif
diff --git a/src/Data/Binary/Generic.hs b/src/Data/Binary/Generic.hs
index 3f8edb3..551047e 100644
--- a/src/Data/Binary/Generic.hs
+++ b/src/Data/Binary/Generic.hs
@@ -32,28 +32,38 @@ import GHC.Generics
import Prelude -- Silence AMP warning.
-- Type without constructors
-instance GBinary V1 where
+instance GBinaryPut V1 where
gput _ = return ()
+
+instance GBinaryGet V1 where
gget = return undefined
-- Constructor without arguments
-instance GBinary U1 where
+instance GBinaryPut U1 where
gput U1 = return ()
+
+instance GBinaryGet U1 where
gget = return U1
-- Product: constructor with parameters
-instance (GBinary a, GBinary b) => GBinary (a :*: b) where
+instance (GBinaryPut a, GBinaryPut b) => GBinaryPut (a :*: b) where
gput (x :*: y) = gput x >> gput y
+
+instance (GBinaryGet a, GBinaryGet b) => GBinaryGet (a :*: b) where
gget = (:*:) <$> gget <*> gget
-- Metadata (constructor name, etc)
-instance GBinary a => GBinary (M1 i c a) where
+instance GBinaryPut a => GBinaryPut (M1 i c a) where
gput = gput . unM1
+
+instance GBinaryGet a => GBinaryGet (M1 i c a) where
gget = M1 <$> gget
-- Constants, additional parameters, and rank-1 recursion
-instance Binary a => GBinary (K1 i a) where
+instance Binary a => GBinaryPut (K1 i a) where
gput = put . unK1
+
+instance Binary a => GBinaryGet (K1 i a) where
gget = K1 <$> get
-- Borrowed from the cereal package.
@@ -69,14 +79,17 @@ instance Binary a => GBinary (K1 i a) where
#define PUTSUM(WORD) GUARD(WORD) = putSum (0 :: WORD) (fromIntegral size)
#define GETSUM(WORD) GUARD(WORD) = (get :: Get WORD) >>= checkGetSum (fromIntegral size)
-instance ( GSum a, GSum b
- , GBinary a, GBinary b
- , SumSize a, SumSize b) => GBinary (a :+: b) where
+instance ( GSumPut a, GSumPut b
+ , GBinaryPut a, GBinaryPut b
+ , SumSize a, SumSize b) => GBinaryPut (a :+: b) where
gput | PUTSUM(Word8) | PUTSUM(Word16) | PUTSUM(Word32) | PUTSUM(Word64)
| otherwise = sizeError "encode" size
where
size = unTagged (sumSize :: Tagged (a :+: b) Word64)
+instance ( GSumGet a, GSumGet b
+ , GBinaryGet a, GBinaryGet b
+ , SumSize a, SumSize b) => GBinaryGet (a :+: b) where
gget | GETSUM(Word8) | GETSUM(Word16) | GETSUM(Word32) | GETSUM(Word64)
| otherwise = sizeError "decode" size
where
@@ -88,23 +101,26 @@ sizeError s size =
------------------------------------------------------------------------
-checkGetSum :: (Ord word, Num word, Bits word, GSum f)
+checkGetSum :: (Ord word, Num word, Bits word, GSumGet f)
=> word -> word -> Get (f a)
checkGetSum size code | code < size = getSum code size
| otherwise = fail "Unknown encoding for constructor"
{-# INLINE checkGetSum #-}
-class GSum f where
+class GSumGet f where
getSum :: (Ord word, Num word, Bits word) => word -> word -> Get (f a)
+
+class GSumPut f where
putSum :: (Num w, Bits w, Binary w) => w -> w -> f a -> Put
-instance (GSum a, GSum b, GBinary a, GBinary b) => GSum (a :+: b) where
+instance (GSumGet a, GSumGet b, GBinaryGet a, GBinaryGet b) => GSumGet (a :+: b) where
getSum !code !size | code < sizeL = L1 <$> getSum code sizeL
| otherwise = R1 <$> getSum (code - sizeL) sizeR
where
sizeL = size `shiftR` 1
sizeR = size - sizeL
+instance (GSumPut a, GSumPut b, GBinaryPut a, GBinaryPut b) => GSumPut (a :+: b) where
putSum !code !size s = case s of
L1 x -> putSum code sizeL x
R1 x -> putSum (code + sizeL) sizeR x
@@ -112,9 +128,10 @@ instance (GSum a, GSum b, GBinary a, GBinary b) => GSum (a :+: b) where
sizeL = size `shiftR` 1
sizeR = size - sizeL
-instance GBinary a => GSum (C1 c a) where
+instance GBinaryGet a => GSumGet (C1 c a) where
getSum _ _ = gget
+instance GBinaryPut a => GSumPut (C1 c a) where
putSum !code _ x = put code *> gput x
------------------------------------------------------------------------
More information about the ghc-commits
mailing list