binary-0.5: tests/NewBinary.hs
{-# 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