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