diff --git a/binary.cabal b/binary.cabal --- a/binary.cabal +++ b/binary.cabal @@ -1,5 +1,5 @@ name: binary -version: 0.4.3.1 +version: 0.4.4 license: BSD3 license-file: LICENSE author: Lennart Kolmodin @@ -16,7 +16,7 @@ stability: provisional build-type: Simple cabal-version: >= 1.2 -tested-with: GHC ==6.4.2, GHC ==6.6.1, GHC ==6.8.0 +tested-with: GHC ==6.4.2, GHC ==6.6.1, GHC ==6.8.0, GHC ==6.10.1 extra-source-files: README index.html flag bytestring-in-base @@ -48,15 +48,18 @@ Data.Binary.Put, Data.Binary.Get, Data.Binary.Builder + extensions: CPP, FlexibleContexts ghc-options: -O2 -Wall -fspec-constr - -fliberate-case-threshold=1000 + -funbox-strict-fields -fdicts-cheap -fno-method-sharing + -fliberate-case-threshold=1000 + -fmax-simplifier-iterations10 -- if impl(ghc < 6.5) -- ghc-options: -fallow-undecidable-instances diff --git a/src/Data/Binary.hs b/src/Data/Binary.hs --- a/src/Data/Binary.hs +++ b/src/Data/Binary.hs @@ -627,20 +627,20 @@ -- Maps and Sets instance (Ord a, Binary a) => Binary (Set.Set a) where - put = put . Set.toAscList - get = liftM Set.fromDistinctAscList get + put s = put (Set.size s) >> mapM_ put (Set.toAscList s) + get = liftM Set.fromDistinctAscList get instance (Ord k, Binary k, Binary e) => Binary (Map.Map k e) where - put = put . Map.toAscList - get = liftM Map.fromDistinctAscList get + put m = put (Map.size m) >> mapM_ put (Map.toAscList m) + get = liftM Map.fromDistinctAscList get instance Binary IntSet.IntSet where - put = put . IntSet.toAscList - get = liftM IntSet.fromDistinctAscList get + put s = put (IntSet.size s) >> mapM_ put (IntSet.toAscList s) + get = liftM IntSet.fromDistinctAscList get instance (Binary e) => Binary (IntMap.IntMap e) where - put = put . IntMap.toAscList - get = liftM IntMap.fromDistinctAscList get + put m = put (IntMap.size m) >> mapM_ put (IntMap.toAscList m) + get = liftM IntMap.fromDistinctAscList get ------------------------------------------------------------------------ -- Queues and Sequences diff --git a/src/Data/Binary/Get.hs b/src/Data/Binary/Get.hs --- a/src/Data/Binary/Get.hs +++ b/src/Data/Binary/Get.hs @@ -105,11 +105,12 @@ {-# UNPACK #-} !Int64 -- bytes read -- | The Get monad is just a State monad carrying around the input ByteString +-- We treat it as a strict state monad. newtype Get a = Get { unGet :: S -> (a, S) } instance Functor Get where - fmap f m = Get (\s -> let (a, s') = unGet m s - in (f a, s')) + fmap f m = Get (\s -> case unGet m s of + (a, s') -> (f a, s')) {-# INLINE fmap #-} #ifdef APPLICATIVE_IN_BASE @@ -118,6 +119,7 @@ (<*>) = ap #endif +-- Definition directly from Control.Monad.State.Strict instance Monad Get where return a = Get (\s -> (a, s)) {-# INLINE return #-} @@ -129,7 +131,7 @@ fail = failDesc instance MonadFix Get where - mfix f = Get (\s -> let (a,s') = unGet (f a) s + mfix f = Get (\s -> let (a,s') = unGet (f a) s in (a,s')) ------------------------------------------------------------------------ @@ -141,10 +143,15 @@ 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 +165,7 @@ 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 +333,7 @@ fail "too few bytes" else return now -{-# INLINE getBytes #-} +{- INLINE getBytes -} -- ^ important #ifndef BYTESTRING_IN_BASE @@ -342,7 +349,7 @@ | 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 +396,14 @@ 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,14 +417,14 @@ 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 = getPtr (sizeOf (undefined :: Word8)) -{-# INLINE getWord8 #-} +{- INLINE getWord8 -} -- | Read a Word16 in big endian format getWord16be :: Get Word16 @@ -425,7 +432,7 @@ 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 @@ -433,7 +440,7 @@ 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 @@ -443,7 +450,7 @@ (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 @@ -453,7 +460,7 @@ (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 @@ -467,7 +474,7 @@ (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 @@ -481,7 +488,7 @@ (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 @@ -491,22 +498,22 @@ -- 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/tests/Makefile b/tests/Makefile --- a/tests/Makefile +++ b/tests/Makefile @@ -5,15 +5,15 @@ compiled: ghc --make -fhpc -O QC.hs -o qc -no-recomp -threaded - time ./qc 500 +RTS -qw -N2 + ./qc 500 +RTS -qw -N2 bench:: Benchmark.hs MemBench.hs CBenchmark.o ghc --make -O2 -fliberate-case-threshold=1000 Benchmark.hs -fasm CBenchmark.o -o bench -no-recomp - time ./bench 100 + ./bench 100 bench-nb:: ghc --make -O2 -fliberate-case-threshold=1000 NewBenchmark.hs -fasm -o bench-nb - time ./bench-nb + ./bench-nb CBenchmark.o: CBenchmark.c gcc -O -c $< -o $@ diff --git a/tests/QC.hs b/tests/QC.hs --- a/tests/QC.hs +++ b/tests/QC.hs @@ -21,7 +21,7 @@ import Data.Array.IArray import Data.Array.Unboxed (UArray) -import qualified Control.Exception as C (catch,evaluate) +import qualified Control.OldException as C (catch,evaluate) import Control.Monad import Foreign import System.Environment