binary 0.4.4 → 0.4.5
raw patch · 16 files changed
+1/−4123 lines, 16 filesdep ~basenew-uploaderPVP ok
version bump matches the API change (PVP)
Dependency ranges changed: base
API changes (from Hackage documentation)
Files
- TODO +0/−28
- binary.cabal +1/−2
- docs/hcar/binary-Lb.tex +0/−48
- tests/Benchmark.hs +0/−1461
- tests/CBenchmark.c +0/−39
- tests/CBenchmark.h +0/−4
- tests/HeapUse.hs +0/−17
- tests/Makefile +0/−34
- tests/MemBench.hs +0/−85
- tests/NewBenchmark.hs +0/−625
- tests/NewBinary.hs +0/−1006
- tests/Parallel.hs +0/−147
- tests/QC.hs +0/−244
- tests/QuickCheckUtils.hs +0/−258
- tools/derive/BinaryDerive.hs +0/−57
- tools/derive/Example.hs +0/−68
− TODO
@@ -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
binary.cabal view
@@ -1,5 +1,5 @@ name: binary-version: 0.4.4+version: 0.4.5 license: BSD3 license-file: LICENSE author: Lennart Kolmodin <kolmodin@dtek.chalmers.se>@@ -57,7 +57,6 @@ -fspec-constr -funbox-strict-fields -fdicts-cheap- -fno-method-sharing -fliberate-case-threshold=1000 -fmax-simplifier-iterations10
− docs/hcar/binary-Lb.tex
@@ -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}
− tests/Benchmark.hs
@@ -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)
− tests/CBenchmark.c
@@ -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;-}
− tests/CBenchmark.h
@@ -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);
− tests/HeapUse.hs
@@ -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))
− tests/Makefile
@@ -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
− tests/MemBench.hs
@@ -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)
− tests/NewBenchmark.hs
@@ -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)
− tests/NewBinary.hs
@@ -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-
− tests/Parallel.hs
@@ -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_
− tests/QC.hs
@@ -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)))- ]
− tests/QuickCheckUtils.hs
@@ -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)
− tools/derive/BinaryDerive.hs
@@ -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))
− tools/derive/Example.hs
@@ -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