{-# 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