diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -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 diff --git a/NewBinary.cabal b/NewBinary.cabal new file mode 100644 --- /dev/null +++ b/NewBinary.cabal @@ -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 diff --git a/NewBinary/Binary.hs b/NewBinary/Binary.hs new file mode 100644 --- /dev/null +++ b/NewBinary/Binary.hs @@ -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 + +-} diff --git a/NewBinary/FastMutInt.lhs b/NewBinary/FastMutInt.lhs new file mode 100644 --- /dev/null +++ b/NewBinary/FastMutInt.lhs @@ -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 + diff --git a/Notes b/Notes new file mode 100644 --- /dev/null +++ b/Notes @@ -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 +To: Simon Marlow , Dean Herington , + Alastair Reid , + Malcolm Wallace , + Marcin 'Qrczak' Kowalczyk +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 diff --git a/Setup.lhs b/Setup.lhs new file mode 100644 --- /dev/null +++ b/Setup.lhs @@ -0,0 +1,8 @@ +#!/usr/bin/env runhaskell + +> module Main where + +> import Distribution.Simple + +> main :: IO () +> main = defaultMain diff --git a/todo.txt b/todo.txt new file mode 100644 --- /dev/null +++ b/todo.txt @@ -0,0 +1,2 @@ +update license +