diff --git a/TODO b/TODO deleted file mode 100644 --- a/TODO +++ /dev/null @@ -1,28 +0,0 @@ -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/binary.cabal b/binary.cabal --- a/binary.cabal +++ b/binary.cabal @@ -1,5 +1,5 @@ name: binary -version: 0.4.4 +version: 0.4.5 license: BSD3 license-file: LICENSE author: Lennart Kolmodin @@ -57,7 +57,6 @@ -fspec-constr -funbox-strict-fields -fdicts-cheap - -fno-method-sharing -fliberate-case-threshold=1000 -fmax-simplifier-iterations10 diff --git a/docs/hcar/binary-Lb.tex b/docs/hcar/binary-Lb.tex deleted file mode 100644 --- a/docs/hcar/binary-Lb.tex +++ /dev/null @@ -1,48 +0,0 @@ -\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/tests/Benchmark.hs b/tests/Benchmark.hs deleted file mode 100644 --- a/tests/Benchmark.hs +++ /dev/null @@ -1,1461 +0,0 @@ -{-# 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 <- [1,2,4,8,16] - ] - - -- now Word16 .. Word64 - sequence_ - [ test wordSize chunkSize end mb - | wordSize <- [2,4,8] - , chunkSize <- [1,2,4,8,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 deleted file mode 100644 --- a/tests/CBenchmark.c +++ /dev/null @@ -1,39 +0,0 @@ -#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 deleted file mode 100644 --- a/tests/CBenchmark.h +++ /dev/null @@ -1,4 +0,0 @@ -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 deleted file mode 100644 --- a/tests/HeapUse.hs +++ /dev/null @@ -1,17 +0,0 @@ --- 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 deleted file mode 100644 --- a/tests/Makefile +++ /dev/null @@ -1,34 +0,0 @@ -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 -fliberate-case-threshold=1000 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 deleted file mode 100644 --- a/tests/MemBench.hs +++ /dev/null @@ -1,85 +0,0 @@ -{-# 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 deleted file mode 100644 --- a/tests/NewBenchmark.hs +++ /dev/null @@ -1,625 +0,0 @@ --- --- 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 deleted file mode 100644 --- a/tests/NewBinary.hs +++ /dev/null @@ -1,1006 +0,0 @@ -{-# 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 deleted file mode 100644 --- a/tests/Parallel.hs +++ /dev/null @@ -1,147 +0,0 @@ ------------------------------------------------------------------------------ --- | --- 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 deleted file mode 100644 --- a/tests/QC.hs +++ /dev/null @@ -1,244 +0,0 @@ -{-# 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 deleted file mode 100644 --- a/tests/QuickCheckUtils.hs +++ /dev/null @@ -1,258 +0,0 @@ -{-# 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/tools/derive/BinaryDerive.hs b/tools/derive/BinaryDerive.hs deleted file mode 100644 --- a/tools/derive/BinaryDerive.hs +++ /dev/null @@ -1,57 +0,0 @@ -{-# 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 deleted file mode 100644 --- a/tools/derive/Example.hs +++ /dev/null @@ -1,68 +0,0 @@ - -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