fix #3: improved benchmarking by Bas Van Dijk

blaze-binary.cabal

@@ -33,14 +33,31 @@ library
         hs-source-dirs:         src
 
         exposed-modules:        Data.Blaze.Binary
-        extensions:             FlexibleContexts
-                              , FlexibleInstances
-                              , MagicHash
-                              , BangPatterns
-                              , OverloadedStrings
 
         ghc-options:            -Wall
         ghc-prof-options:       -prof -auto-all
 
         if impl(ghc >= 7.2.1)
             cpp-options: -DGENERICS
+
+benchmark bench
+  type:              exitcode-stdio-1.0
+  main-is:           Benchmark.hs
+  hs-source-dirs:    bench, src
+  build-depends:     base               >= 4      && < 5
+                   , ghc-prim           >= 0.2    && < 0.3
+                   , containers         >= 0.4    && < 0.5
+                   , array              >= 0.4    && < 0.5
+                   , bytestring         >= 0.9    && < 0.10
+                   , criterion          >= 0.6    && < 0.7
+                   , cereal             >= 0.3    && < 0.4
+           -- Use the 'cps' branch from https://github.com/kolmodin/binary.git
+           -- for binary-0.6.0.0
+                   , binary             >= 0.6    && < 0.7
+                   , bytestring-builder >= 0.1    && < 0.2
+                   , deepseq            >= 1.3    && < 1.4
+                   , primitive          >= 0.4    && < 0.5
+                   , attoparsec         >= 0.10   && < 0.11
+
+  if impl(ghc >= 7.2.1)
+    cpp-options: -DGENERICS

src/Data/Blaze/Binary.hs

@@ -75,9 +75,11 @@ class Binary t where
 #ifdef GENERICS
     default encode :: (Generic t, GBinary (Rep t)) => Encoding t
     encode = gEncode . from
+    {-# INLINE encode #-}
 
     default decode :: (Generic t, GBinary (Rep t)) => D.Decoder t
     decode = to <$> gDecode
+    {-# INLINE decode #-}
 #endif
 
 -- | Encode a value to a strict 'S.ByteString'.

src/Data/Blaze/Binary/Decoding.hs

@@ -1,10 +1,10 @@
-{-# LANGUAGE UnboxedTuples, MagicHash, ScopedTypeVariables, BangPatterns, DeriveDataTypeable, OverloadedStrings #-}
+{-# LANGUAGE CPP, UnboxedTuples, MagicHash, ScopedTypeVariables, BangPatterns, DeriveDataTypeable, OverloadedStrings #-}
 -----------------------------------------------------------------------------
 -- |
 -- Module      : Data.Blaze.Binary.Encoding
 -- Copyright   : 2012, Simon Meier <iridcode@gmail.com>
 -- License     : BSD3-style (see LICENSE)
--- 
+--
 -- Maintainer  : Simon Meier <iridcode@gmail.com>
 -- Stability   :
 -- Portability : portable
@@ -19,28 +19,36 @@ import Prelude hiding (catch)
 import Control.Applicative
 import Control.Exception
 
+import Data.Int (Int8, Int16, Int32, Int64)
 import Data.Typeable
 import qualified Data.ByteString.Internal as S
 import GHC.Prim
 import GHC.Ptr
 import GHC.Word
 import GHC.Exts
 import GHC.IO (IO(IO))
-import Foreign 
+import Foreign.ForeignPtr (ForeignPtr, withForeignPtr)
+import Foreign.Storable (Storable, sizeOf, peek)
+
+#if  __GLASGOW_HASKELL__ >= 702
+import Foreign.ForeignPtr.Unsafe (unsafeForeignPtrToPtr)
+#else
+import Foreign.ForeignPtr (unsafeForeignPtrToPtr)
+#endif
 
 data ParseException = ParseException String -- {-# UNPACK #-} !(Ptr Word8)
   deriving( Show, Typeable )
 
 instance Exception ParseException where
 
-newtype Decoder a = Decoder { 
-          -- unDecoder :: ForeignPtr Word8 -> Addr# -> Addr# 
+newtype Decoder a = Decoder {
+          -- unDecoder :: ForeignPtr Word8 -> Addr# -> Addr#
           unDecoder :: ForeignPtr Word8 -> Ptr Word8 -> Ptr Word8
                     -> State# RealWorld -> (# State# RealWorld, Addr#, a #)
         }
 
 instance Functor Decoder where
-    fmap f = \(Decoder io) -> Decoder $ \fpbuf ip0 ipe s0 -> 
+    fmap f = \(Decoder io) -> Decoder $ \fpbuf ip0 ipe s0 ->
         case io fpbuf ip0 ipe s0 of
             (# s1, ip1, x #) -> (# s1, ip1, f x #)
 
@@ -82,19 +90,19 @@ requires n p = Decoder $ \buf@(Buffer ip ipe) ->
     if ipe `minusPtr` ip >= n
       then unDecoder p buf
       else throw $ ParseException $
-             "required " ++ show n ++ 
+             "required " ++ show n ++
              " bytes, but there are only " ++ show (ipe `minusPtr` ip) ++
              " bytes left."
 -}
 
 {-# INLINE storable #-}
 storable :: forall a. Storable a => Decoder a
 storable = Decoder $ \fpbuf ip0 ipe s0 ->
-    let ip1 = ip0 `plusPtr` size in 
+    let ip1 = ip0 `plusPtr` size in
       if ip1 <= ipe
         then case runIO (peek (castPtr ip0 :: Ptr a)) s0 of
                (# s1, x #) -> (# s1, getAddr ip1, x #)
-        else unDecoder 
+        else unDecoder
                 (fail $ "less than the required " ++ show size ++ " bytes left.")
                 fpbuf ip0 ipe s0
   where
@@ -172,13 +180,13 @@ byteString = int >>= byteStringSlice
 byteStringSlice :: Int -> Decoder S.ByteString
 byteStringSlice len = Decoder $ \fpbuf ip0 ipe s0 ->
     let ip1 = ip0 `plusPtr` len
-    in 
+    in
       if ip1 <= ipe
         then (# s0
              , getAddr ip1
              ,  S.PS fpbuf (ip0 `minusPtr` unsafeForeignPtrToPtr fpbuf) len
              #)
-        else unDecoder 
+        else unDecoder
                 (fail $ "less than the required " ++ show len ++ " bytes left.")
                 fpbuf ip0 ipe s0
 
@@ -200,9 +208,9 @@ getAddr (Ptr a) = a
 
 {-# INLINE decodeList #-}
 decodeList :: Decoder a -> Decoder [a]
-decodeList x = 
+decodeList x =
     go
-  where 
+  where
     go = do tag <- word8
             case tag of
               0 -> return []
@@ -211,9 +219,9 @@ decodeList x =
 
 {-# INLINE decodeMaybe #-}
 decodeMaybe :: Decoder a -> Decoder (Maybe a)
-decodeMaybe just = 
+decodeMaybe just =
     go
-  where 
+  where
     go = do tag <- word8
             case tag of
               0 -> return Nothing
@@ -222,12 +230,12 @@ decodeMaybe just =
 
 {-# INLINE decodeEither #-}
 decodeEither :: Decoder a -> Decoder b -> Decoder (Either a b)
-decodeEither left right = 
+decodeEither left right =
     go
-  where 
+  where
     go = do tag <- word8
             case tag of
-              0 -> Left <$> left 
+              0 -> Left <$> left
               1 -> Right <$> right
               _ -> fail $ "decodeEither: unexpected tag " ++ show tag
 

src/Data/Blaze/Binary/Encoding.hs

@@ -19,6 +19,7 @@ module Data.Blaze.Binary.Encoding (
     -- * Streams of values to be encoded
     , VStream
     , render
+    , renderCompact
     , renderTagged
     , renderTextualUtf8
 
@@ -119,7 +120,7 @@ renderCompact = renderWith
     E.wordBase128LE
     (E.fromF E.int8)  E.int16ZigZagBase128LE E.int32ZigZagBase128LE E.int64ZigZagBase128LE
     E.intZigZagBase128LE
-    E.charUtf8 
+    E.charUtf8
     (E.fromF E.floatLE) (E.fromF E.doubleLE)
     (error "render: integer: implement")
     (\x -> E.encodeWithB E.intZigZagBase128LE (S.length x) <> B.byteString x)

src/Data/Blaze/Binary/StreamDecoding.hs

@@ -1,4 +1,4 @@
-{-# LANGUAGE UnboxedTuples, BangPatterns #-}
+{-# LANGUAGE CPP, UnboxedTuples, BangPatterns #-}
 -----------------------------------------------------------------------------
 -- |
 -- Module      : Data.Blaze.Binary.Encoding
@@ -21,7 +21,15 @@ import Control.Applicative
 
 import qualified Data.ByteString.Internal                            as S
 
-import Foreign
+import Foreign.Ptr        (plusPtr)
+import Foreign.ForeignPtr (touchForeignPtr)
+import Foreign.Storable   (peek)
+
+#if  __GLASGOW_HASKELL__ >= 702
+import Foreign.ForeignPtr.Unsafe (unsafeForeignPtrToPtr)
+#else
+import Foreign.ForeignPtr        (unsafeForeignPtrToPtr)
+#endif
 
 ------------------------------------------------------------------------
 
@@ -56,12 +64,12 @@ toVStream (S.PS fpbuf off len) =
     ip0  = pbuf `plusPtr` off
     ipe  = ip0 `plusPtr` len
 
-    go !ip 
+    go !ip
       | ip < ipe = S.inlinePerformIO $ do
           w <- peek ip
           touchForeignPtr fpbuf
           return $ VWord8 w (go (ip `plusPtr` 1))
-      | otherwise = 
+      | otherwise =
           VEmpty
 
 runDecoder :: Decoder a -> S.ByteString -> Either String a
@@ -80,7 +88,7 @@ instance Applicative Decoder where
   pure = \x -> Decoder $ \vs -> (# x, vs #)
 
   {-# INLINE (<*>) #-}
-  (<*>) = \fd xd -> Decoder $ \vs0 -> 
+  (<*>) = \fd xd -> Decoder $ \vs0 ->
       case unDecoder fd vs0 of
         (# f, vs1 #) -> case unDecoder xd vs1 of
           (# x, vs2 #) -> (# f x, vs2 #)
@@ -90,7 +98,7 @@ instance Monad Decoder where
   return = pure
 
   {-# INLINE (>>=) #-}
-  (>>=) = \md f -> Decoder $ \vs0 -> 
+  (>>=) = \md f -> Decoder $ \vs0 ->
       case unDecoder md vs0 of
         (# _, vs1@(VFail _) #) -> (# error "impossible", vs1 #)
         (# m, vs1           #) -> unDecoder (f m) vs1