diff --git a/beamable.cabal b/beamable.cabal --- a/beamable.cabal +++ b/beamable.cabal @@ -10,7 +10,7 @@ -- PVP summary: +-+------- breaking API changes -- | | +----- non-breaking API additions -- | | | +--- code changes with no API change -version: 0.1.0.2 +version: 0.1.1.0 -- A short (one-line) description of the package. synopsis: Generic serializer/deserializer with compact representation @@ -80,7 +80,7 @@ build-depends: test-framework >= 0.4 && < 0.9, test-framework-quickcheck2 >= 0.2 && < 0.4, - QuickCheck >= 2.4 && < 2.6, + QuickCheck >= 2.4 && < 2.7, -- Copied from regular dependencies... base >= 4.5 && < 4.8, blaze-builder >= 0.3, @@ -96,6 +96,7 @@ build-depends: criterion >= 0.6 && < 0.9, + deepseq >= 1.3 && < 2, -- Copied from regular dependencies... base >= 4.5 && < 4.8, blaze-builder >= 0.3, diff --git a/bench/Bench.hs b/bench/Bench.hs --- a/bench/Bench.hs +++ b/bench/Bench.hs @@ -1,31 +1,66 @@ {-# LANGUAGE BangPatterns #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE RankNTypes #-} module Main where import Criterion import Criterion.Main +import Control.DeepSeq import Data.Beamable import Data.List (sort) import Data.Word +import GHC.Generics main :: IO () main = defaultMain - [ bgroup "roundTrip" rtGroup + [ bgroup "roundTrip" $ allBenches roundTrip + , bgroup "encode" $ allBenches encodeF ] where !_unused = sum testWords !_unused' = sum testInts -rtGroup = - [ bgroup "Int" $ map mkBenchRT testInts - , bgroup "Word" $ map mkBenchRT testWords +-- TODO: generalize this such that we can easily benchmark decoding +-- by itself. At present we can only benchmark decoding by looking at +-- the round-trip times. +allBenches :: (forall a. (Beamable a) => a -> a) -> [Benchmark] +allBenches f = + [ bgroup "Int" $ map (mkBenchGroup f) testInts + , bgroup "Word" $ map (mkBenchGroup f) testWords + , bench "[Int]" $ nf f testInts + , bench "[Int]1000" $ nf f longList + , bench "(Word,Word)" $ nf f ((0,1000000) :: (Word,Word)) + , bench "(Int,Int,(Word,Int))" $ nf f ((0,23451345,(1000000,-4213)) :: (Int,Int,(Word,Int))) + , bench "TestG1" $ nf f (TestG1 10 20 :: TestG [Int]) + , bench "TestG2" $ nf f (TestG2 [1..5] 20 :: TestG [Int]) ] + where + longList = replicate 1000 (1::Int) + !_unused = sum longList -mkBenchRT x = bench (show x) $ whnf ((`asTypeOf` x) . decode . encode) x +mkBenchGroup f x = bench (show x) $ whnf f x +roundTrip x = decode (encode x) `asTypeOf` x + +-- we use the slightly odd type because it fits into 'allBenches' +-- easily. encode produces a strict ByteString, so we can just force +-- it to WHNF to benchmark it. +encodeF :: Beamable a => a -> a +encodeF x = encode x `seq` x + test10s :: [Word] -test10s = 0:[10^x | x <- [0..10]] -testWords = sort $ test10s ++ map (*5) test10s +test10s = [10^x | x <- [0,2..10]] +testWords = 0: (sort $ test10s ++ map (*5) test10s) testInts :: [Int] testInts = let xs = map fromIntegral testWords in reverse (map negate xs) ++ tail xs + +data TestG a = TestG1 Int Int | TestG2 a Word + deriving (Eq, Show, Generic) + +instance Beamable a => Beamable (TestG a) + +instance NFData a => NFData (TestG a) where + rnf (TestG1 a b) = a `seq` b `seq` () + rnf (TestG2 a b) = a `deepseq` b `seq` () diff --git a/src/Data/Beamable.hs b/src/Data/Beamable.hs --- a/src/Data/Beamable.hs +++ b/src/Data/Beamable.hs @@ -23,6 +23,7 @@ , encodeLive , decodeLive , feed + , Phantom(..) -- reexport , Builder diff --git a/src/Data/Beamable/Internal.hs b/src/Data/Beamable/Internal.hs --- a/src/Data/Beamable/Internal.hs +++ b/src/Data/Beamable/Internal.hs @@ -1,7 +1,8 @@ -{-# OPTIONS -Wall #-} +{-# OPTIONS -Wall -fno-full-laziness #-} {-# LANGUAGE DeriveGeneric, TypeOperators, FlexibleContexts, DefaultSignatures #-} {-# LANGUAGE FlexibleInstances, ScopedTypeVariables, BangPatterns #-} {-# LANGUAGE DoAndIfThenElse #-} +{-# LANGUAGE RankNTypes #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} module Data.Beamable.Internal @@ -11,6 +12,7 @@ , typeSignR , typeSign , TypeSign (..) + , Phantom (..) ) where import Data.Beamable.Int @@ -51,7 +53,7 @@ beam v = gbeam (from v) (0,0) default unbeam :: (Generic a, GBeamable (Rep a)) => ByteString -> (a, ByteString) - unbeam v = first to $ gunbeam v (0,0) + unbeam v = runResult (gunbeam v (0,0)) $ \a b -> (to a, b) default typeSignR :: (Generic a, GBeamable (Rep a)) => [String] -> a -> Word64 typeSignR prev v = gtypeSign prev (from v) @@ -79,16 +81,22 @@ unbeamEnum :: Enum a => ByteString -> (a, ByteString) unbeamEnum bs = let (i, bs') = unbeamInt bs in (toEnum (fromIntegral i), bs')-- }}} +-- writing unbeam via a CPS transform seems more efficient. +newtype Result a = Result + { runResult :: forall r. (a -> B.ByteString -> r) -> r } +defResult :: Result a -> (a,B.ByteString) +defResult u = runResult u (,) + class GBeamable f where gbeam :: f a -> (Int, Word) -> Builder - gunbeam :: B.ByteString -> (Int, Word) -> (f a, B.ByteString) + gunbeam :: B.ByteString -> (Int, Word) -> Result (f a) gtypeSign :: [String] -> f a -> Word64 -- this instance used for datatypes with single constructor only instance (GBeamable a, Datatype d, Constructor c) => GBeamable (M1 D d (M1 C c a)) where gbeam (M1 (M1 x)) = gbeam x - gunbeam x = first M1 . gunbeam x + gunbeam x t = Result $ \k -> runResult (gunbeam x t) $ k . M1 gtypeSign prev x | elem (datatypeName x) prev = signMur (datatypeName x, '_') gtypeSign prev x = signMur (datatypeName x, ':', gtypeSign (datatypeName x : prev) (unM1 x)) @@ -97,14 +105,15 @@ instance (GBeamable a, Constructor c) => GBeamable (M1 C c a) where gbeam (M1 x) t@(_, dirs) = mappend (beamWord $ fromIntegral dirs) (gbeam x t) {-# INLINE gbeam #-} - gunbeam bs = first M1 . gunbeam bs + gunbeam x t = Result $ \k -> runResult (gunbeam x t) $ k . M1 gtypeSign prev x = signMur (conName x, '<', gtypeSign prev (unM1 x)) -- this instance is needed to avoid overlapping instances with (M1 D d (M1 C c a)) instance (Datatype d, GBeamable a, GBeamable b) => GBeamable (M1 D d (a :+: b) ) where gbeam (M1 x) = gbeam x - gunbeam bs (lev, _) = let (dirs, bs') = unbeamWord bs - in first M1 $ gunbeam bs' (lev, fromIntegral dirs) + gunbeam bs (lev, _) = Result $ \k -> + let !(!dirs, bs') = unbeamWord bs + in runResult (gunbeam bs' (lev, fromIntegral dirs)) $ k . M1 gtypeSign prev x | elem (datatypeName x) prev = signMur (datatypeName x, '_') gtypeSign prev x = signMur ( gtypeSign (datatypeName x : prev) (unL . unM1 $ x), '|' @@ -112,33 +121,37 @@ -- choose correct constructor based on the first word uncoded from the BS (dirs variable) instance (GBeamable a, GBeamable b) => GBeamable (a :+: b) where - gbeam (L1 x) (lev, dirs) = gbeam x (lev + 1, dirs) - gbeam (R1 x) (lev, dirs) = gbeam x (lev + 1, dirs + (1 `shiftL` lev)) - gunbeam bs (lev, dirs) = if testBit dirs lev - then first R1 $ gunbeam bs (lev + 1, dirs) - else first L1 $ gunbeam bs (lev + 1, dirs) + gbeam (L1 x) (!lev, dirs) = gbeam x (lev + 1, dirs) + gbeam (R1 x) (!lev, !dirs) = gbeam x (lev + 1, dirs + (1 `shiftL` lev)) + gunbeam bs (lev, dirs) = Result $ \k -> + let !lev' = lev+1 in if testBit dirs lev + then runResult (gunbeam bs (lev', dirs)) $ k . R1 + else runResult (gunbeam bs (lev', dirs)) $ k . L1 gtypeSign prev x = signMur (gtypeSign prev (unL x), '|', gtypeSign prev (unR x)) instance GBeamable a => GBeamable (M1 S c a) where gbeam (M1 x) = gbeam x - gunbeam bs = first M1 . gunbeam bs + gunbeam x t = Result $ \k -> runResult (gunbeam x t) $ k . M1 gtypeSign prev ~(M1 x) = signMur ('[', gtypeSign prev x) instance GBeamable U1 where gbeam _ _ = mempty - gunbeam bs _ = (U1, bs) + gunbeam bs _ = Result $ \k -> k U1 bs gtypeSign _ _x = signMur 'U' instance (GBeamable a, GBeamable b) => GBeamable (a :*: b) where gbeam (x :*: y) t = gbeam x t `mappend` gbeam y t - gunbeam bs t = let (ra, bs') = gunbeam bs t - (rb, bs'') = gunbeam bs' t - in (ra :*: rb, bs'') + gunbeam bs t = Result $ \k -> + let !(ra, bs') = defResult $ gunbeam bs t + !(rb, bs'') = defResult $ gunbeam bs' t + in k (ra :*: rb) bs'' gtypeSign prev ~(x :*: y) = signMur (gtypeSign prev x, '*', gtypeSign prev y) instance Beamable a => GBeamable (K1 i a) where gbeam (K1 x) _ = beam x - gunbeam bs _ = first K1 (unbeam bs) + gunbeam bs _ = Result $ \k -> + let !(a, bs') = unbeam bs + in k (K1 a) bs' gtypeSign prev x = signMur ('K', typeSignR prev (unK1 x)) {- @@ -234,17 +247,20 @@ instance Beamable Bool instance Beamable a => Beamable [a] where - beam xs = beamWord (fromIntegral $ length xs) `mappend` mconcat (map beam xs) - unbeam bs = let (cnt, bs') = unbeamWord bs + {-# INLINE beam #-} + beam xs = mconcat (beamWord (fromIntegral $ length xs):(map beam xs) ) + {-# INLINE unbeam #-} + unbeam bs = let !(!cnt, bs') = unbeamWord bs in unfoldCnt (fromIntegral cnt) unbeam bs' typeSignR prev _ = signMur ('L', typeSignR prev (undefined :: a)) +{-# INLINE unfoldCnt #-} unfoldCnt :: Int -> (b -> (a, b)) -> b -> ([a], b) -unfoldCnt cnt_i f = unfoldCnt' [] cnt_i +unfoldCnt cnt_i f = unfoldCnt' id cnt_i where - unfoldCnt' xs 0 b = (reverse xs, b) - unfoldCnt' xs cnt b = let (x, b') = f b - in unfoldCnt' (x:xs) (cnt - 1) b' + unfoldCnt' xs 0 b = (xs [], b) + unfoldCnt' xs cnt b = let !(!x, b') = f b + in unfoldCnt' (xs.(x:)) (cnt - 1) b' instance Beamable ByteString where beam bs = beamWord (fromIntegral $ B.length bs) `mappend` fromByteString bs @@ -256,3 +272,19 @@ unbeam bs = let (chunks, bs') = unbeam bs in (BL.fromChunks chunks, bs') typeSignR _ _ = signMur "ByteString.Lazy" + +-- | @Phantom a@ has just one possible value, like @()@, and is encoded +-- as a 0-byte sequence. However, its 'typeSign' depends on the 'typeSign' +-- of its parameter. +data Phantom a = Phantom + deriving (Show, Eq, Ord, Enum) + +instance Beamable a => Beamable (Phantom a) where + beam = const mempty + unbeam bs = (Phantom, bs) + typeSignR f _ = + let thisDT = "Data.Beamable.Phantom" + f' = thisDT:f + in if elem thisDT f + then signMur (thisDT, '_') + else signMur (thisDT, ':', typeSignR f' (undefined :: a))