merge some changes from the latest version of Data.Binary. Makes the binary decoding faster

3 files changed, 48 insertions, 30 deletions

diff --git a/src/Data/Binary.hs b/src/Data/Binary.hs
index 1b287a099..786f5a09e 100644
--- a/src/Data/Binary.hs
+++ b/src/Data/Binary.hs
@@ -734,9 +734,13 @@ instance (Binary e) => Binary (IntMap.IntMap e) where
 --
 
 instance (Binary e) => Binary (Seq.Seq e) where
-    -- any better way to do this?
-    put = put . Fold.toList
-    get = fmap Seq.fromList get
+    put s = put (Seq.length s) >> Fold.mapM_ put s
+    get = do n <- get :: Get Int
+             rep Seq.empty n get
+      where rep xs 0 _ = return $! xs
+            rep xs n g = xs `seq` n `seq` do
+                           x <- g
+                           rep (xs Seq.|> x) (n-1) g
 
 #endif
 
diff --git a/src/Data/Binary/Get.hs b/src/Data/Binary/Get.hs
index 4b5625359..51062ad31 100644
--- a/src/Data/Binary/Get.hs
+++ b/src/Data/Binary/Get.hs
@@ -141,10 +141,15 @@ put :: S -> Get ()
 put s = Get (\_ -> ((), s))
 
 ------------------------------------------------------------------------
+--
+-- dons, GHC 6.10: explicit inlining disabled, was killing performance.
+-- Without it, GHC seems to do just fine. And we get similar
+-- performance with 6.8.2 anyway.
+--
 
 initState :: L.ByteString -> S
 initState xs = mkState xs 0
-{-# INLINE initState #-}
+{- INLINE initState -}
 
 {-
 initState (B.LPS xs) =
@@ -158,7 +163,7 @@ mkState :: L.ByteString -> Int64 -> S
 mkState l = case l of
     L.Empty      -> S B.empty L.empty
     L.Chunk x xs -> S x xs
-{-# INLINE mkState #-}
+{- INLINE mkState -}
 
 #else
 mkState :: L.ByteString -> Int64 -> S
@@ -326,7 +331,7 @@ getBytes n = do
                             fail "too few bytes"
                          else
                             return now
-{-# INLINE getBytes #-}
+{- INLINE getBytes -}
 -- ^ important
 
 #ifndef BYTESTRING_IN_BASE
@@ -342,7 +347,7 @@ join bb (B.LPS lb)
     | otherwise = B.LPS (bb:lb)
 #endif
     -- don't use L.append, it's strict in it's second argument :/
-{-# INLINE join #-}
+{- INLINE join -}
 
 -- | Split a ByteString. If the first result is consumed before the --
 -- second, this runs in constant heap space.
@@ -389,14 +394,14 @@ splitAtST i (B.LPS ps)  = runST (
 
          where l = fromIntegral (B.length x)
 #endif
-{-# INLINE splitAtST #-}
+{- INLINE splitAtST -}
 
 -- Pull n bytes from the input, and apply a parser to those bytes,
 -- yielding a value. If less than @n@ bytes are available, fail with an
 -- error. This wraps @getBytes@.
 readN :: Int -> (B.ByteString -> a) -> Get a
 readN n f = fmap f $ getBytes n
-{-# INLINE readN #-}
+{- INLINE readN -}
 -- ^ important
 
 ------------------------------------------------------------------------
@@ -410,22 +415,14 @@ getPtr :: Storable a => Int -> Get a
 getPtr n = do
     (fp,o,_) <- readN n B.toForeignPtr
     return . B.inlinePerformIO $ withForeignPtr fp $ \p -> peek (castPtr $ p `plusPtr` o)
-{-# INLINE getPtr #-}
+{- INLINE getPtr -}
 
 ------------------------------------------------------------------------
 
 -- | Read a Word8 from the monad state
 getWord8 :: Get Word8
-getWord8 = do
-    S s ss bytes <- get
-    case B.uncons s of
-      Just (w,rest) -> do put $! S rest ss (bytes + 1)
-                          return $! w
-      Nothing       -> case L.uncons ss of
-                         Just (w,rest) -> do put $! mkState rest (bytes + 1)
-                                             return $! w
-                         Nothing       -> fail "too few bytes"
-{-# INLINE getWord8 #-}
+getWord8 = getPtr (sizeOf (undefined :: Word8))
+{- INLINE getWord8 -}
 
 -- | Read a Word16 in big endian format
 getWord16be :: Get Word16
@@ -433,7 +430,7 @@ getWord16be = do
     s <- readN 2 id
     return $! (fromIntegral (s `B.index` 0) `shiftl_w16` 8) .|.
               (fromIntegral (s `B.index` 1))
-{-# INLINE getWord16be #-}
+{- INLINE getWord16be -}
 
 -- | Read a Word16 in little endian format
 getWord16le :: Get Word16
@@ -441,7 +438,7 @@ getWord16le = do
     s <- readN 2 id
     return $! (fromIntegral (s `B.index` 1) `shiftl_w16` 8) .|.
               (fromIntegral (s `B.index` 0) )
-{-# INLINE getWord16le #-}
+{- INLINE getWord16le -}
 
 -- | Read a Word32 in big endian format
 getWord32be :: Get Word32
@@ -451,7 +448,7 @@ getWord32be = do
               (fromIntegral (s `B.index` 1) `shiftl_w32` 16) .|.
               (fromIntegral (s `B.index` 2) `shiftl_w32`  8) .|.
               (fromIntegral (s `B.index` 3) )
-{-# INLINE getWord32be #-}
+{- INLINE getWord32be -}
 
 -- | Read a Word32 in little endian format
 getWord32le :: Get Word32
@@ -461,7 +458,7 @@ getWord32le = do
               (fromIntegral (s `B.index` 2) `shiftl_w32` 16) .|.
               (fromIntegral (s `B.index` 1) `shiftl_w32`  8) .|.
               (fromIntegral (s `B.index` 0) )
-{-# INLINE getWord32le #-}
+{- INLINE getWord32le -}
 
 -- | Read a Word64 in big endian format
 getWord64be :: Get Word64
@@ -475,7 +472,7 @@ getWord64be = do
               (fromIntegral (s `B.index` 5) `shiftl_w64` 16) .|.
               (fromIntegral (s `B.index` 6) `shiftl_w64`  8) .|.
               (fromIntegral (s `B.index` 7) )
-{-# INLINE getWord64be #-}
+{- INLINE getWord64be -}
 
 -- | Read a Word64 in little endian format
 getWord64le :: Get Word64
@@ -489,7 +486,7 @@ getWord64le = do
               (fromIntegral (s `B.index` 2) `shiftl_w64` 16) .|.
               (fromIntegral (s `B.index` 1) `shiftl_w64`  8) .|.
               (fromIntegral (s `B.index` 0) )
-{-# INLINE getWord64le #-}
+{- INLINE getWord64le -}
 
 ------------------------------------------------------------------------
 -- Host-endian reads
@@ -499,22 +496,22 @@ getWord64le = do
 -- machine the Word is an 8 byte value, on a 32 bit machine, 4 bytes.
 getWordhost :: Get Word
 getWordhost = getPtr (sizeOf (undefined :: Word))
-{-# INLINE getWordhost #-}
+{- INLINE getWordhost -}
 
 -- | /O(1)./ Read a 2 byte Word16 in native host order and host endianness.
 getWord16host :: Get Word16
 getWord16host = getPtr (sizeOf (undefined :: Word16))
-{-# INLINE getWord16host #-}
+{- INLINE getWord16host -}
 
 -- | /O(1)./ Read a Word32 in native host order and host endianness.
 getWord32host :: Get Word32
 getWord32host = getPtr  (sizeOf (undefined :: Word32))
-{-# INLINE getWord32host #-}
+{- INLINE getWord32host -}
 
 -- | /O(1)./ Read a Word64 in native host order and host endianess.
 getWord64host   :: Get Word64
 getWord64host = getPtr  (sizeOf (undefined :: Word64))
-{-# INLINE getWord64host #-}
+{- INLINE getWord64host -}
 
 ------------------------------------------------------------------------
 -- Unchecked shifts
diff --git a/src/Data/Binary/Put.hs b/src/Data/Binary/Put.hs
index 353bfb7b1..a1f78dfba 100644
--- a/src/Data/Binary/Put.hs
+++ b/src/Data/Binary/Put.hs
@@ -19,6 +19,9 @@ module Data.Binary.Put (
       Put
     , PutM(..)
     , runPut
+    , runPutM
+    , putBuilder
+    , execPut
 
     -- * Flushing the implicit parse state
     , flush
@@ -107,11 +110,25 @@ tell :: Builder -> Put
 tell b = Put $ PairS () b
 {-# INLINE tell #-}
 
+putBuilder :: Builder -> Put
+putBuilder = tell
+{-# INLINE putBuilder #-}
+
+-- | Run the 'Put' monad
+execPut :: PutM a -> Builder
+execPut = sndS . unPut
+{-# INLINE execPut #-}
+
 -- | Run the 'Put' monad with a serialiser
 runPut :: Put -> L.ByteString
 runPut = toLazyByteString . sndS . unPut
 {-# INLINE runPut #-}
 
+-- | Run the 'Put' monad with a serialiser and get its result
+runPutM :: PutM a -> (a, L.ByteString)
+runPutM (Put (PairS f s)) = (f, toLazyByteString s)
+{-# INLINE runPutM #-}
+
 ------------------------------------------------------------------------
 
 -- | Pop the ByteString we have constructed so far, if any, yielding a