binary 0.4.5 → 0.5

raw patch · 18 files changed

+4147/−11 lines, 18 filesPVP ok

version bump matches the API change (PVP)

API changes (from Hackage documentation)

Files

• binary.cabal +2/−8
• docs/hcar/binary-Lb.tex +48/−0
• src/Data/Binary.hs +7/−3
• src/Data/Binary/Put.hs +17/−0
• tests/Benchmark.hs +1461/−0
• tests/CBenchmark.c +39/−0
• tests/CBenchmark.h +4/−0
• tests/HeapUse.hs +17/−0
• tests/Makefile +34/−0
• tests/MemBench.hs +85/−0
• tests/NewBenchmark.hs +625/−0
• tests/NewBinary.hs +1006/−0
• tests/Parallel.hs +147/−0
• tests/QC.hs +244/−0
• tests/QuickCheckUtils.hs +258/−0
• todo +28/−0
• tools/derive/BinaryDerive.hs +57/−0
• tools/derive/Example.hs +68/−0

@@ -1,5 +1,5 @@ name:            binary-version:         0.4.5+version:         0.5 license:         BSD3 license-file:    LICENSE author:          Lennart Kolmodin <kolmodin@dtek.chalmers.se>@@ -52,13 +52,7 @@   extensions:      CPP,                    FlexibleContexts -  ghc-options:     -O2-                   -Wall-                   -fspec-constr-                   -funbox-strict-fields -                   -fdicts-cheap-                   -fliberate-case-threshold=1000-                   -fmax-simplifier-iterations10+  ghc-options:     -O2 -Wall -fliberate-case-threshold=1000  --  if impl(ghc < 6.5) --    ghc-options:   -fallow-undecidable-instances

@@ -0,0 +1,48 @@+\begin{hcarentry}{binary}+\label{binary}+\report{Lennart Kolmodin}+\status{active}+\participants{Duncan Coutts, Don Stewart, Binary Strike Team}+\makeheader++The Binary Strike Team is pleased to announce yet a release of a new,+pure, efficient binary serialisation library.++The `binary' package provides efficient serialisation of Haskell values+to and from lazy ByteStrings. ByteStrings constructed this way may then+be written to disk, written to the network, or further processed (e.g.+stored in memory directly, or compressed in memory with zlib or bzlib).++The binary library has been heavily tuned for performance, particularly for+writing speed. Throughput of up to 160M/s has been achieved in practice, and+in general speed is on par or better than NewBinary, with the advantage of a+pure interface. Efforts are underway to improve performance still further.+Plans are also taking shape for a parser combinator library on top of+binary, for bit parsing and foreign structure parsing (e.g. network+protocols).++Data.Derive~\cref{derive} has support for automatically generating Binary+instances, allowing to read and write your data structures with little fuzz.++Binary was developed by a team of 8 during the Haskell Hackathon in Oxford+2007, and since then has about 15 people contributed code and many more+given feedback and cheerleading on \verb|#haskell|.++The package is cabalized and available through Hackage~\cref{hackagedb}.+% to editors: ref. to cabal?++\FurtherReading+\begin{compactitem}+\item Homepage++  \url{http://code.haskell.org/binary/}+\item Hackage++  \url{http://hackage.haskell.org/cgi-bin/hackage-scripts/package/binary}+\item Development version++  \texttt{darcs get --partial}++  \url{http://code.haskell.org/binary}+\end{compactitem}+\end{hcarentry}

@@ -651,9 +651,13 @@ --  instance (Binary e) => Binary (Seq.Seq e) where-    -- any better way to do this?-    put = put . Fold.toList-    get = fmap Seq.fromList get+    put s = put (Seq.length s) >> Fold.mapM_ put s+    get = do n <- get :: Get Int+             rep Seq.empty n get+      where rep xs 0 _ = return $! xs+            rep xs n g = xs `seq` n `seq` do+                           x <- g+                           rep (xs Seq.|> x) (n-1) g  #endif 

@@ -18,6 +18,9 @@       Put     , PutM(..)     , runPut+    , runPutM+    , putBuilder+    , execPut      -- * Flushing the implicit parse state     , flush@@ -106,10 +109,24 @@ tell b = Put $ PairS () b {-# INLINE tell #-} +putBuilder :: Builder -> Put+putBuilder = tell+{-# INLINE putBuilder #-}++-- | Run the 'Put' monad+execPut :: PutM a -> Builder+execPut = sndS . unPut+{-# INLINE execPut #-}+ -- | Run the 'Put' monad with a serialiser runPut :: Put -> L.ByteString runPut = toLazyByteString . sndS . unPut {-# INLINE runPut #-}++-- | Run the 'Put' monad with a serialiser and get its result+runPutM :: PutM a -> (a, L.ByteString)+runPutM (Put (PairS f s)) = (f, toLazyByteString s)+{-# INLINE runPutM #-}  ------------------------------------------------------------------------ 

@@ -0,0 +1,1461 @@+{-# OPTIONS -fbang-patterns #-}+module Main (main) where++import qualified Data.ByteString.Lazy as L+import Data.Binary+import Data.Binary.Put+import Data.Binary.Get++import Control.Exception+import System.CPUTime+import Numeric+import Text.Printf+import System.Environment++import MemBench++data Endian+    = Big+    | Little+    | Host+    deriving (Eq,Ord,Show)++main :: IO ()+main = do+  mb <- getArgs >>= readIO . head+  memBench (mb*10) +  putStrLn ""+  putStrLn "Binary (de)serialisation benchmarks:"++  -- do bytewise +  sequence_+    [ test wordSize chunkSize Host mb+    | wordSize  <- [1]+    , chunkSize <- [16] --1,2,4,8,16]+    ]++  -- now Word16 .. Word64+  sequence_+    [ test wordSize chunkSize end mb+    | wordSize  <- [2,4,8]+    , chunkSize <- [16]+    , end       <- [Host] -- ,Big,Little]+    ]++------------------------------------------------------------------------++time :: IO a -> IO Double+time action = do+    start <- getCPUTime+    action+    end   <- getCPUTime+    return $! (fromIntegral (end - start)) / (10^12)++------------------------------------------------------------------------++test :: Int -> Int -> Endian -> Int -> IO ()+test wordSize chunkSize end mb = do+    let bytes :: Int+        bytes = mb * 2^20+        iterations = bytes `div` wordSize+        bs  = runPut (doPut wordSize chunkSize end iterations)+        sum = runGet (doGet wordSize chunkSize end iterations) bs++    case (chunkSize,end) of (1,Host) -> putStrLn "" ; _ -> return ()++    printf "%dMB of Word%-2d in chunks of %2d (%6s endian): "+        (mb :: Int) (8 * wordSize :: Int) (chunkSize :: Int) (show end)++    putSeconds <- time $ evaluate (L.length bs)+    getSeconds <- time $ evaluate sum+--    print (L.length bs, sum)+    let putThroughput = fromIntegral mb / putSeconds+        getThroughput = fromIntegral mb / getSeconds++    printf "%6.1f MB/s write, %6.1f MB/s read, %5.1f get/put-ratio\n"+           putThroughput+           getThroughput+           (getThroughput/putThroughput)++------------------------------------------------------------------------++doPut :: Int -> Int -> Endian -> Int -> Put+doPut wordSize chunkSize end = case (wordSize, chunkSize, end) of+    (1, 1,_)   -> putWord8N1+    (1, 2,_)   -> putWord8N2+    (1, 4,_)   -> putWord8N4+    (1, 8,_)   -> putWord8N8+    (1, 16, _) -> putWord8N16++    (2, 1,  Big)    -> putWord16N1Big+    (2, 2,  Big)    -> putWord16N2Big+    (2, 4,  Big)    -> putWord16N4Big+    (2, 8,  Big)    -> putWord16N8Big+    (2, 16, Big)    -> putWord16N16Big+    (2, 1,  Little) -> putWord16N1Little+    (2, 2,  Little) -> putWord16N2Little+    (2, 4,  Little) -> putWord16N4Little+    (2, 8,  Little) -> putWord16N8Little+    (2, 16, Little) -> putWord16N16Little+    (2, 1,  Host)   -> putWord16N1Host+    (2, 2,  Host)   -> putWord16N2Host+    (2, 4,  Host)   -> putWord16N4Host+    (2, 8,  Host)   -> putWord16N8Host+    (2, 16, Host)   -> putWord16N16Host++    (4, 1,  Big)    -> putWord32N1Big+    (4, 2,  Big)    -> putWord32N2Big+    (4, 4,  Big)    -> putWord32N4Big+    (4, 8,  Big)    -> putWord32N8Big+    (4, 16, Big)    -> putWord32N16Big+    (4, 1,  Little) -> putWord32N1Little+    (4, 2,  Little) -> putWord32N2Little+    (4, 4,  Little) -> putWord32N4Little+    (4, 8,  Little) -> putWord32N8Little+    (4, 16, Little) -> putWord32N16Little+    (4, 1,  Host)   -> putWord32N1Host+    (4, 2,  Host)   -> putWord32N2Host+    (4, 4,  Host)   -> putWord32N4Host+    (4, 8,  Host)   -> putWord32N8Host+    (4, 16, Host)   -> putWord32N16Host++    (8, 1,  Host)        -> putWord64N1Host+    (8, 2,  Host)        -> putWord64N2Host+    (8, 4,  Host)        -> putWord64N4Host+    (8, 8,  Host)        -> putWord64N8Host+    (8, 16, Host)        -> putWord64N16Host+    (8, 1,  Big)         -> putWord64N1Big+    (8, 2,  Big)         -> putWord64N2Big+    (8, 4,  Big)         -> putWord64N4Big+    (8, 8,  Big)         -> putWord64N8Big+    (8, 16, Big)         -> putWord64N16Big+    (8, 1,  Little)      -> putWord64N1Little+    (8, 2,  Little)      -> putWord64N2Little+    (8, 4,  Little)      -> putWord64N4Little+    (8, 8,  Little)      -> putWord64N8Little+    (8, 16, Little)      -> putWord64N16Little++------------------------------------------------------------------------++doGet :: Int -> Int -> Endian -> Int -> Get Int+doGet wordSize chunkSize end =+  case (wordSize, chunkSize, end) of+    (1, 1,_)  -> fmap fromIntegral . getWord8N1+    (1, 2,_)  -> fmap fromIntegral . getWord8N2+    (1, 4,_)  -> fmap fromIntegral . getWord8N4+    (1, 8,_)  -> fmap fromIntegral . getWord8N8+    (1, 16,_) -> fmap fromIntegral . getWord8N16++    (2, 1,Big)      -> fmap fromIntegral . getWord16N1Big+    (2, 2,Big)      -> fmap fromIntegral . getWord16N2Big+    (2, 4,Big)      -> fmap fromIntegral . getWord16N4Big+    (2, 8,Big)      -> fmap fromIntegral . getWord16N8Big+    (2, 16,Big)     -> fmap fromIntegral . getWord16N16Big+    (2, 1,Little)   -> fmap fromIntegral . getWord16N1Little+    (2, 2,Little)   -> fmap fromIntegral . getWord16N2Little+    (2, 4,Little)   -> fmap fromIntegral . getWord16N4Little+    (2, 8,Little)   -> fmap fromIntegral . getWord16N8Little+    (2, 16,Little)  -> fmap fromIntegral . getWord16N16Little+    (2, 1,Host)     -> fmap fromIntegral . getWord16N1Host+    (2, 2,Host)     -> fmap fromIntegral . getWord16N2Host+    (2, 4,Host)     -> fmap fromIntegral . getWord16N4Host+    (2, 8,Host)     -> fmap fromIntegral . getWord16N8Host+    (2, 16,Host)    -> fmap fromIntegral . getWord16N16Host++    (4, 1,Big)      -> fmap fromIntegral . getWord32N1Big+    (4, 2,Big)      -> fmap fromIntegral . getWord32N2Big+    (4, 4,Big)      -> fmap fromIntegral . getWord32N4Big+    (4, 8,Big)      -> fmap fromIntegral . getWord32N8Big+    (4, 16,Big)     -> fmap fromIntegral . getWord32N16Big+    (4, 1,Little)   -> fmap fromIntegral . getWord32N1Little+    (4, 2,Little)   -> fmap fromIntegral . getWord32N2Little+    (4, 4,Little)   -> fmap fromIntegral . getWord32N4Little+    (4, 8,Little)   -> fmap fromIntegral . getWord32N8Little+    (4, 16,Little)  -> fmap fromIntegral . getWord32N16Little+    (4, 1,Host)     -> fmap fromIntegral . getWord32N1Host+    (4, 2,Host)     -> fmap fromIntegral . getWord32N2Host+    (4, 4,Host)     -> fmap fromIntegral . getWord32N4Host+    (4, 8,Host)     -> fmap fromIntegral . getWord32N8Host+    (4, 16,Host)    -> fmap fromIntegral . getWord32N16Host++    (8, 1,Host)     -> fmap fromIntegral . getWord64N1Host+    (8, 2,Host)     -> fmap fromIntegral . getWord64N2Host+    (8, 4,Host)     -> fmap fromIntegral . getWord64N4Host+    (8, 8,Host)     -> fmap fromIntegral . getWord64N8Host+    (8, 16,Host)    -> fmap fromIntegral . getWord64N16Host+    (8, 1,Big)      -> fmap fromIntegral . getWord64N1Big+    (8, 2,Big)      -> fmap fromIntegral . getWord64N2Big+    (8, 4,Big)      -> fmap fromIntegral . getWord64N4Big+    (8, 8,Big)      -> fmap fromIntegral . getWord64N8Big+    (8, 16,Big)     -> fmap fromIntegral . getWord64N16Big+    (8, 1,Little)   -> fmap fromIntegral . getWord64N1Little+    (8, 2,Little)   -> fmap fromIntegral . getWord64N2Little+    (8, 4,Little)   -> fmap fromIntegral . getWord64N4Little+    (8, 8,Little)   -> fmap fromIntegral . getWord64N8Little+    (8, 16,Little)  -> fmap fromIntegral . getWord64N16Little++------------------------------------------------------------------------++putWord8N1 bytes = loop 0 0+  where loop :: Word8 -> Int -> Put+        loop !s !n | n == bytes = return ()+                   | otherwise  = do putWord8 s+                                     loop (s+1) (n+1)++putWord8N2 = loop 0+  where loop s n | s `seq` n `seq` False = undefined+        loop _ 0 = return ()+        loop s n = do+          putWord8 (s+0)+          putWord8 (s+1)+          loop (s+2) (n-2)++putWord8N4 = loop 0+  where loop s n | s `seq` n `seq` False = undefined+        loop _ 0 = return ()+        loop s n = do+          putWord8 (s+0)+          putWord8 (s+1)+          putWord8 (s+2)+          putWord8 (s+3)+          loop (s+4) (n-4)++putWord8N8 = loop 0+  where loop s n | s `seq` n `seq` False = undefined+        loop _ 0 = return ()+        loop s n = do+          putWord8 (s+0)+          putWord8 (s+1)+          putWord8 (s+2)+          putWord8 (s+3)+          putWord8 (s+4)+          putWord8 (s+5)+          putWord8 (s+6)+          putWord8 (s+7)+          loop (s+8) (n-8)++putWord8N16 = loop 0+  where loop s n | s `seq` n `seq` False = undefined+        loop _ 0 = return ()+        loop s n = do+          putWord8 (s+0)+          putWord8 (s+1)+          putWord8 (s+2)+          putWord8 (s+3)+          putWord8 (s+4)+          putWord8 (s+5)+          putWord8 (s+6)+          putWord8 (s+7)+          putWord8 (s+8)+          putWord8 (s+9)+          putWord8 (s+10)+          putWord8 (s+11)+          putWord8 (s+12)+          putWord8 (s+13)+          putWord8 (s+14)+          putWord8 (s+15)+          loop (s+16) (n-16)++------------------------------------------------------------------------+-- Big endian, word16 writes++putWord16N1Big = loop 0+  where loop s n | s `seq` n `seq` False = undefined+        loop _ 0 = return ()+        loop s n = do+          putWord16be (s+0)+          loop (s+1) (n-1)++putWord16N2Big = loop 0+  where loop s n | s `seq` n `seq` False = undefined+        loop _ 0 = return ()+        loop s n = do+          putWord16be (s+0)+          putWord16be (s+1)+          loop (s+2) (n-2)++putWord16N4Big = loop 0+  where loop s n | s `seq` n `seq` False = undefined+        loop _ 0 = return ()+        loop s n = do+          putWord16be (s+0)+          putWord16be (s+1)+          putWord16be (s+2)+          putWord16be (s+3)+          loop (s+4) (n-4)++putWord16N8Big = loop 0+  where loop s n | s `seq` n `seq` False = undefined+        loop _ 0 = return ()+        loop s n = do+          putWord16be (s+0)+          putWord16be (s+1)+          putWord16be (s+2)+          putWord16be (s+3)+          putWord16be (s+4)+          putWord16be (s+5)+          putWord16be (s+6)+          putWord16be (s+7)+          loop (s+8) (n-8)++putWord16N16Big = loop 0+  where loop s n | s `seq` n `seq` False = undefined+        loop _ 0 = return ()+        loop s n = do+          putWord16be (s+0)+          putWord16be (s+1)+          putWord16be (s+2)+          putWord16be (s+3)+          putWord16be (s+4)+          putWord16be (s+5)+          putWord16be (s+6)+          putWord16be (s+7)+          putWord16be (s+8)+          putWord16be (s+9)+          putWord16be (s+10)+          putWord16be (s+11)+          putWord16be (s+12)+          putWord16be (s+13)+          putWord16be (s+14)+          putWord16be (s+15)+          loop (s+16) (n-16)++------------------------------------------------------------------------+-- Little endian, word16 writes++putWord16N1Little = loop 0+  where loop s n | s `seq` n `seq` False = undefined+        loop _ 0 = return ()+        loop s n = do+          putWord16le (s+0)+          loop (s+1) (n-1)++putWord16N2Little = loop 0+  where loop s n | s `seq` n `seq` False = undefined+        loop _ 0 = return ()+        loop s n = do+          putWord16le (s+0)+          putWord16le (s+1)+          loop (s+2) (n-2)++putWord16N4Little = loop 0+  where loop s n | s `seq` n `seq` False = undefined+        loop _ 0 = return ()+        loop s n = do+          putWord16le (s+0)+          putWord16le (s+1)+          putWord16le (s+2)+          putWord16le (s+3)+          loop (s+4) (n-4)++putWord16N8Little = loop 0+  where loop s n | s `seq` n `seq` False = undefined+        loop _ 0 = return ()+        loop s n = do+          putWord16le (s+0)+          putWord16le (s+1)+          putWord16le (s+2)+          putWord16le (s+3)+          putWord16le (s+4)+          putWord16le (s+5)+          putWord16le (s+6)+          putWord16le (s+7)+          loop (s+8) (n-8)++putWord16N16Little = loop 0+  where loop s n | s `seq` n `seq` False = undefined+        loop _ 0 = return ()+        loop s n = do+          putWord16le (s+0)+          putWord16le (s+1)+          putWord16le (s+2)+          putWord16le (s+3)+          putWord16le (s+4)+          putWord16le (s+5)+          putWord16le (s+6)+          putWord16le (s+7)+          putWord16le (s+8)+          putWord16le (s+9)+          putWord16le (s+10)+          putWord16le (s+11)+          putWord16le (s+12)+          putWord16le (s+13)+          putWord16le (s+14)+          putWord16le (s+15)+          loop (s+16) (n-16)++------------------------------------------------------------------------+-- Host endian, unaligned, word16 writes++putWord16N1Host = loop 0+  where loop s n | s `seq` n `seq` False = undefined+        loop _ 0 = return ()+        loop s n = do+          putWord16host (s+0)+          loop (s+1) (n-1)++putWord16N2Host = loop 0+  where loop s n | s `seq` n `seq` False = undefined+        loop _ 0 = return ()+        loop s n = do+          putWord16host (s+0)+          putWord16host (s+1)+          loop (s+2) (n-2)++putWord16N4Host = loop 0+  where loop s n | s `seq` n `seq` False = undefined+        loop _ 0 = return ()+        loop s n = do+          putWord16host (s+0)+          putWord16host (s+1)+          putWord16host (s+2)+          putWord16host (s+3)+          loop (s+4) (n-4)++putWord16N8Host = loop 0+  where loop s n | s `seq` n `seq` False = undefined+        loop _ 0 = return ()+        loop s n = do+          putWord16host (s+0)+          putWord16host (s+1)+          putWord16host (s+2)+          putWord16host (s+3)+          putWord16host (s+4)+          putWord16host (s+5)+          putWord16host (s+6)+          putWord16host (s+7)+          loop (s+8) (n-8)++putWord16N16Host = loop 0+  where loop s n | s `seq` n `seq` False = undefined+        loop _ 0 = return ()+        loop s n = do+          putWord16host (s+0)+          putWord16host (s+1)+          putWord16host (s+2)+          putWord16host (s+3)+          putWord16host (s+4)+          putWord16host (s+5)+          putWord16host (s+6)+          putWord16host (s+7)+          putWord16host (s+8)+          putWord16host (s+9)+          putWord16host (s+10)+          putWord16host (s+11)+          putWord16host (s+12)+          putWord16host (s+13)+          putWord16host (s+14)+          putWord16host (s+15)+          loop (s+16) (n-16)++------------------------------------------------------------------------++putWord32N1Big = loop 0+  where loop s n | s `seq` n `seq` False = undefined+        loop _ 0 = return ()+        loop s n = do+          putWord32be (s+0)+          loop (s+1) (n-1)++putWord32N2Big = loop 0+  where loop s n | s `seq` n `seq` False = undefined+        loop _ 0 = return ()+        loop s n = do+          putWord32be (s+0)+          putWord32be (s+1)+          loop (s+2) (n-2)++putWord32N4Big = loop 0+  where loop s n | s `seq` n `seq` False = undefined+        loop _ 0 = return ()+        loop s n = do+          putWord32be (s+0)+          putWord32be (s+1)+          putWord32be (s+2)+          putWord32be (s+3)+          loop (s+4) (n-4)++putWord32N8Big = loop 0+  where loop s n | s `seq` n `seq` False = undefined+        loop _ 0 = return ()+        loop s n = do+          putWord32be (s+0)+          putWord32be (s+1)+          putWord32be (s+2)+          putWord32be (s+3)+          putWord32be (s+4)+          putWord32be (s+5)+          putWord32be (s+6)+          putWord32be (s+7)+          loop (s+8) (n-8)++putWord32N16Big = loop 0+  where loop s n | s `seq` n `seq` False = undefined+        loop _ 0 = return ()+        loop s n = do+          putWord32be (s+0)+          putWord32be (s+1)+          putWord32be (s+2)+          putWord32be (s+3)+          putWord32be (s+4)+          putWord32be (s+5)+          putWord32be (s+6)+          putWord32be (s+7)+          putWord32be (s+8)+          putWord32be (s+9)+          putWord32be (s+10)+          putWord32be (s+11)+          putWord32be (s+12)+          putWord32be (s+13)+          putWord32be (s+14)+          putWord32be (s+15)+          loop (s+16) (n-16)++------------------------------------------------------------------------++putWord32N1Little = loop 0+  where loop s n | s `seq` n `seq` False = undefined+        loop _ 0 = return ()+        loop s n = do+          putWord32le (s+0)+          loop (s+1) (n-1)++putWord32N2Little = loop 0+  where loop s n | s `seq` n `seq` False = undefined+        loop _ 0 = return ()+        loop s n = do+          putWord32le (s+0)+          putWord32le (s+1)+          loop (s+2) (n-2)++putWord32N4Little = loop 0+  where loop s n | s `seq` n `seq` False = undefined+        loop _ 0 = return ()+        loop s n = do+          putWord32le (s+0)+          putWord32le (s+1)+          putWord32le (s+2)+          putWord32le (s+3)+          loop (s+4) (n-4)++putWord32N8Little = loop 0+  where loop s n | s `seq` n `seq` False = undefined+        loop _ 0 = return ()+        loop s n = do+          putWord32le (s+0)+          putWord32le (s+1)+          putWord32le (s+2)+          putWord32le (s+3)+          putWord32le (s+4)+          putWord32le (s+5)+          putWord32le (s+6)+          putWord32le (s+7)+          loop (s+8) (n-8)++putWord32N16Little = loop 0+  where loop s n | s `seq` n `seq` False = undefined+        loop _ 0 = return ()+        loop s n = do+          putWord32le (s+0)+          putWord32le (s+1)+          putWord32le (s+2)+          putWord32le (s+3)+          putWord32le (s+4)+          putWord32le (s+5)+          putWord32le (s+6)+          putWord32le (s+7)+          putWord32le (s+8)+          putWord32le (s+9)+          putWord32le (s+10)+          putWord32le (s+11)+          putWord32le (s+12)+          putWord32le (s+13)+          putWord32le (s+14)+          putWord32le (s+15)+          loop (s+16) (n-16)++------------------------------------------------------------------------++putWord32N1Host = loop 0+  where loop s n | s `seq` n `seq` False = undefined+        loop _ 0 = return ()+        loop s n = do+          putWord32host (s+0)+          loop (s+1) (n-1)++putWord32N2Host = loop 0+  where loop s n | s `seq` n `seq` False = undefined+        loop _ 0 = return ()+        loop s n = do+          putWord32host (s+0)+          putWord32host (s+1)+          loop (s+2) (n-2)++putWord32N4Host = loop 0+  where loop s n | s `seq` n `seq` False = undefined+        loop _ 0 = return ()+        loop s n = do+          putWord32host (s+0)+          putWord32host (s+1)+          putWord32host (s+2)+          putWord32host (s+3)+          loop (s+4) (n-4)++putWord32N8Host = loop 0+  where loop s n | s `seq` n `seq` False = undefined+        loop _ 0 = return ()+        loop s n = do+          putWord32host (s+0)+          putWord32host (s+1)+          putWord32host (s+2)+          putWord32host (s+3)+          putWord32host (s+4)+          putWord32host (s+5)+          putWord32host (s+6)+          putWord32host (s+7)+          loop (s+8) (n-8)++putWord32N16Host = loop 0+  where loop s n | s `seq` n `seq` False = undefined+        loop _ 0 = return ()+        loop s n = do+          putWord32host (s+0)+          putWord32host (s+1)+          putWord32host (s+2)+          putWord32host (s+3)+          putWord32host (s+4)+          putWord32host (s+5)+          putWord32host (s+6)+          putWord32host (s+7)+          putWord32host (s+8)+          putWord32host (s+9)+          putWord32host (s+10)+          putWord32host (s+11)+          putWord32host (s+12)+          putWord32host (s+13)+          putWord32host (s+14)+          putWord32host (s+15)+          loop (s+16) (n-16)++------------------------------------------------------------------------++putWord64N1Big = loop 0+  where loop s n | s `seq` n `seq` False = undefined+        loop _ 0 = return ()+        loop s n = do+          putWord64be (s+0)+          loop (s+1) (n-1)++putWord64N2Big = loop 0+  where loop s n | s `seq` n `seq` False = undefined+        loop _ 0 = return ()+        loop s n = do+          putWord64be (s+0)+          putWord64be (s+1)+          loop (s+2) (n-2)++putWord64N4Big = loop 0+  where loop s n | s `seq` n `seq` False = undefined+        loop _ 0 = return ()+        loop s n = do+          putWord64be (s+0)+          putWord64be (s+1)+          putWord64be (s+2)+          putWord64be (s+3)+          loop (s+4) (n-4)++putWord64N8Big = loop 0+  where loop s n | s `seq` n `seq` False = undefined+        loop _ 0 = return ()+        loop s n = do+          putWord64be (s+0)+          putWord64be (s+1)+          putWord64be (s+2)+          putWord64be (s+3)+          putWord64be (s+4)+          putWord64be (s+5)+          putWord64be (s+6)+          putWord64be (s+7)+          loop (s+8) (n-8)++putWord64N16Big = loop 0+  where loop s n | s `seq` n `seq` False = undefined+        loop _ 0 = return ()+        loop s n = do+          putWord64be (s+0)+          putWord64be (s+1)+          putWord64be (s+2)+          putWord64be (s+3)+          putWord64be (s+4)+          putWord64be (s+5)+          putWord64be (s+6)+          putWord64be (s+7)+          putWord64be (s+8)+          putWord64be (s+9)+          putWord64be (s+10)+          putWord64be (s+11)+          putWord64be (s+12)+          putWord64be (s+13)+          putWord64be (s+14)+          putWord64be (s+15)+          loop (s+16) (n-16)++------------------------------------------------------------------------++putWord64N1Little = loop 0+  where loop s n | s `seq` n `seq` False = undefined+        loop _ 0 = return ()+        loop s n = do+          putWord64le (s+0)+          loop (s+1) (n-1)++putWord64N2Little = loop 0+  where loop s n | s `seq` n `seq` False = undefined+        loop _ 0 = return ()+        loop s n = do+          putWord64le (s+0)+          putWord64le (s+1)+          loop (s+2) (n-2)++putWord64N4Little = loop 0+  where loop s n | s `seq` n `seq` False = undefined+        loop _ 0 = return ()+        loop s n = do+          putWord64le (s+0)+          putWord64le (s+1)+          putWord64le (s+2)+          putWord64le (s+3)+          loop (s+4) (n-4)++putWord64N8Little = loop 0+  where loop s n | s `seq` n `seq` False = undefined+        loop _ 0 = return ()+        loop s n = do+          putWord64le (s+0)+          putWord64le (s+1)+          putWord64le (s+2)+          putWord64le (s+3)+          putWord64le (s+4)+          putWord64le (s+5)+          putWord64le (s+6)+          putWord64le (s+7)+          loop (s+8) (n-8)++putWord64N16Little = loop 0+  where loop s n | s `seq` n `seq` False = undefined+        loop _ 0 = return ()+        loop s n = do+          putWord64le (s+0)+          putWord64le (s+1)+          putWord64le (s+2)+          putWord64le (s+3)+          putWord64le (s+4)+          putWord64le (s+5)+          putWord64le (s+6)+          putWord64le (s+7)+          putWord64le (s+8)+          putWord64le (s+9)+          putWord64le (s+10)+          putWord64le (s+11)+          putWord64le (s+12)+          putWord64le (s+13)+          putWord64le (s+14)+          putWord64le (s+15)+          loop (s+16) (n-16)++------------------------------------------------------------------------++putWord64N1Host = loop 0+  where loop s n | s `seq` n `seq` False = undefined+        loop _ 0 = return ()+        loop s n = do+          putWord64host (s+0)+          loop (s+1) (n-1)++putWord64N2Host = loop 0+  where loop s n | s `seq` n `seq` False = undefined+        loop _ 0 = return ()+        loop s n = do+          putWord64host (s+0)+          putWord64host (s+1)+          loop (s+2) (n-2)++putWord64N4Host = loop 0+  where loop s n | s `seq` n `seq` False = undefined+        loop _ 0 = return ()+        loop s n = do+          putWord64host (s+0)+          putWord64host (s+1)+          putWord64host (s+2)+          putWord64host (s+3)+          loop (s+4) (n-4)++putWord64N8Host = loop 0+  where loop s n | s `seq` n `seq` False = undefined+        loop _ 0 = return ()+        loop s n = do+          putWord64host (s+0)+          putWord64host (s+1)+          putWord64host (s+2)+          putWord64host (s+3)+          putWord64host (s+4)+          putWord64host (s+5)+          putWord64host (s+6)+          putWord64host (s+7)+          loop (s+8) (n-8)++putWord64N16Host = loop 0+  where loop s n | s `seq` n `seq` False = undefined+        loop _ 0 = return ()+        loop s n = do+          putWord64host (s+0)+          putWord64host (s+1)+          putWord64host (s+2)+          putWord64host (s+3)+          putWord64host (s+4)+          putWord64host (s+5)+          putWord64host (s+6)+          putWord64host (s+7)+          putWord64host (s+8)+          putWord64host (s+9)+          putWord64host (s+10)+          putWord64host (s+11)+          putWord64host (s+12)+          putWord64host (s+13)+          putWord64host (s+14)+          putWord64host (s+15)+          loop (s+16) (n-16)++------------------------------------------------------------------------+------------------------------------------------------------------------++getWord8N1 = loop 0+  where loop s n | s `seq` n `seq` False = undefined+        loop s 0 = return s+        loop s n = do+          s0 <- getWord8+          loop (s+s0) (n-1)++getWord8N2 = loop 0+  where loop s n | s `seq` n `seq` False = undefined+        loop s 0 = return s+        loop s n = do+          s0 <- getWord8+          s1 <- getWord8+          loop (s+s0+s1) (n-2)++getWord8N4 = loop 0+  where loop s n | s `seq` n `seq` False = undefined+        loop s 0 = return s+        loop s n = do+          s0 <- getWord8+          s1 <- getWord8+          s2 <- getWord8+          s3 <- getWord8+          loop (s+s0+s1+s2+s3) (n-4)++getWord8N8 = loop 0+  where loop s n | s `seq` n `seq` False = undefined+        loop s 0 = return s+        loop s n = do+          s0 <- getWord8+          s1 <- getWord8+          s2 <- getWord8+          s3 <- getWord8+          s4 <- getWord8+          s5 <- getWord8+          s6 <- getWord8+          s7 <- getWord8+          loop (s+s0+s1+s2+s3+s4+s5+s6+s7) (n-8)++getWord8N16 = loop 0+  where loop s n | s `seq` n `seq` False = undefined+        loop s 0 = return s+        loop s n = do+          s0 <- getWord8+          s1 <- getWord8+          s2 <- getWord8+          s3 <- getWord8+          s4 <- getWord8+          s5 <- getWord8+          s6 <- getWord8+          s7 <- getWord8+          s8 <- getWord8+          s9 <- getWord8+          s10 <- getWord8+          s11 <- getWord8+          s12 <- getWord8+          s13 <- getWord8+          s14 <- getWord8+          s15 <- getWord8+          loop (s+s0+s1+s2+s3+s4+s5+s6+s7+s9+s10+s11+s12+s13+s14+s15) (n-16)++------------------------------------------------------------------------++getWord16N1Big = loop 0+  where loop s n | s `seq` n `seq` False = undefined+        loop s 0 = return s+        loop s n = do+          s0 <- getWord16be+          loop (s+s0) (n-1)++getWord16N2Big = loop 0+  where loop s n | s `seq` n `seq` False = undefined+        loop s 0 = return s+        loop s n = do+          s0 <- getWord16be+          s1 <- getWord16be+          loop (s+s0+s1) (n-2)++getWord16N4Big = loop 0+  where loop s n | s `seq` n `seq` False = undefined+        loop s 0 = return s+        loop s n = do+          s0 <- getWord16be+          s1 <- getWord16be+          s2 <- getWord16be+          s3 <- getWord16be+          loop (s+s0+s1+s2+s3) (n-4)++getWord16N8Big = loop 0+  where loop s n | s `seq` n `seq` False = undefined+        loop s 0 = return s+        loop s n = do+          s0 <- getWord16be+          s1 <- getWord16be+          s2 <- getWord16be+          s3 <- getWord16be+          s4 <- getWord16be+          s5 <- getWord16be+          s6 <- getWord16be+          s7 <- getWord16be+          loop (s+s0+s1+s2+s3+s4+s5+s6+s7) (n-8)++getWord16N16Big = loop 0+  where loop s n | s `seq` n `seq` False = undefined+        loop s 0 = return s+        loop s n = do+          s0 <- getWord16be+          s1 <- getWord16be+          s2 <- getWord16be+          s3 <- getWord16be+          s4 <- getWord16be+          s5 <- getWord16be+          s6 <- getWord16be+          s7 <- getWord16be+          s8 <- getWord16be+          s9 <- getWord16be+          s10 <- getWord16be+          s11 <- getWord16be+          s12 <- getWord16be+          s13 <- getWord16be+          s14 <- getWord16be+          s15 <- getWord16be+          loop (s+s0+s1+s2+s3+s4+s5+s6+s7+s9+s10+s11+s12+s13+s14+s15) (n-16)++------------------------------------------------------------------------++getWord16N1Little = loop 0+  where loop s n | s `seq` n `seq` False = undefined+        loop s 0 = return s+        loop s n = do+          s0 <- getWord16le+          loop (s+s0) (n-1)++getWord16N2Little = loop 0+  where loop s n | s `seq` n `seq` False = undefined+        loop s 0 = return s+        loop s n = do+          s0 <- getWord16le+          s1 <- getWord16le+          loop (s+s0+s1) (n-2)++getWord16N4Little = loop 0+  where loop s n | s `seq` n `seq` False = undefined+        loop s 0 = return s+        loop s n = do+          s0 <- getWord16le+          s1 <- getWord16le+          s2 <- getWord16le+          s3 <- getWord16le+          loop (s+s0+s1+s2+s3) (n-4)++getWord16N8Little = loop 0+  where loop s n | s `seq` n `seq` False = undefined+        loop s 0 = return s+        loop s n = do+          s0 <- getWord16le+          s1 <- getWord16le+          s2 <- getWord16le+          s3 <- getWord16le+          s4 <- getWord16le+          s5 <- getWord16le+          s6 <- getWord16le+          s7 <- getWord16le+          loop (s+s0+s1+s2+s3+s4+s5+s6+s7) (n-8)++getWord16N16Little = loop 0+  where loop s n | s `seq` n `seq` False = undefined+        loop s 0 = return s+        loop s n = do+          s0 <- getWord16le+          s1 <- getWord16le+          s2 <- getWord16le+          s3 <- getWord16le+          s4 <- getWord16le+          s5 <- getWord16le+          s6 <- getWord16le+          s7 <- getWord16le+          s8 <- getWord16le+          s9 <- getWord16le+          s10 <- getWord16le+          s11 <- getWord16le+          s12 <- getWord16le+          s13 <- getWord16le+          s14 <- getWord16le+          s15 <- getWord16le+          loop (s+s0+s1+s2+s3+s4+s5+s6+s7+s9+s10+s11+s12+s13+s14+s15) (n-16)++------------------------------------------------------------------------++getWord16N1Host = loop 0+  where loop s n | s `seq` n `seq` False = undefined+        loop s 0 = return s+        loop s n = do+          s0 <- getWord16host+          loop (s+s0) (n-1)++getWord16N2Host = loop 0+  where loop s n | s `seq` n `seq` False = undefined+        loop s 0 = return s+        loop s n = do+          s0 <- getWord16host+          s1 <- getWord16host+          loop (s+s0+s1) (n-2)++getWord16N4Host = loop 0+  where loop s n | s `seq` n `seq` False = undefined+        loop s 0 = return s+        loop s n = do+          s0 <- getWord16host+          s1 <- getWord16host+          s2 <- getWord16host+          s3 <- getWord16host+          loop (s+s0+s1+s2+s3) (n-4)++getWord16N8Host = loop 0+  where loop s n | s `seq` n `seq` False = undefined+        loop s 0 = return s+        loop s n = do+          s0 <- getWord16host+          s1 <- getWord16host+          s2 <- getWord16host+          s3 <- getWord16host+          s4 <- getWord16host+          s5 <- getWord16host+          s6 <- getWord16host+          s7 <- getWord16host+          loop (s+s0+s1+s2+s3+s4+s5+s6+s7) (n-8)++getWord16N16Host = loop 0+  where loop s n | s `seq` n `seq` False = undefined+        loop s 0 = return s+        loop s n = do+          s0 <- getWord16host+          s1 <- getWord16host+          s2 <- getWord16host+          s3 <- getWord16host+          s4 <- getWord16host+          s5 <- getWord16host+          s6 <- getWord16host+          s7 <- getWord16host+          s8 <- getWord16host+          s9 <- getWord16host+          s10 <- getWord16host+          s11 <- getWord16host+          s12 <- getWord16host+          s13 <- getWord16host+          s14 <- getWord16host+          s15 <- getWord16host+          loop (s+s0+s1+s2+s3+s4+s5+s6+s7+s9+s10+s11+s12+s13+s14+s15) (n-16)++------------------------------------------------------------------------++getWord32N1Big = loop 0+  where loop s n | s `seq` n `seq` False = undefined+        loop s 0 = return s+        loop s n = do+          s0 <- getWord32be+          loop (s+s0) (n-1)++getWord32N2Big = loop 0+  where loop s n | s `seq` n `seq` False = undefined+        loop s 0 = return s+        loop s n = do+          s0 <- getWord32be+          s1 <- getWord32be+          loop (s+s0+s1) (n-2)++getWord32N4Big = loop 0+  where loop s n | s `seq` n `seq` False = undefined+        loop s 0 = return s+        loop s n = do+          s0 <- getWord32be+          s1 <- getWord32be+          s2 <- getWord32be+          s3 <- getWord32be+          loop (s+s0+s1+s2+s3) (n-4)++getWord32N8Big = loop 0+  where loop s n | s `seq` n `seq` False = undefined+        loop s 0 = return s+        loop s n = do+          s0 <- getWord32be+          s1 <- getWord32be+          s2 <- getWord32be+          s3 <- getWord32be+          s4 <- getWord32be+          s5 <- getWord32be+          s6 <- getWord32be+          s7 <- getWord32be+          loop (s+s0+s1+s2+s3+s4+s5+s6+s7) (n-8)++-- getWordhostN16 = loop 0+getWord32N16Big = loop 0+  where loop s n | s `seq` n `seq` False = undefined+        loop s 0 = return s+        loop s n = do+          s0 <- getWord32be+          s1 <- getWord32be+          s2 <- getWord32be+          s3 <- getWord32be+          s4 <- getWord32be+          s5 <- getWord32be+          s6 <- getWord32be+          s7 <- getWord32be+          s8 <- getWord32be+          s9 <- getWord32be+          s10 <- getWord32be+          s11 <- getWord32be+          s12 <- getWord32be+          s13 <- getWord32be+          s14 <- getWord32be+          s15 <- getWord32be+          loop (s+s0+s1+s2+s3+s4+s5+s6+s7+s9+s10+s11+s12+s13+s14+s15) (n-16)++------------------------------------------------------------------------++getWord32N1Little = loop 0+  where loop s n | s `seq` n `seq` False = undefined+        loop s 0 = return s+        loop s n = do+          s0 <- getWord32le+          loop (s+s0) (n-1)++getWord32N2Little = loop 0+  where loop s n | s `seq` n `seq` False = undefined+        loop s 0 = return s+        loop s n = do+          s0 <- getWord32le+          s1 <- getWord32le+          loop (s+s0+s1) (n-2)++getWord32N4Little = loop 0+  where loop s n | s `seq` n `seq` False = undefined+        loop s 0 = return s+        loop s n = do+          s0 <- getWord32le+          s1 <- getWord32le+          s2 <- getWord32le+          s3 <- getWord32le+          loop (s+s0+s1+s2+s3) (n-4)++getWord32N8Little = loop 0+  where loop s n | s `seq` n `seq` False = undefined+        loop s 0 = return s+        loop s n = do+          s0 <- getWord32le+          s1 <- getWord32le+          s2 <- getWord32le+          s3 <- getWord32le+          s4 <- getWord32le+          s5 <- getWord32le+          s6 <- getWord32le+          s7 <- getWord32le+          loop (s+s0+s1+s2+s3+s4+s5+s6+s7) (n-8)++-- getWordhostN16 = loop 0+getWord32N16Little = loop 0+  where loop s n | s `seq` n `seq` False = undefined+        loop s 0 = return s+        loop s n = do+          s0 <- getWord32le+          s1 <- getWord32le+          s2 <- getWord32le+          s3 <- getWord32le+          s4 <- getWord32le+          s5 <- getWord32le+          s6 <- getWord32le+          s7 <- getWord32le+          s8 <- getWord32le+          s9 <- getWord32le+          s10 <- getWord32le+          s11 <- getWord32le+          s12 <- getWord32le+          s13 <- getWord32le+          s14 <- getWord32le+          s15 <- getWord32le+          loop (s+s0+s1+s2+s3+s4+s5+s6+s7+s9+s10+s11+s12+s13+s14+s15) (n-16)++------------------------------------------------------------------------++getWord32N1Host = loop 0+  where loop s n | s `seq` n `seq` False = undefined+        loop s 0 = return s+        loop s n = do+          s0 <- getWord32host+          loop (s+s0) (n-1)++getWord32N2Host = loop 0+  where loop s n | s `seq` n `seq` False = undefined+        loop s 0 = return s+        loop s n = do+          s0 <- getWord32host+          s1 <- getWord32host+          loop (s+s0+s1) (n-2)++getWord32N4Host = loop 0+  where loop s n | s `seq` n `seq` False = undefined+        loop s 0 = return s+        loop s n = do+          s0 <- getWord32host+          s1 <- getWord32host+          s2 <- getWord32host+          s3 <- getWord32host+          loop (s+s0+s1+s2+s3) (n-4)++getWord32N8Host = loop 0+  where loop s n | s `seq` n `seq` False = undefined+        loop s 0 = return s+        loop s n = do+          s0 <- getWord32host+          s1 <- getWord32host+          s2 <- getWord32host+          s3 <- getWord32host+          s4 <- getWord32host+          s5 <- getWord32host+          s6 <- getWord32host+          s7 <- getWord32host+          loop (s+s0+s1+s2+s3+s4+s5+s6+s7) (n-8)++-- getWordhostN16 = loop 0+getWord32N16Host = loop 0+  where loop s n | s `seq` n `seq` False = undefined+        loop s 0 = return s+        loop s n = do+          s0 <- getWord32host+          s1 <- getWord32host+          s2 <- getWord32host+          s3 <- getWord32host+          s4 <- getWord32host+          s5 <- getWord32host+          s6 <- getWord32host+          s7 <- getWord32host+          s8 <- getWord32host+          s9 <- getWord32host+          s10 <- getWord32host+          s11 <- getWord32host+          s12 <- getWord32host+          s13 <- getWord32host+          s14 <- getWord32host+          s15 <- getWord32host+          loop (s+s0+s1+s2+s3+s4+s5+s6+s7+s9+s10+s11+s12+s13+s14+s15) (n-16)++------------------------------------------------------------------------++getWord64N1Big = loop 0+  where loop s n | s `seq` n `seq` False = undefined+        loop s 0 = return s+        loop s n = do+          s0 <- getWord64be+          loop (s+s0) (n-1)++getWord64N2Big = loop 0+  where loop s n | s `seq` n `seq` False = undefined+        loop s 0 = return s+        loop s n = do+          s0 <- getWord64be+          s1 <- getWord64be+          loop (s+s0+s1) (n-2)++getWord64N4Big = loop 0+  where loop s n | s `seq` n `seq` False = undefined+        loop s 0 = return s+        loop s n = do+          s0 <- getWord64be+          s1 <- getWord64be+          s2 <- getWord64be+          s3 <- getWord64be+          loop (s+s0+s1+s2+s3) (n-4)++getWord64N8Big = loop 0+  where loop s n | s `seq` n `seq` False = undefined+        loop s 0 = return s+        loop s n = do+          s0 <- getWord64be+          s1 <- getWord64be+          s2 <- getWord64be+          s3 <- getWord64be+          s4 <- getWord64be+          s5 <- getWord64be+          s6 <- getWord64be+          s7 <- getWord64be+          loop (s+s0+s1+s2+s3+s4+s5+s6+s7) (n-8)++getWord64N16Big = loop 0+  where loop s n | s `seq` n `seq` False = undefined+        loop s 0 = return s+        loop s n = do+          s0 <- getWord64be+          s1 <- getWord64be+          s2 <- getWord64be+          s3 <- getWord64be+          s4 <- getWord64be+          s5 <- getWord64be+          s6 <- getWord64be+          s7 <- getWord64be+          s8 <- getWord64be+          s9 <- getWord64be+          s10 <- getWord64be+          s11 <- getWord64be+          s12 <- getWord64be+          s13 <- getWord64be+          s14 <- getWord64be+          s15 <- getWord64be+          loop (s+s0+s1+s2+s3+s4+s5+s6+s7+s9+s10+s11+s12+s13+s14+s15) (n-16)++------------------------------------------------------------------------++getWord64N1Little = loop 0+  where loop s n | s `seq` n `seq` False = undefined+        loop s 0 = return s+        loop s n = do+          s0 <- getWord64le+          loop (s+s0) (n-1)++getWord64N2Little = loop 0+  where loop s n | s `seq` n `seq` False = undefined+        loop s 0 = return s+        loop s n = do+          s0 <- getWord64le+          s1 <- getWord64le+          loop (s+s0+s1) (n-2)++getWord64N4Little = loop 0+  where loop s n | s `seq` n `seq` False = undefined+        loop s 0 = return s+        loop s n = do+          s0 <- getWord64le+          s1 <- getWord64le+          s2 <- getWord64le+          s3 <- getWord64le+          loop (s+s0+s1+s2+s3) (n-4)++getWord64N8Little = loop 0+  where loop s n | s `seq` n `seq` False = undefined+        loop s 0 = return s+        loop s n = do+          s0 <- getWord64le+          s1 <- getWord64le+          s2 <- getWord64le+          s3 <- getWord64le+          s4 <- getWord64le+          s5 <- getWord64le+          s6 <- getWord64le+          s7 <- getWord64le+          loop (s+s0+s1+s2+s3+s4+s5+s6+s7) (n-8)++getWord64N16Little = loop 0+  where loop s n | s `seq` n `seq` False = undefined+        loop s 0 = return s+        loop s n = do+          s0 <- getWord64le+          s1 <- getWord64le+          s2 <- getWord64le+          s3 <- getWord64le+          s4 <- getWord64le+          s5 <- getWord64le+          s6 <- getWord64le+          s7 <- getWord64le+          s8 <- getWord64le+          s9 <- getWord64le+          s10 <- getWord64le+          s11 <- getWord64le+          s12 <- getWord64le+          s13 <- getWord64le+          s14 <- getWord64le+          s15 <- getWord64le+          loop (s+s0+s1+s2+s3+s4+s5+s6+s7+s9+s10+s11+s12+s13+s14+s15) (n-16)++------------------------------------------------------------------------++getWord64N1Host = loop 0+  where loop s n | s `seq` n `seq` False = undefined+        loop s 0 = return s+        loop s n = do+          s0 <- getWord64host+          loop (s+s0) (n-1)++getWord64N2Host = loop 0+  where loop s n | s `seq` n `seq` False = undefined+        loop s 0 = return s+        loop s n = do+          s0 <- getWord64host+          s1 <- getWord64host+          loop (s+s0+s1) (n-2)++getWord64N4Host = loop 0+  where loop s n | s `seq` n `seq` False = undefined+        loop s 0 = return s+        loop s n = do+          s0 <- getWord64host+          s1 <- getWord64host+          s2 <- getWord64host+          s3 <- getWord64host+          loop (s+s0+s1+s2+s3) (n-4)++getWord64N8Host = loop 0+  where loop s n | s `seq` n `seq` False = undefined+        loop s 0 = return s+        loop s n = do+          s0 <- getWord64host+          s1 <- getWord64host+          s2 <- getWord64host+          s3 <- getWord64host+          s4 <- getWord64host+          s5 <- getWord64host+          s6 <- getWord64host+          s7 <- getWord64host+          loop (s+s0+s1+s2+s3+s4+s5+s6+s7) (n-8)++getWord64N16Host = loop 0+  where loop s n | s `seq` n `seq` False = undefined+        loop s 0 = return s+        loop s n = do+          s0 <- getWord64host+          s1 <- getWord64host+          s2 <- getWord64host+          s3 <- getWord64host+          s4 <- getWord64host+          s5 <- getWord64host+          s6 <- getWord64host+          s7 <- getWord64host+          s8 <- getWord64host+          s9 <- getWord64host+          s10 <- getWord64host+          s11 <- getWord64host+          s12 <- getWord64host+          s13 <- getWord64host+          s14 <- getWord64host+          s15 <- getWord64host+          loop (s+s0+s1+s2+s3+s4+s5+s6+s7+s9+s10+s11+s12+s13+s14+s15) (n-16)

@@ -0,0 +1,39 @@+#include "CBenchmark.h"++void bytewrite(unsigned char *a, int bytes) {+  unsigned char n = 0;+  int i = 0;+  int iterations = bytes;+  while (i < iterations) {+    a[i++] = n++;+  }+}++unsigned char byteread(unsigned char *a, int bytes) {+  unsigned char n = 0;+  int i = 0;+  int iterations = bytes;+  while (i < iterations) {+    n += a[i++];+  }+  return n;+}++void wordwrite(unsigned long *a, int bytes) {+  unsigned long n = 0;+  int i = 0;+  int iterations = bytes / sizeof(unsigned long) ;+  while (i < iterations) {+    a[i++] = n++;+  }+}++unsigned int wordread(unsigned long *a, int bytes) {+  unsigned long n = 0;+  int i = 0;+  int iterations = bytes / sizeof(unsigned long);+  while (i < iterations) {+    n += a[i++];+  }+  return n;+}

@@ -0,0 +1,4 @@+void bytewrite(unsigned char *a, int bytes);+unsigned char byteread(unsigned char *a, int bytes);+void wordwrite(unsigned long *a, int bytes);+unsigned int wordread(unsigned long *a, int bytes);

@@ -0,0 +1,17 @@+-- Checks heap behavior of getBytes++import Data.Binary.Get (runGet, getBytes)++import Control.Monad (liftM)+import qualified Data.ByteString.Lazy as L++main = do+       let x = (L.take 110000042 $ L.iterate (+1) 0)+       mapM_ (print . L.length) (chunks 20000000 x)++chunks n = runGet (unfoldM f)+  where f = do x <- getBytes 20000000 +               return $ if L.null x then Nothing else Just x++unfoldM :: Monad m => m (Maybe a) -> m [a]+unfoldM f = f >>= maybe (return []) (\x -> liftM (x:) (unfoldM f))

@@ -0,0 +1,34 @@+all: compiled+     +interpreted:+	runhaskell QC.hs 1000++compiled:+	ghc --make -fhpc -O QC.hs -o qc -no-recomp -threaded+	./qc 500 +RTS -qw -N2++bench:: Benchmark.hs MemBench.hs CBenchmark.o+	ghc --make -O2 Benchmark.hs -fasm CBenchmark.o -o bench -no-recomp+	./bench 100++bench-nb::+	ghc --make -O2 -fliberate-case-threshold=1000 NewBenchmark.hs -fasm -o bench-nb+	./bench-nb ++CBenchmark.o: CBenchmark.c+	gcc -O -c $< -o $@++hugs:+	runhugs -98 QC.hs  +++HeapUse: HeapUse.hs+	ghc --make -O $^ -fasm -o $@++heap: HeapUse+	./HeapUse +RTS -M10M -t/dev/stderr -RTS++clean:+	rm -f *.o *.hi qc bench bench-nb *~++.PHONY: clean bench bench-nb

@@ -0,0 +1,85 @@+{-# OPTIONS_GHC -fffi -fbang-patterns #-}+module MemBench (memBench) where++import Foreign+import Foreign.C++import Control.Exception+import System.CPUTime+import Numeric++memBench :: Int -> IO ()+memBench mb = do+  let bytes = mb * 2^20+  allocaBytes bytes $ \ptr -> do+    let bench label test = do+          seconds <- time $ test (castPtr ptr) (fromIntegral bytes)+          let throughput = fromIntegral mb / seconds+          putStrLn $ show mb ++ "MB of " ++ label+                  ++ " in " ++ showFFloat (Just 3) seconds "s, at: "+                  ++ showFFloat (Just 1) throughput "MB/s"+    bench "setup        " c_wordwrite+    putStrLn ""+    putStrLn "C memory throughput benchmarks:"+    bench "bytes written" c_bytewrite+    bench "bytes read   " c_byteread+    bench "words written" c_wordwrite+    bench "words read   " c_wordread+    putStrLn ""+    putStrLn "Haskell memory throughput benchmarks:"+    bench "bytes written" hs_bytewrite+    bench "bytes read   " hs_byteread+    bench "words written" hs_wordwrite+    bench "words read   " hs_wordread++hs_bytewrite  :: Ptr CUChar -> Int -> IO ()+hs_bytewrite !ptr bytes = loop 0 0+  where iterations = bytes+        loop :: Int -> CUChar -> IO ()+        loop !i !n | i == iterations = return ()+                   | otherwise = do pokeByteOff ptr i n+                                    loop (i+1) (n+1)++hs_byteread  :: Ptr CUChar -> Int -> IO CUChar+hs_byteread !ptr bytes = loop 0 0+  where iterations = bytes+        loop :: Int -> CUChar -> IO CUChar+        loop !i !n | i == iterations = return n+                   | otherwise = do x <- peekByteOff ptr i+                                    loop (i+1) (n+x)++hs_wordwrite :: Ptr CULong -> Int -> IO ()+hs_wordwrite !ptr bytes = loop 0 0+  where iterations = bytes `div` sizeOf (undefined :: CULong)+        loop :: Int -> CULong -> IO ()+        loop !i !n | i == iterations = return ()+                   | otherwise = do pokeByteOff ptr i n+                                    loop (i+1) (n+1)++hs_wordread  :: Ptr CULong -> Int -> IO CULong+hs_wordread !ptr bytes = loop 0 0+  where iterations = bytes `div` sizeOf (undefined :: CULong)+        loop :: Int -> CULong -> IO CULong+        loop !i !n | i == iterations = return n+                   | otherwise = do x <- peekByteOff ptr i+                                    loop (i+1) (n+x)+++foreign import ccall unsafe "CBenchmark.h byteread"+  c_byteread :: Ptr CUChar -> CInt -> IO ()++foreign import ccall unsafe "CBenchmark.h bytewrite"+  c_bytewrite :: Ptr CUChar -> CInt -> IO ()++foreign import ccall unsafe "CBenchmark.h wordread"+  c_wordread :: Ptr CUInt -> CInt -> IO ()++foreign import ccall unsafe "CBenchmark.h wordwrite"+  c_wordwrite :: Ptr CUInt -> CInt -> IO ()++time :: IO a -> IO Double+time action = do+    start <- getCPUTime+    action+    end   <- getCPUTime+    return $! (fromIntegral (end - start)) / (10^12)

@@ -0,0 +1,625 @@+--+-- benchmark NewBinary+--++module Main where++import System.IO+import Data.Word+import NewBinary++import Control.Exception+import System.CPUTime+import Numeric++mb :: Int+mb = 10++main :: IO ()+main = sequence_ +  [ test wordSize chunkSize mb+  | wordSize  <- [1,2,4,8]+  , chunkSize <- [1,2,4,8,16] ]++time :: IO a -> IO Double+time action = do+    start <- getCPUTime+    action+    end   <- getCPUTime+    return $! (fromIntegral (end - start)) / (10^12)++test :: Int -> Int -> Int -> IO ()+test wordSize chunkSize mb = do+    let bytes :: Int+        bytes = mb * 2^20+        iterations = bytes `div` wordSize+    putStr $ show mb ++ "MB of Word" ++ show (8 * wordSize)+          ++ " in chunks of " ++ show chunkSize ++ ": "+    h <- openBinMem bytes undefined+    start <- tellBin h+    putSeconds <- time $ do+      doPut wordSize chunkSize h iterations+--      BinPtr n _ <- tellBin h+--      print n+    getSeconds <- time $ do+      seekBin h start+      sum <- doGet wordSize chunkSize h iterations+      evaluate sum+--      BinPtr n _ <- tellBin h+--      print (n, sum)+    let putThroughput = fromIntegral mb / putSeconds+        getThroughput = fromIntegral mb / getSeconds+    putStrLn $ showFFloat (Just 2) putThroughput "MB/s write, "+            ++ showFFloat (Just 2) getThroughput "MB/s read"++doPut :: Int -> Int -> BinHandle -> Int -> IO ()+doPut wordSize chunkSize =+  case (wordSize, chunkSize) of+    (1, 1)  -> putWord8N1+    (1, 2)  -> putWord8N2+    (1, 4)  -> putWord8N4+    (1, 8)  -> putWord8N8+    (1, 16) -> putWord8N16+    (2, 1)  -> putWord16N1+    (2, 2)  -> putWord16N2+    (2, 4)  -> putWord16N4+    (2, 8)  -> putWord16N8+    (2, 16) -> putWord16N16+    (4, 1)  -> putWord32N1+    (4, 2)  -> putWord32N2+    (4, 4)  -> putWord32N4+    (4, 8)  -> putWord32N8+    (4, 16) -> putWord32N16+    (8, 1)  -> putWord64N1+    (8, 2)  -> putWord64N2+    (8, 4)  -> putWord64N4+    (8, 8)  -> putWord64N8+    (8, 16) -> putWord64N16++putWord8 :: BinHandle -> Word8 -> IO ()+putWord8 = put_+{-# INLINE putWord8 #-}++putWord16be :: BinHandle -> Word16 -> IO ()+putWord16be = put_+{-# INLINE putWord16be #-}++putWord32be :: BinHandle -> Word32 -> IO ()+putWord32be = put_+{-# INLINE putWord32be #-}++putWord64be :: BinHandle -> Word64 -> IO ()+putWord64be = put_+{-# INLINE putWord64be #-}++getWord8 :: BinHandle -> IO Word8+getWord8 = get+{-# INLINE getWord8 #-}++getWord16be :: BinHandle -> IO Word16+getWord16be = get+{-# INLINE getWord16be #-}++getWord32be :: BinHandle -> IO Word32+getWord32be = get+{-# INLINE getWord32be #-}++getWord64be :: BinHandle -> IO Word64+getWord64be = get+{-# INLINE getWord64be #-}++putWord8N1 hnd = loop 0+  where loop s n | s `seq` n `seq` False = undefined+        loop _ 0 = return ()+        loop s n = do+          putWord8 hnd (s+0)+          loop (s+1) (n-1)++putWord8N2 hnd = loop 0+  where loop s n | s `seq` n `seq` False = undefined+        loop _ 0 = return ()+        loop s n = do+          putWord8 hnd (s+0)+          putWord8 hnd (s+1)+          loop (s+2) (n-2)++putWord8N4 hnd = loop 0+  where loop s n | s `seq` n `seq` False = undefined+        loop _ 0 = return ()+        loop s n = do+          putWord8 hnd (s+0)+          putWord8 hnd (s+1)+          putWord8 hnd (s+2)+          putWord8 hnd (s+3)+          loop (s+4) (n-4)++putWord8N8 hnd = loop 0+  where loop s n | s `seq` n `seq` False = undefined+        loop _ 0 = return ()+        loop s n = do+          putWord8 hnd (s+0)+          putWord8 hnd (s+1)+          putWord8 hnd (s+2)+          putWord8 hnd (s+3)+          putWord8 hnd (s+4)+          putWord8 hnd (s+5)+          putWord8 hnd (s+6)+          putWord8 hnd (s+7)+          loop (s+8) (n-8)++putWord8N16 hnd = loop 0+  where loop s n | s `seq` n `seq` False = undefined+        loop _ 0 = return ()+        loop s n = do+          putWord8 hnd (s+0)+          putWord8 hnd (s+1)+          putWord8 hnd (s+2)+          putWord8 hnd (s+3)+          putWord8 hnd (s+4)+          putWord8 hnd (s+5)+          putWord8 hnd (s+6)+          putWord8 hnd (s+7)+          putWord8 hnd (s+8)+          putWord8 hnd (s+9)+          putWord8 hnd (s+10)+          putWord8 hnd (s+11)+          putWord8 hnd (s+12)+          putWord8 hnd (s+13)+          putWord8 hnd (s+14)+          putWord8 hnd (s+15)+          loop (s+16) (n-16)+++putWord16N1 hnd = loop 0+  where loop s n | s `seq` n `seq` False = undefined+        loop _ 0 = return ()+        loop s n = do+          putWord16be hnd (s+0)+          loop (s+1) (n-1)++putWord16N2 hnd = loop 0+  where loop s n | s `seq` n `seq` False = undefined+        loop _ 0 = return ()+        loop s n = do+          putWord16be hnd (s+0)+          putWord16be hnd (s+1)+          loop (s+2) (n-2)++putWord16N4 hnd = loop 0+  where loop s n | s `seq` n `seq` False = undefined+        loop _ 0 = return ()+        loop s n = do+          putWord16be hnd (s+0)+          putWord16be hnd (s+1)+          putWord16be hnd (s+2)+          putWord16be hnd (s+3)+          loop (s+4) (n-4)++putWord16N8 hnd = loop 0+  where loop s n | s `seq` n `seq` False = undefined+        loop _ 0 = return ()+        loop s n = do+          putWord16be hnd (s+0)+          putWord16be hnd (s+1)+          putWord16be hnd (s+2)+          putWord16be hnd (s+3)+          putWord16be hnd (s+4)+          putWord16be hnd (s+5)+          putWord16be hnd (s+6)+          putWord16be hnd (s+7)+          loop (s+8) (n-8)++putWord16N16 hnd = loop 0+  where loop s n | s `seq` n `seq` False = undefined+        loop _ 0 = return ()+        loop s n = do+          putWord16be hnd (s+0)+          putWord16be hnd (s+1)+          putWord16be hnd (s+2)+          putWord16be hnd (s+3)+          putWord16be hnd (s+4)+          putWord16be hnd (s+5)+          putWord16be hnd (s+6)+          putWord16be hnd (s+7)+          putWord16be hnd (s+8)+          putWord16be hnd (s+9)+          putWord16be hnd (s+10)+          putWord16be hnd (s+11)+          putWord16be hnd (s+12)+          putWord16be hnd (s+13)+          putWord16be hnd (s+14)+          putWord16be hnd (s+15)+          loop (s+16) (n-16)+++putWord32N1 hnd = loop 0+  where loop s n | s `seq` n `seq` False = undefined+        loop _ 0 = return ()+        loop s n = do+          putWord32be hnd (s+0)+          loop (s+1) (n-1)++putWord32N2 hnd = loop 0+  where loop s n | s `seq` n `seq` False = undefined+        loop _ 0 = return ()+        loop s n = do+          putWord32be hnd (s+0)+          putWord32be hnd (s+1)+          loop (s+2) (n-2)++putWord32N4 hnd = loop 0+  where loop s n | s `seq` n `seq` False = undefined+        loop _ 0 = return ()+        loop s n = do+          putWord32be hnd (s+0)+          putWord32be hnd (s+1)+          putWord32be hnd (s+2)+          putWord32be hnd (s+3)+          loop (s+4) (n-4)++putWord32N8 hnd = loop 0+  where loop s n | s `seq` n `seq` False = undefined+        loop _ 0 = return ()+        loop s n = do+          putWord32be hnd (s+0)+          putWord32be hnd (s+1)+          putWord32be hnd (s+2)+          putWord32be hnd (s+3)+          putWord32be hnd (s+4)+          putWord32be hnd (s+5)+          putWord32be hnd (s+6)+          putWord32be hnd (s+7)+          loop (s+8) (n-8)++putWord32N16 hnd = loop 0+  where loop s n | s `seq` n `seq` False = undefined+        loop _ 0 = return ()+        loop s n = do+          putWord32be hnd (s+0)+          putWord32be hnd (s+1)+          putWord32be hnd (s+2)+          putWord32be hnd (s+3)+          putWord32be hnd (s+4)+          putWord32be hnd (s+5)+          putWord32be hnd (s+6)+          putWord32be hnd (s+7)+          putWord32be hnd (s+8)+          putWord32be hnd (s+9)+          putWord32be hnd (s+10)+          putWord32be hnd (s+11)+          putWord32be hnd (s+12)+          putWord32be hnd (s+13)+          putWord32be hnd (s+14)+          putWord32be hnd (s+15)+          loop (s+16) (n-16)++putWord64N1 hnd = loop 0+  where loop s n | s `seq` n `seq` False = undefined+        loop _ 0 = return ()+        loop s n = do+          putWord64be hnd (s+0)+          loop (s+1) (n-1)++putWord64N2 hnd = loop 0+  where loop s n | s `seq` n `seq` False = undefined+        loop _ 0 = return ()+        loop s n = do+          putWord64be hnd (s+0)+          putWord64be hnd (s+1)+          loop (s+2) (n-2)++putWord64N4 hnd = loop 0+  where loop s n | s `seq` n `seq` False = undefined+        loop _ 0 = return ()+        loop s n = do+          putWord64be hnd (s+0)+          putWord64be hnd (s+1)+          putWord64be hnd (s+2)+          putWord64be hnd (s+3)+          loop (s+4) (n-4)++putWord64N8 hnd = loop 0+  where loop s n | s `seq` n `seq` False = undefined+        loop _ 0 = return ()+        loop s n = do+          putWord64be hnd (s+0)+          putWord64be hnd (s+1)+          putWord64be hnd (s+2)+          putWord64be hnd (s+3)+          putWord64be hnd (s+4)+          putWord64be hnd (s+5)+          putWord64be hnd (s+6)+          putWord64be hnd (s+7)+          loop (s+8) (n-8)++putWord64N16 hnd = loop 0+  where loop s n | s `seq` n `seq` False = undefined+        loop _ 0 = return ()+        loop s n = do+          putWord64be hnd (s+0)+          putWord64be hnd (s+1)+          putWord64be hnd (s+2)+          putWord64be hnd (s+3)+          putWord64be hnd (s+4)+          putWord64be hnd (s+5)+          putWord64be hnd (s+6)+          putWord64be hnd (s+7)+          putWord64be hnd (s+8)+          putWord64be hnd (s+9)+          putWord64be hnd (s+10)+          putWord64be hnd (s+11)+          putWord64be hnd (s+12)+          putWord64be hnd (s+13)+          putWord64be hnd (s+14)+          putWord64be hnd (s+15)+          loop (s+16) (n-16)++doGet :: Int -> Int -> BinHandle -> Int ->  IO Int+doGet wordSize chunkSize hnd =+  case (wordSize, chunkSize) of+    (1, 1)  -> fmap fromIntegral . getWord8N1 hnd+    (1, 2)  -> fmap fromIntegral . getWord8N2 hnd+    (1, 4)  -> fmap fromIntegral . getWord8N4 hnd+    (1, 8)  -> fmap fromIntegral . getWord8N8 hnd+    (1, 16) -> fmap fromIntegral . getWord8N16 hnd+    (2, 1)  -> fmap fromIntegral . getWord16N1 hnd+    (2, 2)  -> fmap fromIntegral . getWord16N2 hnd+    (2, 4)  -> fmap fromIntegral . getWord16N4 hnd+    (2, 8)  -> fmap fromIntegral . getWord16N8 hnd+    (2, 16) -> fmap fromIntegral . getWord16N16 hnd+    (4, 1)  -> fmap fromIntegral . getWord32N1 hnd+    (4, 2)  -> fmap fromIntegral . getWord32N2 hnd+    (4, 4)  -> fmap fromIntegral . getWord32N4 hnd+    (4, 8)  -> fmap fromIntegral . getWord32N8 hnd+    (4, 16) -> fmap fromIntegral . getWord32N16 hnd+    (8, 1)  -> fmap fromIntegral . getWord64N1 hnd+    (8, 2)  -> fmap fromIntegral . getWord64N2 hnd+    (8, 4)  -> fmap fromIntegral . getWord64N4 hnd+    (8, 8)  -> fmap fromIntegral . getWord64N8 hnd+    (8, 16) -> fmap fromIntegral . getWord64N16 hnd++getWord8N1 hnd = loop 0+  where loop s n | s `seq` n `seq` False = undefined+        loop s 0 = return s+        loop s n = do+          s0 <- getWord8 hnd+          loop (s+s0) (n-1)++getWord8N2 hnd = loop 0+  where loop s n | s `seq` n `seq` False = undefined+        loop s 0 = return s+        loop s n = do+          s0 <- getWord8 hnd+          s1 <- getWord8 hnd+          loop (s+s0+s1) (n-2)++getWord8N4 hnd = loop 0+  where loop s n | s `seq` n `seq` False = undefined+        loop s 0 = return s+        loop s n = do+          s0 <- getWord8 hnd+          s1 <- getWord8 hnd+          s2 <- getWord8 hnd+          s3 <- getWord8 hnd+          loop (s+s0+s1+s2+s3) (n-4)++getWord8N8 hnd = loop 0+  where loop s n | s `seq` n `seq` False = undefined+        loop s 0 = return s+        loop s n = do+          s0 <- getWord8 hnd+          s1 <- getWord8 hnd+          s2 <- getWord8 hnd+          s3 <- getWord8 hnd+          s4 <- getWord8 hnd+          s5 <- getWord8 hnd+          s6 <- getWord8 hnd+          s7 <- getWord8 hnd+          loop (s+s0+s1+s2+s3+s4+s5+s6+s7) (n-8)++getWord8N16 hnd = loop 0+  where loop s n | s `seq` n `seq` False = undefined+        loop s 0 = return s+        loop s n = do+          s0 <- getWord8 hnd+          s1 <- getWord8 hnd+          s2 <- getWord8 hnd+          s3 <- getWord8 hnd+          s4 <- getWord8 hnd+          s5 <- getWord8 hnd+          s6 <- getWord8 hnd+          s7 <- getWord8 hnd+          s8 <- getWord8 hnd+          s9 <- getWord8 hnd+          s10 <- getWord8 hnd+          s11 <- getWord8 hnd+          s12 <- getWord8 hnd+          s13 <- getWord8 hnd+          s14 <- getWord8 hnd+          s15 <- getWord8 hnd+          loop (s+s0+s1+s2+s3+s4+s5+s6+s7+s9+s10+s11+s12+s13+s14+s15) (n-16)+++getWord16N1 hnd = loop 0+  where loop s n | s `seq` n `seq` False = undefined+        loop s 0 = return s+        loop s n = do+          s0 <- getWord16be hnd+          loop (s+s0) (n-1)++getWord16N2 hnd = loop 0+  where loop s n | s `seq` n `seq` False = undefined+        loop s 0 = return s+        loop s n = do+          s0 <- getWord16be hnd+          s1 <- getWord16be hnd+          loop (s+s0+s1) (n-2)++getWord16N4 hnd = loop 0+  where loop s n | s `seq` n `seq` False = undefined+        loop s 0 = return s+        loop s n = do+          s0 <- getWord16be hnd+          s1 <- getWord16be hnd+          s2 <- getWord16be hnd+          s3 <- getWord16be hnd+          loop (s+s0+s1+s2+s3) (n-4)++getWord16N8 hnd = loop 0+  where loop s n | s `seq` n `seq` False = undefined+        loop s 0 = return s+        loop s n = do+          s0 <- getWord16be hnd+          s1 <- getWord16be hnd+          s2 <- getWord16be hnd+          s3 <- getWord16be hnd+          s4 <- getWord16be hnd+          s5 <- getWord16be hnd+          s6 <- getWord16be hnd+          s7 <- getWord16be hnd+          loop (s+s0+s1+s2+s3+s4+s5+s6+s7) (n-8)++getWord16N16 hnd = loop 0+  where loop s n | s `seq` n `seq` False = undefined+        loop s 0 = return s+        loop s n = do+          s0 <- getWord16be hnd+          s1 <- getWord16be hnd+          s2 <- getWord16be hnd+          s3 <- getWord16be hnd+          s4 <- getWord16be hnd+          s5 <- getWord16be hnd+          s6 <- getWord16be hnd+          s7 <- getWord16be hnd+          s8 <- getWord16be hnd+          s9 <- getWord16be hnd+          s10 <- getWord16be hnd+          s11 <- getWord16be hnd+          s12 <- getWord16be hnd+          s13 <- getWord16be hnd+          s14 <- getWord16be hnd+          s15 <- getWord16be hnd+          loop (s+s0+s1+s2+s3+s4+s5+s6+s7+s9+s10+s11+s12+s13+s14+s15) (n-16)+++getWord32N1 hnd = loop 0+  where loop s n | s `seq` n `seq` False = undefined+        loop s 0 = return s+        loop s n = do+          s0 <- getWord32be hnd+          loop (s+s0) (n-1)++getWord32N2 hnd = loop 0+  where loop s n | s `seq` n `seq` False = undefined+        loop s 0 = return s+        loop s n = do+          s0 <- getWord32be hnd+          s1 <- getWord32be hnd+          loop (s+s0+s1) (n-2)++getWord32N4 hnd = loop 0+  where loop s n | s `seq` n `seq` False = undefined+        loop s 0 = return s+        loop s n = do+          s0 <- getWord32be hnd+          s1 <- getWord32be hnd+          s2 <- getWord32be hnd+          s3 <- getWord32be hnd+          loop (s+s0+s1+s2+s3) (n-4)++getWord32N8 hnd = loop 0+  where loop s n | s `seq` n `seq` False = undefined+        loop s 0 = return s+        loop s n = do+          s0 <- getWord32be hnd+          s1 <- getWord32be hnd+          s2 <- getWord32be hnd+          s3 <- getWord32be hnd+          s4 <- getWord32be hnd+          s5 <- getWord32be hnd+          s6 <- getWord32be hnd+          s7 <- getWord32be hnd+          loop (s+s0+s1+s2+s3+s4+s5+s6+s7) (n-8)++getWord32N16 hnd = loop 0+  where loop s n | s `seq` n `seq` False = undefined+        loop s 0 = return s+        loop s n = do+          s0 <- getWord32be hnd+          s1 <- getWord32be hnd+          s2 <- getWord32be hnd+          s3 <- getWord32be hnd+          s4 <- getWord32be hnd+          s5 <- getWord32be hnd+          s6 <- getWord32be hnd+          s7 <- getWord32be hnd+          s8 <- getWord32be hnd+          s9 <- getWord32be hnd+          s10 <- getWord32be hnd+          s11 <- getWord32be hnd+          s12 <- getWord32be hnd+          s13 <- getWord32be hnd+          s14 <- getWord32be hnd+          s15 <- getWord32be hnd+          loop (s+s0+s1+s2+s3+s4+s5+s6+s7+s9+s10+s11+s12+s13+s14+s15) (n-16)++getWord64N1 hnd = loop 0+  where loop s n | s `seq` n `seq` False = undefined+        loop s 0 = return s+        loop s n = do+          s0 <- getWord64be hnd+          loop (s+s0) (n-1)++getWord64N2 hnd = loop 0+  where loop s n | s `seq` n `seq` False = undefined+        loop s 0 = return s+        loop s n = do+          s0 <- getWord64be hnd+          s1 <- getWord64be hnd+          loop (s+s0+s1) (n-2)++getWord64N4 hnd = loop 0+  where loop s n | s `seq` n `seq` False = undefined+        loop s 0 = return s+        loop s n = do+          s0 <- getWord64be hnd+          s1 <- getWord64be hnd+          s2 <- getWord64be hnd+          s3 <- getWord64be hnd+          loop (s+s0+s1+s2+s3) (n-4)++getWord64N8 hnd = loop 0+  where loop s n | s `seq` n `seq` False = undefined+        loop s 0 = return s+        loop s n = do+          s0 <- getWord64be hnd+          s1 <- getWord64be hnd+          s2 <- getWord64be hnd+          s3 <- getWord64be hnd+          s4 <- getWord64be hnd+          s5 <- getWord64be hnd+          s6 <- getWord64be hnd+          s7 <- getWord64be hnd+          loop (s+s0+s1+s2+s3+s4+s5+s6+s7) (n-8)++getWord64N16 hnd = loop 0+  where loop s n | s `seq` n `seq` False = undefined+        loop s 0 = return s+        loop s n = do+          s0 <- getWord64be hnd+          s1 <- getWord64be hnd+          s2 <- getWord64be hnd+          s3 <- getWord64be hnd+          s4 <- getWord64be hnd+          s5 <- getWord64be hnd+          s6 <- getWord64be hnd+          s7 <- getWord64be hnd+          s8 <- getWord64be hnd+          s9 <- getWord64be hnd+          s10 <- getWord64be hnd+          s11 <- getWord64be hnd+          s12 <- getWord64be hnd+          s13 <- getWord64be hnd+          s14 <- getWord64be hnd+          s15 <- getWord64be hnd+          loop (s+s0+s1+s2+s3+s4+s5+s6+s7+s9+s10+s11+s12+s13+s14+s15) (n-16)

@@ -0,0 +1,1006 @@+{-# OPTIONS -cpp -fglasgow-exts  #-}+--+-- (c) The University of Glasgow 2002+--+-- Binary I/O library, with special tweaks for GHC+--+-- Based on the nhc98 Binary library, which is copyright+-- (c) Malcolm Wallace and Colin Runciman, University of York, 1998.+-- Under the terms of the license for that software, we must tell you+-- where you can obtain the original version of the Binary library, namely+--     http://www.cs.york.ac.uk/fp/nhc98/++module NewBinary+  ( {-type-}  Bin,+    {-class-} Binary(..),+    {-type-}  BinHandle(..),++   openBinIO, +   openBinIO_,+   openBinMem,+--   closeBin,++--   getUserData,++   seekBin,+   tellBin,+   tellBinByte,+   castBin,++   writeBinMem,+   readBinMem,++   isEOFBin,++   -- for writing instances:+   putByte,+   getByte,++   -- bit stuff+   putBits,+   getBits,+   flushByte,+   finishByte,+   putMaybeInt,+   getMaybeInt,++   -- lazy Bin I/O+   lazyGet,+   lazyPut,++   -- GHC only:+   ByteArray(..),+   getByteArray,+   putByteArray,++--   getBinFileWithDict,    -- :: Binary a => FilePath -> IO a+--   putBinFileWithDict,    -- :: Binary a => FilePath -> Module -> a -> IO ()++  ) where++#include "MachDeps.h"++import GHC.Exts+import GHC.IOBase+import GHC.Real+import Data.Array.IO        ( IOUArray )+import Data.Bits+import Data.Int+import Data.Word+import Data.Char+import Control.Monad+import Control.Exception+import Data.Array+import Data.Array.IO+import Data.Array.Base+import System.IO as IO+import System.IO.Error      ( mkIOError, eofErrorType )+import GHC.Handle       +import System.IO++import GHC.Exts+#if __GLASGOW_HASKELL__ >= 504+import GHC.IOBase+import Data.Word+import Data.Bits+#else+import PrelIOBase+import Word+import Bits+#endif++#ifndef SIZEOF_HSINT+#define SIZEOF_HSINT  INT_SIZE_IN_BYTES+#endif++#if __GLASGOW_HASKELL__ < 503+type BinArray = MutableByteArray RealWorld Int+newArray_ bounds     = stToIO (newCharArray bounds)+unsafeWrite arr ix e = stToIO (writeWord8Array arr ix e)+unsafeRead  arr ix   = stToIO (readWord8Array arr ix)++hPutArray h arr sz   = hPutBufBA h arr sz+hGetArray h sz       = hGetBufBA h sz++mkIOError :: IOErrorType -> String -> Maybe Handle -> Maybe FilePath -> Exception+mkIOError t location maybe_hdl maybe_filename+  = IOException (IOError maybe_hdl t location ""+                 maybe_filename+        )++eofErrorType = EOF++#ifndef SIZEOF_HSINT+#define SIZEOF_HSINT  INT_SIZE_IN_BYTES+#endif++#ifndef SIZEOF_HSWORD+#define SIZEOF_HSWORD WORD_SIZE_IN_BYTES+#endif++#else+type BinArray = IOUArray Int Word8+#endif++data BinHandle+  = BinMem {        -- binary data stored in an unboxed array+     off_r :: !FastMutInt,      -- the current offset+     sz_r  :: !FastMutInt,      -- size of the array (cached)+     arr_r :: !(IORef BinArray),    -- the array (bounds: (0,size-1))+     bit_off_r :: !FastMutInt,          -- the bit offset (see end of file)+     bit_cache_r :: !FastMutInt           -- the bit cache  (see end of file)+    }+    -- XXX: should really store a "high water mark" for dumping out+    -- the binary data to a file.++  | BinIO {     -- binary data stored in a file+     off_r :: !FastMutInt,      -- the current offset (cached)+     hdl   :: !IO.Handle,               -- the file handle (must be seekable)+     bit_off_r :: !FastMutInt,          -- the bit offset (see end of file)+     bit_cache_r :: !FastMutInt           -- the bit cache  (see end of file)+   }+    -- cache the file ptr in BinIO; using hTell is too expensive+    -- to call repeatedly.  If anyone else is modifying this Handle+    -- at the same time, we'll be screwed.++data Bin a = BinPtr !Int !Int -- byte/bit+  deriving (Eq, Ord, Show, Bounded)++castBin :: Bin a -> Bin b+castBin (BinPtr i j) = BinPtr i j++class Binary a where+    put_   :: BinHandle -> a -> IO ()+    put    :: BinHandle -> a -> IO (Bin a)+    get    :: BinHandle -> IO a++    -- define one of put_, put.  Use of put_ is recommended because it+    -- is more likely that tail-calls can kick in, and we rarely need the+    -- position return value.+    put_ bh a = do put bh a; return ()+    put bh a  = do p <- tellBin bh; put_ bh a; return p++putAt  :: Binary a => BinHandle -> Bin a -> a -> IO ()+putAt bh p x = do seekBin bh p; put bh x; return ()++getAt  :: Binary a => BinHandle -> Bin a -> IO a+getAt bh p = do seekBin bh p; get bh++openBinIO_ :: IO.Handle -> IO BinHandle+openBinIO_ h = openBinIO h noBinHandleUserData++newZeroInt = do r <- newFastMutInt; writeFastMutInt r 0; return r++-- openBinIO :: IO.Handle -> Module -> IO BinHandle+openBinIO :: forall t. Handle -> t -> IO BinHandle+openBinIO h mod = do+  r <- newZeroInt+  o <- newZeroInt+  c <- newZeroInt+--  state <- newWriteState mod+  return (BinIO r h o c)++--openBinMem :: Int -> Module -> IO BinHandle+openBinMem :: forall t. Int -> t -> IO BinHandle+openBinMem size mod+ | size <= 0 = error "Data.Binary.openBinMem: size must be > 0"   -- fix, was ">= 0"+ | otherwise = do+   arr <- newArray_ (0,size-1)+   arr_r <- newIORef arr+   ix_r <- newFastMutInt+   writeFastMutInt ix_r 0+   sz_r <- newFastMutInt+   writeFastMutInt sz_r size+   o <- newZeroInt+   c <- newZeroInt+--   state <- newWriteState mod+   return (BinMem ix_r sz_r arr_r o c)++noBinHandleUserData = error "Binary.BinHandle: no user data"++--getUserData :: BinHandle -> BinHandleState+--getUserData bh = state bh++tellBin :: BinHandle -> IO (Bin a)+tellBin (BinIO r _ o _)   =  do ix <- readFastMutInt r; bix <- readFastMutInt o; return (BinPtr ix bix)+tellBin (BinMem r _ _ o _) = do ix <- readFastMutInt r; bix <- readFastMutInt o; return (BinPtr ix bix)++tellBinByte (BinIO r _ _ _)    = do ix <- readFastMutInt r; return ix+tellBinByte (BinMem r _ _ _ _) = do ix <- readFastMutInt r; return ix++seekBin :: BinHandle -> Bin a -> IO ()+seekBin bh@(BinIO ix_r h o c) (BinPtr p bit) = do +  writeFastMutInt ix_r p+  writeFastMutInt o 0+  writeFastMutInt c 0+  hSeek h AbsoluteSeek (fromIntegral p)+  when (bit /= 0) $ getBits bh bit >> return ()+  return ()+seekBin h@(BinMem ix_r sz_r a o c) (BinPtr p bit) = do+  sz <- readFastMutInt sz_r+  if (p >= sz)+    then do expandBin h p+            writeFastMutInt ix_r p+            writeFastMutInt o 0+            writeFastMutInt c 0+            when (bit /= 0) $ getBits h bit >> return ()+            return ()++    else do writeFastMutInt ix_r p+            writeFastMutInt o 0+            writeFastMutInt c 0+            when (bit /= 0) $ getBits h bit >> return ()+            return ()++isEOFBin :: BinHandle -> IO Bool+isEOFBin (BinMem ix_r sz_r a _ _) = do+  ix <- readFastMutInt ix_r+  sz <- readFastMutInt sz_r+  return (ix >= sz)+isEOFBin (BinIO ix_r h _ _) = hIsEOF h++writeBinMem :: BinHandle -> FilePath -> IO ()+writeBinMem (BinIO _ _ _ _) _ = error "Data.Binary.writeBinMem: not a memory handle"+writeBinMem bh@(BinMem ix_r sz_r arr_r bit_off_r bit_cache_r) fn = do+  flushByte bh+  h <- openBinaryFile fn WriteMode+  arr <- readIORef arr_r+  ix  <- readFastMutInt ix_r+  hPutArray h arr ix+  hClose h++flushByte :: BinHandle -> IO ()+flushByte bh = do+  bit_off <- readFastMutInt (bit_off_r bh)+  if bit_off == 0+    then return ()+    else putBits bh (8 - bit_off) 0++finishByte :: BinHandle -> IO ()+finishByte bh = do+  bit_off <- readFastMutInt (bit_off_r bh)+  if bit_off == 0+    then return ()+    else getBits bh (8 - bit_off) >> return ()++readBinMem :: FilePath -> IO BinHandle+readBinMem filename = do+  h <- openBinaryFile filename ReadMode+  filesize' <- hFileSize h+  let filesize = fromIntegral filesize'+  arr <- newArray_ (0,filesize-1)+  count <- hGetArray h arr filesize+  when (count /= filesize)+    (error ("Binary.readBinMem: only read " ++ show count ++ " bytes"))+  hClose h+  arr_r <- newIORef arr+  ix_r <- newFastMutInt+  writeFastMutInt ix_r 0+  sz_r <- newFastMutInt+  writeFastMutInt sz_r filesize+  bit_off_r <- newZeroInt+  bit_cache_r <- newZeroInt+  return (BinMem {-initReadState-} ix_r sz_r arr_r bit_off_r bit_cache_r)++-- expand the size of the array to include a specified offset+expandBin :: BinHandle -> Int -> IO ()+expandBin (BinMem ix_r sz_r arr_r _ _) off = do+   sz <- readFastMutInt sz_r+   let sz' = head (dropWhile (<= off) (iterate (* 2) sz))+   arr <- readIORef arr_r+   arr' <- newArray_ (0,sz'-1)+   sequence_ [ unsafeRead arr i >>= unsafeWrite arr' i+         | i <- [ 0 .. sz-1 ] ]+   writeFastMutInt sz_r sz'+   writeIORef arr_r arr'+--   hPutStrLn stderr ("expanding to size: " ++ show sz')+   return ()+expandBin (BinIO _ _ _ _) _ = return ()+    -- no need to expand a file, we'll assume they expand by themselves.++-- -----------------------------------------------------------------------------+-- Low-level reading/writing of bytes++putWord8 :: BinHandle -> Word8 -> IO ()+putWord8 h@(BinMem ix_r sz_r arr_r bit_off_r bit_cache_r) w = do+    bit_off <- readFastMutInt bit_off_r+    if bit_off /= 0 then putBits h 8 w else do   -- only do standard putWord8 if bit_off == 0+    ix <- readFastMutInt ix_r+    sz <- readFastMutInt sz_r+    -- double the size of the array if it overflows+    if (ix >= sz) +        then do expandBin h ix+                putWord8 h w+        else do arr <- readIORef arr_r+                unsafeWrite arr ix w+                writeFastMutInt ix_r (ix+1)+                return ()++putWord8 bh@(BinIO ix_r h bit_off_r bit_cache_r) w = do+    bit_off <- readFastMutInt bit_off_r+    if bit_off /= 0 then putBits bh 8 w else do+        ix <- readFastMutInt ix_r+        hPutChar h (chr (fromIntegral w))   -- XXX not really correct+        writeFastMutInt ix_r (ix+1)+        return ()++putByteNoBits :: BinHandle -> Word8 -> IO ()+putByteNoBits h@(BinMem ix_r sz_r arr_r _ _) w = do+    ix <- readFastMutInt ix_r+    sz <- readFastMutInt sz_r+    -- double the size of the array if it overflows+    if (ix >= sz) +        then do expandBin h ix+                putByteNoBits h w+        else do arr <- readIORef arr_r+                unsafeWrite arr ix w+                writeFastMutInt ix_r (ix+1)+                return ()++putByteNoBits bh@(BinIO ix_r h _ _) w = do+    hPutChar h (chr (fromIntegral w))   -- XXX not really correct+    incFastMutInt ix_r+    return ()++getByteNoBits :: BinHandle -> IO Word8+getByteNoBits h@(BinMem ix_r sz_r arr_r _ _) = do+    ix <- readFastMutInt ix_r+    sz <- readFastMutInt sz_r+    when (ix >= sz)  $+        throw (IOException $ mkIOError eofErrorType "Data.Binary.getWord8" Nothing Nothing)+    arr <- readIORef arr_r+    w <- unsafeRead arr ix+    writeFastMutInt ix_r (ix+1)+    return w++getByteNoBits bh@(BinIO ix_r h _ _) = do+    c <- hGetChar h+    incFastMutInt ix_r+    return $! (fromIntegral (ord c))    -- XXX not really correct++getWord8 :: BinHandle -> IO Word8+getWord8 h@(BinMem ix_r sz_r arr_r bit_off_r _) = do+    bit_off <- readFastMutInt bit_off_r+    if bit_off /= 0 then getBits h 8 else do+    ix <- readFastMutInt ix_r+    sz <- readFastMutInt sz_r+    when (ix >= sz)  $+        throw (IOException $ mkIOError eofErrorType "Data.Binary.getWord8" Nothing Nothing)+    arr <- readIORef arr_r+    w <- unsafeRead arr ix+    writeFastMutInt ix_r (ix+1)+    return w+getWord8 bh@(BinIO ix_r h bit_off_r _) = do+    bit_off <- readFastMutInt bit_off_r+    if bit_off /= 0 then getBits bh 8 else do+    ix <- readFastMutInt ix_r+    c <- hGetChar h+    writeFastMutInt ix_r (ix+1)+    return $! (fromIntegral (ord c))    -- XXX not really correct++putByte :: BinHandle -> Word8 -> IO ()+putByte bh w = put_ bh w++getByte :: BinHandle -> IO Word8+getByte = getWord8++-- -----------------------------------------------------------------------------+-- Bit functions++putBits :: BinHandle -> Int -> Word8 -> IO ()+putBits bh num_bits bits {- | num_bits == 0 = return ()+                         | num_bits <  0 = error "putBits cannot write negative numbers of bits"+                         | num_bits >  8 = error "putBits cannot write more than 8 bits at a time"+                         | otherwise    -} = do+  bit_off <- readFastMutInt (bit_off_r bh)+  if num_bits + bit_off < 8+    then do incFastMutIntBy (bit_off_r bh) num_bits+            orFastMutInt (bit_cache_r bh) (bits `shiftL` bit_off)+    else if num_bits + bit_off == 8+           then do writeFastMutInt (bit_off_r bh) 0+                   bit_cache <- {-# SCC "bc1" #-} readFastMutInt (bit_cache_r bh) >>= return . fromIntegral+                   writeFastMutInt (bit_cache_r bh) 0+                   --putByte bh (bit_cache .|. (bits `shiftL` bit_off))    -- won't call putBits because bit_off_r == 0+                   putByteNoBits bh (bit_cache .|. (bits `shiftL` bit_off))++           else do let leftover_bits = 8 - bit_off                       -- we are going over a byte boundary+                   bit_cache <- {-# SCC "bc2" #-} readFastMutInt (bit_cache_r bh) >>= \x -> return ({-# SCC "fi" #-} fromIntegral x)+                   writeFastMutInt (bit_off_r bh) 0+                   writeFastMutInt (bit_cache_r bh) 0+                   {- putByte bh (bit_cache .|. (bits `shiftL` bit_off))  -}  -- won't call putBits+                   putByteNoBits bh (bit_cache .|. (bits `shiftL` bit_off))+                   putBits bh (num_bits - leftover_bits) (bits `shiftR` leftover_bits)++getBits :: BinHandle -> Int -> IO Word8+getBits bh num_bits {- | num_bits == 0 = return 0+                    | num_bits <  0 = error "getBits cannot read negative numbers of bits"+                    | num_bits >  8 = error "getBits cannot read more than 8 bits at a time"+                    | otherwise     -} = do+  bit_off <- readFastMutInt (bit_off_r bh)+  if bit_off == 0+    then do bit_cache <- getByte bh+            if num_bits == 8+              then do writeFastMutInt (bit_off_r   bh) 0+                      writeFastMutInt (bit_cache_r bh) 0+                      return bit_cache+              else do writeFastMutInt (bit_off_r   bh) (fromIntegral num_bits)+                      writeFastMutInt (bit_cache_r bh) (fromIntegral bit_cache)+                      return (bit_cache .&. bit_mask num_bits)+    else if bit_off + num_bits < 8+    then do incFastMutIntBy (bit_off_r bh) num_bits+            bit_cache <- readFastMutInt (bit_cache_r bh) >>= return . fromIntegral+            return ((bit_cache `shiftR` bit_off) .&. bit_mask num_bits)+    else if bit_off + num_bits == 8+    then do writeFastMutInt (bit_off_r bh) 0+            bit_cache <- readFastMutInt (bit_cache_r bh) >>= return . fromIntegral+            writeFastMutInt (bit_cache_r bh) 0+            return ((bit_cache `shiftR` bit_off) .&. bit_mask num_bits)+    else do let leftover_bits = 8 - bit_off+            bit_cache <- readFastMutInt (bit_cache_r bh) >>= return . fromIntegral+            let bits = (bit_cache `shiftR` bit_off) .&. bit_mask leftover_bits+            writeFastMutInt (bit_cache_r bh) 0+            writeFastMutInt (bit_off_r   bh) 0+            {- bit_cache <- getByte bh -}+            -- use a version that doesn't care about bits+            bit_cache <- getByteNoBits bh+            writeFastMutInt (bit_off_r   bh) (num_bits - leftover_bits)+            writeFastMutInt (bit_cache_r bh) (fromIntegral bit_cache)+            return (bits .|. ((bit_cache .&. bit_mask (num_bits - leftover_bits)) `shiftL` leftover_bits))++            +bit_mask n = (complement 0) `shiftR` (8 - n)++-- -----------------------------------------------------------------------------+-- Primitve Word writes++instance Binary Word8 where+  put_ = putWord8+  get  = getWord8++instance Binary Word16 where+  put_ h w = do -- XXX too slow.. inline putWord8?+    putByte h (fromIntegral (w `shiftR` 8))+    putByte h (fromIntegral (w .&. 0xff))+  get h = do+    w1 <- getWord8 h+    w2 <- getWord8 h+    return $! ((fromIntegral w1 `shiftL` 8) .|. fromIntegral w2)+++instance Binary Word32 where+  put_ h w = do+    putByte h (fromIntegral (w `shiftR` 24))+    putByte h (fromIntegral ((w `shiftR` 16) .&. 0xff))+    putByte h (fromIntegral ((w `shiftR` 8)  .&. 0xff))+    putByte h (fromIntegral (w .&. 0xff))+  get h = do+    w1 <- getWord8 h+    w2 <- getWord8 h+    w3 <- getWord8 h+    w4 <- getWord8 h+    return $! ((fromIntegral w1 `shiftL` 24) .|. +           (fromIntegral w2 `shiftL` 16) .|. +           (fromIntegral w3 `shiftL`  8) .|. +           (fromIntegral w4))+++instance Binary Word64 where+  put_ h w = do+    putByte h (fromIntegral (w `shiftR` 56))+    putByte h (fromIntegral ((w `shiftR` 48) .&. 0xff))+    putByte h (fromIntegral ((w `shiftR` 40) .&. 0xff))+    putByte h (fromIntegral ((w `shiftR` 32) .&. 0xff))+    putByte h (fromIntegral ((w `shiftR` 24) .&. 0xff))+    putByte h (fromIntegral ((w `shiftR` 16) .&. 0xff))+    putByte h (fromIntegral ((w `shiftR`  8) .&. 0xff))+    putByte h (fromIntegral (w .&. 0xff))+  get h = do+    w1 <- getWord8 h+    w2 <- getWord8 h+    w3 <- getWord8 h+    w4 <- getWord8 h+    w5 <- getWord8 h+    w6 <- getWord8 h+    w7 <- getWord8 h+    w8 <- getWord8 h+    return $! ((fromIntegral w1 `shiftL` 56) .|. +           (fromIntegral w2 `shiftL` 48) .|. +           (fromIntegral w3 `shiftL` 40) .|. +           (fromIntegral w4 `shiftL` 32) .|. +           (fromIntegral w5 `shiftL` 24) .|. +           (fromIntegral w6 `shiftL` 16) .|. +           (fromIntegral w7 `shiftL`  8) .|. +           (fromIntegral w8))++-- -----------------------------------------------------------------------------+-- Primitve Int writes++instance Binary Int8 where+  put_ h w = put_ h (fromIntegral w :: Word8)+  get h    = do w <- get h; return $! (fromIntegral (w::Word8))++instance Binary Int16 where+  put_ h w = put_ h (fromIntegral w :: Word16)+  get h    = do w <- get h; return $! (fromIntegral (w::Word16))++instance Binary Int32 where+  put_ h w = put_ h (fromIntegral w :: Word32)+  get h    = do w <- get h; return $! (fromIntegral (w::Word32))++put31ofInt32 :: BinHandle -> Int32 -> IO ()+put31ofInt32 h i = do+    putBits h 7 (fromIntegral (w `shiftR` 24))+    putBits h 8 (fromIntegral ((w `shiftR` 16) .&. 0xff))+    putBits h 8 (fromIntegral ((w `shiftR` 8)  .&. 0xff))+    putBits h 8 (fromIntegral (w .&. 0xff))+    where w = fromIntegral i :: Word32++get31ofInt32 :: BinHandle -> IO Int32+get31ofInt32 h = do+    w1 <- getBits  h 7+    w2 <- getWord8 h+    w3 <- getWord8 h+    w4 <- getWord8 h+    return $! ((fromIntegral w1 `shiftL` 24) .|. +           (fromIntegral w2 `shiftL` 16) .|. +           (fromIntegral w3 `shiftL`  8) .|. +           (fromIntegral w4))++instance Binary Int64 where+  put_ h w = put_ h (fromIntegral w :: Word64)+  get h    = do w <- get h; return $! (fromIntegral (w::Word64))++-- -----------------------------------------------------------------------------+-- Instances for standard types++instance Binary () where+    put_ bh () = return ()+    get  _     = return ()+--    getF bh p  = case getBitsF bh 0 p of (_,b) -> ((),b)++{- updated for bits+instance Binary Bool where+    put_ bh b = putByte bh (fromIntegral (fromEnum b))+    get  bh   = do x <- getWord8 bh; return $! (toEnum (fromIntegral x))+--    getF bh p = case getBitsF bh 1 p of (x,b) -> (toEnum x,b)+-}++instance Binary Bool where+    put_ bh True  = putBits bh 1 1+    put_ bh False = putBits bh 1 0+    get  bh = do b <- getBits bh 1; return (b == 1)++instance Binary Char where+    put_  bh c = put_ bh (fromIntegral (ord c) :: Word32)+    get  bh   = do x <- get bh; return $! (chr (fromIntegral (x :: Word32)))+--    getF bh p = case getBitsF bh 8 p of (x,b) -> (toEnum x,b)++instance Binary Int where+#if SIZEOF_HSINT == 4+    put_ bh i = put_ bh (fromIntegral i :: Int32)+    get  bh = do+    x <- get bh+    return $! (fromIntegral (x :: Int32))+#elif SIZEOF_HSINT == 8+    put_ bh i = put_ bh (fromIntegral i :: Int64)+    get  bh = do+    x <- get bh+    return $! (fromIntegral (x :: Int64))+#else+#error "unsupported sizeof(HsInt)"+#endif+--    getF bh   = getBitsF bh 32++{-+instance Binary a => Binary [a] where+    put_ bh []     = putByte bh 0+    put_ bh (x:xs) = do putByte bh 1; put_ bh x; put_ bh xs+    get bh         = do h <- getWord8 bh+                        case h of+                          0 -> return []+                          _ -> do x  <- get bh+                                  xs <- get bh+                                  return (x:xs)+-}++instance Binary a => Binary [a] where+    put_ bh l = do+       put_ bh (length l)+       mapM (put_ bh) l+       return ()+    get bh = do+       len <- get bh+       mapM (\_ -> get bh) [1..(len::Int)]++instance (Binary a, Binary b) => Binary (a,b) where+    put_ bh (a,b) = do put_ bh a; put_ bh b+    get bh        = do a <- get bh+                       b <- get bh+                       return (a,b)++instance (Binary a, Binary b, Binary c) => Binary (a,b,c) where+    put_ bh (a,b,c) = do put_ bh a; put_ bh b; put_ bh c+    get bh          = do a <- get bh+                         b <- get bh+                         c <- get bh+                         return (a,b,c)++instance (Binary a, Binary b, Binary c, Binary d) => Binary (a,b,c,d) where+    put_ bh (a,b,c,d) = do put_ bh a; put_ bh b; put_ bh c; put_ bh d+    get bh          = do a <- get bh+                         b <- get bh+                         c <- get bh+                         d <- get bh+                         return (a,b,c,d)++instance (Binary a, Binary b, Binary c, Binary d, Binary e) => Binary (a,b,c,d,e) where+    put_ bh (a,b,c,d,e) = do put_ bh a; put_ bh b; put_ bh c; put_ bh d; put_ bh e+    get bh          = do a <- get bh+                         b <- get bh+                         c <- get bh+                         d <- get bh+                         e <- get bh+                         return (a,b,c,d,e)++instance (Binary a, Binary b, Binary c, Binary d, Binary e, Binary f) => Binary (a,b,c,d,e,f) where+    put_ bh (a,b,c,d,e,f) = do put_ bh a; put_ bh b; put_ bh c; put_ bh d; put_ bh e; put_ bh f+    get bh          = do a <- get bh+                         b <- get bh+                         c <- get bh+                         d <- get bh+                         e <- get bh+                         f <- get bh+                         return (a,b,c,d,e,f)++instance Binary a => Binary (Maybe a) where+    put_ bh Nothing  = putByte bh 0+    put_ bh (Just a) = do putByte bh 1; put_ bh a+    get bh           = do h <- getWord8 bh+                          case h of+                            0 -> return Nothing+                            _ -> do x <- get bh; return (Just x)++putMaybeInt :: BinHandle -> Maybe Int -> IO ()+getMaybeInt :: BinHandle -> IO (Maybe Int)+putMaybeInt bh Nothing = putBits bh 1 0+putMaybeInt bh (Just i) = do putBits bh 1 1; put31ofInt32 bh (fromIntegral i)++getMaybeInt bh = do +  b <- getBits bh 1+  case b of+    0 -> return Nothing+    _ -> do i <- get31ofInt32 bh+            return (Just (fromIntegral i))++{- RULES get = getMaybeInt -}++{- SPECIALIZE put_ :: BinHandle -> Maybe Int -> IO () = putMaybeInt -}+{- SPECIALIZE get  :: BinHandle -> IO (Maybe Int)     = getMaybeInt -}+++instance (Binary a, Binary b) => Binary (Either a b) where+    put_ bh (Left  a) = do putByte bh 0; put_ bh a+    put_ bh (Right b) = do putByte bh 1; put_ bh b+    get bh            = do h <- getWord8 bh+                           case h of+                             0 -> do a <- get bh ; return (Left a)+                             _ -> do b <- get bh ; return (Right b)++instance Binary Integer where+    put_ bh (S# i#) = do putByte bh 0; put_ bh (I# i#)+    put_ bh (J# s# a#) = do+        p <- putByte bh 1;+        put_ bh (I# s#)+        let sz# = sizeofByteArray# a#  -- in *bytes*+        put_ bh (I# sz#)  -- in *bytes*+        putByteArray bh a# sz#++    get bh = do+        b <- getByte bh+        case b of+          0 -> do (I# i#) <- get bh+                  return (S# i#)+          _ -> do (I# s#) <- get bh+                  sz <- get bh+                  (BA a#) <- getByteArray bh sz+                  return (J# s# a#)++putByteArray :: BinHandle -> ByteArray# -> Int# -> IO ()+putByteArray bh a s# = loop 0#+  where loop n# +           | n# ==# s# = return ()+           | otherwise = do+                putByte bh (indexByteArray a n#)+                loop (n# +# 1#)++getByteArray :: BinHandle -> Int -> IO ByteArray+getByteArray bh (I# sz) = do+  (MBA arr) <- newByteArray sz +  let loop n+       | n ==# sz = return ()+       | otherwise = do+        w <- getByte bh +        writeByteArray arr n w+        loop (n +# 1#)+  loop 0#+  freezeByteArray arr+++data ByteArray = BA ByteArray#+data MBA = MBA (MutableByteArray# RealWorld)++newByteArray :: Int# -> IO MBA+newByteArray sz = IO $ \s ->+  case newByteArray# sz s of { (# s, arr #) ->+  (# s, MBA arr #) }++freezeByteArray :: MutableByteArray# RealWorld -> IO ByteArray+freezeByteArray arr = IO $ \s ->+  case unsafeFreezeByteArray# arr s of { (# s, arr #) ->+  (# s, BA arr #) }++writeByteArray :: MutableByteArray# RealWorld -> Int# -> Word8 -> IO ()++writeByteArray arr i w8 = IO $ \s ->+  case fromIntegral w8 of { W# w# -> +  case writeCharArray# arr i (chr# (word2Int# w#)) s  of { s ->+  (# s , () #) }}++indexByteArray a# n# = fromIntegral (I# (ord# (indexCharArray# a# n#)))++instance (Integral a, Binary a) => Binary (Ratio a) where+    put_ bh (a :% b) = do put_ bh a; put_ bh b+    get bh = do a <- get bh; b <- get bh; return (a :% b)++instance Binary (Bin a) where+  put_ bh (BinPtr i j) = put_ bh (i,j)+  get bh = do (i,j) <- get bh; return (BinPtr i j)++-- -----------------------------------------------------------------------------+-- Lazy reading/writing++lazyPut :: Binary a => BinHandle -> a -> IO ()+lazyPut bh a = do+    -- output the obj with a ptr to skip over it:+    pre_a <- tellBin bh+    put_ bh pre_a   -- save a slot for the ptr+    put_ bh a       -- dump the object+    q <- tellBin bh     -- q = ptr to after object+    putAt bh pre_a q    -- fill in slot before a with ptr to q+    seekBin bh q    -- finally carry on writing at q++lazyGet :: Binary a => BinHandle -> IO a+lazyGet bh = do+    p <- get bh     -- a BinPtr+    p_a <- tellBin bh+    a <- unsafeInterleaveIO (getAt bh p_a)+    seekBin bh p -- skip over the object for now+    return a++-- -----------------------------------------------------------------------------+-- BinHandleState+{-+type BinHandleState = +    (Module, +     IORef Int,+     IORef (UniqFM (Int,FastString)),+     Array Int FastString)++initReadState :: BinHandleState+initReadState = (undef, undef, undef, undef)++newWriteState :: Module -> IO BinHandleState+newWriteState m = do+  j_r <- newIORef 0+  out_r <- newIORef emptyUFM+  return (m,j_r,out_r,undef)++undef = error "Binary.BinHandleState"++-- -----------------------------------------------------------------------------+-- FastString binary interface++getBinFileWithDict :: Binary a => FilePath -> IO a+getBinFileWithDict file_path = do+  bh <- Binary.readBinMem file_path+  magic <- get bh+  when (magic /= binaryInterfaceMagic) $+    throwDyn (ProgramError (+       "magic number mismatch: old/corrupt interface file?"))+  dict_p <- Binary.get bh       -- get the dictionary ptr+  data_p <- tellBin bh+  seekBin bh dict_p+  dict <- getDictionary bh+  seekBin bh data_p+  let (mod, j_r, out_r, _) = state bh+  get bh{ state = (mod,j_r,out_r,dict) }++initBinMemSize = (1024*1024) :: Int++binaryInterfaceMagic = 0x1face :: Word32++putBinFileWithDict :: Binary a => FilePath -> Module -> a -> IO ()+putBinFileWithDict file_path mod a = do+  bh <- openBinMem initBinMemSize mod+  put_ bh binaryInterfaceMagic+  p <- tellBin bh+  put_ bh p     -- placeholder for ptr to dictionary+  put_ bh a+  let (_, j_r, fm_r, _) = state bh+  j <- readIORef j_r+  fm <- readIORef fm_r+  dict_p <- tellBin bh+  putAt bh p dict_p -- fill in the placeholder+  seekBin bh dict_p -- seek back to the end of the file+  putDictionary bh j (constructDictionary j fm)+  writeBinMem bh file_path+  +type Dictionary = Array Int FastString+    -- should be 0-indexed++putDictionary :: BinHandle -> Int -> Dictionary -> IO ()+putDictionary bh sz dict = do+  put_ bh sz+  mapM_ (putFS bh) (elems dict)++getDictionary :: BinHandle -> IO Dictionary+getDictionary bh = do +  sz <- get bh+  elems <- sequence (take sz (repeat (getFS bh)))+  return (listArray (0,sz-1) elems)++constructDictionary :: Int -> UniqFM (Int,FastString) -> Dictionary+constructDictionary j fm = array (0,j-1) (eltsUFM fm)++putFS bh (FastString id l ba) = do+  put_ bh (I# l)+  putByteArray bh ba l+putFS bh s = error ("Binary.put_(FastString): " ++ unpackFS s)+    -- Note: the length of the FastString is *not* the same as+    -- the size of the ByteArray: the latter is rounded up to a+    -- multiple of the word size.+  +{- -- possible faster version, not quite there yet:+getFS bh@BinMem{} = do+  (I# l) <- get bh+  arr <- readIORef (arr_r bh)+  off <- readFastMutInt (off_r bh)+  return $! (mkFastSubStringBA# arr off l)+-}+getFS bh = do+  (I# l) <- get bh+  (BA ba) <- getByteArray bh (I# l)+  return $! (mkFastSubStringBA# ba 0# l)++instance Binary FastString where+  put_ bh f@(FastString id l ba) =+    case getUserData bh of { (_, j_r, out_r, dict) -> do+    out <- readIORef out_r+    let uniq = getUnique f+    case lookupUFM out uniq of+    Just (j,f)  -> put_ bh j+    Nothing -> do+       j <- readIORef j_r+       put_ bh j+       writeIORef j_r (j+1)+       writeIORef out_r (addToUFM out uniq (j,f))+    }+  put_ bh s = error ("Binary.put_(FastString): " ++ show (unpackFS s))++  get bh = do +    j <- get bh+    case getUserData bh of (_, _, _, arr) -> return (arr ! j)+-}++++{----------------------------------------------------------------------+ ---------- Hal's Notes -----------------------------------------------+ ----------------------------------------------------------------------++We are adding support for ++  putBits   :: BinHandle -> Int -> Word8 -> IO ()+  getBits   :: BinHandle -> Int -> IO Word8+  flushBits :: BinHandle -> Int -> IO ()+  closeHandle :: BinHandle -> IO ()++where++  `putBits bh num_bits bits' writes the right-most num_bits of bits to+  bh.  `getBits bh num_bits` reads num_bits from bh and stores them in+  the right-most positions of the result.  flushBits bh n alignes the+  stream to the next 2^n bit boundary.  closeHandle flushes all+  remaining bits and closes the handle.++In order to implement this, we need to extend the BinHandles with two+fields: bit_off_r :: Int and bit_cache :: Word8.  Based on this, the+basic implementations look something like this:++putBits bh num_bits bits =+  if num_bits + bit_off_r <= 8+    then bit_off_r += num_bits+         add num_bits of bits to the tail of bit_cache+         if bit_off_r == 8+           then write bit_cache and set bit_cache = 0, bit_off_r = 0+    else let leftover_bits = 8 - bit_off_r+         add leftover_bits of bits to tail of bit_cache+         write bit_cache and set bit_cache = 0, bit_off_r = 0+         putBits bh (num_bits - leftover_bits) (bits >> leftover_bits)++(note that this will recurse at most once)++getBits bh num_bits =+  if bit_off_r == 0+    then bit_cache <- read a byte+         bit_off_r = num_bits+         if bit_off_r == 8, set bit_off_r = 0, bit_cache = 0+    else if bit_off_r + num_bits <= 8+           then bit_off_r += num_bits+                bits = bits from bit_off_r -> bit_off_r+num_bits of bit_cache+                if bit_off_r == 8, set bit_off_r = 0, bit_cache = 0+                return bits+           else let leftover_bits = 8 - bit_off_r+                bits = (last leftover_bits from bit_cache) << (num_bits - leftover_bits)+                bit_cache <- read a byte+                bit_off_r = num_bits - leftover_bits+                return (bits || first (num_bits - leftover_bits) of bit_cache)++Now, we must also modify putByte/getByte.  In these, we do a quick+check to see if bit_off_r == 0; if it does, then we just execute+normally.  Otherwise, we just call putBits/getBits with num_bits=8.++closeHandle bh =+  if bit_off_r == 0+    then close the handle+    else write bit_cache and set bit_cache = 0, bit_off_r =0+         close the handle++-}++------------------------------------------------------------------------++#if __GLASGOW_HASKELL__ < 411+newByteArray# = newCharArray#+#endif++#ifdef __GLASGOW_HASKELL__++data FastMutInt = FastMutInt (MutableByteArray# RealWorld)++newFastMutInt :: IO FastMutInt+newFastMutInt = IO $ \s ->+  case newByteArray# size s of { (# s, arr #) ->+  (# s, FastMutInt arr #) }+  where I# size = SIZEOF_HSINT++readFastMutInt :: FastMutInt -> IO Int+readFastMutInt (FastMutInt arr) = IO $ \s ->+  case readIntArray# arr 0# s of { (# s, i #) ->+  (# s, I# i #) }++writeFastMutInt :: FastMutInt -> Int -> IO ()+writeFastMutInt (FastMutInt arr) (I# i) = IO $ \s ->+  case writeIntArray# arr 0# i s of { s ->+  (# s, () #) }++incFastMutInt :: FastMutInt -> IO Int   -- Returns original value+incFastMutInt (FastMutInt arr) = IO $ \s ->+  case readIntArray# arr 0# s of { (# s, i #) ->+  case writeIntArray# arr 0# (i +# 1#) s of { s ->+  (# s, I# i #) } }++incFastMutIntBy :: FastMutInt -> Int -> IO Int  -- Returns original value+incFastMutIntBy (FastMutInt arr) (I# n) = IO $ \s ->+  case readIntArray# arr 0# s of { (# s, i #) ->+  case writeIntArray# arr 0# (i +# n) s of { s ->+  (# s, I# i #) } }++-- we should optimize this: ask SimonM :)+orFastMutInt :: FastMutInt -> Word8 -> IO ()+orFastMutInt fmi w = do+  i <- readFastMutInt fmi+  writeFastMutInt fmi (i .|. (fromIntegral w))++#endif+

@@ -0,0 +1,147 @@+-----------------------------------------------------------------------------+-- |+-- Module      :  Test.QuickCheck.Parallel+-- Copyright   :  (c) Don Stewart 2006+-- License     :  BSD-style (see the file LICENSE)+-- +-- Maintainer  :  dons@cse.unsw.edu.au+-- Stability   :  experimental+-- Portability :  non-portable (uses Control.Exception, Control.Concurrent)+--+-- A parallel batch driver for running QuickCheck on threaded or SMP systems.+-- See the /Example.hs/ file for a complete overview.+--++module Parallel (+    pRun,+    pDet,+    pNon+  ) where++import Test.QuickCheck+import Data.List+import Control.Concurrent+import Control.Exception  hiding (evaluate)+import System.Random+import System.IO          (hFlush,stdout)+import Text.Printf++type Name   = String+type Depth  = Int+type Test   = (Name, Depth -> IO String)++-- | Run a list of QuickCheck properties in parallel chunks, using+-- 'n' Haskell threads (first argument), and test to a depth of 'd'+-- (second argument). Compile your application with '-threaded' and run+-- with the SMP runtime's '-N4' (or however many OS threads you want to+-- donate), for best results.+--+-- > import Test.QuickCheck.Parallel+-- >+-- > do n <- getArgs >>= readIO . head+-- >    pRun n 1000 [ ("sort1", pDet prop_sort1) ]+--+-- Will run 'n' threads over the property list, to depth 1000.+--+pRun :: Int -> Int -> [Test] -> IO ()+pRun n depth tests = do+    chan <- newChan+    ps   <- getChanContents chan+    work <- newMVar tests++    forM_ [1..n] $ forkIO . thread work chan++    let wait xs i+            | i >= n     = return () -- done+            | otherwise = case xs of+                    Nothing : xs -> wait xs $! i+1+                    Just s  : xs -> putStr s >> hFlush stdout >> wait xs i+    wait ps 0++  where+    thread :: MVar [Test] -> Chan (Maybe String) -> Int -> IO ()+    thread work chan me = loop+      where+        loop = do+            job <- modifyMVar work $ \jobs -> return $ case jobs of+                        []     -> ([], Nothing)+                        (j:js) -> (js, Just j)+            case job of+                Nothing          -> writeChan chan Nothing -- done+                Just (name,prop) -> do+                    v <- prop depth+                    writeChan chan . Just $ printf "%d: %-25s: %s" me name v+                    loop+++-- | Wrap a property, and run it on a deterministic set of data+pDet :: Testable a => a -> Int -> IO String+pDet a n = mycheck Det defaultConfig+    { configMaxTest = n+    , configEvery   = \n args -> unlines args } a++-- | Wrap a property, and run it on a non-deterministic set of data+pNon :: Testable a => a -> Int -> IO String+pNon a n = mycheck NonDet defaultConfig+    { configMaxTest = n+    , configEvery   = \n args -> unlines args } a++data Mode = Det | NonDet++------------------------------------------------------------------------++mycheck :: Testable a => Mode -> Config -> a -> IO String+mycheck Det config a = do+     let rnd = mkStdGen 99  -- deterministic+     mytests config (evaluate a) rnd 0 0 []++mycheck NonDet config a = do+    rnd <- newStdGen        -- different each run+    mytests config (evaluate a) rnd 0 0 []++mytests :: Config -> Gen Result -> StdGen -> Int -> Int -> [[String]] -> IO String+mytests config gen rnd0 ntest nfail stamps+  | ntest == configMaxTest config = do done "OK," ntest stamps+  | nfail == configMaxFail config = do done "Arguments exhausted after" ntest stamps+  | otherwise = do+         case ok result of+           Nothing    ->+             mytests config gen rnd1 ntest (nfail+1) stamps+           Just True  ->+             mytests config gen rnd1 (ntest+1) nfail (stamp result:stamps)+           Just False ->+             return ( "Falsifiable after "+                   ++ show ntest+                   ++ " tests:\n"+                   ++ unlines (arguments result)+                    )+     where+      result      = generate (configSize config ntest) rnd2 gen+      (rnd1,rnd2) = split rnd0++done :: String -> Int -> [[String]] -> IO String+done mesg ntest stamps =+    return ( mesg ++ " " ++ show ntest ++ " tests" ++ table )+  where+    table = display+        . map entry+        . reverse+        . sort+        . map pairLength+        . group+        . sort+        . filter (not . null)+        $ stamps++    display []  = ".\n"+    display [x] = " (" ++ x ++ ").\n"+    display xs  = ".\n" ++ unlines (map (++ ".") xs)++    pairLength xss@(xs:_) = (length xss, xs)+    entry (n, xs)         = percentage n ntest+                          ++ " "+                          ++ concat (intersperse ", " xs)++    percentage n m        = show ((100 * n) `div` m) ++ "%"++forM_ = flip mapM_

@@ -0,0 +1,244 @@+{-# OPTIONS_GHC -fglasgow-exts #-}+module Main where++import Data.Binary+import Data.Binary.Put+import Data.Binary.Get++import Parallel++import qualified Data.ByteString as B+import qualified Data.ByteString.Internal as B+import qualified Data.ByteString.Unsafe as B+import qualified Data.ByteString.Lazy as L+import qualified Data.ByteString.Lazy.Internal as L+import qualified Data.Map as Map+import qualified Data.Set as Set+import qualified Data.IntMap as IntMap+import qualified Data.IntSet as IntSet++import Data.Array (Array)+import Data.Array.IArray+import Data.Array.Unboxed (UArray)++import qualified Control.OldException as C (catch,evaluate)+import Control.Monad+import Foreign+import System.Environment+import System.IO+import System.IO.Unsafe++import Test.QuickCheck hiding (test)+import QuickCheckUtils+import Text.Printf++-- import qualified Data.Sequence as Seq++------------------------------------------------------------------------++roundTrip :: (Eq a, Binary a) => a -> (L.ByteString -> L.ByteString) -> Bool+roundTrip a f = a ==+    {-# SCC "decode.refragment.encode" #-} decode (f (encode a))++roundTripWith put get x =+    forAll positiveList $ \xs ->+    x == runGet get (refragment xs (runPut (put x)))++-- make sure that a test fails+errorish :: B a+errorish a = unsafePerformIO $+    C.catch (do C.evaluate a+                return False)+            (\_ -> return True)++-- low level ones:++prop_Word16be = roundTripWith putWord16be getWord16be+prop_Word16le = roundTripWith putWord16le getWord16le+prop_Word16host = roundTripWith putWord16host getWord16host++prop_Word32be = roundTripWith putWord32be getWord32be+prop_Word32le = roundTripWith putWord32le getWord32le+prop_Word32host = roundTripWith putWord32host getWord32host++prop_Word64be = roundTripWith putWord64be getWord64be+prop_Word64le = roundTripWith putWord64le getWord64le+prop_Word64host = roundTripWith putWord64host getWord64host++prop_Wordhost = roundTripWith putWordhost getWordhost++-- read too much:++prop_bookworm x = errorish $ x == a && x /= b+  where+    (a,b) = decode (encode x)++-- sanity:++invariant_lbs :: L.ByteString -> Bool+invariant_lbs (L.Empty)      = True+invariant_lbs (L.Chunk x xs) = not (B.null x) && invariant_lbs xs++prop_invariant :: (Binary a) => a -> Bool+prop_invariant = invariant_lbs . encode++-- be lazy!++-- doesn't do fair testing of lazy put/get.+-- tons of untested cases++-- lazyTrip :: (Binary a, Eq a) => a -> Property+-- lazyTrip a = forAll positiveList $ \xs ->+--     a == (runGet lazyGet . refragment xs . runPut . lazyPut $ a)++-- refragment a lazy bytestring's chunks+refragment :: [Int] -> L.ByteString -> L.ByteString+refragment [] lps = lps+refragment (x:xs) lps =+    let x' = fromIntegral . (+1) . abs $ x+        rest = refragment xs (L.drop x' lps) in+    L.append (L.fromChunks [B.concat . L.toChunks . L.take x' $ lps]) rest++-- check identity of refragmentation+prop_refragment lps xs = lps == refragment xs lps++-- check that refragmention still hold invariant+prop_refragment_inv lps xs = invariant_lbs $ refragment xs lps++main :: IO ()+main = do+    hSetBuffering stdout NoBuffering+    s <- getArgs+    let x = if null s then 100 else read (head s)+    pRun 2 x tests++{-+run :: [(String, Int -> IO ())] -> IO ()+run tests = do+    x <- getArgs+    let n = if null x then 100 else read . head $ x+    mapM_ (\(s,a) -> printf "%-50s" s >> a n) tests+-}++------------------------------------------------------------------------++type T a = a -> Property+type B a = a -> Bool++p       :: Testable a => a -> Int -> IO String+p       = pNon++test    :: (Eq a, Binary a) => a -> Property+test a  = forAll positiveList (roundTrip a . refragment)++positiveList :: Gen [Int]+positiveList = fmap (filter (/=0) . map abs) $ arbitrary++-- tests :: [(String, Int -> IO String)]+tests =+-- utils+        [ ("refragment id",        p prop_refragment     )+        , ("refragment invariant", p prop_refragment_inv )++-- boundaries+        , ("read to much",  p (prop_bookworm :: B Word8     ))++-- Primitives+        , ("Word16be",      p prop_Word16be)+        , ("Word16le",      p prop_Word16le)+        , ("Word16host",    p prop_Word16host)+        , ("Word32be",      p prop_Word32be)+        , ("Word32le",      p prop_Word32le)+        , ("Word32host",    p prop_Word32host)+        , ("Word64be",      p prop_Word64be)+        , ("Word64le",      p prop_Word64le)+        , ("Word64host",    p prop_Word64host)+        , ("Wordhost",      p prop_Wordhost)++-- higher level ones using the Binary class+        ,("()",         p (test :: T ()                     ))+        ,("Bool",       p (test :: T Bool                   ))+        ,("Ordering",   p (test :: T Ordering               ))++        ,("Word8",      p (test :: T Word8                  ))+        ,("Word16",     p (test :: T Word16                 ))+        ,("Word32",     p (test :: T Word32                 ))+        ,("Word64",     p (test :: T Word64                 ))++        ,("Int8",       p (test :: T Int8                   ))+        ,("Int16",      p (test :: T Int16                  ))+        ,("Int32",      p (test :: T Int32                  ))+        ,("Int64",      p (test :: T Int64                  ))++        ,("Word",       p (test :: T Word                   ))+        ,("Int",        p (test :: T Int                    ))+        ,("Integer",    p (test :: T Integer                ))++        ,("Float",      p (test :: T Float                  ))+        ,("Double",     p (test :: T Double                 ))++        ,("Char",       p (test :: T Char                   ))++        ,("[()]",       p (test :: T [()]                  ))+        ,("[Word8]",    p (test :: T [Word8]               ))+        ,("[Word32]",   p (test :: T [Word32]              ))+        ,("[Word64]",   p (test :: T [Word64]              ))+        ,("[Word]",     p (test :: T [Word]                ))+        ,("[Int]",      p (test :: T [Int]                 ))+        ,("[Integer]",  p (test :: T [Integer]             ))+        ,("String",     p (test :: T String                ))++        ,("((), ())",           p (test :: T ((), ())        ))+        ,("(Word8, Word32)",    p (test :: T (Word8, Word32) ))+        ,("(Int8, Int32)",      p (test :: T (Int8,  Int32)  ))+        ,("(Int32, [Int])",     p (test :: T (Int32, [Int])  ))++        ,("Maybe Int8",         p (test :: T (Maybe Int8)        ))+        ,("Either Int8 Int16",  p (test :: T (Either Int8 Int16) ))++        ,("(Maybe Word8, Bool, [Int], Either Bool Word8)",+                p (test :: T (Maybe Word8, Bool, [Int], Either Bool Word8) ))++        ,("(Int, ByteString)",        p (test     :: T (Int, B.ByteString)   ))+--      ,("Lazy (Int, ByteString)",   p (lazyTrip :: T (Int, B.ByteString)   ))+        ,("[(Int, ByteString)]",      p (test     :: T [(Int, B.ByteString)] ))+--      ,("Lazy [(Int, ByteString)]", p (lazyTrip :: T [(Int, B.ByteString)] ))+++--      ,("Lazy IntMap",       p (lazyTrip  :: T IntSet.IntSet          ))+        ,("IntSet",            p (test      :: T IntSet.IntSet          ))+        ,("IntMap ByteString", p (test      :: T (IntMap.IntMap B.ByteString) ))++        ,("B.ByteString",  p (test :: T B.ByteString        ))+        ,("L.ByteString",  p (test :: T L.ByteString        ))++        ,("B.ByteString invariant",   p (prop_invariant :: B B.ByteString                 ))+        ,("[B.ByteString] invariant", p (prop_invariant :: B [B.ByteString]               ))+        ,("L.ByteString invariant",   p (prop_invariant :: B L.ByteString                 ))+        ,("[L.ByteString] invariant", p (prop_invariant :: B [L.ByteString]               ))+        ,("IntMap invariant",         p (prop_invariant :: B (IntMap.IntMap B.ByteString) ))++        ,("Set Word32",      p (test :: T (Set.Set Word32)      ))+        ,("Map Word16 Int",  p (test :: T (Map.Map Word16 Int)  ))++        ,("(Maybe Int64, Bool, [Int])", p (test :: T (Maybe Int64, Bool, [Int])))++{-+--+-- Big tuples lack an Arbitrary instance in Hugs/QuickCheck+--++        ,("(Maybe Word16, Bool, [Int], Either Bool Word16, Int)",+            p (test :: T (Maybe Word16, Bool, [Int], Either Bool Word16, Int) ))++        ,("(Maybe Word32, Bool, [Int], Either Bool Word32, Int, Int)", p (roundTrip :: (Maybe Word32, Bool, [Int], Either Bool Word32, Int, Int) -> Bool))++        ,("(Maybe Word64, Bool, [Int], Either Bool Word64, Int, Int, Int)", p (roundTrip :: (Maybe Word64, Bool, [Int], Either Bool Word64, Int, Int, Int) -> Bool))+-}++-- GHC only:+--      ,("Sequence", p (roundTrip :: Seq.Seq Int64 -> Bool))++-- Obsolete+--      ,("ensureLeft/Fail", mytest (shouldFail (decode L.empty :: Either ParseError Int)))+        ]

@@ -0,0 +1,258 @@+{-# OPTIONS_GHC -fglasgow-exts #-}+--+-- Uses multi-param type classes+--+module QuickCheckUtils where++import Control.Monad++import Test.QuickCheck.Batch+import Test.QuickCheck+import Text.Show.Functions++import qualified Data.ByteString as B+import qualified Data.ByteString.Unsafe as B+import qualified Data.ByteString.Internal as B+import qualified Data.ByteString.Lazy as L+import qualified Data.Map as Map+import qualified Data.Set as Set+import qualified Data.IntMap as IntMap+import qualified Data.IntSet as IntSet++import qualified Control.Exception as C (evaluate)++import Control.Monad        ( liftM2 )+import Data.Char+import Data.List+import Data.Word+import Data.Int+import System.Random+import System.IO++-- import Control.Concurrent+import System.Mem+import System.CPUTime+import Text.Printf++import qualified Data.ByteString      as P+import qualified Data.ByteString.Lazy as L+import qualified Data.ByteString.Lazy.Internal as L++-- import qualified Data.Sequence as Seq++-- Enable this to get verbose test output. Including the actual tests.+debug = False++mytest :: Testable a => a -> Int -> IO ()+mytest a n = mycheck defaultConfig+    { configMaxTest=n+    , configEvery= \n args -> if debug then show n ++ ":\n" ++ unlines args else [] } a++mycheck :: Testable a => Config -> a -> IO ()+mycheck config a = do+     rnd <- newStdGen+     performGC -- >> threadDelay 100+     t <- mytests config (evaluate a) rnd 0 0 [] 0 -- 0+     printf " %0.3f seconds\n" (t :: Double)+     hFlush stdout++time :: a -> IO (a , Double)+time a = do+    start <- getCPUTime+    v     <- C.evaluate a+    v `seq` return ()+    end   <- getCPUTime+    return (v,     (      (fromIntegral (end - start)) / (10^12)))++mytests :: Config -> Gen Result -> StdGen -> Int -> Int -> [[String]] -> Double -> IO  Double+mytests config gen rnd0 ntest nfail stamps t0+  | ntest == configMaxTest config = do done "OK," ntest stamps+                                       return t0++  | nfail == configMaxFail config = do done "Arguments exhausted after" ntest stamps+                                       return t0++  | otherwise = do+     (result,t1) <- time (generate (configSize config ntest) rnd2 gen)++     putStr (configEvery config ntest (arguments result)) >> hFlush stdout+     case ok result of+       Nothing    ->+         mytests config gen rnd1 ntest (nfail+1) stamps (t0 + t1)+       Just True  ->+         mytests config gen rnd1 (ntest+1) nfail (stamp result:stamps) (t0 + t1)+       Just False -> do+         putStr ( "Falsifiable after "+               ++ show ntest+               ++ " tests:\n"+               ++ unlines (arguments result)+                ) >> hFlush stdout+         return t0++     where+      (rnd1,rnd2) = split rnd0++done :: String -> Int -> [[String]] -> IO ()+done mesg ntest stamps = putStr ( mesg ++ " " ++ show ntest ++ " tests" ++ table )+ where+  table = display+        . map entry+        . reverse+        . sort+        . map pairLength+        . group+        . sort+        . filter (not . null)+        $ stamps++  display []  = ". "+  display [x] = " (" ++ x ++ "). "+  display xs  = ".\n" ++ unlines (map (++ ".") xs)++  pairLength xss@(xs:_) = (length xss, xs)+  entry (n, xs)         = percentage n ntest+                       ++ " "+                       ++ concat (intersperse ", " xs)++  percentage n m        = show ((100 * n) `div` m) ++ "%"++------------------------------------------------------------------------++instance Random Word8 where+  randomR = integralRandomR+  random = randomR (minBound,maxBound)++instance Random Int8 where+  randomR = integralRandomR+  random = randomR (minBound,maxBound)++instance Random Word16 where+  randomR = integralRandomR+  random = randomR (minBound,maxBound)++instance Random Int16 where+  randomR = integralRandomR+  random = randomR (minBound,maxBound)++instance Random Word where+  randomR = integralRandomR+  random = randomR (minBound,maxBound)++instance Random Word32 where+  randomR = integralRandomR+  random = randomR (minBound,maxBound)++instance Random Int32 where+  randomR = integralRandomR+  random = randomR (minBound,maxBound)++instance Random Word64 where+  randomR = integralRandomR+  random = randomR (minBound,maxBound)++instance Random Int64 where+  randomR = integralRandomR+  random = randomR (minBound,maxBound)++------------------------------------------------------------------------++integralRandomR :: (Integral a, RandomGen g) => (a,a) -> g -> (a,g)+integralRandomR  (a,b) g = case randomR (fromIntegral a :: Integer,+                                         fromIntegral b :: Integer) g of+                            (x,g) -> (fromIntegral x, g)++------------------------------------------------------------------------++instance Arbitrary Word8 where+    arbitrary       = choose (0, 2^8-1)+    coarbitrary w   = variant 0++instance Arbitrary Word16 where+    arbitrary       = choose (0, 2^16-1)+    coarbitrary     = undefined++instance Arbitrary Word32 where+--  arbitrary       = choose (0, 2^32-1)+    arbitrary       = choose (minBound, maxBound)+    coarbitrary     = undefined++instance Arbitrary Word64 where+--  arbitrary       = choose (0, 2^64-1)+    arbitrary       = choose (minBound, maxBound)+    coarbitrary     = undefined++instance Arbitrary Int8 where+--  arbitrary       = choose (0, 2^8-1)+    arbitrary       = choose (minBound, maxBound)+    coarbitrary w   = variant 0++instance Arbitrary Int16 where+--  arbitrary       = choose (0, 2^16-1)+    arbitrary       = choose (minBound, maxBound)+    coarbitrary     = undefined++instance Arbitrary Int32 where+--  arbitrary       = choose (0, 2^32-1)+    arbitrary       = choose (minBound, maxBound)+    coarbitrary     = undefined++instance Arbitrary Int64 where+--  arbitrary       = choose (0, 2^64-1)+    arbitrary       = choose (minBound, maxBound)+    coarbitrary     = undefined++instance Arbitrary Word where+    arbitrary       = choose (minBound, maxBound)+    coarbitrary w   = variant 0++------------------------------------------------------------------------++instance Arbitrary Char where+    arbitrary = choose (maxBound, minBound)+    coarbitrary = undefined++{-+instance Arbitrary a => Arbitrary (Maybe a) where+    arbitrary = oneof [ return Nothing, liftM Just arbitrary]+    coarbitrary = undefined+    -}++instance Arbitrary Ordering where+    arbitrary = oneof [ return LT,return  GT,return  EQ ]+    coarbitrary = undefined++{-+instance (Arbitrary a, Arbitrary b) => Arbitrary (Either a b) where+    arbitrary = oneof [ liftM Left arbitrary, liftM Right arbitrary]+    coarbitrary = undefined+    -}++instance Arbitrary IntSet.IntSet where+    arbitrary = fmap IntSet.fromList arbitrary+    coarbitrary = undefined++instance (Arbitrary e) => Arbitrary (IntMap.IntMap e) where+    arbitrary = fmap IntMap.fromList arbitrary+    coarbitrary = undefined++instance (Arbitrary a, Ord a) => Arbitrary (Set.Set a) where+    arbitrary = fmap Set.fromList arbitrary+    coarbitrary = undefined++instance (Arbitrary a, Ord a, Arbitrary b) => Arbitrary (Map.Map a b) where+    arbitrary = fmap Map.fromList arbitrary+    coarbitrary = undefined++{-+instance (Arbitrary a) => Arbitrary (Seq.Seq a) where+    arbitrary = fmap Seq.fromList arbitrary+    coarbitrary = undefined+-}++instance Arbitrary L.ByteString where+    arbitrary     = arbitrary >>= return . L.fromChunks . filter (not. B.null) -- maintain the invariant.+    coarbitrary s = coarbitrary (L.unpack s)++instance Arbitrary B.ByteString where+  arbitrary = B.pack `fmap` arbitrary+  coarbitrary s = coarbitrary (B.unpack s)

@@ -0,0 +1,28 @@+layer handling:++    bit packing+    state parameters+    string pools++    reading structures from the end of a stream, seek/tell behaviour++seek based protocols are too hard. +    hGetContents/ interleaving.++user requests:++    get remaining bytestring after a runGet++    some kind of lookahead, or restoring parsing state, or something with+      equal functionality. make it another layer on top?++    getLazyByteString takes an Int, which in Haskell98 is only guarantied to+      be 29 bits, ie. 512 mb.+      maybe we should have a readN64 for allowing reading of larger stuff?+      (which could be implemented with readN on 64bit machines)+      reference: bringerts tar archive decoder would be limitid to 0.5GB+                 files, alt. 2GB in GHC++SYB-deriving++investigate the UArray instance, it does not seem to compile in GHC 6.4

@@ -0,0 +1,57 @@+{-# OPTIONS -fglasgow-exts #-}++module BinaryDerive where++import Data.Generics+import Data.List++deriveM ::  (Typeable a, Data a) => a -> IO ()+deriveM (a :: a) = mapM_ putStrLn . lines $ derive (undefined :: a)++derive :: (Typeable a, Data a) => a -> String+derive x = +    "instance " ++ context ++ "Binary " ++ inst ++ " where\n" +++    concat putDefs ++ getDefs+    where+    context+        | nTypeChildren > 0 =+            wrap (join ", " (map ("Binary "++) typeLetters)) ++ " => "+        | otherwise = ""+    inst = wrap $ tyConString typeName ++ concatMap (" "++) typeLetters+    wrap x = if nTypeChildren > 0 then "("++x++")" else x +    join sep lst = concat $ intersperse sep lst+    nTypeChildren = length typeChildren+    typeLetters = take nTypeChildren manyLetters+    manyLetters = map (:[]) ['a'..'z']+    (typeName,typeChildren) = splitTyConApp (typeOf x)+    constrs :: [(Int, (String, Int))]+    constrs = zip [0..] $ map gen $ dataTypeConstrs (dataTypeOf x)+    gen con = ( showConstr con+              , length $ gmapQ undefined $ fromConstr con `asTypeOf` x+              )+    putDefs = map ((++"\n") . putDef) constrs+    putDef (n, (name, ps)) =+        let wrap = if ps /= 0 then ("("++) . (++")") else id+            pattern = name ++ concatMap (' ':) (take ps manyLetters)+        in+        "  put " ++ wrap pattern ++" = "+        ++ concat [ "putWord8 " ++ show n | length constrs  > 1 ]+        ++ concat [ " >> "                | length constrs  > 1 && ps  > 0 ]+        ++ concat [ "return ()"           | length constrs == 1 && ps == 0 ]+        ++ join " >> " (map ("put "++) (take ps manyLetters))+    getDefs =+       (if length constrs > 1+            then "  get = do\n    tag_ <- getWord8\n    case tag_ of\n"+            else "  get =")+        ++ concatMap ((++"\n")) (map getDef constrs) +++       (if length constrs > 1+	    then "      _ -> fail \"no parse\""+	    else ""+       )+    getDef (n, (name, ps)) =+        let wrap = if ps /= 0 then ("("++) . (++")") else id+        in+        concat [ "      " ++ show n ++ " ->" | length constrs > 1 ]+        ++ concatMap (\x -> " get >>= \\"++x++" ->") (take ps manyLetters)+        ++ " return "+        ++ wrap (name ++ concatMap (" "++) (take ps manyLetters))

@@ -0,0 +1,68 @@++import Data.Generics++import Data.Binary++import BinaryDerive++data Foo = Bar+    deriving (Typeable, Data, Show, Eq)++instance Binary Main.Foo where+  put Bar = return ()+  get = return Bar++data Color = RGB Int Int Int+           | CMYK Int Int Int Int+    deriving (Typeable, Data, Show, Eq)++instance Binary Main.Color where+  put (RGB a b c) = putWord8 0 >> put a >> put b >> put c+  put (CMYK a b c d) = putWord8 1 >> put a >> put b >> put c >> put d+  get = do+    tag_ <- getWord8+    case tag_ of+      0 -> get >>= \a -> get >>= \b -> get >>= \c -> return (RGB a b c)+      1 -> get >>= \a -> get >>= \b -> get >>= \c -> get >>= \d -> return (CMYK a b c d)++data Computer = Laptop { weight :: Int }+              | Desktop { speed :: Int, memory :: Int }+    deriving (Typeable, Data, Show, Eq)++instance Binary Main.Computer where+  put (Laptop a) = putWord8 0 >> put a+  put (Desktop a b) = putWord8 1 >> put a >> put b+  get = do+    tag_ <- getWord8+    case tag_ of+      0 -> get >>= \a -> return (Laptop a)+      1 -> get >>= \a -> get >>= \b -> return (Desktop a b)++-- | All drinks mankind will ever need+data Drinks = Beer Bool{-ale?-}+            | Coffee+            | Tea+            | EnergyDrink+            | Water+            | Wine+            | Whisky+    deriving (Typeable, Data, Show, Eq)++instance Binary Main.Drinks where+  put (Beer a) = putWord8 0 >> put a+  put Coffee = putWord8 1+  put Tea = putWord8 2+  put EnergyDrink = putWord8 3+  put Water = putWord8 4+  put Wine = putWord8 5+  put Whisky = putWord8 6+  get = do+    tag_ <- getWord8+    case tag_ of+      0 -> get >>= \a -> return (Beer a)+      1 -> return Coffee+      2 -> return Tea+      3 -> return EnergyDrink+      4 -> return Water+      5 -> return Wine+      6 -> return Whisky