{-# OPTIONS -cpp #-}
--
--- (c) The University of Glasgow 2002
+-- (c) The University of Glasgow 2002-2006
--
-- Binary I/O library, with special tweaks for GHC
--
-- closeBin,
seekBin,
+ seekBy,
tellBin,
castBin,
writeBinMem,
readBinMem,
+ fingerprintBinMem,
isEOFBin,
+ putAt, getAt,
+
-- for writing instances:
putByte,
getByte,
lazyGet,
lazyPut,
+#ifdef __GLASGOW_HASKELL__
-- GHC only:
ByteArray(..),
getByteArray,
putByteArray,
+#endif
- getBinFileWithDict, -- :: Binary a => FilePath -> IO a
- putBinFileWithDict, -- :: Binary a => FilePath -> ModuleName -> a -> IO ()
-
+ UserData(..), getUserData, setUserData,
+ newReadState, newWriteState,
+ putDictionary, getDictionary, putFS,
) where
#include "HsVersions.h"
-- The *host* architecture version:
#include "MachDeps.h"
+import {-# SOURCE #-} Name (Name)
import FastString
-import Unique
import Panic
import UniqFM
import FastMutInt
-import PackageConfig ( PackageId, packageIdFS, fsToPackageId )
+import Util
+import Fingerprint
import Foreign
-import Data.Array.IO
import Data.Array
import Data.Bits
import Data.Int
import Data.Word
import Data.IORef
-import Data.Char ( ord, chr )
-import Data.Array.Base ( unsafeRead, unsafeWrite )
-import Control.Monad ( when )
-import Control.Exception ( throwDyn )
+import Data.Char ( ord, chr )
+import Control.Monad ( when )
import System.IO as IO
-import System.IO.Unsafe ( unsafeInterleaveIO )
-import System.IO.Error ( mkIOError, eofErrorType )
-import GHC.Real ( Ratio(..) )
+import System.IO.Unsafe ( unsafeInterleaveIO )
+import System.IO.Error ( mkIOError, eofErrorType )
+import GHC.Real ( Ratio(..) )
import GHC.Exts
-import GHC.IOBase ( IO(..) )
-import GHC.Word ( Word8(..) )
-#if __GLASGOW_HASKELL__ < 601
--- openFileEx is available from the lang package, but we want to
+import GHC.IOBase ( IO(..) )
+import GHC.Word ( Word8(..) )
+#if defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ < 601
+-- openFileEx is available from the lang package, but we want to
-- be independent of hslibs libraries.
-import GHC.Handle ( openFileEx, IOModeEx(..) )
+import GHC.Handle ( openFileEx, IOModeEx(..) )
#else
-import System.IO ( openBinaryFile )
+import System.IO ( openBinaryFile )
#endif
-#if __GLASGOW_HASKELL__ < 601
+#if defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ < 601
openBinaryFile f mode = openFileEx f (BinaryMode mode)
#endif
-type BinArray = IOUArray Int Word8
+type BinArray = ForeignPtr Word8
---------------------------------------------------------------
--- BinHandle
+-- BinHandle
---------------------------------------------------------------
data BinHandle
- = BinMem { -- binary data stored in an unboxed array
- bh_usr :: UserData, -- sigh, need parameterized modules :-)
- off_r :: !FastMutInt, -- the current offset
- sz_r :: !FastMutInt, -- size of the array (cached)
- arr_r :: !(IORef BinArray) -- the array (bounds: (0,size-1))
+ = BinMem { -- binary data stored in an unboxed array
+ bh_usr :: UserData, -- sigh, need parameterized modules :-)
+ _off_r :: !FastMutInt, -- the current offset
+ _sz_r :: !FastMutInt, -- size of the array (cached)
+ _arr_r :: !(IORef BinArray) -- the array (bounds: (0,size-1))
}
- -- XXX: should really store a "high water mark" for dumping out
- -- the binary data to a 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
+ | BinIO { -- binary data stored in a file
bh_usr :: UserData,
- off_r :: !FastMutInt, -- the current offset (cached)
- hdl :: !IO.Handle -- the file handle (must be seekable)
+ _off_r :: !FastMutInt, -- the current offset (cached)
+ _hdl :: !IO.Handle -- the file handle (must be seekable)
}
- -- 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.
+ -- 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.
getUserData :: BinHandle -> UserData
getUserData bh = bh_usr bh
---------------------------------------------------------------
--- Bin
+-- Bin
---------------------------------------------------------------
-newtype Bin a = BinPtr Int
+newtype Bin a = BinPtr Int
deriving (Eq, Ord, Show, Bounded)
castBin :: Bin a -> Bin b
castBin (BinPtr i) = BinPtr i
---------------------------------------------------------------
--- class Binary
+-- class Binary
---------------------------------------------------------------
class Binary a where
getAt bh p = do seekBin bh p; get bh
openBinIO_ :: IO.Handle -> IO BinHandle
-openBinIO_ h = openBinIO h
+openBinIO_ h = openBinIO h
openBinIO :: IO.Handle -> IO BinHandle
openBinIO h = do
openBinMem size
| size <= 0 = error "Data.Binary.openBinMem: size must be >= 0"
| otherwise = do
- arr <- newArray_ (0,size-1)
+ arr <- mallocForeignPtrBytes size
arr_r <- newIORef arr
ix_r <- newFastMutInt
writeFastMutInt ix_r 0
tellBin (BinMem _ r _ _) = do ix <- readFastMutInt r; return (BinPtr ix)
seekBin :: BinHandle -> Bin a -> IO ()
-seekBin (BinIO _ ix_r h) (BinPtr p) = do
+seekBin (BinIO _ ix_r h) (BinPtr p) = do
writeFastMutInt ix_r p
hSeek h AbsoluteSeek (fromIntegral p)
-seekBin h@(BinMem _ ix_r sz_r a) (BinPtr p) = do
+seekBin h@(BinMem _ ix_r sz_r _) (BinPtr p) = do
sz <- readFastMutInt sz_r
if (p >= sz)
- then do expandBin h p; writeFastMutInt ix_r p
- else writeFastMutInt ix_r p
+ then do expandBin h p; writeFastMutInt ix_r p
+ else writeFastMutInt ix_r p
+
+seekBy :: BinHandle -> Int -> IO ()
+seekBy (BinIO _ ix_r h) off = do
+ ix <- readFastMutInt ix_r
+ let ix' = ix + off
+ writeFastMutInt ix_r ix'
+ hSeek h AbsoluteSeek (fromIntegral ix')
+seekBy h@(BinMem _ ix_r sz_r _) off = do
+ sz <- readFastMutInt sz_r
+ ix <- readFastMutInt ix_r
+ let ix' = ix + off
+ if (ix' >= sz)
+ then do expandBin h ix'; writeFastMutInt ix_r ix'
+ else writeFastMutInt ix_r ix'
isEOFBin :: BinHandle -> IO Bool
-isEOFBin (BinMem _ ix_r sz_r a) = do
+isEOFBin (BinMem _ ix_r sz_r _) = do
ix <- readFastMutInt ix_r
sz <- readFastMutInt sz_r
return (ix >= sz)
-isEOFBin (BinIO _ ix_r h) = hIsEOF h
+isEOFBin (BinIO _ _ h) = hIsEOF h
writeBinMem :: BinHandle -> FilePath -> IO ()
writeBinMem (BinIO _ _ _) _ = error "Data.Binary.writeBinMem: not a memory handle"
-writeBinMem (BinMem _ ix_r sz_r arr_r) fn = do
+writeBinMem (BinMem _ ix_r _ arr_r) fn = do
h <- openBinaryFile fn WriteMode
arr <- readIORef arr_r
ix <- readFastMutInt ix_r
- hPutArray h arr ix
-#if __GLASGOW_HASKELL__ <= 500
- -- workaround a bug in old implementation of hPutBuf (it doesn't
- -- set the FILEOBJ_RW_WRITTEN flag on the file object, so the file doens't
- -- get flushed properly). Adding an extra '\0' doens't do any harm.
- hPutChar h '\0'
-#endif
+ withForeignPtr arr $ \p -> hPutBuf h p ix
hClose h
readBinMem :: FilePath -> IO BinHandle
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"))
+ arr <- mallocForeignPtrBytes (filesize*2)
+ count <- withForeignPtr arr $ \p -> hGetBuf h p filesize
+ when (count /= filesize) $
+ error ("Binary.readBinMem: only read " ++ show count ++ " bytes")
hClose h
arr_r <- newIORef arr
ix_r <- newFastMutInt
writeFastMutInt sz_r filesize
return (BinMem noUserData ix_r sz_r arr_r)
+fingerprintBinMem :: BinHandle -> IO Fingerprint
+fingerprintBinMem (BinIO _ _ _) = error "Binary.md5BinMem: not a memory handle"
+fingerprintBinMem (BinMem _ ix_r _ arr_r) = do
+ arr <- readIORef arr_r
+ ix <- readFastMutInt ix_r
+ withForeignPtr arr $ \p -> fingerprintData p ix
+
-- 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
+expandBin (BinMem _ _ 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 ] ]
+ arr' <- mallocForeignPtrBytes sz'
+ withForeignPtr arr $ \old ->
+ withForeignPtr arr' $ \new ->
+ copyBytes new old sz
writeFastMutInt sz_r sz'
writeIORef arr_r arr'
-#ifdef DEBUG
- hPutStrLn stderr ("Binary: expanding to size: " ++ show sz')
-#endif
+ when debugIsOn $
+ hPutStrLn stderr ("Binary: expanding to size: " ++ show sz')
return ()
expandBin (BinIO _ _ _) _ = return ()
- -- no need to expand a file, we'll assume they expand by themselves.
+-- no need to expand a file, we'll assume they expand by themselves.
-- -----------------------------------------------------------------------------
-- Low-level reading/writing of bytes
putWord8 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
- putWord8 h w
- else do arr <- readIORef arr_r
- unsafeWrite arr ix w
- writeFastMutInt ix_r (ix+1)
- return ()
+ -- 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
+ withForeignPtr arr $ \p -> pokeByteOff p ix w
+ writeFastMutInt ix_r (ix+1)
+ return ()
putWord8 (BinIO _ ix_r h) w = do
ix <- readFastMutInt ix_r
- hPutChar h (chr (fromIntegral w)) -- XXX not really correct
+ hPutChar h (chr (fromIntegral w)) -- XXX not really correct
writeFastMutInt ix_r (ix+1)
return ()
getWord8 (BinMem _ ix_r sz_r arr_r) = do
ix <- readFastMutInt ix_r
sz <- readFastMutInt sz_r
- when (ix >= sz) $
-#if __GLASGOW_HASKELL__ <= 408
- throw (mkIOError eofErrorType "Data.Binary.getWord8" Nothing Nothing)
-#else
- ioError (mkIOError eofErrorType "Data.Binary.getWord8" Nothing Nothing)
-#endif
+ when (ix >= sz) $
+ ioError (mkIOError eofErrorType "Data.Binary.getWord8" Nothing Nothing)
arr <- readIORef arr_r
- w <- unsafeRead arr ix
+ w <- withForeignPtr arr $ \p -> peekByteOff p ix
writeFastMutInt ix_r (ix+1)
return w
getWord8 (BinIO _ ix_r h) = do
ix <- readFastMutInt ix_r
c <- hGetChar h
writeFastMutInt ix_r (ix+1)
- return $! (fromIntegral (ord c)) -- XXX not really correct
+ return $! (fromIntegral (ord c)) -- XXX not really correct
putByte :: BinHandle -> Word8 -> IO ()
putByte bh w = put_ bh w
w2 <- getWord8 h
w3 <- getWord8 h
w4 <- getWord8 h
- return $! ((fromIntegral w1 `shiftL` 24) .|.
- (fromIntegral w2 `shiftL` 16) .|.
- (fromIntegral w3 `shiftL` 8) .|.
- (fromIntegral w4))
-
+ return $! ((fromIntegral w1 `shiftL` 24) .|.
+ (fromIntegral w2 `shiftL` 16) .|.
+ (fromIntegral w3 `shiftL` 8) .|.
+ (fromIntegral w4))
instance Binary Word64 where
put_ h w = do
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))
+ 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
-- Instances for standard types
instance Binary () where
- put_ bh () = return ()
- get _ = return ()
+ put_ _ () = return ()
+ get _ = return ()
-- getF bh p = case getBitsF bh 0 p of (_,b) -> ((),b)
instance Binary Bool where
#if SIZEOF_HSINT == 4
put_ bh i = put_ bh (fromIntegral i :: Int32)
get bh = do
- x <- get bh
- return $! (fromIntegral (x :: Int32))
+ 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))
+ 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 l = do
- let len = length l
- if (len < 0xff)
- then putByte bh (fromIntegral len :: Word8)
- else do putByte bh 0xff; put_ bh (fromIntegral len :: Word32)
- mapM_ (put_ bh) l
+ put_ bh l = do
+ let len = length l
+ if (len < 0xff)
+ then putByte bh (fromIntegral len :: Word8)
+ else do putByte bh 0xff; put_ bh (fromIntegral len :: Word32)
+ mapM_ (put_ bh) l
get bh = do
- b <- getByte bh
- len <- if b == 0xff
- then get bh
- else return (fromIntegral b :: Word32)
- let loop 0 = return []
- loop n = do a <- get bh; as <- loop (n-1); return (a:as)
- loop len
+ b <- getByte bh
+ len <- if b == 0xff
+ then get bh
+ else return (fromIntegral b :: Word32)
+ let loop 0 = return []
+ loop n = do a <- get bh; as <- loop (n-1); return (a:as)
+ loop len
instance (Binary a, Binary b) => Binary (a,b) where
put_ bh (a,b) = do put_ bh a; put_ bh b
0 -> do a <- get bh ; return (Left a)
_ -> do b <- get bh ; return (Right b)
-#ifdef __GLASGOW_HASKELL__
+#if defined(__GLASGOW_HASKELL__) || 1
+--to quote binary-0.3 on this code idea,
+--
+-- TODO This instance is not architecture portable. GMP stores numbers as
+-- arrays of machine sized words, so the byte format is not portable across
+-- architectures with different endianess and word size.
+--
+-- This makes it hard (impossible) to make an equivalent instance
+-- with code that is compilable with non-GHC. Do we need any instance
+-- Binary Integer, and if so, does it have to be blazing fast? Or can
+-- we just change this instance to be portable like the rest of the
+-- instances? (binary package has code to steal for that)
+--
+-- yes, we need Binary Integer and Binary Rational in basicTypes/Literal.lhs
+
instance Binary Integer where
+ -- XXX This is hideous
+ put_ bh i = put_ bh (show i)
+ get bh = do str <- get bh
+ case reads str of
+ [(i, "")] -> return i
+ _ -> fail ("Binary Integer: got " ++ show str)
+
+ {-
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#)
+ 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#)
+-}
+
+-- As for the rest of this code, even though this module
+-- exports it, it doesn't seem to be used anywhere else
+-- in GHC!
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#)
+ 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
+ (MBA arr) <- newByteArray sz
let loop n
- | n ==# sz = return ()
- | otherwise = do
- w <- getByte bh
- writeByteArray arr n w
- loop (n +# 1#)
+ | n ==# sz = return ()
+ | otherwise = do
+ w <- getByte bh
+ writeByteArray arr n w
+ loop (n +# 1#)
loop 0#
freezeByteArray arr
(# s, BA arr #) }
writeByteArray :: MutableByteArray# RealWorld -> Int# -> Word8 -> IO ()
-
-#if __GLASGOW_HASKELL__ < 503
-writeByteArray arr i w8 = IO $ \s ->
- case word8ToWord w8 of { W# w# ->
- case writeCharArray# arr i (chr# (word2Int# w#)) s of { s ->
- (# s , () #) }}
-#else
writeByteArray arr i (W8# w) = IO $ \s ->
case writeWord8Array# arr i w s of { s ->
(# s, () #) }
-#endif
-#if __GLASGOW_HASKELL__ < 503
-indexByteArray a# n# = fromIntegral (I# (ord# (indexCharArray# a# n#)))
-#else
+indexByteArray :: ByteArray# -> Int# -> Word8
indexByteArray a# n# = W8# (indexWord8Array# a# n#)
-#endif
instance (Integral a, Binary a) => Binary (Ratio a) where
put_ bh (a :% b) = do put_ bh a; put_ bh b
lazyPut :: Binary a => BinHandle -> a -> IO ()
lazyPut bh a = do
- -- output the obj with a ptr to skip over it:
+ -- 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
+ 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 <- 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
--- --------------------------------------------------------------
--- Main wrappers: getBinFileWithDict, putBinFileWithDict
---
--- This layer is built on top of the stuff above,
--- and should not know anything about BinHandles
--- --------------------------------------------------------------
-
-initBinMemSize = (1024*1024) :: Int
-
-#if WORD_SIZE_IN_BITS == 32
-binaryInterfaceMagic = 0x1face :: Word32
-#elif WORD_SIZE_IN_BITS == 64
-binaryInterfaceMagic = 0x1face64 :: Word32
-#endif
-
-getBinFileWithDict :: Binary a => FilePath -> IO a
-getBinFileWithDict file_path = do
- bh <- Binary.readBinMem file_path
-
- -- Read the magic number to check that this really is a GHC .hi file
- -- (This magic number does not change when we change
- -- GHC interface file format)
- magic <- get bh
- when (magic /= binaryInterfaceMagic) $
- throwDyn (ProgramError (
- "magic number mismatch: old/corrupt interface file?"))
-
- -- Read the dictionary
- -- The next word in the file is a pointer to where the dictionary is
- -- (probably at the end of the file)
- dict_p <- Binary.get bh -- Get the dictionary ptr
- data_p <- tellBin bh -- Remember where we are now
- seekBin bh dict_p
- dict <- getDictionary bh
- seekBin bh data_p -- Back to where we were before
-
- -- Initialise the user-data field of bh
- let bh' = setUserData bh (initReadState dict)
-
- -- At last, get the thing
- get bh'
-
-putBinFileWithDict :: Binary a => FilePath -> a -> IO ()
-putBinFileWithDict file_path the_thing = do
- bh <- openBinMem initBinMemSize
- put_ bh binaryInterfaceMagic
-
- -- Remember where the dictionary pointer will go
- dict_p_p <- tellBin bh
- put_ bh dict_p_p -- Placeholder for ptr to dictionary
-
- -- Make some intial state
- usr_state <- newWriteState
-
- -- Put the main thing,
- put_ (setUserData bh usr_state) the_thing
-
- -- Get the final-state
- j <- readIORef (ud_next usr_state)
- fm <- readIORef (ud_map usr_state)
- dict_p <- tellBin bh -- This is where the dictionary will start
-
- -- Write the dictionary pointer at the fornt of the file
- putAt bh dict_p_p dict_p -- Fill in the placeholder
- seekBin bh dict_p -- Seek back to the end of the file
-
- -- Write the dictionary itself
- putDictionary bh j (constructDictionary j fm)
-
- -- And send the result to the file
- writeBinMem bh file_path
-
-- -----------------------------------------------------------------------------
-- UserData
-- -----------------------------------------------------------------------------
-data UserData =
- UserData { -- This field is used only when reading
- ud_dict :: Dictionary,
-
- -- The next two fields are only used when writing
- ud_next :: IORef Int, -- The next index to use
- ud_map :: IORef (UniqFM (Int,FastString))
- }
-
-noUserData = error "Binary.UserData: no user data"
-
-initReadState :: Dictionary -> UserData
-initReadState dict = UserData{ ud_dict = dict,
- ud_next = undef "next",
- ud_map = undef "map" }
-
-newWriteState :: IO UserData
-newWriteState = do
- j_r <- newIORef 0
- out_r <- newIORef emptyUFM
- return (UserData { ud_dict = panic "dict",
- ud_next = j_r,
- ud_map = out_r })
+data UserData =
+ UserData {
+ -- for *deserialising* only:
+ ud_dict :: Dictionary,
+ ud_symtab :: SymbolTable,
+ -- for *serialising* only:
+ ud_put_name :: BinHandle -> Name -> IO (),
+ ud_put_fs :: BinHandle -> FastString -> IO ()
+ }
+newReadState :: Dictionary -> IO UserData
+newReadState dict = do
+ return UserData { ud_dict = dict,
+ ud_symtab = undef "symtab",
+ ud_put_name = undef "put_name",
+ ud_put_fs = undef "put_fs"
+ }
+
+newWriteState :: (BinHandle -> Name -> IO ())
+ -> (BinHandle -> FastString -> IO ())
+ -> IO UserData
+newWriteState put_name put_fs = do
+ return UserData { ud_dict = undef "dict",
+ ud_symtab = undef "symtab",
+ ud_put_name = put_name,
+ ud_put_fs = put_fs
+ }
+
+noUserData :: a
+noUserData = undef "UserData"
+
+undef :: String -> a
undef s = panic ("Binary.UserData: no " ++ s)
---------------------------------------------------------
--- The Dictionary
+-- The Dictionary
---------------------------------------------------------
-type Dictionary = Array Int FastString -- The dictionary
- -- Should be 0-indexed
+type Dictionary = Array Int FastString -- The dictionary
+ -- Should be 0-indexed
-putDictionary :: BinHandle -> Int -> Dictionary -> IO ()
+putDictionary :: BinHandle -> Int -> UniqFM (Int,FastString) -> IO ()
putDictionary bh sz dict = do
put_ bh sz
- mapM_ (putFS bh) (elems dict)
+ mapM_ (putFS bh) (elems (array (0,sz-1) (eltsUFM dict)))
getDictionary :: BinHandle -> IO Dictionary
-getDictionary bh = do
+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)
+---------------------------------------------------------
+-- The Symbol Table
+---------------------------------------------------------
+
+-- On disk, the symbol table is an array of IfaceExtName, when
+-- reading it in we turn it into a SymbolTable.
+
+type SymbolTable = Array Int Name
---------------------------------------------------------
--- Reading and writing FastStrings
+-- Reading and writing FastStrings
---------------------------------------------------------
-putFS bh (FastString id l _ buf _) = do
+putFS :: BinHandle -> FastString -> IO ()
+putFS bh (FastString _ l _ buf _) = do
put_ bh l
- withForeignPtr buf $ \ptr ->
- let
- go n | n == l = return ()
- | otherwise = do
- b <- peekElemOff ptr n
- putByte bh b
- go (n+1)
- in
+ withForeignPtr buf $ \ptr ->
+ let
+ go n | n == l = return ()
+ | otherwise = do
+ b <- peekElemOff ptr n
+ putByte bh b
+ go (n+1)
+ in
go 0
-
+
{- -- possible faster version, not quite there yet:
getFS bh@BinMem{} = do
(I# l) <- get bh
off <- readFastMutInt (off_r bh)
return $! (mkFastSubStringBA# arr off l)
-}
+getFS :: BinHandle -> IO FastString
getFS bh = do
l <- get bh
fp <- mallocForeignPtrBytes l
withForeignPtr fp $ \ptr -> do
- let
- go n | n == l = mkFastStringForeignPtr ptr fp l
- | otherwise = do
- b <- getByte bh
- pokeElemOff ptr n b
- go (n+1)
+ let
+ go n | n == l = mkFastStringForeignPtr ptr fp l
+ | otherwise = do
+ b <- getByte bh
+ pokeElemOff ptr n b
+ go (n+1)
--
go 0
-#if __GLASGOW_HASKELL__ < 600
-mallocForeignPtrBytes :: Int -> IO (ForeignPtr a)
-mallocForeignPtrBytes n = do
- r <- mallocBytes n
- newForeignPtr r (finalizerFree r)
+instance Binary FastString where
+ put_ bh f =
+ case getUserData bh of
+ UserData { ud_put_fs = put_fs } -> put_fs bh f
-foreign import ccall unsafe "stdlib.h free"
- finalizerFree :: Ptr a -> IO ()
-#endif
+ get bh = do
+ j <- get bh
+ return $! (ud_dict (getUserData bh) ! j)
-instance Binary PackageId where
- put_ bh pid = put_ bh (packageIdFS pid)
- get bh = do { fs <- get bh; return (fsToPackageId fs) }
+-- Here to avoid loop
-instance Binary FastString where
- put_ bh f@(FastString id l _ fp _) =
- case getUserData bh of {
- UserData { ud_next = j_r, ud_map = out_r, ud_dict = 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))
- }
+instance Binary Fingerprint where
+ put_ h (Fingerprint w1 w2) = do put_ h w1; put_ h w2
+ get h = do w1 <- get h; w2 <- get h; return (Fingerprint w1 w2)
- get bh = do
- j <- get bh
- return $! (ud_dict (getUserData bh) ! j)
projects / ghc-hetmet.git / blobdiff