Tune to beat NewBinary
authorDon Stewart <dons@cse.unsw.edu.au>
Tue, 16 Jan 2007 15:06:01 +0000 (16:06 +0100)
committerDon Stewart <dons@cse.unsw.edu.au>
Tue, 16 Jan 2007 15:06:01 +0000 (16:06 +0100)
binary.cabal
src/Data/Binary.hs
src/Data/Binary/Put.hs
tests/Benchmark.hs
tests/Makefile
tests/NewBenchmark.hs [new file with mode: 0644]
tests/NewBinary.hs [new file with mode: 0644]

index c1a5250..fc0b85b 100644 (file)
@@ -11,4 +11,4 @@ exposed-modules: Data.Binary,
                  Data.Binary.Get
 extensions:      ForeignFunctionInterface,CPP,FlexibleInstances
 hs-source-dirs:  src
-ghc-options:     -O -Wall -Werror
+ghc-options:     -O2 -optc-O3 -Wall -Werror -fliberate-case-threshold=100
index 3716458..656aca3 100644 (file)
@@ -8,7 +8,7 @@
 -- Stability   : unstable
 -- Portability : portable to Hugs and GHC. Requires the FFI and some flexible instances
 --
--- Binary serialisation of values to and from lazy ByteStrings.
+-- Binary serialisation of Haskell values to and from lazy ByteStrings.
 --
 -----------------------------------------------------------------------------
 
@@ -17,6 +17,8 @@ module Data.Binary (
     -- * The Binary class
       Binary(..)
 
+    -- $example
+
     -- * The Get and Put monads
     , Get
     , Put
@@ -37,8 +39,12 @@ module Data.Binary (
     , lazyPut
     , lazyGet
 
+    , module Data.Word -- useful
+
     ) where
 
+import Data.Word
+
 import Data.Binary.Put
 import Data.Binary.Get
 
@@ -73,14 +79,29 @@ import qualified Data.Sequence as Seq
 ------------------------------------------------------------------------
 
 -- | The @Binary@ class provides 'put' and 'get', methods to encode and
--- decode a value to a lazy bytestring.
+-- decode a Haskell value to a lazy ByteString. It mirrors the Read and
+-- Show classes for textual representation of Haskell types, and is
+-- suitable for serialising Haskell values to disk, over the network.
+--
+-- For parsing and generating simple external binary formats (e.g. C
+-- structures), Binary may be used, but in general is not suitable
+-- for complex protocols. Instead use the Put and Get primitives
+-- directly.
 --
--- New instances for binary should have the following property:
+-- Instances of Binary should satisfy the following property:
 --
 -- > get . put == id
 --
--- A range of instances are provided for basic Haskell types. To
--- serialise a custom type, an instance of Binary for that type is
+-- A range of instances are provided for basic Haskell types. 
+--
+class Binary t where
+    -- | Encode a value in the Put monad.
+    put :: t -> Put
+    -- | Decode a value in the Get monad
+    get :: Get t
+
+-- $example
+-- To serialise a custom type, an instance of Binary for that type is
 -- required. For example, suppose we have a data structure:
 --
 -- > data Exp = IntE Int
@@ -143,11 +164,6 @@ import qualified Data.Sequence as Seq
 --
 -- > > encodeFile "/tmp/a.txt" v
 --
-class Binary t where
-    -- | Encode a value in the Put monad.
-    put :: t -> Put
-    -- | Decode a value in the Get monad
-    get :: Get t
 
 ------------------------------------------------------------------------
 -- Wrappers to run the underlying monad
index 28437eb..a46eb91 100644 (file)
@@ -41,33 +41,41 @@ module Data.Binary.Put (
 import Control.Monad.Writer
 
 import Foreign
-import System.IO.Unsafe
 
 import Data.Monoid
 import Data.Word
+import Data.ByteString.Base (inlinePerformIO)
 import qualified Data.ByteString.Base as S
 import qualified Data.ByteString.Lazy as L
 
 type Put = Writer Builder ()
 
+-- | Run the 'Put' monad with a serialiser
 runPut              :: Put -> L.ByteString
 runPut              = runBuilder . execWriter
 
+-- | Pop the ByteString we have constructed so far, if any, yielding a
+-- new chunk in the result ByteString.
 flush               :: Put
 flush               = tell flushB
 
 putWord8            :: Word8 -> Put
 putWord8            = tell . singleton
 
+-- | An efficient primitive to write a strict ByteString into the output buffer.
+-- It flushes the current buffer, and writes the argument into a new chunk.
 putByteString       :: S.ByteString -> Put
 putByteString       = tell . putByteStringB
 
+-- | Write a lazy ByteString efficiently, simply appending the lazy
+-- ByteString chunks to the output buffer
 putLazyByteString   :: L.ByteString -> Put
 putLazyByteString   = tell . putLazyByteStringB
 
 -- | Write a Word16 in big endian format
 putWord16be         :: Word16 -> Put
 putWord16be         = tell . putWord16beB
+{-# INLINE putWord16be #-}
 
 -- | Write a Word16 in little endian format
 putWord16le         :: Word16 -> Put
@@ -145,13 +153,13 @@ defaultSize = 32 * k - overhead
 -- Run the builder monoid
 --
 runBuilder :: Builder -> L.ByteString
-runBuilder m = S.LPS $ unsafePerformIO $ do
+runBuilder m = S.LPS $ inlinePerformIO $ do
     buf <- newBuffer defaultSize
     return (unBuilder (m `append` flushB) (const []) buf)
 
 -- | Sequence an IO operation on the buffer
 unsafeLiftIO :: (Buffer -> IO Buffer) -> Builder
-unsafeLiftIO f =  Builder $ \ k buf -> unsafePerformIO $ do
+unsafeLiftIO f =  Builder $ \ k buf -> inlinePerformIO $ do
     buf' <- f buf
     return (k buf')
 
@@ -175,7 +183,7 @@ flushB = Builder $ \ k buf@(Buffer p o u l) ->
 
 -- | Ensure that there are at least @n@ many bytes available.
 ensureFree :: Int -> Builder
-ensureFree n = withSize $ \ l ->
+ensureFree n = n `seq` withSize $ \ l ->
     if n <= l then empty else
         flushB `append` unsafeLiftIO (const (newBuffer (max n defaultSize)))
 {-# INLINE [1] ensureFree #-}
@@ -219,8 +227,8 @@ putWord16beB w16 =
     let w1 = shiftR w16 8
         w2 = w16 .&. 0xff
     in
-    singleton (fromIntegral w1) `append`
-    singleton (fromIntegral w2)
+    putWord8B (fromIntegral w1) `append`
+    putWord8B (fromIntegral w2)
 {-# INLINE putWord16be #-}
 
 -- | Write a Word16 in little endian format
index 128d79f..a377daa 100644 (file)
@@ -1,8 +1,10 @@
+{-# OPTIONS -fbang-patterns #-}
 module Main where
 
 import qualified Data.ByteString.Lazy as L
 import Data.Binary
 import Data.Binary.Put
+import Text.Printf
 
 import Control.Exception
 import System.CPUTime
@@ -22,21 +24,22 @@ time label f = do
     v     <- f
     end   <- getCPUTime
     let diff = (fromIntegral (end - start)) / (10^12)
-    print (diff :: Double)
+    printf "%0.4f\n" (diff :: Double)
     return v
 
 test label f n fs s = time label $ do
-    let bs = runPut (doN n fs s f)
+    let bs = runPut (doN (n :: Int) fs s f)
     evaluate (L.length bs)
     return ()
 
+doN :: Int -> (t2 -> t2) -> t2 -> (t2 -> Put) -> Put
 doN 0 _ _ _ = return ()
 doN !n !f !s !body = do
     body s
     doN (n-1) f (f s) body
 
-word8  = test "Word8  1MB" putWord8    1000000 (+1) 0
-word16 = test "Word16 1MB" putWord16be  500000 (+1) 0
-word32 = test "Word32 1MB" putWord32be  250000 (+1) 0
-word64 = test "Word64 1MB" putWord64be  125000 (+1) 0
+word8  = test "Word8  10MB" putWord8    10000000 (+1) 0
+word16 = test "Word16 10MB" putWord16be  5000000 (+1) 0
+word32 = test "Word32 10MB" putWord32be  2500000 (+1) 0
+word64 = test "Word64 10MB" putWord64be  1250000 (+1) 0
 
index 2bf4238..b7b0a8a 100644 (file)
@@ -4,15 +4,19 @@ interpreted:
        runhaskell QC.hs 1000
 
 compiled: bench
-       ghc -prof -auto-all --make -O QC.hs -o qc -no-recomp
+       ghc -prof-auto-all --make -O QC.hs -o qc -no-recomp
        time ./qc 1000
 
-bench:
+bench::
        ghc -fbang-patterns --make -O Benchmark.hs -o bench -no-recomp
        time ./bench
 
+bench-nb::
+       ghc -fbang-patterns --make -O NewBenchmark.hs -o bench-nb -no-recomp
+       time ./bench-nb
+
 hugs:
        runhugs -98 QC.hs  
 
 clean:
-       rm -f *.o *.hi qc bench *~
+       rm -f *.o *.hi qc bench bench-nb *~
diff --git a/tests/NewBenchmark.hs b/tests/NewBenchmark.hs
new file mode 100644 (file)
index 0000000..7ab718a
--- /dev/null
@@ -0,0 +1,52 @@
+{-# OPTIONS -fbang-patterns #-}
+--
+-- benchmark NewBinary
+--
+
+module Main where
+
+import System.IO
+import Data.Word
+import NewBinary
+import qualified Data.ByteString.Lazy as L
+
+import Text.Printf
+import Control.Exception
+import System.CPUTime
+
+main :: IO ()
+main = do
+    word8 
+    word16
+    word32
+    word64
+
+time :: String -> IO a -> IO a
+time label f = do
+    putStr (label ++ " ")
+    start <- getCPUTime
+    v     <- f
+    end   <- getCPUTime
+    let diff = (fromIntegral (end - start)) / (10^12)
+    printf "%0.4f\n" (diff :: Double)
+    return v
+
+test label f n fs s = do
+    h <- openBinMem (1024 * 1024 * 10) undefined
+    time label $ doN n fs s f h
+
+doN 0 _ _ _  _ = return ()
+doN !n !f !s !body !h = do
+    body h s
+    doN (n-1) f (f s) body h
+
+putWord8 h w    = put h (w :: Word8)
+putWord16be h w = put h (w :: Word16)
+putWord32be h w = put h (w :: Word32)
+putWord64be h w = put h (w :: Word64)
+
+word8  = test "Word8  10MB" putWord8    10000000 (+1) 0
+word16 = test "Word16 10MB" putWord16be  5000000 (+1) 0
+word32 = test "Word32 10MB" putWord32be  2500000 (+1) 0
+word64 = test "Word64 10MB" putWord64be  1250000 (+1) 0
+
diff --git a/tests/NewBinary.hs b/tests/NewBinary.hs
new file mode 100644 (file)
index 0000000..9c7d9c8
--- /dev/null
@@ -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
+