diff --git a/binary.cabal b/binary.cabal --- a/binary.cabal +++ b/binary.cabal @@ -1,5 +1,5 @@ name: binary -version: 0.4.5 +version: 0.5 license: BSD3 license-file: LICENSE author: Lennart Kolmodin @@ -52,13 +52,7 @@ extensions: CPP, FlexibleContexts - ghc-options: -O2 - -Wall - -fspec-constr - -funbox-strict-fields - -fdicts-cheap - -fliberate-case-threshold=1000 - -fmax-simplifier-iterations10 + ghc-options: -O2 -Wall -fliberate-case-threshold=1000 -- if impl(ghc < 6.5) -- ghc-options: -fallow-undecidable-instances diff --git a/docs/hcar/binary-Lb.tex b/docs/hcar/binary-Lb.tex new file mode 100644 --- /dev/null +++ b/docs/hcar/binary-Lb.tex @@ -0,0 +1,48 @@ +\begin{hcarentry}{binary} +\label{binary} +\report{Lennart Kolmodin} +\status{active} +\participants{Duncan Coutts, Don Stewart, Binary Strike Team} +\makeheader + +The Binary Strike Team is pleased to announce yet a release of a new, +pure, efficient binary serialisation library. + +The `binary' package provides efficient serialisation of Haskell values +to and from lazy ByteStrings. ByteStrings constructed this way may then +be written to disk, written to the network, or further processed (e.g. +stored in memory directly, or compressed in memory with zlib or bzlib). + +The binary library has been heavily tuned for performance, particularly for +writing speed. Throughput of up to 160M/s has been achieved in practice, and +in general speed is on par or better than NewBinary, with the advantage of a +pure interface. Efforts are underway to improve performance still further. +Plans are also taking shape for a parser combinator library on top of +binary, for bit parsing and foreign structure parsing (e.g. network +protocols). + +Data.Derive~\cref{derive} has support for automatically generating Binary +instances, allowing to read and write your data structures with little fuzz. + +Binary was developed by a team of 8 during the Haskell Hackathon in Oxford +2007, and since then has about 15 people contributed code and many more +given feedback and cheerleading on \verb|#haskell|. + +The package is cabalized and available through Hackage~\cref{hackagedb}. +% to editors: ref. to cabal? + +\FurtherReading +\begin{compactitem} +\item Homepage + + \url{http://code.haskell.org/binary/} +\item Hackage + + \url{http://hackage.haskell.org/cgi-bin/hackage-scripts/package/binary} +\item Development version + + \texttt{darcs get --partial} + + \url{http://code.haskell.org/binary} +\end{compactitem} +\end{hcarentry} diff --git a/src/Data/Binary.hs b/src/Data/Binary.hs --- a/src/Data/Binary.hs +++ b/src/Data/Binary.hs @@ -651,9 +651,13 @@ -- 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/Put.hs b/src/Data/Binary/Put.hs --- a/src/Data/Binary/Put.hs +++ b/src/Data/Binary/Put.hs @@ -18,6 +18,9 @@ Put , PutM(..) , runPut + , runPutM + , putBuilder + , execPut -- * Flushing the implicit parse state , flush @@ -106,10 +109,24 @@ 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 #-} ------------------------------------------------------------------------ diff --git a/tests/Benchmark.hs b/tests/Benchmark.hs new file mode 100644 --- /dev/null +++ b/tests/Benchmark.hs @@ -0,0 +1,1461 @@ +{-# OPTIONS -fbang-patterns #-} +module Main (main) where + +import qualified Data.ByteString.Lazy as L +import Data.Binary +import Data.Binary.Put +import Data.Binary.Get + +import Control.Exception +import System.CPUTime +import Numeric +import Text.Printf +import System.Environment + +import MemBench + +data Endian + = Big + | Little + | Host + deriving (Eq,Ord,Show) + +main :: IO () +main = do + mb <- getArgs >>= readIO . head + memBench (mb*10) + putStrLn "" + putStrLn "Binary (de)serialisation benchmarks:" + + -- do bytewise + sequence_ + [ test wordSize chunkSize Host mb + | wordSize <- [1] + , chunkSize <- [16] --1,2,4,8,16] + ] + + -- now Word16 .. Word64 + sequence_ + [ test wordSize chunkSize end mb + | wordSize <- [2,4,8] + , chunkSize <- [16] + , end <- [Host] -- ,Big,Little] + ] + +------------------------------------------------------------------------ + +time :: IO a -> IO Double +time action = do + start <- getCPUTime + action + end <- getCPUTime + return $! (fromIntegral (end - start)) / (10^12) + +------------------------------------------------------------------------ + +test :: Int -> Int -> Endian -> Int -> IO () +test wordSize chunkSize end mb = do + let bytes :: Int + bytes = mb * 2^20 + iterations = bytes `div` wordSize + bs = runPut (doPut wordSize chunkSize end iterations) + sum = runGet (doGet wordSize chunkSize end iterations) bs + + case (chunkSize,end) of (1,Host) -> putStrLn "" ; _ -> return () + + printf "%dMB of Word%-2d in chunks of %2d (%6s endian): " + (mb :: Int) (8 * wordSize :: Int) (chunkSize :: Int) (show end) + + putSeconds <- time $ evaluate (L.length bs) + getSeconds <- time $ evaluate sum +-- print (L.length bs, sum) + let putThroughput = fromIntegral mb / putSeconds + getThroughput = fromIntegral mb / getSeconds + + printf "%6.1f MB/s write, %6.1f MB/s read, %5.1f get/put-ratio\n" + putThroughput + getThroughput + (getThroughput/putThroughput) + +------------------------------------------------------------------------ + +doPut :: Int -> Int -> Endian -> Int -> Put +doPut wordSize chunkSize end = case (wordSize, chunkSize, end) of + (1, 1,_) -> putWord8N1 + (1, 2,_) -> putWord8N2 + (1, 4,_) -> putWord8N4 + (1, 8,_) -> putWord8N8 + (1, 16, _) -> putWord8N16 + + (2, 1, Big) -> putWord16N1Big + (2, 2, Big) -> putWord16N2Big + (2, 4, Big) -> putWord16N4Big + (2, 8, Big) -> putWord16N8Big + (2, 16, Big) -> putWord16N16Big + (2, 1, Little) -> putWord16N1Little + (2, 2, Little) -> putWord16N2Little + (2, 4, Little) -> putWord16N4Little + (2, 8, Little) -> putWord16N8Little + (2, 16, Little) -> putWord16N16Little + (2, 1, Host) -> putWord16N1Host + (2, 2, Host) -> putWord16N2Host + (2, 4, Host) -> putWord16N4Host + (2, 8, Host) -> putWord16N8Host + (2, 16, Host) -> putWord16N16Host + + (4, 1, Big) -> putWord32N1Big + (4, 2, Big) -> putWord32N2Big + (4, 4, Big) -> putWord32N4Big + (4, 8, Big) -> putWord32N8Big + (4, 16, Big) -> putWord32N16Big + (4, 1, Little) -> putWord32N1Little + (4, 2, Little) -> putWord32N2Little + (4, 4, Little) -> putWord32N4Little + (4, 8, Little) -> putWord32N8Little + (4, 16, Little) -> putWord32N16Little + (4, 1, Host) -> putWord32N1Host + (4, 2, Host) -> putWord32N2Host + (4, 4, Host) -> putWord32N4Host + (4, 8, Host) -> putWord32N8Host + (4, 16, Host) -> putWord32N16Host + + (8, 1, Host) -> putWord64N1Host + (8, 2, Host) -> putWord64N2Host + (8, 4, Host) -> putWord64N4Host + (8, 8, Host) -> putWord64N8Host + (8, 16, Host) -> putWord64N16Host + (8, 1, Big) -> putWord64N1Big + (8, 2, Big) -> putWord64N2Big + (8, 4, Big) -> putWord64N4Big + (8, 8, Big) -> putWord64N8Big + (8, 16, Big) -> putWord64N16Big + (8, 1, Little) -> putWord64N1Little + (8, 2, Little) -> putWord64N2Little + (8, 4, Little) -> putWord64N4Little + (8, 8, Little) -> putWord64N8Little + (8, 16, Little) -> putWord64N16Little + +------------------------------------------------------------------------ + +doGet :: Int -> Int -> Endian -> Int -> Get Int +doGet wordSize chunkSize end = + case (wordSize, chunkSize, end) of + (1, 1,_) -> fmap fromIntegral . getWord8N1 + (1, 2,_) -> fmap fromIntegral . getWord8N2 + (1, 4,_) -> fmap fromIntegral . getWord8N4 + (1, 8,_) -> fmap fromIntegral . getWord8N8 + (1, 16,_) -> fmap fromIntegral . getWord8N16 + + (2, 1,Big) -> fmap fromIntegral . getWord16N1Big + (2, 2,Big) -> fmap fromIntegral . getWord16N2Big + (2, 4,Big) -> fmap fromIntegral . getWord16N4Big + (2, 8,Big) -> fmap fromIntegral . getWord16N8Big + (2, 16,Big) -> fmap fromIntegral . getWord16N16Big + (2, 1,Little) -> fmap fromIntegral . getWord16N1Little + (2, 2,Little) -> fmap fromIntegral . getWord16N2Little + (2, 4,Little) -> fmap fromIntegral . getWord16N4Little + (2, 8,Little) -> fmap fromIntegral . getWord16N8Little + (2, 16,Little) -> fmap fromIntegral . getWord16N16Little + (2, 1,Host) -> fmap fromIntegral . getWord16N1Host + (2, 2,Host) -> fmap fromIntegral . getWord16N2Host + (2, 4,Host) -> fmap fromIntegral . getWord16N4Host + (2, 8,Host) -> fmap fromIntegral . getWord16N8Host + (2, 16,Host) -> fmap fromIntegral . getWord16N16Host + + (4, 1,Big) -> fmap fromIntegral . getWord32N1Big + (4, 2,Big) -> fmap fromIntegral . getWord32N2Big + (4, 4,Big) -> fmap fromIntegral . getWord32N4Big + (4, 8,Big) -> fmap fromIntegral . getWord32N8Big + (4, 16,Big) -> fmap fromIntegral . getWord32N16Big + (4, 1,Little) -> fmap fromIntegral . getWord32N1Little + (4, 2,Little) -> fmap fromIntegral . getWord32N2Little + (4, 4,Little) -> fmap fromIntegral . getWord32N4Little + (4, 8,Little) -> fmap fromIntegral . getWord32N8Little + (4, 16,Little) -> fmap fromIntegral . getWord32N16Little + (4, 1,Host) -> fmap fromIntegral . getWord32N1Host + (4, 2,Host) -> fmap fromIntegral . getWord32N2Host + (4, 4,Host) -> fmap fromIntegral . getWord32N4Host + (4, 8,Host) -> fmap fromIntegral . getWord32N8Host + (4, 16,Host) -> fmap fromIntegral . getWord32N16Host + + (8, 1,Host) -> fmap fromIntegral . getWord64N1Host + (8, 2,Host) -> fmap fromIntegral . getWord64N2Host + (8, 4,Host) -> fmap fromIntegral . getWord64N4Host + (8, 8,Host) -> fmap fromIntegral . getWord64N8Host + (8, 16,Host) -> fmap fromIntegral . getWord64N16Host + (8, 1,Big) -> fmap fromIntegral . getWord64N1Big + (8, 2,Big) -> fmap fromIntegral . getWord64N2Big + (8, 4,Big) -> fmap fromIntegral . getWord64N4Big + (8, 8,Big) -> fmap fromIntegral . getWord64N8Big + (8, 16,Big) -> fmap fromIntegral . getWord64N16Big + (8, 1,Little) -> fmap fromIntegral . getWord64N1Little + (8, 2,Little) -> fmap fromIntegral . getWord64N2Little + (8, 4,Little) -> fmap fromIntegral . getWord64N4Little + (8, 8,Little) -> fmap fromIntegral . getWord64N8Little + (8, 16,Little) -> fmap fromIntegral . getWord64N16Little + +------------------------------------------------------------------------ + +putWord8N1 bytes = loop 0 0 + where loop :: Word8 -> Int -> Put + loop !s !n | n == bytes = return () + | otherwise = do putWord8 s + loop (s+1) (n+1) + +putWord8N2 = loop 0 + where loop s n | s `seq` n `seq` False = undefined + loop _ 0 = return () + loop s n = do + putWord8 (s+0) + putWord8 (s+1) + loop (s+2) (n-2) + +putWord8N4 = loop 0 + where loop s n | s `seq` n `seq` False = undefined + loop _ 0 = return () + loop s n = do + putWord8 (s+0) + putWord8 (s+1) + putWord8 (s+2) + putWord8 (s+3) + loop (s+4) (n-4) + +putWord8N8 = loop 0 + where loop s n | s `seq` n `seq` False = undefined + loop _ 0 = return () + loop s n = do + putWord8 (s+0) + putWord8 (s+1) + putWord8 (s+2) + putWord8 (s+3) + putWord8 (s+4) + putWord8 (s+5) + putWord8 (s+6) + putWord8 (s+7) + loop (s+8) (n-8) + +putWord8N16 = loop 0 + where loop s n | s `seq` n `seq` False = undefined + loop _ 0 = return () + loop s n = do + putWord8 (s+0) + putWord8 (s+1) + putWord8 (s+2) + putWord8 (s+3) + putWord8 (s+4) + putWord8 (s+5) + putWord8 (s+6) + putWord8 (s+7) + putWord8 (s+8) + putWord8 (s+9) + putWord8 (s+10) + putWord8 (s+11) + putWord8 (s+12) + putWord8 (s+13) + putWord8 (s+14) + putWord8 (s+15) + loop (s+16) (n-16) + +------------------------------------------------------------------------ +-- Big endian, word16 writes + +putWord16N1Big = loop 0 + where loop s n | s `seq` n `seq` False = undefined + loop _ 0 = return () + loop s n = do + putWord16be (s+0) + loop (s+1) (n-1) + +putWord16N2Big = loop 0 + where loop s n | s `seq` n `seq` False = undefined + loop _ 0 = return () + loop s n = do + putWord16be (s+0) + putWord16be (s+1) + loop (s+2) (n-2) + +putWord16N4Big = loop 0 + where loop s n | s `seq` n `seq` False = undefined + loop _ 0 = return () + loop s n = do + putWord16be (s+0) + putWord16be (s+1) + putWord16be (s+2) + putWord16be (s+3) + loop (s+4) (n-4) + +putWord16N8Big = loop 0 + where loop s n | s `seq` n `seq` False = undefined + loop _ 0 = return () + loop s n = do + putWord16be (s+0) + putWord16be (s+1) + putWord16be (s+2) + putWord16be (s+3) + putWord16be (s+4) + putWord16be (s+5) + putWord16be (s+6) + putWord16be (s+7) + loop (s+8) (n-8) + +putWord16N16Big = loop 0 + where loop s n | s `seq` n `seq` False = undefined + loop _ 0 = return () + loop s n = do + putWord16be (s+0) + putWord16be (s+1) + putWord16be (s+2) + putWord16be (s+3) + putWord16be (s+4) + putWord16be (s+5) + putWord16be (s+6) + putWord16be (s+7) + putWord16be (s+8) + putWord16be (s+9) + putWord16be (s+10) + putWord16be (s+11) + putWord16be (s+12) + putWord16be (s+13) + putWord16be (s+14) + putWord16be (s+15) + loop (s+16) (n-16) + +------------------------------------------------------------------------ +-- Little endian, word16 writes + +putWord16N1Little = loop 0 + where loop s n | s `seq` n `seq` False = undefined + loop _ 0 = return () + loop s n = do + putWord16le (s+0) + loop (s+1) (n-1) + +putWord16N2Little = loop 0 + where loop s n | s `seq` n `seq` False = undefined + loop _ 0 = return () + loop s n = do + putWord16le (s+0) + putWord16le (s+1) + loop (s+2) (n-2) + +putWord16N4Little = loop 0 + where loop s n | s `seq` n `seq` False = undefined + loop _ 0 = return () + loop s n = do + putWord16le (s+0) + putWord16le (s+1) + putWord16le (s+2) + putWord16le (s+3) + loop (s+4) (n-4) + +putWord16N8Little = loop 0 + where loop s n | s `seq` n `seq` False = undefined + loop _ 0 = return () + loop s n = do + putWord16le (s+0) + putWord16le (s+1) + putWord16le (s+2) + putWord16le (s+3) + putWord16le (s+4) + putWord16le (s+5) + putWord16le (s+6) + putWord16le (s+7) + loop (s+8) (n-8) + +putWord16N16Little = loop 0 + where loop s n | s `seq` n `seq` False = undefined + loop _ 0 = return () + loop s n = do + putWord16le (s+0) + putWord16le (s+1) + putWord16le (s+2) + putWord16le (s+3) + putWord16le (s+4) + putWord16le (s+5) + putWord16le (s+6) + putWord16le (s+7) + putWord16le (s+8) + putWord16le (s+9) + putWord16le (s+10) + putWord16le (s+11) + putWord16le (s+12) + putWord16le (s+13) + putWord16le (s+14) + putWord16le (s+15) + loop (s+16) (n-16) + +------------------------------------------------------------------------ +-- Host endian, unaligned, word16 writes + +putWord16N1Host = loop 0 + where loop s n | s `seq` n `seq` False = undefined + loop _ 0 = return () + loop s n = do + putWord16host (s+0) + loop (s+1) (n-1) + +putWord16N2Host = loop 0 + where loop s n | s `seq` n `seq` False = undefined + loop _ 0 = return () + loop s n = do + putWord16host (s+0) + putWord16host (s+1) + loop (s+2) (n-2) + +putWord16N4Host = loop 0 + where loop s n | s `seq` n `seq` False = undefined + loop _ 0 = return () + loop s n = do + putWord16host (s+0) + putWord16host (s+1) + putWord16host (s+2) + putWord16host (s+3) + loop (s+4) (n-4) + +putWord16N8Host = loop 0 + where loop s n | s `seq` n `seq` False = undefined + loop _ 0 = return () + loop s n = do + putWord16host (s+0) + putWord16host (s+1) + putWord16host (s+2) + putWord16host (s+3) + putWord16host (s+4) + putWord16host (s+5) + putWord16host (s+6) + putWord16host (s+7) + loop (s+8) (n-8) + +putWord16N16Host = loop 0 + where loop s n | s `seq` n `seq` False = undefined + loop _ 0 = return () + loop s n = do + putWord16host (s+0) + putWord16host (s+1) + putWord16host (s+2) + putWord16host (s+3) + putWord16host (s+4) + putWord16host (s+5) + putWord16host (s+6) + putWord16host (s+7) + putWord16host (s+8) + putWord16host (s+9) + putWord16host (s+10) + putWord16host (s+11) + putWord16host (s+12) + putWord16host (s+13) + putWord16host (s+14) + putWord16host (s+15) + loop (s+16) (n-16) + +------------------------------------------------------------------------ + +putWord32N1Big = loop 0 + where loop s n | s `seq` n `seq` False = undefined + loop _ 0 = return () + loop s n = do + putWord32be (s+0) + loop (s+1) (n-1) + +putWord32N2Big = loop 0 + where loop s n | s `seq` n `seq` False = undefined + loop _ 0 = return () + loop s n = do + putWord32be (s+0) + putWord32be (s+1) + loop (s+2) (n-2) + +putWord32N4Big = loop 0 + where loop s n | s `seq` n `seq` False = undefined + loop _ 0 = return () + loop s n = do + putWord32be (s+0) + putWord32be (s+1) + putWord32be (s+2) + putWord32be (s+3) + loop (s+4) (n-4) + +putWord32N8Big = loop 0 + where loop s n | s `seq` n `seq` False = undefined + loop _ 0 = return () + loop s n = do + putWord32be (s+0) + putWord32be (s+1) + putWord32be (s+2) + putWord32be (s+3) + putWord32be (s+4) + putWord32be (s+5) + putWord32be (s+6) + putWord32be (s+7) + loop (s+8) (n-8) + +putWord32N16Big = loop 0 + where loop s n | s `seq` n `seq` False = undefined + loop _ 0 = return () + loop s n = do + putWord32be (s+0) + putWord32be (s+1) + putWord32be (s+2) + putWord32be (s+3) + putWord32be (s+4) + putWord32be (s+5) + putWord32be (s+6) + putWord32be (s+7) + putWord32be (s+8) + putWord32be (s+9) + putWord32be (s+10) + putWord32be (s+11) + putWord32be (s+12) + putWord32be (s+13) + putWord32be (s+14) + putWord32be (s+15) + loop (s+16) (n-16) + +------------------------------------------------------------------------ + +putWord32N1Little = loop 0 + where loop s n | s `seq` n `seq` False = undefined + loop _ 0 = return () + loop s n = do + putWord32le (s+0) + loop (s+1) (n-1) + +putWord32N2Little = loop 0 + where loop s n | s `seq` n `seq` False = undefined + loop _ 0 = return () + loop s n = do + putWord32le (s+0) + putWord32le (s+1) + loop (s+2) (n-2) + +putWord32N4Little = loop 0 + where loop s n | s `seq` n `seq` False = undefined + loop _ 0 = return () + loop s n = do + putWord32le (s+0) + putWord32le (s+1) + putWord32le (s+2) + putWord32le (s+3) + loop (s+4) (n-4) + +putWord32N8Little = loop 0 + where loop s n | s `seq` n `seq` False = undefined + loop _ 0 = return () + loop s n = do + putWord32le (s+0) + putWord32le (s+1) + putWord32le (s+2) + putWord32le (s+3) + putWord32le (s+4) + putWord32le (s+5) + putWord32le (s+6) + putWord32le (s+7) + loop (s+8) (n-8) + +putWord32N16Little = loop 0 + where loop s n | s `seq` n `seq` False = undefined + loop _ 0 = return () + loop s n = do + putWord32le (s+0) + putWord32le (s+1) + putWord32le (s+2) + putWord32le (s+3) + putWord32le (s+4) + putWord32le (s+5) + putWord32le (s+6) + putWord32le (s+7) + putWord32le (s+8) + putWord32le (s+9) + putWord32le (s+10) + putWord32le (s+11) + putWord32le (s+12) + putWord32le (s+13) + putWord32le (s+14) + putWord32le (s+15) + loop (s+16) (n-16) + +------------------------------------------------------------------------ + +putWord32N1Host = loop 0 + where loop s n | s `seq` n `seq` False = undefined + loop _ 0 = return () + loop s n = do + putWord32host (s+0) + loop (s+1) (n-1) + +putWord32N2Host = loop 0 + where loop s n | s `seq` n `seq` False = undefined + loop _ 0 = return () + loop s n = do + putWord32host (s+0) + putWord32host (s+1) + loop (s+2) (n-2) + +putWord32N4Host = loop 0 + where loop s n | s `seq` n `seq` False = undefined + loop _ 0 = return () + loop s n = do + putWord32host (s+0) + putWord32host (s+1) + putWord32host (s+2) + putWord32host (s+3) + loop (s+4) (n-4) + +putWord32N8Host = loop 0 + where loop s n | s `seq` n `seq` False = undefined + loop _ 0 = return () + loop s n = do + putWord32host (s+0) + putWord32host (s+1) + putWord32host (s+2) + putWord32host (s+3) + putWord32host (s+4) + putWord32host (s+5) + putWord32host (s+6) + putWord32host (s+7) + loop (s+8) (n-8) + +putWord32N16Host = loop 0 + where loop s n | s `seq` n `seq` False = undefined + loop _ 0 = return () + loop s n = do + putWord32host (s+0) + putWord32host (s+1) + putWord32host (s+2) + putWord32host (s+3) + putWord32host (s+4) + putWord32host (s+5) + putWord32host (s+6) + putWord32host (s+7) + putWord32host (s+8) + putWord32host (s+9) + putWord32host (s+10) + putWord32host (s+11) + putWord32host (s+12) + putWord32host (s+13) + putWord32host (s+14) + putWord32host (s+15) + loop (s+16) (n-16) + +------------------------------------------------------------------------ + +putWord64N1Big = loop 0 + where loop s n | s `seq` n `seq` False = undefined + loop _ 0 = return () + loop s n = do + putWord64be (s+0) + loop (s+1) (n-1) + +putWord64N2Big = loop 0 + where loop s n | s `seq` n `seq` False = undefined + loop _ 0 = return () + loop s n = do + putWord64be (s+0) + putWord64be (s+1) + loop (s+2) (n-2) + +putWord64N4Big = loop 0 + where loop s n | s `seq` n `seq` False = undefined + loop _ 0 = return () + loop s n = do + putWord64be (s+0) + putWord64be (s+1) + putWord64be (s+2) + putWord64be (s+3) + loop (s+4) (n-4) + +putWord64N8Big = loop 0 + where loop s n | s `seq` n `seq` False = undefined + loop _ 0 = return () + loop s n = do + putWord64be (s+0) + putWord64be (s+1) + putWord64be (s+2) + putWord64be (s+3) + putWord64be (s+4) + putWord64be (s+5) + putWord64be (s+6) + putWord64be (s+7) + loop (s+8) (n-8) + +putWord64N16Big = loop 0 + where loop s n | s `seq` n `seq` False = undefined + loop _ 0 = return () + loop s n = do + putWord64be (s+0) + putWord64be (s+1) + putWord64be (s+2) + putWord64be (s+3) + putWord64be (s+4) + putWord64be (s+5) + putWord64be (s+6) + putWord64be (s+7) + putWord64be (s+8) + putWord64be (s+9) + putWord64be (s+10) + putWord64be (s+11) + putWord64be (s+12) + putWord64be (s+13) + putWord64be (s+14) + putWord64be (s+15) + loop (s+16) (n-16) + +------------------------------------------------------------------------ + +putWord64N1Little = loop 0 + where loop s n | s `seq` n `seq` False = undefined + loop _ 0 = return () + loop s n = do + putWord64le (s+0) + loop (s+1) (n-1) + +putWord64N2Little = loop 0 + where loop s n | s `seq` n `seq` False = undefined + loop _ 0 = return () + loop s n = do + putWord64le (s+0) + putWord64le (s+1) + loop (s+2) (n-2) + +putWord64N4Little = loop 0 + where loop s n | s `seq` n `seq` False = undefined + loop _ 0 = return () + loop s n = do + putWord64le (s+0) + putWord64le (s+1) + putWord64le (s+2) + putWord64le (s+3) + loop (s+4) (n-4) + +putWord64N8Little = loop 0 + where loop s n | s `seq` n `seq` False = undefined + loop _ 0 = return () + loop s n = do + putWord64le (s+0) + putWord64le (s+1) + putWord64le (s+2) + putWord64le (s+3) + putWord64le (s+4) + putWord64le (s+5) + putWord64le (s+6) + putWord64le (s+7) + loop (s+8) (n-8) + +putWord64N16Little = loop 0 + where loop s n | s `seq` n `seq` False = undefined + loop _ 0 = return () + loop s n = do + putWord64le (s+0) + putWord64le (s+1) + putWord64le (s+2) + putWord64le (s+3) + putWord64le (s+4) + putWord64le (s+5) + putWord64le (s+6) + putWord64le (s+7) + putWord64le (s+8) + putWord64le (s+9) + putWord64le (s+10) + putWord64le (s+11) + putWord64le (s+12) + putWord64le (s+13) + putWord64le (s+14) + putWord64le (s+15) + loop (s+16) (n-16) + +------------------------------------------------------------------------ + +putWord64N1Host = loop 0 + where loop s n | s `seq` n `seq` False = undefined + loop _ 0 = return () + loop s n = do + putWord64host (s+0) + loop (s+1) (n-1) + +putWord64N2Host = loop 0 + where loop s n | s `seq` n `seq` False = undefined + loop _ 0 = return () + loop s n = do + putWord64host (s+0) + putWord64host (s+1) + loop (s+2) (n-2) + +putWord64N4Host = loop 0 + where loop s n | s `seq` n `seq` False = undefined + loop _ 0 = return () + loop s n = do + putWord64host (s+0) + putWord64host (s+1) + putWord64host (s+2) + putWord64host (s+3) + loop (s+4) (n-4) + +putWord64N8Host = loop 0 + where loop s n | s `seq` n `seq` False = undefined + loop _ 0 = return () + loop s n = do + putWord64host (s+0) + putWord64host (s+1) + putWord64host (s+2) + putWord64host (s+3) + putWord64host (s+4) + putWord64host (s+5) + putWord64host (s+6) + putWord64host (s+7) + loop (s+8) (n-8) + +putWord64N16Host = loop 0 + where loop s n | s `seq` n `seq` False = undefined + loop _ 0 = return () + loop s n = do + putWord64host (s+0) + putWord64host (s+1) + putWord64host (s+2) + putWord64host (s+3) + putWord64host (s+4) + putWord64host (s+5) + putWord64host (s+6) + putWord64host (s+7) + putWord64host (s+8) + putWord64host (s+9) + putWord64host (s+10) + putWord64host (s+11) + putWord64host (s+12) + putWord64host (s+13) + putWord64host (s+14) + putWord64host (s+15) + loop (s+16) (n-16) + +------------------------------------------------------------------------ +------------------------------------------------------------------------ + +getWord8N1 = loop 0 + where loop s n | s `seq` n `seq` False = undefined + loop s 0 = return s + loop s n = do + s0 <- getWord8 + loop (s+s0) (n-1) + +getWord8N2 = loop 0 + where loop s n | s `seq` n `seq` False = undefined + loop s 0 = return s + loop s n = do + s0 <- getWord8 + s1 <- getWord8 + loop (s+s0+s1) (n-2) + +getWord8N4 = loop 0 + where loop s n | s `seq` n `seq` False = undefined + loop s 0 = return s + loop s n = do + s0 <- getWord8 + s1 <- getWord8 + s2 <- getWord8 + s3 <- getWord8 + loop (s+s0+s1+s2+s3) (n-4) + +getWord8N8 = loop 0 + where loop s n | s `seq` n `seq` False = undefined + loop s 0 = return s + loop s n = do + s0 <- getWord8 + s1 <- getWord8 + s2 <- getWord8 + s3 <- getWord8 + s4 <- getWord8 + s5 <- getWord8 + s6 <- getWord8 + s7 <- getWord8 + loop (s+s0+s1+s2+s3+s4+s5+s6+s7) (n-8) + +getWord8N16 = loop 0 + where loop s n | s `seq` n `seq` False = undefined + loop s 0 = return s + loop s n = do + s0 <- getWord8 + s1 <- getWord8 + s2 <- getWord8 + s3 <- getWord8 + s4 <- getWord8 + s5 <- getWord8 + s6 <- getWord8 + s7 <- getWord8 + s8 <- getWord8 + s9 <- getWord8 + s10 <- getWord8 + s11 <- getWord8 + s12 <- getWord8 + s13 <- getWord8 + s14 <- getWord8 + s15 <- getWord8 + loop (s+s0+s1+s2+s3+s4+s5+s6+s7+s9+s10+s11+s12+s13+s14+s15) (n-16) + +------------------------------------------------------------------------ + +getWord16N1Big = loop 0 + where loop s n | s `seq` n `seq` False = undefined + loop s 0 = return s + loop s n = do + s0 <- getWord16be + loop (s+s0) (n-1) + +getWord16N2Big = loop 0 + where loop s n | s `seq` n `seq` False = undefined + loop s 0 = return s + loop s n = do + s0 <- getWord16be + s1 <- getWord16be + loop (s+s0+s1) (n-2) + +getWord16N4Big = loop 0 + where loop s n | s `seq` n `seq` False = undefined + loop s 0 = return s + loop s n = do + s0 <- getWord16be + s1 <- getWord16be + s2 <- getWord16be + s3 <- getWord16be + loop (s+s0+s1+s2+s3) (n-4) + +getWord16N8Big = loop 0 + where loop s n | s `seq` n `seq` False = undefined + loop s 0 = return s + loop s n = do + s0 <- getWord16be + s1 <- getWord16be + s2 <- getWord16be + s3 <- getWord16be + s4 <- getWord16be + s5 <- getWord16be + s6 <- getWord16be + s7 <- getWord16be + loop (s+s0+s1+s2+s3+s4+s5+s6+s7) (n-8) + +getWord16N16Big = loop 0 + where loop s n | s `seq` n `seq` False = undefined + loop s 0 = return s + loop s n = do + s0 <- getWord16be + s1 <- getWord16be + s2 <- getWord16be + s3 <- getWord16be + s4 <- getWord16be + s5 <- getWord16be + s6 <- getWord16be + s7 <- getWord16be + s8 <- getWord16be + s9 <- getWord16be + s10 <- getWord16be + s11 <- getWord16be + s12 <- getWord16be + s13 <- getWord16be + s14 <- getWord16be + s15 <- getWord16be + loop (s+s0+s1+s2+s3+s4+s5+s6+s7+s9+s10+s11+s12+s13+s14+s15) (n-16) + +------------------------------------------------------------------------ + +getWord16N1Little = loop 0 + where loop s n | s `seq` n `seq` False = undefined + loop s 0 = return s + loop s n = do + s0 <- getWord16le + loop (s+s0) (n-1) + +getWord16N2Little = loop 0 + where loop s n | s `seq` n `seq` False = undefined + loop s 0 = return s + loop s n = do + s0 <- getWord16le + s1 <- getWord16le + loop (s+s0+s1) (n-2) + +getWord16N4Little = loop 0 + where loop s n | s `seq` n `seq` False = undefined + loop s 0 = return s + loop s n = do + s0 <- getWord16le + s1 <- getWord16le + s2 <- getWord16le + s3 <- getWord16le + loop (s+s0+s1+s2+s3) (n-4) + +getWord16N8Little = loop 0 + where loop s n | s `seq` n `seq` False = undefined + loop s 0 = return s + loop s n = do + s0 <- getWord16le + s1 <- getWord16le + s2 <- getWord16le + s3 <- getWord16le + s4 <- getWord16le + s5 <- getWord16le + s6 <- getWord16le + s7 <- getWord16le + loop (s+s0+s1+s2+s3+s4+s5+s6+s7) (n-8) + +getWord16N16Little = loop 0 + where loop s n | s `seq` n `seq` False = undefined + loop s 0 = return s + loop s n = do + s0 <- getWord16le + s1 <- getWord16le + s2 <- getWord16le + s3 <- getWord16le + s4 <- getWord16le + s5 <- getWord16le + s6 <- getWord16le + s7 <- getWord16le + s8 <- getWord16le + s9 <- getWord16le + s10 <- getWord16le + s11 <- getWord16le + s12 <- getWord16le + s13 <- getWord16le + s14 <- getWord16le + s15 <- getWord16le + loop (s+s0+s1+s2+s3+s4+s5+s6+s7+s9+s10+s11+s12+s13+s14+s15) (n-16) + +------------------------------------------------------------------------ + +getWord16N1Host = loop 0 + where loop s n | s `seq` n `seq` False = undefined + loop s 0 = return s + loop s n = do + s0 <- getWord16host + loop (s+s0) (n-1) + +getWord16N2Host = loop 0 + where loop s n | s `seq` n `seq` False = undefined + loop s 0 = return s + loop s n = do + s0 <- getWord16host + s1 <- getWord16host + loop (s+s0+s1) (n-2) + +getWord16N4Host = loop 0 + where loop s n | s `seq` n `seq` False = undefined + loop s 0 = return s + loop s n = do + s0 <- getWord16host + s1 <- getWord16host + s2 <- getWord16host + s3 <- getWord16host + loop (s+s0+s1+s2+s3) (n-4) + +getWord16N8Host = loop 0 + where loop s n | s `seq` n `seq` False = undefined + loop s 0 = return s + loop s n = do + s0 <- getWord16host + s1 <- getWord16host + s2 <- getWord16host + s3 <- getWord16host + s4 <- getWord16host + s5 <- getWord16host + s6 <- getWord16host + s7 <- getWord16host + loop (s+s0+s1+s2+s3+s4+s5+s6+s7) (n-8) + +getWord16N16Host = loop 0 + where loop s n | s `seq` n `seq` False = undefined + loop s 0 = return s + loop s n = do + s0 <- getWord16host + s1 <- getWord16host + s2 <- getWord16host + s3 <- getWord16host + s4 <- getWord16host + s5 <- getWord16host + s6 <- getWord16host + s7 <- getWord16host + s8 <- getWord16host + s9 <- getWord16host + s10 <- getWord16host + s11 <- getWord16host + s12 <- getWord16host + s13 <- getWord16host + s14 <- getWord16host + s15 <- getWord16host + loop (s+s0+s1+s2+s3+s4+s5+s6+s7+s9+s10+s11+s12+s13+s14+s15) (n-16) + +------------------------------------------------------------------------ + +getWord32N1Big = loop 0 + where loop s n | s `seq` n `seq` False = undefined + loop s 0 = return s + loop s n = do + s0 <- getWord32be + loop (s+s0) (n-1) + +getWord32N2Big = loop 0 + where loop s n | s `seq` n `seq` False = undefined + loop s 0 = return s + loop s n = do + s0 <- getWord32be + s1 <- getWord32be + loop (s+s0+s1) (n-2) + +getWord32N4Big = loop 0 + where loop s n | s `seq` n `seq` False = undefined + loop s 0 = return s + loop s n = do + s0 <- getWord32be + s1 <- getWord32be + s2 <- getWord32be + s3 <- getWord32be + loop (s+s0+s1+s2+s3) (n-4) + +getWord32N8Big = loop 0 + where loop s n | s `seq` n `seq` False = undefined + loop s 0 = return s + loop s n = do + s0 <- getWord32be + s1 <- getWord32be + s2 <- getWord32be + s3 <- getWord32be + s4 <- getWord32be + s5 <- getWord32be + s6 <- getWord32be + s7 <- getWord32be + loop (s+s0+s1+s2+s3+s4+s5+s6+s7) (n-8) + +-- getWordhostN16 = loop 0 +getWord32N16Big = loop 0 + where loop s n | s `seq` n `seq` False = undefined + loop s 0 = return s + loop s n = do + s0 <- getWord32be + s1 <- getWord32be + s2 <- getWord32be + s3 <- getWord32be + s4 <- getWord32be + s5 <- getWord32be + s6 <- getWord32be + s7 <- getWord32be + s8 <- getWord32be + s9 <- getWord32be + s10 <- getWord32be + s11 <- getWord32be + s12 <- getWord32be + s13 <- getWord32be + s14 <- getWord32be + s15 <- getWord32be + loop (s+s0+s1+s2+s3+s4+s5+s6+s7+s9+s10+s11+s12+s13+s14+s15) (n-16) + +------------------------------------------------------------------------ + +getWord32N1Little = loop 0 + where loop s n | s `seq` n `seq` False = undefined + loop s 0 = return s + loop s n = do + s0 <- getWord32le + loop (s+s0) (n-1) + +getWord32N2Little = loop 0 + where loop s n | s `seq` n `seq` False = undefined + loop s 0 = return s + loop s n = do + s0 <- getWord32le + s1 <- getWord32le + loop (s+s0+s1) (n-2) + +getWord32N4Little = loop 0 + where loop s n | s `seq` n `seq` False = undefined + loop s 0 = return s + loop s n = do + s0 <- getWord32le + s1 <- getWord32le + s2 <- getWord32le + s3 <- getWord32le + loop (s+s0+s1+s2+s3) (n-4) + +getWord32N8Little = loop 0 + where loop s n | s `seq` n `seq` False = undefined + loop s 0 = return s + loop s n = do + s0 <- getWord32le + s1 <- getWord32le + s2 <- getWord32le + s3 <- getWord32le + s4 <- getWord32le + s5 <- getWord32le + s6 <- getWord32le + s7 <- getWord32le + loop (s+s0+s1+s2+s3+s4+s5+s6+s7) (n-8) + +-- getWordhostN16 = loop 0 +getWord32N16Little = loop 0 + where loop s n | s `seq` n `seq` False = undefined + loop s 0 = return s + loop s n = do + s0 <- getWord32le + s1 <- getWord32le + s2 <- getWord32le + s3 <- getWord32le + s4 <- getWord32le + s5 <- getWord32le + s6 <- getWord32le + s7 <- getWord32le + s8 <- getWord32le + s9 <- getWord32le + s10 <- getWord32le + s11 <- getWord32le + s12 <- getWord32le + s13 <- getWord32le + s14 <- getWord32le + s15 <- getWord32le + loop (s+s0+s1+s2+s3+s4+s5+s6+s7+s9+s10+s11+s12+s13+s14+s15) (n-16) + +------------------------------------------------------------------------ + +getWord32N1Host = loop 0 + where loop s n | s `seq` n `seq` False = undefined + loop s 0 = return s + loop s n = do + s0 <- getWord32host + loop (s+s0) (n-1) + +getWord32N2Host = loop 0 + where loop s n | s `seq` n `seq` False = undefined + loop s 0 = return s + loop s n = do + s0 <- getWord32host + s1 <- getWord32host + loop (s+s0+s1) (n-2) + +getWord32N4Host = loop 0 + where loop s n | s `seq` n `seq` False = undefined + loop s 0 = return s + loop s n = do + s0 <- getWord32host + s1 <- getWord32host + s2 <- getWord32host + s3 <- getWord32host + loop (s+s0+s1+s2+s3) (n-4) + +getWord32N8Host = loop 0 + where loop s n | s `seq` n `seq` False = undefined + loop s 0 = return s + loop s n = do + s0 <- getWord32host + s1 <- getWord32host + s2 <- getWord32host + s3 <- getWord32host + s4 <- getWord32host + s5 <- getWord32host + s6 <- getWord32host + s7 <- getWord32host + loop (s+s0+s1+s2+s3+s4+s5+s6+s7) (n-8) + +-- getWordhostN16 = loop 0 +getWord32N16Host = loop 0 + where loop s n | s `seq` n `seq` False = undefined + loop s 0 = return s + loop s n = do + s0 <- getWord32host + s1 <- getWord32host + s2 <- getWord32host + s3 <- getWord32host + s4 <- getWord32host + s5 <- getWord32host + s6 <- getWord32host + s7 <- getWord32host + s8 <- getWord32host + s9 <- getWord32host + s10 <- getWord32host + s11 <- getWord32host + s12 <- getWord32host + s13 <- getWord32host + s14 <- getWord32host + s15 <- getWord32host + loop (s+s0+s1+s2+s3+s4+s5+s6+s7+s9+s10+s11+s12+s13+s14+s15) (n-16) + +------------------------------------------------------------------------ + +getWord64N1Big = loop 0 + where loop s n | s `seq` n `seq` False = undefined + loop s 0 = return s + loop s n = do + s0 <- getWord64be + loop (s+s0) (n-1) + +getWord64N2Big = loop 0 + where loop s n | s `seq` n `seq` False = undefined + loop s 0 = return s + loop s n = do + s0 <- getWord64be + s1 <- getWord64be + loop (s+s0+s1) (n-2) + +getWord64N4Big = loop 0 + where loop s n | s `seq` n `seq` False = undefined + loop s 0 = return s + loop s n = do + s0 <- getWord64be + s1 <- getWord64be + s2 <- getWord64be + s3 <- getWord64be + loop (s+s0+s1+s2+s3) (n-4) + +getWord64N8Big = loop 0 + where loop s n | s `seq` n `seq` False = undefined + loop s 0 = return s + loop s n = do + s0 <- getWord64be + s1 <- getWord64be + s2 <- getWord64be + s3 <- getWord64be + s4 <- getWord64be + s5 <- getWord64be + s6 <- getWord64be + s7 <- getWord64be + loop (s+s0+s1+s2+s3+s4+s5+s6+s7) (n-8) + +getWord64N16Big = loop 0 + where loop s n | s `seq` n `seq` False = undefined + loop s 0 = return s + loop s n = do + s0 <- getWord64be + s1 <- getWord64be + s2 <- getWord64be + s3 <- getWord64be + s4 <- getWord64be + s5 <- getWord64be + s6 <- getWord64be + s7 <- getWord64be + s8 <- getWord64be + s9 <- getWord64be + s10 <- getWord64be + s11 <- getWord64be + s12 <- getWord64be + s13 <- getWord64be + s14 <- getWord64be + s15 <- getWord64be + loop (s+s0+s1+s2+s3+s4+s5+s6+s7+s9+s10+s11+s12+s13+s14+s15) (n-16) + +------------------------------------------------------------------------ + +getWord64N1Little = loop 0 + where loop s n | s `seq` n `seq` False = undefined + loop s 0 = return s + loop s n = do + s0 <- getWord64le + loop (s+s0) (n-1) + +getWord64N2Little = loop 0 + where loop s n | s `seq` n `seq` False = undefined + loop s 0 = return s + loop s n = do + s0 <- getWord64le + s1 <- getWord64le + loop (s+s0+s1) (n-2) + +getWord64N4Little = loop 0 + where loop s n | s `seq` n `seq` False = undefined + loop s 0 = return s + loop s n = do + s0 <- getWord64le + s1 <- getWord64le + s2 <- getWord64le + s3 <- getWord64le + loop (s+s0+s1+s2+s3) (n-4) + +getWord64N8Little = loop 0 + where loop s n | s `seq` n `seq` False = undefined + loop s 0 = return s + loop s n = do + s0 <- getWord64le + s1 <- getWord64le + s2 <- getWord64le + s3 <- getWord64le + s4 <- getWord64le + s5 <- getWord64le + s6 <- getWord64le + s7 <- getWord64le + loop (s+s0+s1+s2+s3+s4+s5+s6+s7) (n-8) + +getWord64N16Little = loop 0 + where loop s n | s `seq` n `seq` False = undefined + loop s 0 = return s + loop s n = do + s0 <- getWord64le + s1 <- getWord64le + s2 <- getWord64le + s3 <- getWord64le + s4 <- getWord64le + s5 <- getWord64le + s6 <- getWord64le + s7 <- getWord64le + s8 <- getWord64le + s9 <- getWord64le + s10 <- getWord64le + s11 <- getWord64le + s12 <- getWord64le + s13 <- getWord64le + s14 <- getWord64le + s15 <- getWord64le + loop (s+s0+s1+s2+s3+s4+s5+s6+s7+s9+s10+s11+s12+s13+s14+s15) (n-16) + +------------------------------------------------------------------------ + +getWord64N1Host = loop 0 + where loop s n | s `seq` n `seq` False = undefined + loop s 0 = return s + loop s n = do + s0 <- getWord64host + loop (s+s0) (n-1) + +getWord64N2Host = loop 0 + where loop s n | s `seq` n `seq` False = undefined + loop s 0 = return s + loop s n = do + s0 <- getWord64host + s1 <- getWord64host + loop (s+s0+s1) (n-2) + +getWord64N4Host = loop 0 + where loop s n | s `seq` n `seq` False = undefined + loop s 0 = return s + loop s n = do + s0 <- getWord64host + s1 <- getWord64host + s2 <- getWord64host + s3 <- getWord64host + loop (s+s0+s1+s2+s3) (n-4) + +getWord64N8Host = loop 0 + where loop s n | s `seq` n `seq` False = undefined + loop s 0 = return s + loop s n = do + s0 <- getWord64host + s1 <- getWord64host + s2 <- getWord64host + s3 <- getWord64host + s4 <- getWord64host + s5 <- getWord64host + s6 <- getWord64host + s7 <- getWord64host + loop (s+s0+s1+s2+s3+s4+s5+s6+s7) (n-8) + +getWord64N16Host = loop 0 + where loop s n | s `seq` n `seq` False = undefined + loop s 0 = return s + loop s n = do + s0 <- getWord64host + s1 <- getWord64host + s2 <- getWord64host + s3 <- getWord64host + s4 <- getWord64host + s5 <- getWord64host + s6 <- getWord64host + s7 <- getWord64host + s8 <- getWord64host + s9 <- getWord64host + s10 <- getWord64host + s11 <- getWord64host + s12 <- getWord64host + s13 <- getWord64host + s14 <- getWord64host + s15 <- getWord64host + loop (s+s0+s1+s2+s3+s4+s5+s6+s7+s9+s10+s11+s12+s13+s14+s15) (n-16) diff --git a/tests/CBenchmark.c b/tests/CBenchmark.c new file mode 100644 --- /dev/null +++ b/tests/CBenchmark.c @@ -0,0 +1,39 @@ +#include "CBenchmark.h" + +void bytewrite(unsigned char *a, int bytes) { + unsigned char n = 0; + int i = 0; + int iterations = bytes; + while (i < iterations) { + a[i++] = n++; + } +} + +unsigned char byteread(unsigned char *a, int bytes) { + unsigned char n = 0; + int i = 0; + int iterations = bytes; + while (i < iterations) { + n += a[i++]; + } + return n; +} + +void wordwrite(unsigned long *a, int bytes) { + unsigned long n = 0; + int i = 0; + int iterations = bytes / sizeof(unsigned long) ; + while (i < iterations) { + a[i++] = n++; + } +} + +unsigned int wordread(unsigned long *a, int bytes) { + unsigned long n = 0; + int i = 0; + int iterations = bytes / sizeof(unsigned long); + while (i < iterations) { + n += a[i++]; + } + return n; +} diff --git a/tests/CBenchmark.h b/tests/CBenchmark.h new file mode 100644 --- /dev/null +++ b/tests/CBenchmark.h @@ -0,0 +1,4 @@ +void bytewrite(unsigned char *a, int bytes); +unsigned char byteread(unsigned char *a, int bytes); +void wordwrite(unsigned long *a, int bytes); +unsigned int wordread(unsigned long *a, int bytes); diff --git a/tests/HeapUse.hs b/tests/HeapUse.hs new file mode 100644 --- /dev/null +++ b/tests/HeapUse.hs @@ -0,0 +1,17 @@ +-- Checks heap behavior of getBytes + +import Data.Binary.Get (runGet, getBytes) + +import Control.Monad (liftM) +import qualified Data.ByteString.Lazy as L + +main = do + let x = (L.take 110000042 $ L.iterate (+1) 0) + mapM_ (print . L.length) (chunks 20000000 x) + +chunks n = runGet (unfoldM f) + where f = do x <- getBytes 20000000 + return $ if L.null x then Nothing else Just x + +unfoldM :: Monad m => m (Maybe a) -> m [a] +unfoldM f = f >>= maybe (return []) (\x -> liftM (x:) (unfoldM f)) diff --git a/tests/Makefile b/tests/Makefile new file mode 100644 --- /dev/null +++ b/tests/Makefile @@ -0,0 +1,34 @@ +all: compiled + +interpreted: + runhaskell QC.hs 1000 + +compiled: + ghc --make -fhpc -O QC.hs -o qc -no-recomp -threaded + ./qc 500 +RTS -qw -N2 + +bench:: Benchmark.hs MemBench.hs CBenchmark.o + ghc --make -O2 Benchmark.hs -fasm CBenchmark.o -o bench -no-recomp + ./bench 100 + +bench-nb:: + ghc --make -O2 -fliberate-case-threshold=1000 NewBenchmark.hs -fasm -o bench-nb + ./bench-nb + +CBenchmark.o: CBenchmark.c + gcc -O -c $< -o $@ + +hugs: + runhugs -98 QC.hs + + +HeapUse: HeapUse.hs + ghc --make -O $^ -fasm -o $@ + +heap: HeapUse + ./HeapUse +RTS -M10M -t/dev/stderr -RTS + +clean: + rm -f *.o *.hi qc bench bench-nb *~ + +.PHONY: clean bench bench-nb diff --git a/tests/MemBench.hs b/tests/MemBench.hs new file mode 100644 --- /dev/null +++ b/tests/MemBench.hs @@ -0,0 +1,85 @@ +{-# OPTIONS_GHC -fffi -fbang-patterns #-} +module MemBench (memBench) where + +import Foreign +import Foreign.C + +import Control.Exception +import System.CPUTime +import Numeric + +memBench :: Int -> IO () +memBench mb = do + let bytes = mb * 2^20 + allocaBytes bytes $ \ptr -> do + let bench label test = do + seconds <- time $ test (castPtr ptr) (fromIntegral bytes) + let throughput = fromIntegral mb / seconds + putStrLn $ show mb ++ "MB of " ++ label + ++ " in " ++ showFFloat (Just 3) seconds "s, at: " + ++ showFFloat (Just 1) throughput "MB/s" + bench "setup " c_wordwrite + putStrLn "" + putStrLn "C memory throughput benchmarks:" + bench "bytes written" c_bytewrite + bench "bytes read " c_byteread + bench "words written" c_wordwrite + bench "words read " c_wordread + putStrLn "" + putStrLn "Haskell memory throughput benchmarks:" + bench "bytes written" hs_bytewrite + bench "bytes read " hs_byteread + bench "words written" hs_wordwrite + bench "words read " hs_wordread + +hs_bytewrite :: Ptr CUChar -> Int -> IO () +hs_bytewrite !ptr bytes = loop 0 0 + where iterations = bytes + loop :: Int -> CUChar -> IO () + loop !i !n | i == iterations = return () + | otherwise = do pokeByteOff ptr i n + loop (i+1) (n+1) + +hs_byteread :: Ptr CUChar -> Int -> IO CUChar +hs_byteread !ptr bytes = loop 0 0 + where iterations = bytes + loop :: Int -> CUChar -> IO CUChar + loop !i !n | i == iterations = return n + | otherwise = do x <- peekByteOff ptr i + loop (i+1) (n+x) + +hs_wordwrite :: Ptr CULong -> Int -> IO () +hs_wordwrite !ptr bytes = loop 0 0 + where iterations = bytes `div` sizeOf (undefined :: CULong) + loop :: Int -> CULong -> IO () + loop !i !n | i == iterations = return () + | otherwise = do pokeByteOff ptr i n + loop (i+1) (n+1) + +hs_wordread :: Ptr CULong -> Int -> IO CULong +hs_wordread !ptr bytes = loop 0 0 + where iterations = bytes `div` sizeOf (undefined :: CULong) + loop :: Int -> CULong -> IO CULong + loop !i !n | i == iterations = return n + | otherwise = do x <- peekByteOff ptr i + loop (i+1) (n+x) + + +foreign import ccall unsafe "CBenchmark.h byteread" + c_byteread :: Ptr CUChar -> CInt -> IO () + +foreign import ccall unsafe "CBenchmark.h bytewrite" + c_bytewrite :: Ptr CUChar -> CInt -> IO () + +foreign import ccall unsafe "CBenchmark.h wordread" + c_wordread :: Ptr CUInt -> CInt -> IO () + +foreign import ccall unsafe "CBenchmark.h wordwrite" + c_wordwrite :: Ptr CUInt -> CInt -> IO () + +time :: IO a -> IO Double +time action = do + start <- getCPUTime + action + end <- getCPUTime + return $! (fromIntegral (end - start)) / (10^12) diff --git a/tests/NewBenchmark.hs b/tests/NewBenchmark.hs new file mode 100644 --- /dev/null +++ b/tests/NewBenchmark.hs @@ -0,0 +1,625 @@ +-- +-- benchmark NewBinary +-- + +module Main where + +import System.IO +import Data.Word +import NewBinary + +import Control.Exception +import System.CPUTime +import Numeric + +mb :: Int +mb = 10 + +main :: IO () +main = sequence_ + [ test wordSize chunkSize mb + | wordSize <- [1,2,4,8] + , chunkSize <- [1,2,4,8,16] ] + +time :: IO a -> IO Double +time action = do + start <- getCPUTime + action + end <- getCPUTime + return $! (fromIntegral (end - start)) / (10^12) + +test :: Int -> Int -> Int -> IO () +test wordSize chunkSize mb = do + let bytes :: Int + bytes = mb * 2^20 + iterations = bytes `div` wordSize + putStr $ show mb ++ "MB of Word" ++ show (8 * wordSize) + ++ " in chunks of " ++ show chunkSize ++ ": " + h <- openBinMem bytes undefined + start <- tellBin h + putSeconds <- time $ do + doPut wordSize chunkSize h iterations +-- BinPtr n _ <- tellBin h +-- print n + getSeconds <- time $ do + seekBin h start + sum <- doGet wordSize chunkSize h iterations + evaluate sum +-- BinPtr n _ <- tellBin h +-- print (n, sum) + let putThroughput = fromIntegral mb / putSeconds + getThroughput = fromIntegral mb / getSeconds + putStrLn $ showFFloat (Just 2) putThroughput "MB/s write, " + ++ showFFloat (Just 2) getThroughput "MB/s read" + +doPut :: Int -> Int -> BinHandle -> Int -> IO () +doPut wordSize chunkSize = + case (wordSize, chunkSize) of + (1, 1) -> putWord8N1 + (1, 2) -> putWord8N2 + (1, 4) -> putWord8N4 + (1, 8) -> putWord8N8 + (1, 16) -> putWord8N16 + (2, 1) -> putWord16N1 + (2, 2) -> putWord16N2 + (2, 4) -> putWord16N4 + (2, 8) -> putWord16N8 + (2, 16) -> putWord16N16 + (4, 1) -> putWord32N1 + (4, 2) -> putWord32N2 + (4, 4) -> putWord32N4 + (4, 8) -> putWord32N8 + (4, 16) -> putWord32N16 + (8, 1) -> putWord64N1 + (8, 2) -> putWord64N2 + (8, 4) -> putWord64N4 + (8, 8) -> putWord64N8 + (8, 16) -> putWord64N16 + +putWord8 :: BinHandle -> Word8 -> IO () +putWord8 = put_ +{-# INLINE putWord8 #-} + +putWord16be :: BinHandle -> Word16 -> IO () +putWord16be = put_ +{-# INLINE putWord16be #-} + +putWord32be :: BinHandle -> Word32 -> IO () +putWord32be = put_ +{-# INLINE putWord32be #-} + +putWord64be :: BinHandle -> Word64 -> IO () +putWord64be = put_ +{-# INLINE putWord64be #-} + +getWord8 :: BinHandle -> IO Word8 +getWord8 = get +{-# INLINE getWord8 #-} + +getWord16be :: BinHandle -> IO Word16 +getWord16be = get +{-# INLINE getWord16be #-} + +getWord32be :: BinHandle -> IO Word32 +getWord32be = get +{-# INLINE getWord32be #-} + +getWord64be :: BinHandle -> IO Word64 +getWord64be = get +{-# INLINE getWord64be #-} + +putWord8N1 hnd = loop 0 + where loop s n | s `seq` n `seq` False = undefined + loop _ 0 = return () + loop s n = do + putWord8 hnd (s+0) + loop (s+1) (n-1) + +putWord8N2 hnd = loop 0 + where loop s n | s `seq` n `seq` False = undefined + loop _ 0 = return () + loop s n = do + putWord8 hnd (s+0) + putWord8 hnd (s+1) + loop (s+2) (n-2) + +putWord8N4 hnd = loop 0 + where loop s n | s `seq` n `seq` False = undefined + loop _ 0 = return () + loop s n = do + putWord8 hnd (s+0) + putWord8 hnd (s+1) + putWord8 hnd (s+2) + putWord8 hnd (s+3) + loop (s+4) (n-4) + +putWord8N8 hnd = loop 0 + where loop s n | s `seq` n `seq` False = undefined + loop _ 0 = return () + loop s n = do + putWord8 hnd (s+0) + putWord8 hnd (s+1) + putWord8 hnd (s+2) + putWord8 hnd (s+3) + putWord8 hnd (s+4) + putWord8 hnd (s+5) + putWord8 hnd (s+6) + putWord8 hnd (s+7) + loop (s+8) (n-8) + +putWord8N16 hnd = loop 0 + where loop s n | s `seq` n `seq` False = undefined + loop _ 0 = return () + loop s n = do + putWord8 hnd (s+0) + putWord8 hnd (s+1) + putWord8 hnd (s+2) + putWord8 hnd (s+3) + putWord8 hnd (s+4) + putWord8 hnd (s+5) + putWord8 hnd (s+6) + putWord8 hnd (s+7) + putWord8 hnd (s+8) + putWord8 hnd (s+9) + putWord8 hnd (s+10) + putWord8 hnd (s+11) + putWord8 hnd (s+12) + putWord8 hnd (s+13) + putWord8 hnd (s+14) + putWord8 hnd (s+15) + loop (s+16) (n-16) + + +putWord16N1 hnd = loop 0 + where loop s n | s `seq` n `seq` False = undefined + loop _ 0 = return () + loop s n = do + putWord16be hnd (s+0) + loop (s+1) (n-1) + +putWord16N2 hnd = loop 0 + where loop s n | s `seq` n `seq` False = undefined + loop _ 0 = return () + loop s n = do + putWord16be hnd (s+0) + putWord16be hnd (s+1) + loop (s+2) (n-2) + +putWord16N4 hnd = loop 0 + where loop s n | s `seq` n `seq` False = undefined + loop _ 0 = return () + loop s n = do + putWord16be hnd (s+0) + putWord16be hnd (s+1) + putWord16be hnd (s+2) + putWord16be hnd (s+3) + loop (s+4) (n-4) + +putWord16N8 hnd = loop 0 + where loop s n | s `seq` n `seq` False = undefined + loop _ 0 = return () + loop s n = do + putWord16be hnd (s+0) + putWord16be hnd (s+1) + putWord16be hnd (s+2) + putWord16be hnd (s+3) + putWord16be hnd (s+4) + putWord16be hnd (s+5) + putWord16be hnd (s+6) + putWord16be hnd (s+7) + loop (s+8) (n-8) + +putWord16N16 hnd = loop 0 + where loop s n | s `seq` n `seq` False = undefined + loop _ 0 = return () + loop s n = do + putWord16be hnd (s+0) + putWord16be hnd (s+1) + putWord16be hnd (s+2) + putWord16be hnd (s+3) + putWord16be hnd (s+4) + putWord16be hnd (s+5) + putWord16be hnd (s+6) + putWord16be hnd (s+7) + putWord16be hnd (s+8) + putWord16be hnd (s+9) + putWord16be hnd (s+10) + putWord16be hnd (s+11) + putWord16be hnd (s+12) + putWord16be hnd (s+13) + putWord16be hnd (s+14) + putWord16be hnd (s+15) + loop (s+16) (n-16) + + +putWord32N1 hnd = loop 0 + where loop s n | s `seq` n `seq` False = undefined + loop _ 0 = return () + loop s n = do + putWord32be hnd (s+0) + loop (s+1) (n-1) + +putWord32N2 hnd = loop 0 + where loop s n | s `seq` n `seq` False = undefined + loop _ 0 = return () + loop s n = do + putWord32be hnd (s+0) + putWord32be hnd (s+1) + loop (s+2) (n-2) + +putWord32N4 hnd = loop 0 + where loop s n | s `seq` n `seq` False = undefined + loop _ 0 = return () + loop s n = do + putWord32be hnd (s+0) + putWord32be hnd (s+1) + putWord32be hnd (s+2) + putWord32be hnd (s+3) + loop (s+4) (n-4) + +putWord32N8 hnd = loop 0 + where loop s n | s `seq` n `seq` False = undefined + loop _ 0 = return () + loop s n = do + putWord32be hnd (s+0) + putWord32be hnd (s+1) + putWord32be hnd (s+2) + putWord32be hnd (s+3) + putWord32be hnd (s+4) + putWord32be hnd (s+5) + putWord32be hnd (s+6) + putWord32be hnd (s+7) + loop (s+8) (n-8) + +putWord32N16 hnd = loop 0 + where loop s n | s `seq` n `seq` False = undefined + loop _ 0 = return () + loop s n = do + putWord32be hnd (s+0) + putWord32be hnd (s+1) + putWord32be hnd (s+2) + putWord32be hnd (s+3) + putWord32be hnd (s+4) + putWord32be hnd (s+5) + putWord32be hnd (s+6) + putWord32be hnd (s+7) + putWord32be hnd (s+8) + putWord32be hnd (s+9) + putWord32be hnd (s+10) + putWord32be hnd (s+11) + putWord32be hnd (s+12) + putWord32be hnd (s+13) + putWord32be hnd (s+14) + putWord32be hnd (s+15) + loop (s+16) (n-16) + +putWord64N1 hnd = loop 0 + where loop s n | s `seq` n `seq` False = undefined + loop _ 0 = return () + loop s n = do + putWord64be hnd (s+0) + loop (s+1) (n-1) + +putWord64N2 hnd = loop 0 + where loop s n | s `seq` n `seq` False = undefined + loop _ 0 = return () + loop s n = do + putWord64be hnd (s+0) + putWord64be hnd (s+1) + loop (s+2) (n-2) + +putWord64N4 hnd = loop 0 + where loop s n | s `seq` n `seq` False = undefined + loop _ 0 = return () + loop s n = do + putWord64be hnd (s+0) + putWord64be hnd (s+1) + putWord64be hnd (s+2) + putWord64be hnd (s+3) + loop (s+4) (n-4) + +putWord64N8 hnd = loop 0 + where loop s n | s `seq` n `seq` False = undefined + loop _ 0 = return () + loop s n = do + putWord64be hnd (s+0) + putWord64be hnd (s+1) + putWord64be hnd (s+2) + putWord64be hnd (s+3) + putWord64be hnd (s+4) + putWord64be hnd (s+5) + putWord64be hnd (s+6) + putWord64be hnd (s+7) + loop (s+8) (n-8) + +putWord64N16 hnd = loop 0 + where loop s n | s `seq` n `seq` False = undefined + loop _ 0 = return () + loop s n = do + putWord64be hnd (s+0) + putWord64be hnd (s+1) + putWord64be hnd (s+2) + putWord64be hnd (s+3) + putWord64be hnd (s+4) + putWord64be hnd (s+5) + putWord64be hnd (s+6) + putWord64be hnd (s+7) + putWord64be hnd (s+8) + putWord64be hnd (s+9) + putWord64be hnd (s+10) + putWord64be hnd (s+11) + putWord64be hnd (s+12) + putWord64be hnd (s+13) + putWord64be hnd (s+14) + putWord64be hnd (s+15) + loop (s+16) (n-16) + +doGet :: Int -> Int -> BinHandle -> Int -> IO Int +doGet wordSize chunkSize hnd = + case (wordSize, chunkSize) of + (1, 1) -> fmap fromIntegral . getWord8N1 hnd + (1, 2) -> fmap fromIntegral . getWord8N2 hnd + (1, 4) -> fmap fromIntegral . getWord8N4 hnd + (1, 8) -> fmap fromIntegral . getWord8N8 hnd + (1, 16) -> fmap fromIntegral . getWord8N16 hnd + (2, 1) -> fmap fromIntegral . getWord16N1 hnd + (2, 2) -> fmap fromIntegral . getWord16N2 hnd + (2, 4) -> fmap fromIntegral . getWord16N4 hnd + (2, 8) -> fmap fromIntegral . getWord16N8 hnd + (2, 16) -> fmap fromIntegral . getWord16N16 hnd + (4, 1) -> fmap fromIntegral . getWord32N1 hnd + (4, 2) -> fmap fromIntegral . getWord32N2 hnd + (4, 4) -> fmap fromIntegral . getWord32N4 hnd + (4, 8) -> fmap fromIntegral . getWord32N8 hnd + (4, 16) -> fmap fromIntegral . getWord32N16 hnd + (8, 1) -> fmap fromIntegral . getWord64N1 hnd + (8, 2) -> fmap fromIntegral . getWord64N2 hnd + (8, 4) -> fmap fromIntegral . getWord64N4 hnd + (8, 8) -> fmap fromIntegral . getWord64N8 hnd + (8, 16) -> fmap fromIntegral . getWord64N16 hnd + +getWord8N1 hnd = loop 0 + where loop s n | s `seq` n `seq` False = undefined + loop s 0 = return s + loop s n = do + s0 <- getWord8 hnd + loop (s+s0) (n-1) + +getWord8N2 hnd = loop 0 + where loop s n | s `seq` n `seq` False = undefined + loop s 0 = return s + loop s n = do + s0 <- getWord8 hnd + s1 <- getWord8 hnd + loop (s+s0+s1) (n-2) + +getWord8N4 hnd = loop 0 + where loop s n | s `seq` n `seq` False = undefined + loop s 0 = return s + loop s n = do + s0 <- getWord8 hnd + s1 <- getWord8 hnd + s2 <- getWord8 hnd + s3 <- getWord8 hnd + loop (s+s0+s1+s2+s3) (n-4) + +getWord8N8 hnd = loop 0 + where loop s n | s `seq` n `seq` False = undefined + loop s 0 = return s + loop s n = do + s0 <- getWord8 hnd + s1 <- getWord8 hnd + s2 <- getWord8 hnd + s3 <- getWord8 hnd + s4 <- getWord8 hnd + s5 <- getWord8 hnd + s6 <- getWord8 hnd + s7 <- getWord8 hnd + loop (s+s0+s1+s2+s3+s4+s5+s6+s7) (n-8) + +getWord8N16 hnd = loop 0 + where loop s n | s `seq` n `seq` False = undefined + loop s 0 = return s + loop s n = do + s0 <- getWord8 hnd + s1 <- getWord8 hnd + s2 <- getWord8 hnd + s3 <- getWord8 hnd + s4 <- getWord8 hnd + s5 <- getWord8 hnd + s6 <- getWord8 hnd + s7 <- getWord8 hnd + s8 <- getWord8 hnd + s9 <- getWord8 hnd + s10 <- getWord8 hnd + s11 <- getWord8 hnd + s12 <- getWord8 hnd + s13 <- getWord8 hnd + s14 <- getWord8 hnd + s15 <- getWord8 hnd + loop (s+s0+s1+s2+s3+s4+s5+s6+s7+s9+s10+s11+s12+s13+s14+s15) (n-16) + + +getWord16N1 hnd = loop 0 + where loop s n | s `seq` n `seq` False = undefined + loop s 0 = return s + loop s n = do + s0 <- getWord16be hnd + loop (s+s0) (n-1) + +getWord16N2 hnd = loop 0 + where loop s n | s `seq` n `seq` False = undefined + loop s 0 = return s + loop s n = do + s0 <- getWord16be hnd + s1 <- getWord16be hnd + loop (s+s0+s1) (n-2) + +getWord16N4 hnd = loop 0 + where loop s n | s `seq` n `seq` False = undefined + loop s 0 = return s + loop s n = do + s0 <- getWord16be hnd + s1 <- getWord16be hnd + s2 <- getWord16be hnd + s3 <- getWord16be hnd + loop (s+s0+s1+s2+s3) (n-4) + +getWord16N8 hnd = loop 0 + where loop s n | s `seq` n `seq` False = undefined + loop s 0 = return s + loop s n = do + s0 <- getWord16be hnd + s1 <- getWord16be hnd + s2 <- getWord16be hnd + s3 <- getWord16be hnd + s4 <- getWord16be hnd + s5 <- getWord16be hnd + s6 <- getWord16be hnd + s7 <- getWord16be hnd + loop (s+s0+s1+s2+s3+s4+s5+s6+s7) (n-8) + +getWord16N16 hnd = loop 0 + where loop s n | s `seq` n `seq` False = undefined + loop s 0 = return s + loop s n = do + s0 <- getWord16be hnd + s1 <- getWord16be hnd + s2 <- getWord16be hnd + s3 <- getWord16be hnd + s4 <- getWord16be hnd + s5 <- getWord16be hnd + s6 <- getWord16be hnd + s7 <- getWord16be hnd + s8 <- getWord16be hnd + s9 <- getWord16be hnd + s10 <- getWord16be hnd + s11 <- getWord16be hnd + s12 <- getWord16be hnd + s13 <- getWord16be hnd + s14 <- getWord16be hnd + s15 <- getWord16be hnd + loop (s+s0+s1+s2+s3+s4+s5+s6+s7+s9+s10+s11+s12+s13+s14+s15) (n-16) + + +getWord32N1 hnd = loop 0 + where loop s n | s `seq` n `seq` False = undefined + loop s 0 = return s + loop s n = do + s0 <- getWord32be hnd + loop (s+s0) (n-1) + +getWord32N2 hnd = loop 0 + where loop s n | s `seq` n `seq` False = undefined + loop s 0 = return s + loop s n = do + s0 <- getWord32be hnd + s1 <- getWord32be hnd + loop (s+s0+s1) (n-2) + +getWord32N4 hnd = loop 0 + where loop s n | s `seq` n `seq` False = undefined + loop s 0 = return s + loop s n = do + s0 <- getWord32be hnd + s1 <- getWord32be hnd + s2 <- getWord32be hnd + s3 <- getWord32be hnd + loop (s+s0+s1+s2+s3) (n-4) + +getWord32N8 hnd = loop 0 + where loop s n | s `seq` n `seq` False = undefined + loop s 0 = return s + loop s n = do + s0 <- getWord32be hnd + s1 <- getWord32be hnd + s2 <- getWord32be hnd + s3 <- getWord32be hnd + s4 <- getWord32be hnd + s5 <- getWord32be hnd + s6 <- getWord32be hnd + s7 <- getWord32be hnd + loop (s+s0+s1+s2+s3+s4+s5+s6+s7) (n-8) + +getWord32N16 hnd = loop 0 + where loop s n | s `seq` n `seq` False = undefined + loop s 0 = return s + loop s n = do + s0 <- getWord32be hnd + s1 <- getWord32be hnd + s2 <- getWord32be hnd + s3 <- getWord32be hnd + s4 <- getWord32be hnd + s5 <- getWord32be hnd + s6 <- getWord32be hnd + s7 <- getWord32be hnd + s8 <- getWord32be hnd + s9 <- getWord32be hnd + s10 <- getWord32be hnd + s11 <- getWord32be hnd + s12 <- getWord32be hnd + s13 <- getWord32be hnd + s14 <- getWord32be hnd + s15 <- getWord32be hnd + loop (s+s0+s1+s2+s3+s4+s5+s6+s7+s9+s10+s11+s12+s13+s14+s15) (n-16) + +getWord64N1 hnd = loop 0 + where loop s n | s `seq` n `seq` False = undefined + loop s 0 = return s + loop s n = do + s0 <- getWord64be hnd + loop (s+s0) (n-1) + +getWord64N2 hnd = loop 0 + where loop s n | s `seq` n `seq` False = undefined + loop s 0 = return s + loop s n = do + s0 <- getWord64be hnd + s1 <- getWord64be hnd + loop (s+s0+s1) (n-2) + +getWord64N4 hnd = loop 0 + where loop s n | s `seq` n `seq` False = undefined + loop s 0 = return s + loop s n = do + s0 <- getWord64be hnd + s1 <- getWord64be hnd + s2 <- getWord64be hnd + s3 <- getWord64be hnd + loop (s+s0+s1+s2+s3) (n-4) + +getWord64N8 hnd = loop 0 + where loop s n | s `seq` n `seq` False = undefined + loop s 0 = return s + loop s n = do + s0 <- getWord64be hnd + s1 <- getWord64be hnd + s2 <- getWord64be hnd + s3 <- getWord64be hnd + s4 <- getWord64be hnd + s5 <- getWord64be hnd + s6 <- getWord64be hnd + s7 <- getWord64be hnd + loop (s+s0+s1+s2+s3+s4+s5+s6+s7) (n-8) + +getWord64N16 hnd = loop 0 + where loop s n | s `seq` n `seq` False = undefined + loop s 0 = return s + loop s n = do + s0 <- getWord64be hnd + s1 <- getWord64be hnd + s2 <- getWord64be hnd + s3 <- getWord64be hnd + s4 <- getWord64be hnd + s5 <- getWord64be hnd + s6 <- getWord64be hnd + s7 <- getWord64be hnd + s8 <- getWord64be hnd + s9 <- getWord64be hnd + s10 <- getWord64be hnd + s11 <- getWord64be hnd + s12 <- getWord64be hnd + s13 <- getWord64be hnd + s14 <- getWord64be hnd + s15 <- getWord64be hnd + loop (s+s0+s1+s2+s3+s4+s5+s6+s7+s9+s10+s11+s12+s13+s14+s15) (n-16) diff --git a/tests/NewBinary.hs b/tests/NewBinary.hs new file mode 100644 --- /dev/null +++ b/tests/NewBinary.hs @@ -0,0 +1,1006 @@ +{-# OPTIONS -cpp -fglasgow-exts #-} +-- +-- (c) The University of Glasgow 2002 +-- +-- Binary I/O library, with special tweaks for GHC +-- +-- Based on the nhc98 Binary library, which is copyright +-- (c) Malcolm Wallace and Colin Runciman, University of York, 1998. +-- Under the terms of the license for that software, we must tell you +-- where you can obtain the original version of the Binary library, namely +-- http://www.cs.york.ac.uk/fp/nhc98/ + +module NewBinary + ( {-type-} Bin, + {-class-} Binary(..), + {-type-} BinHandle(..), + + openBinIO, + openBinIO_, + openBinMem, +-- closeBin, + +-- getUserData, + + seekBin, + tellBin, + tellBinByte, + castBin, + + writeBinMem, + readBinMem, + + isEOFBin, + + -- for writing instances: + putByte, + getByte, + + -- bit stuff + putBits, + getBits, + flushByte, + finishByte, + putMaybeInt, + getMaybeInt, + + -- lazy Bin I/O + lazyGet, + lazyPut, + + -- GHC only: + ByteArray(..), + getByteArray, + putByteArray, + +-- getBinFileWithDict, -- :: Binary a => FilePath -> IO a +-- putBinFileWithDict, -- :: Binary a => FilePath -> Module -> a -> IO () + + ) where + +#include "MachDeps.h" + +import GHC.Exts +import GHC.IOBase +import GHC.Real +import Data.Array.IO ( IOUArray ) +import Data.Bits +import Data.Int +import Data.Word +import Data.Char +import Control.Monad +import Control.Exception +import Data.Array +import Data.Array.IO +import Data.Array.Base +import System.IO as IO +import System.IO.Error ( mkIOError, eofErrorType ) +import GHC.Handle +import System.IO + +import GHC.Exts +#if __GLASGOW_HASKELL__ >= 504 +import GHC.IOBase +import Data.Word +import Data.Bits +#else +import PrelIOBase +import Word +import Bits +#endif + +#ifndef SIZEOF_HSINT +#define SIZEOF_HSINT INT_SIZE_IN_BYTES +#endif + +#if __GLASGOW_HASKELL__ < 503 +type BinArray = MutableByteArray RealWorld Int +newArray_ bounds = stToIO (newCharArray bounds) +unsafeWrite arr ix e = stToIO (writeWord8Array arr ix e) +unsafeRead arr ix = stToIO (readWord8Array arr ix) + +hPutArray h arr sz = hPutBufBA h arr sz +hGetArray h sz = hGetBufBA h sz + +mkIOError :: IOErrorType -> String -> Maybe Handle -> Maybe FilePath -> Exception +mkIOError t location maybe_hdl maybe_filename + = IOException (IOError maybe_hdl t location "" + maybe_filename + ) + +eofErrorType = EOF + +#ifndef SIZEOF_HSINT +#define SIZEOF_HSINT INT_SIZE_IN_BYTES +#endif + +#ifndef SIZEOF_HSWORD +#define SIZEOF_HSWORD WORD_SIZE_IN_BYTES +#endif + +#else +type BinArray = IOUArray Int Word8 +#endif + +data BinHandle + = BinMem { -- binary data stored in an unboxed array + off_r :: !FastMutInt, -- the current offset + sz_r :: !FastMutInt, -- size of the array (cached) + arr_r :: !(IORef BinArray), -- the array (bounds: (0,size-1)) + bit_off_r :: !FastMutInt, -- the bit offset (see end of file) + bit_cache_r :: !FastMutInt -- the bit cache (see end of file) + } + -- XXX: should really store a "high water mark" for dumping out + -- the binary data to a file. + + | BinIO { -- binary data stored in a file + off_r :: !FastMutInt, -- the current offset (cached) + hdl :: !IO.Handle, -- the file handle (must be seekable) + bit_off_r :: !FastMutInt, -- the bit offset (see end of file) + bit_cache_r :: !FastMutInt -- the bit cache (see end of file) + } + -- cache the file ptr in BinIO; using hTell is too expensive + -- to call repeatedly. If anyone else is modifying this Handle + -- at the same time, we'll be screwed. + +data Bin a = BinPtr !Int !Int -- byte/bit + deriving (Eq, Ord, Show, Bounded) + +castBin :: Bin a -> Bin b +castBin (BinPtr i j) = BinPtr i j + +class Binary a where + put_ :: BinHandle -> a -> IO () + put :: BinHandle -> a -> IO (Bin a) + get :: BinHandle -> IO a + + -- define one of put_, put. Use of put_ is recommended because it + -- is more likely that tail-calls can kick in, and we rarely need the + -- position return value. + put_ bh a = do put bh a; return () + put bh a = do p <- tellBin bh; put_ bh a; return p + +putAt :: Binary a => BinHandle -> Bin a -> a -> IO () +putAt bh p x = do seekBin bh p; put bh x; return () + +getAt :: Binary a => BinHandle -> Bin a -> IO a +getAt bh p = do seekBin bh p; get bh + +openBinIO_ :: IO.Handle -> IO BinHandle +openBinIO_ h = openBinIO h noBinHandleUserData + +newZeroInt = do r <- newFastMutInt; writeFastMutInt r 0; return r + +-- openBinIO :: IO.Handle -> Module -> IO BinHandle +openBinIO :: forall t. Handle -> t -> IO BinHandle +openBinIO h mod = do + r <- newZeroInt + o <- newZeroInt + c <- newZeroInt +-- state <- newWriteState mod + return (BinIO r h o c) + +--openBinMem :: Int -> Module -> IO BinHandle +openBinMem :: forall t. Int -> t -> IO BinHandle +openBinMem size mod + | size <= 0 = error "Data.Binary.openBinMem: size must be > 0" -- fix, was ">= 0" + | otherwise = do + arr <- newArray_ (0,size-1) + arr_r <- newIORef arr + ix_r <- newFastMutInt + writeFastMutInt ix_r 0 + sz_r <- newFastMutInt + writeFastMutInt sz_r size + o <- newZeroInt + c <- newZeroInt +-- state <- newWriteState mod + return (BinMem ix_r sz_r arr_r o c) + +noBinHandleUserData = error "Binary.BinHandle: no user data" + +--getUserData :: BinHandle -> BinHandleState +--getUserData bh = state bh + +tellBin :: BinHandle -> IO (Bin a) +tellBin (BinIO r _ o _) = do ix <- readFastMutInt r; bix <- readFastMutInt o; return (BinPtr ix bix) +tellBin (BinMem r _ _ o _) = do ix <- readFastMutInt r; bix <- readFastMutInt o; return (BinPtr ix bix) + +tellBinByte (BinIO r _ _ _) = do ix <- readFastMutInt r; return ix +tellBinByte (BinMem r _ _ _ _) = do ix <- readFastMutInt r; return ix + +seekBin :: BinHandle -> Bin a -> IO () +seekBin bh@(BinIO ix_r h o c) (BinPtr p bit) = do + writeFastMutInt ix_r p + writeFastMutInt o 0 + writeFastMutInt c 0 + hSeek h AbsoluteSeek (fromIntegral p) + when (bit /= 0) $ getBits bh bit >> return () + return () +seekBin h@(BinMem ix_r sz_r a o c) (BinPtr p bit) = do + sz <- readFastMutInt sz_r + if (p >= sz) + then do expandBin h p + writeFastMutInt ix_r p + writeFastMutInt o 0 + writeFastMutInt c 0 + when (bit /= 0) $ getBits h bit >> return () + return () + + else do writeFastMutInt ix_r p + writeFastMutInt o 0 + writeFastMutInt c 0 + when (bit /= 0) $ getBits h bit >> return () + return () + +isEOFBin :: BinHandle -> IO Bool +isEOFBin (BinMem ix_r sz_r a _ _) = do + ix <- readFastMutInt ix_r + sz <- readFastMutInt sz_r + return (ix >= sz) +isEOFBin (BinIO ix_r h _ _) = hIsEOF h + +writeBinMem :: BinHandle -> FilePath -> IO () +writeBinMem (BinIO _ _ _ _) _ = error "Data.Binary.writeBinMem: not a memory handle" +writeBinMem bh@(BinMem ix_r sz_r arr_r bit_off_r bit_cache_r) fn = do + flushByte bh + h <- openBinaryFile fn WriteMode + arr <- readIORef arr_r + ix <- readFastMutInt ix_r + hPutArray h arr ix + hClose h + +flushByte :: BinHandle -> IO () +flushByte bh = do + bit_off <- readFastMutInt (bit_off_r bh) + if bit_off == 0 + then return () + else putBits bh (8 - bit_off) 0 + +finishByte :: BinHandle -> IO () +finishByte bh = do + bit_off <- readFastMutInt (bit_off_r bh) + if bit_off == 0 + then return () + else getBits bh (8 - bit_off) >> return () + +readBinMem :: FilePath -> IO BinHandle +readBinMem filename = do + h <- openBinaryFile filename ReadMode + filesize' <- hFileSize h + let filesize = fromIntegral filesize' + arr <- newArray_ (0,filesize-1) + count <- hGetArray h arr filesize + when (count /= filesize) + (error ("Binary.readBinMem: only read " ++ show count ++ " bytes")) + hClose h + arr_r <- newIORef arr + ix_r <- newFastMutInt + writeFastMutInt ix_r 0 + sz_r <- newFastMutInt + writeFastMutInt sz_r filesize + bit_off_r <- newZeroInt + bit_cache_r <- newZeroInt + return (BinMem {-initReadState-} ix_r sz_r arr_r bit_off_r bit_cache_r) + +-- expand the size of the array to include a specified offset +expandBin :: BinHandle -> Int -> IO () +expandBin (BinMem ix_r sz_r arr_r _ _) off = do + sz <- readFastMutInt sz_r + let sz' = head (dropWhile (<= off) (iterate (* 2) sz)) + arr <- readIORef arr_r + arr' <- newArray_ (0,sz'-1) + sequence_ [ unsafeRead arr i >>= unsafeWrite arr' i + | i <- [ 0 .. sz-1 ] ] + writeFastMutInt sz_r sz' + writeIORef arr_r arr' +-- hPutStrLn stderr ("expanding to size: " ++ show sz') + return () +expandBin (BinIO _ _ _ _) _ = return () + -- no need to expand a file, we'll assume they expand by themselves. + +-- ----------------------------------------------------------------------------- +-- Low-level reading/writing of bytes + +putWord8 :: BinHandle -> Word8 -> IO () +putWord8 h@(BinMem ix_r sz_r arr_r bit_off_r bit_cache_r) w = do + bit_off <- readFastMutInt bit_off_r + if bit_off /= 0 then putBits h 8 w else do -- only do standard putWord8 if bit_off == 0 + ix <- readFastMutInt ix_r + sz <- readFastMutInt sz_r + -- double the size of the array if it overflows + if (ix >= sz) + then do expandBin h ix + putWord8 h w + else do arr <- readIORef arr_r + unsafeWrite arr ix w + writeFastMutInt ix_r (ix+1) + return () + +putWord8 bh@(BinIO ix_r h bit_off_r bit_cache_r) w = do + bit_off <- readFastMutInt bit_off_r + if bit_off /= 0 then putBits bh 8 w else do + ix <- readFastMutInt ix_r + hPutChar h (chr (fromIntegral w)) -- XXX not really correct + writeFastMutInt ix_r (ix+1) + return () + +putByteNoBits :: BinHandle -> Word8 -> IO () +putByteNoBits h@(BinMem ix_r sz_r arr_r _ _) w = do + ix <- readFastMutInt ix_r + sz <- readFastMutInt sz_r + -- double the size of the array if it overflows + if (ix >= sz) + then do expandBin h ix + putByteNoBits h w + else do arr <- readIORef arr_r + unsafeWrite arr ix w + writeFastMutInt ix_r (ix+1) + return () + +putByteNoBits bh@(BinIO ix_r h _ _) w = do + hPutChar h (chr (fromIntegral w)) -- XXX not really correct + incFastMutInt ix_r + return () + +getByteNoBits :: BinHandle -> IO Word8 +getByteNoBits h@(BinMem ix_r sz_r arr_r _ _) = do + ix <- readFastMutInt ix_r + sz <- readFastMutInt sz_r + when (ix >= sz) $ + throw (IOException $ mkIOError eofErrorType "Data.Binary.getWord8" Nothing Nothing) + arr <- readIORef arr_r + w <- unsafeRead arr ix + writeFastMutInt ix_r (ix+1) + return w + +getByteNoBits bh@(BinIO ix_r h _ _) = do + c <- hGetChar h + incFastMutInt ix_r + return $! (fromIntegral (ord c)) -- XXX not really correct + +getWord8 :: BinHandle -> IO Word8 +getWord8 h@(BinMem ix_r sz_r arr_r bit_off_r _) = do + bit_off <- readFastMutInt bit_off_r + if bit_off /= 0 then getBits h 8 else do + ix <- readFastMutInt ix_r + sz <- readFastMutInt sz_r + when (ix >= sz) $ + throw (IOException $ mkIOError eofErrorType "Data.Binary.getWord8" Nothing Nothing) + arr <- readIORef arr_r + w <- unsafeRead arr ix + writeFastMutInt ix_r (ix+1) + return w +getWord8 bh@(BinIO ix_r h bit_off_r _) = do + bit_off <- readFastMutInt bit_off_r + if bit_off /= 0 then getBits bh 8 else do + ix <- readFastMutInt ix_r + c <- hGetChar h + writeFastMutInt ix_r (ix+1) + return $! (fromIntegral (ord c)) -- XXX not really correct + +putByte :: BinHandle -> Word8 -> IO () +putByte bh w = put_ bh w + +getByte :: BinHandle -> IO Word8 +getByte = getWord8 + +-- ----------------------------------------------------------------------------- +-- Bit functions + +putBits :: BinHandle -> Int -> Word8 -> IO () +putBits bh num_bits bits {- | num_bits == 0 = return () + | num_bits < 0 = error "putBits cannot write negative numbers of bits" + | num_bits > 8 = error "putBits cannot write more than 8 bits at a time" + | otherwise -} = do + bit_off <- readFastMutInt (bit_off_r bh) + if num_bits + bit_off < 8 + then do incFastMutIntBy (bit_off_r bh) num_bits + orFastMutInt (bit_cache_r bh) (bits `shiftL` bit_off) + else if num_bits + bit_off == 8 + then do writeFastMutInt (bit_off_r bh) 0 + bit_cache <- {-# SCC "bc1" #-} readFastMutInt (bit_cache_r bh) >>= return . fromIntegral + writeFastMutInt (bit_cache_r bh) 0 + --putByte bh (bit_cache .|. (bits `shiftL` bit_off)) -- won't call putBits because bit_off_r == 0 + putByteNoBits bh (bit_cache .|. (bits `shiftL` bit_off)) + + else do let leftover_bits = 8 - bit_off -- we are going over a byte boundary + bit_cache <- {-# SCC "bc2" #-} readFastMutInt (bit_cache_r bh) >>= \x -> return ({-# SCC "fi" #-} fromIntegral x) + writeFastMutInt (bit_off_r bh) 0 + writeFastMutInt (bit_cache_r bh) 0 + {- putByte bh (bit_cache .|. (bits `shiftL` bit_off)) -} -- won't call putBits + putByteNoBits bh (bit_cache .|. (bits `shiftL` bit_off)) + putBits bh (num_bits - leftover_bits) (bits `shiftR` leftover_bits) + +getBits :: BinHandle -> Int -> IO Word8 +getBits bh num_bits {- | num_bits == 0 = return 0 + | num_bits < 0 = error "getBits cannot read negative numbers of bits" + | num_bits > 8 = error "getBits cannot read more than 8 bits at a time" + | otherwise -} = do + bit_off <- readFastMutInt (bit_off_r bh) + if bit_off == 0 + then do bit_cache <- getByte bh + if num_bits == 8 + then do writeFastMutInt (bit_off_r bh) 0 + writeFastMutInt (bit_cache_r bh) 0 + return bit_cache + else do writeFastMutInt (bit_off_r bh) (fromIntegral num_bits) + writeFastMutInt (bit_cache_r bh) (fromIntegral bit_cache) + return (bit_cache .&. bit_mask num_bits) + else if bit_off + num_bits < 8 + then do incFastMutIntBy (bit_off_r bh) num_bits + bit_cache <- readFastMutInt (bit_cache_r bh) >>= return . fromIntegral + return ((bit_cache `shiftR` bit_off) .&. bit_mask num_bits) + else if bit_off + num_bits == 8 + then do writeFastMutInt (bit_off_r bh) 0 + bit_cache <- readFastMutInt (bit_cache_r bh) >>= return . fromIntegral + writeFastMutInt (bit_cache_r bh) 0 + return ((bit_cache `shiftR` bit_off) .&. bit_mask num_bits) + else do let leftover_bits = 8 - bit_off + bit_cache <- readFastMutInt (bit_cache_r bh) >>= return . fromIntegral + let bits = (bit_cache `shiftR` bit_off) .&. bit_mask leftover_bits + writeFastMutInt (bit_cache_r bh) 0 + writeFastMutInt (bit_off_r bh) 0 + {- bit_cache <- getByte bh -} + -- use a version that doesn't care about bits + bit_cache <- getByteNoBits bh + writeFastMutInt (bit_off_r bh) (num_bits - leftover_bits) + writeFastMutInt (bit_cache_r bh) (fromIntegral bit_cache) + return (bits .|. ((bit_cache .&. bit_mask (num_bits - leftover_bits)) `shiftL` leftover_bits)) + + +bit_mask n = (complement 0) `shiftR` (8 - n) + +-- ----------------------------------------------------------------------------- +-- Primitve Word writes + +instance Binary Word8 where + put_ = putWord8 + get = getWord8 + +instance Binary Word16 where + put_ h w = do -- XXX too slow.. inline putWord8? + putByte h (fromIntegral (w `shiftR` 8)) + putByte h (fromIntegral (w .&. 0xff)) + get h = do + w1 <- getWord8 h + w2 <- getWord8 h + return $! ((fromIntegral w1 `shiftL` 8) .|. fromIntegral w2) + + +instance Binary Word32 where + put_ h w = do + putByte h (fromIntegral (w `shiftR` 24)) + putByte h (fromIntegral ((w `shiftR` 16) .&. 0xff)) + putByte h (fromIntegral ((w `shiftR` 8) .&. 0xff)) + putByte h (fromIntegral (w .&. 0xff)) + get h = do + w1 <- getWord8 h + w2 <- getWord8 h + w3 <- getWord8 h + w4 <- getWord8 h + return $! ((fromIntegral w1 `shiftL` 24) .|. + (fromIntegral w2 `shiftL` 16) .|. + (fromIntegral w3 `shiftL` 8) .|. + (fromIntegral w4)) + + +instance Binary Word64 where + put_ h w = do + putByte h (fromIntegral (w `shiftR` 56)) + putByte h (fromIntegral ((w `shiftR` 48) .&. 0xff)) + putByte h (fromIntegral ((w `shiftR` 40) .&. 0xff)) + putByte h (fromIntegral ((w `shiftR` 32) .&. 0xff)) + putByte h (fromIntegral ((w `shiftR` 24) .&. 0xff)) + putByte h (fromIntegral ((w `shiftR` 16) .&. 0xff)) + putByte h (fromIntegral ((w `shiftR` 8) .&. 0xff)) + putByte h (fromIntegral (w .&. 0xff)) + get h = do + w1 <- getWord8 h + w2 <- getWord8 h + w3 <- getWord8 h + w4 <- getWord8 h + w5 <- getWord8 h + w6 <- getWord8 h + w7 <- getWord8 h + w8 <- getWord8 h + return $! ((fromIntegral w1 `shiftL` 56) .|. + (fromIntegral w2 `shiftL` 48) .|. + (fromIntegral w3 `shiftL` 40) .|. + (fromIntegral w4 `shiftL` 32) .|. + (fromIntegral w5 `shiftL` 24) .|. + (fromIntegral w6 `shiftL` 16) .|. + (fromIntegral w7 `shiftL` 8) .|. + (fromIntegral w8)) + +-- ----------------------------------------------------------------------------- +-- Primitve Int writes + +instance Binary Int8 where + put_ h w = put_ h (fromIntegral w :: Word8) + get h = do w <- get h; return $! (fromIntegral (w::Word8)) + +instance Binary Int16 where + put_ h w = put_ h (fromIntegral w :: Word16) + get h = do w <- get h; return $! (fromIntegral (w::Word16)) + +instance Binary Int32 where + put_ h w = put_ h (fromIntegral w :: Word32) + get h = do w <- get h; return $! (fromIntegral (w::Word32)) + +put31ofInt32 :: BinHandle -> Int32 -> IO () +put31ofInt32 h i = do + putBits h 7 (fromIntegral (w `shiftR` 24)) + putBits h 8 (fromIntegral ((w `shiftR` 16) .&. 0xff)) + putBits h 8 (fromIntegral ((w `shiftR` 8) .&. 0xff)) + putBits h 8 (fromIntegral (w .&. 0xff)) + where w = fromIntegral i :: Word32 + +get31ofInt32 :: BinHandle -> IO Int32 +get31ofInt32 h = do + w1 <- getBits h 7 + w2 <- getWord8 h + w3 <- getWord8 h + w4 <- getWord8 h + return $! ((fromIntegral w1 `shiftL` 24) .|. + (fromIntegral w2 `shiftL` 16) .|. + (fromIntegral w3 `shiftL` 8) .|. + (fromIntegral w4)) + +instance Binary Int64 where + put_ h w = put_ h (fromIntegral w :: Word64) + get h = do w <- get h; return $! (fromIntegral (w::Word64)) + +-- ----------------------------------------------------------------------------- +-- Instances for standard types + +instance Binary () where + put_ bh () = return () + get _ = return () +-- getF bh p = case getBitsF bh 0 p of (_,b) -> ((),b) + +{- updated for bits +instance Binary Bool where + put_ bh b = putByte bh (fromIntegral (fromEnum b)) + get bh = do x <- getWord8 bh; return $! (toEnum (fromIntegral x)) +-- getF bh p = case getBitsF bh 1 p of (x,b) -> (toEnum x,b) +-} + +instance Binary Bool where + put_ bh True = putBits bh 1 1 + put_ bh False = putBits bh 1 0 + get bh = do b <- getBits bh 1; return (b == 1) + +instance Binary Char where + put_ bh c = put_ bh (fromIntegral (ord c) :: Word32) + get bh = do x <- get bh; return $! (chr (fromIntegral (x :: Word32))) +-- getF bh p = case getBitsF bh 8 p of (x,b) -> (toEnum x,b) + +instance Binary Int where +#if SIZEOF_HSINT == 4 + put_ bh i = put_ bh (fromIntegral i :: Int32) + get bh = do + x <- get bh + return $! (fromIntegral (x :: Int32)) +#elif SIZEOF_HSINT == 8 + put_ bh i = put_ bh (fromIntegral i :: Int64) + get bh = do + x <- get bh + return $! (fromIntegral (x :: Int64)) +#else +#error "unsupported sizeof(HsInt)" +#endif +-- getF bh = getBitsF bh 32 + +{- +instance Binary a => Binary [a] where + put_ bh [] = putByte bh 0 + put_ bh (x:xs) = do putByte bh 1; put_ bh x; put_ bh xs + get bh = do h <- getWord8 bh + case h of + 0 -> return [] + _ -> do x <- get bh + xs <- get bh + return (x:xs) +-} + +instance Binary a => Binary [a] where + put_ bh l = do + put_ bh (length l) + mapM (put_ bh) l + return () + get bh = do + len <- get bh + mapM (\_ -> get bh) [1..(len::Int)] + +instance (Binary a, Binary b) => Binary (a,b) where + put_ bh (a,b) = do put_ bh a; put_ bh b + get bh = do a <- get bh + b <- get bh + return (a,b) + +instance (Binary a, Binary b, Binary c) => Binary (a,b,c) where + put_ bh (a,b,c) = do put_ bh a; put_ bh b; put_ bh c + get bh = do a <- get bh + b <- get bh + c <- get bh + return (a,b,c) + +instance (Binary a, Binary b, Binary c, Binary d) => Binary (a,b,c,d) where + put_ bh (a,b,c,d) = do put_ bh a; put_ bh b; put_ bh c; put_ bh d + get bh = do a <- get bh + b <- get bh + c <- get bh + d <- get bh + return (a,b,c,d) + +instance (Binary a, Binary b, Binary c, Binary d, Binary e) => Binary (a,b,c,d,e) where + put_ bh (a,b,c,d,e) = do put_ bh a; put_ bh b; put_ bh c; put_ bh d; put_ bh e + get bh = do a <- get bh + b <- get bh + c <- get bh + d <- get bh + e <- get bh + return (a,b,c,d,e) + +instance (Binary a, Binary b, Binary c, Binary d, Binary e, Binary f) => Binary (a,b,c,d,e,f) where + put_ bh (a,b,c,d,e,f) = do put_ bh a; put_ bh b; put_ bh c; put_ bh d; put_ bh e; put_ bh f + get bh = do a <- get bh + b <- get bh + c <- get bh + d <- get bh + e <- get bh + f <- get bh + return (a,b,c,d,e,f) + +instance Binary a => Binary (Maybe a) where + put_ bh Nothing = putByte bh 0 + put_ bh (Just a) = do putByte bh 1; put_ bh a + get bh = do h <- getWord8 bh + case h of + 0 -> return Nothing + _ -> do x <- get bh; return (Just x) + +putMaybeInt :: BinHandle -> Maybe Int -> IO () +getMaybeInt :: BinHandle -> IO (Maybe Int) +putMaybeInt bh Nothing = putBits bh 1 0 +putMaybeInt bh (Just i) = do putBits bh 1 1; put31ofInt32 bh (fromIntegral i) + +getMaybeInt bh = do + b <- getBits bh 1 + case b of + 0 -> return Nothing + _ -> do i <- get31ofInt32 bh + return (Just (fromIntegral i)) + +{- RULES get = getMaybeInt -} + +{- SPECIALIZE put_ :: BinHandle -> Maybe Int -> IO () = putMaybeInt -} +{- SPECIALIZE get :: BinHandle -> IO (Maybe Int) = getMaybeInt -} + + +instance (Binary a, Binary b) => Binary (Either a b) where + put_ bh (Left a) = do putByte bh 0; put_ bh a + put_ bh (Right b) = do putByte bh 1; put_ bh b + get bh = do h <- getWord8 bh + case h of + 0 -> do a <- get bh ; return (Left a) + _ -> do b <- get bh ; return (Right b) + +instance Binary Integer where + put_ bh (S# i#) = do putByte bh 0; put_ bh (I# i#) + put_ bh (J# s# a#) = do + p <- putByte bh 1; + put_ bh (I# s#) + let sz# = sizeofByteArray# a# -- in *bytes* + put_ bh (I# sz#) -- in *bytes* + putByteArray bh a# sz# + + get bh = do + b <- getByte bh + case b of + 0 -> do (I# i#) <- get bh + return (S# i#) + _ -> do (I# s#) <- get bh + sz <- get bh + (BA a#) <- getByteArray bh sz + return (J# s# a#) + +putByteArray :: BinHandle -> ByteArray# -> Int# -> IO () +putByteArray bh a s# = loop 0# + where loop n# + | n# ==# s# = return () + | otherwise = do + putByte bh (indexByteArray a n#) + loop (n# +# 1#) + +getByteArray :: BinHandle -> Int -> IO ByteArray +getByteArray bh (I# sz) = do + (MBA arr) <- newByteArray sz + let loop n + | n ==# sz = return () + | otherwise = do + w <- getByte bh + writeByteArray arr n w + loop (n +# 1#) + loop 0# + freezeByteArray arr + + +data ByteArray = BA ByteArray# +data MBA = MBA (MutableByteArray# RealWorld) + +newByteArray :: Int# -> IO MBA +newByteArray sz = IO $ \s -> + case newByteArray# sz s of { (# s, arr #) -> + (# s, MBA arr #) } + +freezeByteArray :: MutableByteArray# RealWorld -> IO ByteArray +freezeByteArray arr = IO $ \s -> + case unsafeFreezeByteArray# arr s of { (# s, arr #) -> + (# s, BA arr #) } + +writeByteArray :: MutableByteArray# RealWorld -> Int# -> Word8 -> IO () + +writeByteArray arr i w8 = IO $ \s -> + case fromIntegral w8 of { W# w# -> + case writeCharArray# arr i (chr# (word2Int# w#)) s of { s -> + (# s , () #) }} + +indexByteArray a# n# = fromIntegral (I# (ord# (indexCharArray# a# n#))) + +instance (Integral a, Binary a) => Binary (Ratio a) where + put_ bh (a :% b) = do put_ bh a; put_ bh b + get bh = do a <- get bh; b <- get bh; return (a :% b) + +instance Binary (Bin a) where + put_ bh (BinPtr i j) = put_ bh (i,j) + get bh = do (i,j) <- get bh; return (BinPtr i j) + +-- ----------------------------------------------------------------------------- +-- Lazy reading/writing + +lazyPut :: Binary a => BinHandle -> a -> IO () +lazyPut bh a = do + -- output the obj with a ptr to skip over it: + pre_a <- tellBin bh + put_ bh pre_a -- save a slot for the ptr + put_ bh a -- dump the object + q <- tellBin bh -- q = ptr to after object + putAt bh pre_a q -- fill in slot before a with ptr to q + seekBin bh q -- finally carry on writing at q + +lazyGet :: Binary a => BinHandle -> IO a +lazyGet bh = do + p <- get bh -- a BinPtr + p_a <- tellBin bh + a <- unsafeInterleaveIO (getAt bh p_a) + seekBin bh p -- skip over the object for now + return a + +-- ----------------------------------------------------------------------------- +-- BinHandleState +{- +type BinHandleState = + (Module, + IORef Int, + IORef (UniqFM (Int,FastString)), + Array Int FastString) + +initReadState :: BinHandleState +initReadState = (undef, undef, undef, undef) + +newWriteState :: Module -> IO BinHandleState +newWriteState m = do + j_r <- newIORef 0 + out_r <- newIORef emptyUFM + return (m,j_r,out_r,undef) + +undef = error "Binary.BinHandleState" + +-- ----------------------------------------------------------------------------- +-- FastString binary interface + +getBinFileWithDict :: Binary a => FilePath -> IO a +getBinFileWithDict file_path = do + bh <- Binary.readBinMem file_path + magic <- get bh + when (magic /= binaryInterfaceMagic) $ + throwDyn (ProgramError ( + "magic number mismatch: old/corrupt interface file?")) + dict_p <- Binary.get bh -- get the dictionary ptr + data_p <- tellBin bh + seekBin bh dict_p + dict <- getDictionary bh + seekBin bh data_p + let (mod, j_r, out_r, _) = state bh + get bh{ state = (mod,j_r,out_r,dict) } + +initBinMemSize = (1024*1024) :: Int + +binaryInterfaceMagic = 0x1face :: Word32 + +putBinFileWithDict :: Binary a => FilePath -> Module -> a -> IO () +putBinFileWithDict file_path mod a = do + bh <- openBinMem initBinMemSize mod + put_ bh binaryInterfaceMagic + p <- tellBin bh + put_ bh p -- placeholder for ptr to dictionary + put_ bh a + let (_, j_r, fm_r, _) = state bh + j <- readIORef j_r + fm <- readIORef fm_r + dict_p <- tellBin bh + putAt bh p dict_p -- fill in the placeholder + seekBin bh dict_p -- seek back to the end of the file + putDictionary bh j (constructDictionary j fm) + writeBinMem bh file_path + +type Dictionary = Array Int FastString + -- should be 0-indexed + +putDictionary :: BinHandle -> Int -> Dictionary -> IO () +putDictionary bh sz dict = do + put_ bh sz + mapM_ (putFS bh) (elems dict) + +getDictionary :: BinHandle -> IO Dictionary +getDictionary bh = do + sz <- get bh + elems <- sequence (take sz (repeat (getFS bh))) + return (listArray (0,sz-1) elems) + +constructDictionary :: Int -> UniqFM (Int,FastString) -> Dictionary +constructDictionary j fm = array (0,j-1) (eltsUFM fm) + +putFS bh (FastString id l ba) = do + put_ bh (I# l) + putByteArray bh ba l +putFS bh s = error ("Binary.put_(FastString): " ++ unpackFS s) + -- Note: the length of the FastString is *not* the same as + -- the size of the ByteArray: the latter is rounded up to a + -- multiple of the word size. + +{- -- possible faster version, not quite there yet: +getFS bh@BinMem{} = do + (I# l) <- get bh + arr <- readIORef (arr_r bh) + off <- readFastMutInt (off_r bh) + return $! (mkFastSubStringBA# arr off l) +-} +getFS bh = do + (I# l) <- get bh + (BA ba) <- getByteArray bh (I# l) + return $! (mkFastSubStringBA# ba 0# l) + +instance Binary FastString where + put_ bh f@(FastString id l ba) = + case getUserData bh of { (_, j_r, out_r, dict) -> do + out <- readIORef out_r + let uniq = getUnique f + case lookupUFM out uniq of + Just (j,f) -> put_ bh j + Nothing -> do + j <- readIORef j_r + put_ bh j + writeIORef j_r (j+1) + writeIORef out_r (addToUFM out uniq (j,f)) + } + put_ bh s = error ("Binary.put_(FastString): " ++ show (unpackFS s)) + + get bh = do + j <- get bh + case getUserData bh of (_, _, _, arr) -> return (arr ! j) +-} + + + +{---------------------------------------------------------------------- + ---------- Hal's Notes ----------------------------------------------- + ---------------------------------------------------------------------- + +We are adding support for + + putBits :: BinHandle -> Int -> Word8 -> IO () + getBits :: BinHandle -> Int -> IO Word8 + flushBits :: BinHandle -> Int -> IO () + closeHandle :: BinHandle -> IO () + +where + + `putBits bh num_bits bits' writes the right-most num_bits of bits to + bh. `getBits bh num_bits` reads num_bits from bh and stores them in + the right-most positions of the result. flushBits bh n alignes the + stream to the next 2^n bit boundary. closeHandle flushes all + remaining bits and closes the handle. + +In order to implement this, we need to extend the BinHandles with two +fields: bit_off_r :: Int and bit_cache :: Word8. Based on this, the +basic implementations look something like this: + +putBits bh num_bits bits = + if num_bits + bit_off_r <= 8 + then bit_off_r += num_bits + add num_bits of bits to the tail of bit_cache + if bit_off_r == 8 + then write bit_cache and set bit_cache = 0, bit_off_r = 0 + else let leftover_bits = 8 - bit_off_r + add leftover_bits of bits to tail of bit_cache + write bit_cache and set bit_cache = 0, bit_off_r = 0 + putBits bh (num_bits - leftover_bits) (bits >> leftover_bits) + +(note that this will recurse at most once) + +getBits bh num_bits = + if bit_off_r == 0 + then bit_cache <- read a byte + bit_off_r = num_bits + if bit_off_r == 8, set bit_off_r = 0, bit_cache = 0 + else if bit_off_r + num_bits <= 8 + then bit_off_r += num_bits + bits = bits from bit_off_r -> bit_off_r+num_bits of bit_cache + if bit_off_r == 8, set bit_off_r = 0, bit_cache = 0 + return bits + else let leftover_bits = 8 - bit_off_r + bits = (last leftover_bits from bit_cache) << (num_bits - leftover_bits) + bit_cache <- read a byte + bit_off_r = num_bits - leftover_bits + return (bits || first (num_bits - leftover_bits) of bit_cache) + +Now, we must also modify putByte/getByte. In these, we do a quick +check to see if bit_off_r == 0; if it does, then we just execute +normally. Otherwise, we just call putBits/getBits with num_bits=8. + +closeHandle bh = + if bit_off_r == 0 + then close the handle + else write bit_cache and set bit_cache = 0, bit_off_r =0 + close the handle + +-} + +------------------------------------------------------------------------ + +#if __GLASGOW_HASKELL__ < 411 +newByteArray# = newCharArray# +#endif + +#ifdef __GLASGOW_HASKELL__ + +data FastMutInt = FastMutInt (MutableByteArray# RealWorld) + +newFastMutInt :: IO FastMutInt +newFastMutInt = IO $ \s -> + case newByteArray# size s of { (# s, arr #) -> + (# s, FastMutInt arr #) } + where I# size = SIZEOF_HSINT + +readFastMutInt :: FastMutInt -> IO Int +readFastMutInt (FastMutInt arr) = IO $ \s -> + case readIntArray# arr 0# s of { (# s, i #) -> + (# s, I# i #) } + +writeFastMutInt :: FastMutInt -> Int -> IO () +writeFastMutInt (FastMutInt arr) (I# i) = IO $ \s -> + case writeIntArray# arr 0# i s of { s -> + (# s, () #) } + +incFastMutInt :: FastMutInt -> IO Int -- Returns original value +incFastMutInt (FastMutInt arr) = IO $ \s -> + case readIntArray# arr 0# s of { (# s, i #) -> + case writeIntArray# arr 0# (i +# 1#) s of { s -> + (# s, I# i #) } } + +incFastMutIntBy :: FastMutInt -> Int -> IO Int -- Returns original value +incFastMutIntBy (FastMutInt arr) (I# n) = IO $ \s -> + case readIntArray# arr 0# s of { (# s, i #) -> + case writeIntArray# arr 0# (i +# n) s of { s -> + (# s, I# i #) } } + +-- we should optimize this: ask SimonM :) +orFastMutInt :: FastMutInt -> Word8 -> IO () +orFastMutInt fmi w = do + i <- readFastMutInt fmi + writeFastMutInt fmi (i .|. (fromIntegral w)) + +#endif + diff --git a/tests/Parallel.hs b/tests/Parallel.hs new file mode 100644 --- /dev/null +++ b/tests/Parallel.hs @@ -0,0 +1,147 @@ +----------------------------------------------------------------------------- +-- | +-- Module : Test.QuickCheck.Parallel +-- Copyright : (c) Don Stewart 2006 +-- License : BSD-style (see the file LICENSE) +-- +-- Maintainer : dons@cse.unsw.edu.au +-- Stability : experimental +-- Portability : non-portable (uses Control.Exception, Control.Concurrent) +-- +-- A parallel batch driver for running QuickCheck on threaded or SMP systems. +-- See the /Example.hs/ file for a complete overview. +-- + +module Parallel ( + pRun, + pDet, + pNon + ) where + +import Test.QuickCheck +import Data.List +import Control.Concurrent +import Control.Exception hiding (evaluate) +import System.Random +import System.IO (hFlush,stdout) +import Text.Printf + +type Name = String +type Depth = Int +type Test = (Name, Depth -> IO String) + +-- | Run a list of QuickCheck properties in parallel chunks, using +-- 'n' Haskell threads (first argument), and test to a depth of 'd' +-- (second argument). Compile your application with '-threaded' and run +-- with the SMP runtime's '-N4' (or however many OS threads you want to +-- donate), for best results. +-- +-- > import Test.QuickCheck.Parallel +-- > +-- > do n <- getArgs >>= readIO . head +-- > pRun n 1000 [ ("sort1", pDet prop_sort1) ] +-- +-- Will run 'n' threads over the property list, to depth 1000. +-- +pRun :: Int -> Int -> [Test] -> IO () +pRun n depth tests = do + chan <- newChan + ps <- getChanContents chan + work <- newMVar tests + + forM_ [1..n] $ forkIO . thread work chan + + let wait xs i + | i >= n = return () -- done + | otherwise = case xs of + Nothing : xs -> wait xs $! i+1 + Just s : xs -> putStr s >> hFlush stdout >> wait xs i + wait ps 0 + + where + thread :: MVar [Test] -> Chan (Maybe String) -> Int -> IO () + thread work chan me = loop + where + loop = do + job <- modifyMVar work $ \jobs -> return $ case jobs of + [] -> ([], Nothing) + (j:js) -> (js, Just j) + case job of + Nothing -> writeChan chan Nothing -- done + Just (name,prop) -> do + v <- prop depth + writeChan chan . Just $ printf "%d: %-25s: %s" me name v + loop + + +-- | Wrap a property, and run it on a deterministic set of data +pDet :: Testable a => a -> Int -> IO String +pDet a n = mycheck Det defaultConfig + { configMaxTest = n + , configEvery = \n args -> unlines args } a + +-- | Wrap a property, and run it on a non-deterministic set of data +pNon :: Testable a => a -> Int -> IO String +pNon a n = mycheck NonDet defaultConfig + { configMaxTest = n + , configEvery = \n args -> unlines args } a + +data Mode = Det | NonDet + +------------------------------------------------------------------------ + +mycheck :: Testable a => Mode -> Config -> a -> IO String +mycheck Det config a = do + let rnd = mkStdGen 99 -- deterministic + mytests config (evaluate a) rnd 0 0 [] + +mycheck NonDet config a = do + rnd <- newStdGen -- different each run + mytests config (evaluate a) rnd 0 0 [] + +mytests :: Config -> Gen Result -> StdGen -> Int -> Int -> [[String]] -> IO String +mytests config gen rnd0 ntest nfail stamps + | ntest == configMaxTest config = do done "OK," ntest stamps + | nfail == configMaxFail config = do done "Arguments exhausted after" ntest stamps + | otherwise = do + case ok result of + Nothing -> + mytests config gen rnd1 ntest (nfail+1) stamps + Just True -> + mytests config gen rnd1 (ntest+1) nfail (stamp result:stamps) + Just False -> + return ( "Falsifiable after " + ++ show ntest + ++ " tests:\n" + ++ unlines (arguments result) + ) + where + result = generate (configSize config ntest) rnd2 gen + (rnd1,rnd2) = split rnd0 + +done :: String -> Int -> [[String]] -> IO String +done mesg ntest stamps = + return ( mesg ++ " " ++ show ntest ++ " tests" ++ table ) + where + table = display + . map entry + . reverse + . sort + . map pairLength + . group + . sort + . filter (not . null) + $ stamps + + display [] = ".\n" + display [x] = " (" ++ x ++ ").\n" + display xs = ".\n" ++ unlines (map (++ ".") xs) + + pairLength xss@(xs:_) = (length xss, xs) + entry (n, xs) = percentage n ntest + ++ " " + ++ concat (intersperse ", " xs) + + percentage n m = show ((100 * n) `div` m) ++ "%" + +forM_ = flip mapM_ diff --git a/tests/QC.hs b/tests/QC.hs new file mode 100644 --- /dev/null +++ b/tests/QC.hs @@ -0,0 +1,244 @@ +{-# OPTIONS_GHC -fglasgow-exts #-} +module Main where + +import Data.Binary +import Data.Binary.Put +import Data.Binary.Get + +import Parallel + +import qualified Data.ByteString as B +import qualified Data.ByteString.Internal as B +import qualified Data.ByteString.Unsafe as B +import qualified Data.ByteString.Lazy as L +import qualified Data.ByteString.Lazy.Internal as L +import qualified Data.Map as Map +import qualified Data.Set as Set +import qualified Data.IntMap as IntMap +import qualified Data.IntSet as IntSet + +import Data.Array (Array) +import Data.Array.IArray +import Data.Array.Unboxed (UArray) + +import qualified Control.OldException as C (catch,evaluate) +import Control.Monad +import Foreign +import System.Environment +import System.IO +import System.IO.Unsafe + +import Test.QuickCheck hiding (test) +import QuickCheckUtils +import Text.Printf + +-- import qualified Data.Sequence as Seq + +------------------------------------------------------------------------ + +roundTrip :: (Eq a, Binary a) => a -> (L.ByteString -> L.ByteString) -> Bool +roundTrip a f = a == + {-# SCC "decode.refragment.encode" #-} decode (f (encode a)) + +roundTripWith put get x = + forAll positiveList $ \xs -> + x == runGet get (refragment xs (runPut (put x))) + +-- make sure that a test fails +errorish :: B a +errorish a = unsafePerformIO $ + C.catch (do C.evaluate a + return False) + (\_ -> return True) + +-- low level ones: + +prop_Word16be = roundTripWith putWord16be getWord16be +prop_Word16le = roundTripWith putWord16le getWord16le +prop_Word16host = roundTripWith putWord16host getWord16host + +prop_Word32be = roundTripWith putWord32be getWord32be +prop_Word32le = roundTripWith putWord32le getWord32le +prop_Word32host = roundTripWith putWord32host getWord32host + +prop_Word64be = roundTripWith putWord64be getWord64be +prop_Word64le = roundTripWith putWord64le getWord64le +prop_Word64host = roundTripWith putWord64host getWord64host + +prop_Wordhost = roundTripWith putWordhost getWordhost + +-- read too much: + +prop_bookworm x = errorish $ x == a && x /= b + where + (a,b) = decode (encode x) + +-- sanity: + +invariant_lbs :: L.ByteString -> Bool +invariant_lbs (L.Empty) = True +invariant_lbs (L.Chunk x xs) = not (B.null x) && invariant_lbs xs + +prop_invariant :: (Binary a) => a -> Bool +prop_invariant = invariant_lbs . encode + +-- be lazy! + +-- doesn't do fair testing of lazy put/get. +-- tons of untested cases + +-- lazyTrip :: (Binary a, Eq a) => a -> Property +-- lazyTrip a = forAll positiveList $ \xs -> +-- a == (runGet lazyGet . refragment xs . runPut . lazyPut $ a) + +-- refragment a lazy bytestring's chunks +refragment :: [Int] -> L.ByteString -> L.ByteString +refragment [] lps = lps +refragment (x:xs) lps = + let x' = fromIntegral . (+1) . abs $ x + rest = refragment xs (L.drop x' lps) in + L.append (L.fromChunks [B.concat . L.toChunks . L.take x' $ lps]) rest + +-- check identity of refragmentation +prop_refragment lps xs = lps == refragment xs lps + +-- check that refragmention still hold invariant +prop_refragment_inv lps xs = invariant_lbs $ refragment xs lps + +main :: IO () +main = do + hSetBuffering stdout NoBuffering + s <- getArgs + let x = if null s then 100 else read (head s) + pRun 2 x tests + +{- +run :: [(String, Int -> IO ())] -> IO () +run tests = do + x <- getArgs + let n = if null x then 100 else read . head $ x + mapM_ (\(s,a) -> printf "%-50s" s >> a n) tests +-} + +------------------------------------------------------------------------ + +type T a = a -> Property +type B a = a -> Bool + +p :: Testable a => a -> Int -> IO String +p = pNon + +test :: (Eq a, Binary a) => a -> Property +test a = forAll positiveList (roundTrip a . refragment) + +positiveList :: Gen [Int] +positiveList = fmap (filter (/=0) . map abs) $ arbitrary + +-- tests :: [(String, Int -> IO String)] +tests = +-- utils + [ ("refragment id", p prop_refragment ) + , ("refragment invariant", p prop_refragment_inv ) + +-- boundaries + , ("read to much", p (prop_bookworm :: B Word8 )) + +-- Primitives + , ("Word16be", p prop_Word16be) + , ("Word16le", p prop_Word16le) + , ("Word16host", p prop_Word16host) + , ("Word32be", p prop_Word32be) + , ("Word32le", p prop_Word32le) + , ("Word32host", p prop_Word32host) + , ("Word64be", p prop_Word64be) + , ("Word64le", p prop_Word64le) + , ("Word64host", p prop_Word64host) + , ("Wordhost", p prop_Wordhost) + +-- higher level ones using the Binary class + ,("()", p (test :: T () )) + ,("Bool", p (test :: T Bool )) + ,("Ordering", p (test :: T Ordering )) + + ,("Word8", p (test :: T Word8 )) + ,("Word16", p (test :: T Word16 )) + ,("Word32", p (test :: T Word32 )) + ,("Word64", p (test :: T Word64 )) + + ,("Int8", p (test :: T Int8 )) + ,("Int16", p (test :: T Int16 )) + ,("Int32", p (test :: T Int32 )) + ,("Int64", p (test :: T Int64 )) + + ,("Word", p (test :: T Word )) + ,("Int", p (test :: T Int )) + ,("Integer", p (test :: T Integer )) + + ,("Float", p (test :: T Float )) + ,("Double", p (test :: T Double )) + + ,("Char", p (test :: T Char )) + + ,("[()]", p (test :: T [()] )) + ,("[Word8]", p (test :: T [Word8] )) + ,("[Word32]", p (test :: T [Word32] )) + ,("[Word64]", p (test :: T [Word64] )) + ,("[Word]", p (test :: T [Word] )) + ,("[Int]", p (test :: T [Int] )) + ,("[Integer]", p (test :: T [Integer] )) + ,("String", p (test :: T String )) + + ,("((), ())", p (test :: T ((), ()) )) + ,("(Word8, Word32)", p (test :: T (Word8, Word32) )) + ,("(Int8, Int32)", p (test :: T (Int8, Int32) )) + ,("(Int32, [Int])", p (test :: T (Int32, [Int]) )) + + ,("Maybe Int8", p (test :: T (Maybe Int8) )) + ,("Either Int8 Int16", p (test :: T (Either Int8 Int16) )) + + ,("(Maybe Word8, Bool, [Int], Either Bool Word8)", + p (test :: T (Maybe Word8, Bool, [Int], Either Bool Word8) )) + + ,("(Int, ByteString)", p (test :: T (Int, B.ByteString) )) +-- ,("Lazy (Int, ByteString)", p (lazyTrip :: T (Int, B.ByteString) )) + ,("[(Int, ByteString)]", p (test :: T [(Int, B.ByteString)] )) +-- ,("Lazy [(Int, ByteString)]", p (lazyTrip :: T [(Int, B.ByteString)] )) + + +-- ,("Lazy IntMap", p (lazyTrip :: T IntSet.IntSet )) + ,("IntSet", p (test :: T IntSet.IntSet )) + ,("IntMap ByteString", p (test :: T (IntMap.IntMap B.ByteString) )) + + ,("B.ByteString", p (test :: T B.ByteString )) + ,("L.ByteString", p (test :: T L.ByteString )) + + ,("B.ByteString invariant", p (prop_invariant :: B B.ByteString )) + ,("[B.ByteString] invariant", p (prop_invariant :: B [B.ByteString] )) + ,("L.ByteString invariant", p (prop_invariant :: B L.ByteString )) + ,("[L.ByteString] invariant", p (prop_invariant :: B [L.ByteString] )) + ,("IntMap invariant", p (prop_invariant :: B (IntMap.IntMap B.ByteString) )) + + ,("Set Word32", p (test :: T (Set.Set Word32) )) + ,("Map Word16 Int", p (test :: T (Map.Map Word16 Int) )) + + ,("(Maybe Int64, Bool, [Int])", p (test :: T (Maybe Int64, Bool, [Int]))) + +{- +-- +-- Big tuples lack an Arbitrary instance in Hugs/QuickCheck +-- + + ,("(Maybe Word16, Bool, [Int], Either Bool Word16, Int)", + p (test :: T (Maybe Word16, Bool, [Int], Either Bool Word16, Int) )) + + ,("(Maybe Word32, Bool, [Int], Either Bool Word32, Int, Int)", p (roundTrip :: (Maybe Word32, Bool, [Int], Either Bool Word32, Int, Int) -> Bool)) + + ,("(Maybe Word64, Bool, [Int], Either Bool Word64, Int, Int, Int)", p (roundTrip :: (Maybe Word64, Bool, [Int], Either Bool Word64, Int, Int, Int) -> Bool)) +-} + +-- GHC only: +-- ,("Sequence", p (roundTrip :: Seq.Seq Int64 -> Bool)) + +-- Obsolete +-- ,("ensureLeft/Fail", mytest (shouldFail (decode L.empty :: Either ParseError Int))) + ] diff --git a/tests/QuickCheckUtils.hs b/tests/QuickCheckUtils.hs new file mode 100644 --- /dev/null +++ b/tests/QuickCheckUtils.hs @@ -0,0 +1,258 @@ +{-# OPTIONS_GHC -fglasgow-exts #-} +-- +-- Uses multi-param type classes +-- +module QuickCheckUtils where + +import Control.Monad + +import Test.QuickCheck.Batch +import Test.QuickCheck +import Text.Show.Functions + +import qualified Data.ByteString as B +import qualified Data.ByteString.Unsafe as B +import qualified Data.ByteString.Internal as B +import qualified Data.ByteString.Lazy as L +import qualified Data.Map as Map +import qualified Data.Set as Set +import qualified Data.IntMap as IntMap +import qualified Data.IntSet as IntSet + +import qualified Control.Exception as C (evaluate) + +import Control.Monad ( liftM2 ) +import Data.Char +import Data.List +import Data.Word +import Data.Int +import System.Random +import System.IO + +-- import Control.Concurrent +import System.Mem +import System.CPUTime +import Text.Printf + +import qualified Data.ByteString as P +import qualified Data.ByteString.Lazy as L +import qualified Data.ByteString.Lazy.Internal as L + +-- import qualified Data.Sequence as Seq + +-- Enable this to get verbose test output. Including the actual tests. +debug = False + +mytest :: Testable a => a -> Int -> IO () +mytest a n = mycheck defaultConfig + { configMaxTest=n + , configEvery= \n args -> if debug then show n ++ ":\n" ++ unlines args else [] } a + +mycheck :: Testable a => Config -> a -> IO () +mycheck config a = do + rnd <- newStdGen + performGC -- >> threadDelay 100 + t <- mytests config (evaluate a) rnd 0 0 [] 0 -- 0 + printf " %0.3f seconds\n" (t :: Double) + hFlush stdout + +time :: a -> IO (a , Double) +time a = do + start <- getCPUTime + v <- C.evaluate a + v `seq` return () + end <- getCPUTime + return (v, ( (fromIntegral (end - start)) / (10^12))) + +mytests :: Config -> Gen Result -> StdGen -> Int -> Int -> [[String]] -> Double -> IO Double +mytests config gen rnd0 ntest nfail stamps t0 + | ntest == configMaxTest config = do done "OK," ntest stamps + return t0 + + | nfail == configMaxFail config = do done "Arguments exhausted after" ntest stamps + return t0 + + | otherwise = do + (result,t1) <- time (generate (configSize config ntest) rnd2 gen) + + putStr (configEvery config ntest (arguments result)) >> hFlush stdout + case ok result of + Nothing -> + mytests config gen rnd1 ntest (nfail+1) stamps (t0 + t1) + Just True -> + mytests config gen rnd1 (ntest+1) nfail (stamp result:stamps) (t0 + t1) + Just False -> do + putStr ( "Falsifiable after " + ++ show ntest + ++ " tests:\n" + ++ unlines (arguments result) + ) >> hFlush stdout + return t0 + + where + (rnd1,rnd2) = split rnd0 + +done :: String -> Int -> [[String]] -> IO () +done mesg ntest stamps = putStr ( mesg ++ " " ++ show ntest ++ " tests" ++ table ) + where + table = display + . map entry + . reverse + . sort + . map pairLength + . group + . sort + . filter (not . null) + $ stamps + + display [] = ". " + display [x] = " (" ++ x ++ "). " + display xs = ".\n" ++ unlines (map (++ ".") xs) + + pairLength xss@(xs:_) = (length xss, xs) + entry (n, xs) = percentage n ntest + ++ " " + ++ concat (intersperse ", " xs) + + percentage n m = show ((100 * n) `div` m) ++ "%" + +------------------------------------------------------------------------ + +instance Random Word8 where + randomR = integralRandomR + random = randomR (minBound,maxBound) + +instance Random Int8 where + randomR = integralRandomR + random = randomR (minBound,maxBound) + +instance Random Word16 where + randomR = integralRandomR + random = randomR (minBound,maxBound) + +instance Random Int16 where + randomR = integralRandomR + random = randomR (minBound,maxBound) + +instance Random Word where + randomR = integralRandomR + random = randomR (minBound,maxBound) + +instance Random Word32 where + randomR = integralRandomR + random = randomR (minBound,maxBound) + +instance Random Int32 where + randomR = integralRandomR + random = randomR (minBound,maxBound) + +instance Random Word64 where + randomR = integralRandomR + random = randomR (minBound,maxBound) + +instance Random Int64 where + randomR = integralRandomR + random = randomR (minBound,maxBound) + +------------------------------------------------------------------------ + +integralRandomR :: (Integral a, RandomGen g) => (a,a) -> g -> (a,g) +integralRandomR (a,b) g = case randomR (fromIntegral a :: Integer, + fromIntegral b :: Integer) g of + (x,g) -> (fromIntegral x, g) + +------------------------------------------------------------------------ + +instance Arbitrary Word8 where + arbitrary = choose (0, 2^8-1) + coarbitrary w = variant 0 + +instance Arbitrary Word16 where + arbitrary = choose (0, 2^16-1) + coarbitrary = undefined + +instance Arbitrary Word32 where +-- arbitrary = choose (0, 2^32-1) + arbitrary = choose (minBound, maxBound) + coarbitrary = undefined + +instance Arbitrary Word64 where +-- arbitrary = choose (0, 2^64-1) + arbitrary = choose (minBound, maxBound) + coarbitrary = undefined + +instance Arbitrary Int8 where +-- arbitrary = choose (0, 2^8-1) + arbitrary = choose (minBound, maxBound) + coarbitrary w = variant 0 + +instance Arbitrary Int16 where +-- arbitrary = choose (0, 2^16-1) + arbitrary = choose (minBound, maxBound) + coarbitrary = undefined + +instance Arbitrary Int32 where +-- arbitrary = choose (0, 2^32-1) + arbitrary = choose (minBound, maxBound) + coarbitrary = undefined + +instance Arbitrary Int64 where +-- arbitrary = choose (0, 2^64-1) + arbitrary = choose (minBound, maxBound) + coarbitrary = undefined + +instance Arbitrary Word where + arbitrary = choose (minBound, maxBound) + coarbitrary w = variant 0 + +------------------------------------------------------------------------ + +instance Arbitrary Char where + arbitrary = choose (maxBound, minBound) + coarbitrary = undefined + +{- +instance Arbitrary a => Arbitrary (Maybe a) where + arbitrary = oneof [ return Nothing, liftM Just arbitrary] + coarbitrary = undefined + -} + +instance Arbitrary Ordering where + arbitrary = oneof [ return LT,return GT,return EQ ] + coarbitrary = undefined + +{- +instance (Arbitrary a, Arbitrary b) => Arbitrary (Either a b) where + arbitrary = oneof [ liftM Left arbitrary, liftM Right arbitrary] + coarbitrary = undefined + -} + +instance Arbitrary IntSet.IntSet where + arbitrary = fmap IntSet.fromList arbitrary + coarbitrary = undefined + +instance (Arbitrary e) => Arbitrary (IntMap.IntMap e) where + arbitrary = fmap IntMap.fromList arbitrary + coarbitrary = undefined + +instance (Arbitrary a, Ord a) => Arbitrary (Set.Set a) where + arbitrary = fmap Set.fromList arbitrary + coarbitrary = undefined + +instance (Arbitrary a, Ord a, Arbitrary b) => Arbitrary (Map.Map a b) where + arbitrary = fmap Map.fromList arbitrary + coarbitrary = undefined + +{- +instance (Arbitrary a) => Arbitrary (Seq.Seq a) where + arbitrary = fmap Seq.fromList arbitrary + coarbitrary = undefined +-} + +instance Arbitrary L.ByteString where + arbitrary = arbitrary >>= return . L.fromChunks . filter (not. B.null) -- maintain the invariant. + coarbitrary s = coarbitrary (L.unpack s) + +instance Arbitrary B.ByteString where + arbitrary = B.pack `fmap` arbitrary + coarbitrary s = coarbitrary (B.unpack s) diff --git a/todo b/todo new file mode 100644 --- /dev/null +++ b/todo @@ -0,0 +1,28 @@ +layer handling: + + bit packing + state parameters + string pools + + reading structures from the end of a stream, seek/tell behaviour + +seek based protocols are too hard. + hGetContents/ interleaving. + +user requests: + + get remaining bytestring after a runGet + + some kind of lookahead, or restoring parsing state, or something with + equal functionality. make it another layer on top? + + getLazyByteString takes an Int, which in Haskell98 is only guarantied to + be 29 bits, ie. 512 mb. + maybe we should have a readN64 for allowing reading of larger stuff? + (which could be implemented with readN on 64bit machines) + reference: bringerts tar archive decoder would be limitid to 0.5GB + files, alt. 2GB in GHC + +SYB-deriving + +investigate the UArray instance, it does not seem to compile in GHC 6.4 diff --git a/tools/derive/BinaryDerive.hs b/tools/derive/BinaryDerive.hs new file mode 100644 --- /dev/null +++ b/tools/derive/BinaryDerive.hs @@ -0,0 +1,57 @@ +{-# OPTIONS -fglasgow-exts #-} + +module BinaryDerive where + +import Data.Generics +import Data.List + +deriveM :: (Typeable a, Data a) => a -> IO () +deriveM (a :: a) = mapM_ putStrLn . lines $ derive (undefined :: a) + +derive :: (Typeable a, Data a) => a -> String +derive x = + "instance " ++ context ++ "Binary " ++ inst ++ " where\n" ++ + concat putDefs ++ getDefs + where + context + | nTypeChildren > 0 = + wrap (join ", " (map ("Binary "++) typeLetters)) ++ " => " + | otherwise = "" + inst = wrap $ tyConString typeName ++ concatMap (" "++) typeLetters + wrap x = if nTypeChildren > 0 then "("++x++")" else x + join sep lst = concat $ intersperse sep lst + nTypeChildren = length typeChildren + typeLetters = take nTypeChildren manyLetters + manyLetters = map (:[]) ['a'..'z'] + (typeName,typeChildren) = splitTyConApp (typeOf x) + constrs :: [(Int, (String, Int))] + constrs = zip [0..] $ map gen $ dataTypeConstrs (dataTypeOf x) + gen con = ( showConstr con + , length $ gmapQ undefined $ fromConstr con `asTypeOf` x + ) + putDefs = map ((++"\n") . putDef) constrs + putDef (n, (name, ps)) = + let wrap = if ps /= 0 then ("("++) . (++")") else id + pattern = name ++ concatMap (' ':) (take ps manyLetters) + in + " put " ++ wrap pattern ++" = " + ++ concat [ "putWord8 " ++ show n | length constrs > 1 ] + ++ concat [ " >> " | length constrs > 1 && ps > 0 ] + ++ concat [ "return ()" | length constrs == 1 && ps == 0 ] + ++ join " >> " (map ("put "++) (take ps manyLetters)) + getDefs = + (if length constrs > 1 + then " get = do\n tag_ <- getWord8\n case tag_ of\n" + else " get =") + ++ concatMap ((++"\n")) (map getDef constrs) ++ + (if length constrs > 1 + then " _ -> fail \"no parse\"" + else "" + ) + getDef (n, (name, ps)) = + let wrap = if ps /= 0 then ("("++) . (++")") else id + in + concat [ " " ++ show n ++ " ->" | length constrs > 1 ] + ++ concatMap (\x -> " get >>= \\"++x++" ->") (take ps manyLetters) + ++ " return " + ++ wrap (name ++ concatMap (" "++) (take ps manyLetters)) diff --git a/tools/derive/Example.hs b/tools/derive/Example.hs new file mode 100644 --- /dev/null +++ b/tools/derive/Example.hs @@ -0,0 +1,68 @@ + +import Data.Generics + +import Data.Binary + +import BinaryDerive + +data Foo = Bar + deriving (Typeable, Data, Show, Eq) + +instance Binary Main.Foo where + put Bar = return () + get = return Bar + +data Color = RGB Int Int Int + | CMYK Int Int Int Int + deriving (Typeable, Data, Show, Eq) + +instance Binary Main.Color where + put (RGB a b c) = putWord8 0 >> put a >> put b >> put c + put (CMYK a b c d) = putWord8 1 >> put a >> put b >> put c >> put d + get = do + tag_ <- getWord8 + case tag_ of + 0 -> get >>= \a -> get >>= \b -> get >>= \c -> return (RGB a b c) + 1 -> get >>= \a -> get >>= \b -> get >>= \c -> get >>= \d -> return (CMYK a b c d) + +data Computer = Laptop { weight :: Int } + | Desktop { speed :: Int, memory :: Int } + deriving (Typeable, Data, Show, Eq) + +instance Binary Main.Computer where + put (Laptop a) = putWord8 0 >> put a + put (Desktop a b) = putWord8 1 >> put a >> put b + get = do + tag_ <- getWord8 + case tag_ of + 0 -> get >>= \a -> return (Laptop a) + 1 -> get >>= \a -> get >>= \b -> return (Desktop a b) + +-- | All drinks mankind will ever need +data Drinks = Beer Bool{-ale?-} + | Coffee + | Tea + | EnergyDrink + | Water + | Wine + | Whisky + deriving (Typeable, Data, Show, Eq) + +instance Binary Main.Drinks where + put (Beer a) = putWord8 0 >> put a + put Coffee = putWord8 1 + put Tea = putWord8 2 + put EnergyDrink = putWord8 3 + put Water = putWord8 4 + put Wine = putWord8 5 + put Whisky = putWord8 6 + get = do + tag_ <- getWord8 + case tag_ of + 0 -> get >>= \a -> return (Beer a) + 1 -> return Coffee + 2 -> return Tea + 3 -> return EnergyDrink + 4 -> return Water + 5 -> return Wine + 6 -> return Whisky