NewBinary (empty) → 0.1
raw patch · 7 files changed
+1159/−0 lines, 7 filesdep +basebuild-type:Customsetup-changed
Dependencies added: base
Files
- LICENSE +13/−0
- NewBinary.cabal +13/−0
- NewBinary/Binary.hs +962/−0
- NewBinary/FastMutInt.lhs +80/−0
- Notes +81/−0
- Setup.lhs +8/−0
- todo.txt +2/−0
+ LICENSE view
@@ -0,0 +1,13 @@+-- (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/++The nhc98 license page is here:++http://www.cs.york.ac.uk/fp/nhc98/copyright.html
+ NewBinary.cabal view
@@ -0,0 +1,13 @@+Name: NewBinary+Version: 0.1+License: OtherLicense+License-File: LICENSE+Maintainer: jeremy@n-heptane.com+Category: Data+Synopsis: A binary I/O library+Description: An older binary serialization library used by a number of+ projects. For new projects consider an alternative such as 'binary'.+ghc-options: -fglasgow-exts -cpp+Build-Depends: base+Exposed-modules: NewBinary.FastMutInt, NewBinary.Binary+extra-source-files: todo.txt, Notes
+ NewBinary/Binary.hs view
@@ -0,0 +1,962 @@+{-# OPTIONS -cpp #-}+--+-- (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.Binary+ ( {-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 NewBinary.FastMutInt++#if __GLASGOW_HASKELL__ > 503+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 +#else+import Bits+import Int+import Word+import Char+import Monad+import Exception+import Array+import IOExts+import GlaExts hiding (ByteArray, newByteArray, freezeByteArray)+import PrelIOBase -- ( IOError(..), IOErrorType(..) )+import PrelReal -- ( Ratio(..) )+import PrelIOBase -- ( IO(..) )+import MArray (IOUArray)+#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 h mod = do+ r <- newZeroInt+ o <- newZeroInt+ c <- newZeroInt+-- state <- newWriteState mod+ return (BinIO r h o c)++--openBinMem :: Int -> Module -> 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+#if __GLASGOW_HASKELL__ > 503+ h <- openBinaryFile fn WriteMode+#else+ h <- openFileEx fn (BinaryMode WriteMode)+#endif+ 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+#if __GLASGOW_HASKELL__ > 503+ h <- openBinaryFile filename ReadMode+#else+ h <- openFileEx filename (BinaryMode ReadMode)+#endif+ 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++-}
+ NewBinary/FastMutInt.lhs view
@@ -0,0 +1,80 @@+{-# OPTIONS -cpp #-}+--+-- (c) The University of Glasgow 2002+--+-- Unboxed mutable Ints++\begin{code}+module NewBinary.FastMutInt(+ FastMutInt, newFastMutInt,+ readFastMutInt, writeFastMutInt,+ incFastMutInt, incFastMutIntBy,+ orFastMutInt+ ) where++#include "MachDeps.h"++#ifndef SIZEOF_HSINT+#define SIZEOF_HSINT INT_SIZE_IN_BYTES+#endif+++import GHC.Exts+#if __GLASGOW_HASKELL__ >= 504+import GHC.IOBase+import Data.Word+import Data.Bits+#else+import PrelIOBase+import Word+import Bits+#endif++#if __GLASGOW_HASKELL__ < 411+newByteArray# = newCharArray#+#endif+\end{code}++\begin{code}+#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))+++\end{code}+#endif+
+ Notes view
@@ -0,0 +1,81 @@+From hdaume@ISI.EDU Tue Dec 3 09:11:32 2002+Date: Wed, 13 Nov 2002 10:24:26 -0800 (PST)+From: Hal Daume III <hdaume@ISI.EDU>+To: Simon Marlow <simonmar@microsoft.com>, Dean Herington <heringto@cs.unc.edu>,+ Alastair Reid <alastair@reid-consulting-uk.ltd.uk>,+ Malcolm Wallace <Malcolm.Wallace@cs.york.ac.uk>,+ Marcin 'Qrczak' Kowalczyk <qrczak@knm.org.pl>+Cc: libraries@haskell.org+Subject: RE: getting a Binary module into the standard libs++I was waiting a while before replying, hoping to get other comments from+people who know more about this stuff than I do, but that doesn't seem to+be happening. As I see it, there are three things left on the table:++ 1) Should putBits support >8 bit operations+ 2) How should we support flushByte+ 3) How should we buffer BinIO++I'll address each of these in turn.++1) I vote in favor of "no". I fear my opinion on this is influenced by+the fact that I offered to implement it. Of course you could always+define putGT8Bits in terms of putLEQ8Bits, but would probably be less+efficient than defining putGT8Bits "natively." I don't see a real need+for it, as Simon said, most of the use for this will be for constructors+and Booleans. I could probably be persuaded otherwise, but I'd like to+hear a good, strong example of why more than 8 bit puts are essential.++2) The proposals for flushByte, as I see it, are:++ a) flushBytes h n aligns the stream to the next 2^n byte + (bit?) boundary++ b) flushBytes h m n aligns the stream such that the position + p satisfies (p = n) mod 2^m++ c) encoding (b) as a single integer (as per Dean's suggestion)++This is something I don't really know enough about to comment. Clearly+(a) is the simplest, implementation wise, and probably the+fastest. (b) would be a bit more work and I don't understand what it+would gain you, but since it seems to be well known I'll admit that I just+know too little to say. (c) wouldn't be much more work than (b), but I+wonder if it's getting too complicated. My vote is probably for (a), but+my vote should only count epsilon in this context. Perhaps (b) is the+right thing to do (I don't need too much convincing here).++3) I think we can all agree that we should buffer BinIOs. There are a few+questions, given this:++ a) Should multiple threads be allowed to write the same BinHandle+ simultaneously? If not, is an error thrown or is the behiour+ just left "unspecified"?++ b) Should multiple threads be allowed to read from the same+ BinHandle simultaneously? If not, ...++ c) Should one thread be allowed to write and another to read from+ the same BH simultaneously? If not, ...++I would probably say:++ a) No & left unspecified+ b) Yes+ c) Yes++That said, we probably need a dupBin function as Simon suggests. I must+say here that I don't know enough about how Handles are implemented in GHC+to know where to start on this. I know that they are already MVars of+Handle__s which basically hold the file pointer and some other stuff, but+I don't know what would need to be done to accomplish such a dupBin+function.++That said, I put it out to the rest of you for comments/persuasions.++ - Hal++_______________________________________________+Libraries mailing list+Libraries@haskell.org+http://www.haskell.org/mailman/listinfo/libraries
+ Setup.lhs view
@@ -0,0 +1,8 @@+#!/usr/bin/env runhaskell++> module Main where++> import Distribution.Simple++> main :: IO ()+> main = defaultMain
+ todo.txt view
@@ -0,0 +1,2 @@+update license+