summaryrefslogtreecommitdiff
path: root/compiler/utils/Binary.hs
diff options
context:
space:
mode:
Diffstat (limited to 'compiler/utils/Binary.hs')
-rw-r--r--compiler/utils/Binary.hs756
1 files changed, 756 insertions, 0 deletions
diff --git a/compiler/utils/Binary.hs b/compiler/utils/Binary.hs
new file mode 100644
index 0000000000..7a1ca515b7
--- /dev/null
+++ b/compiler/utils/Binary.hs
@@ -0,0 +1,756 @@
+{-# 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 Binary
+ ( {-type-} Bin,
+ {-class-} Binary(..),
+ {-type-} BinHandle,
+
+ openBinIO, openBinIO_,
+ openBinMem,
+-- closeBin,
+
+ seekBin,
+ tellBin,
+ castBin,
+
+ writeBinMem,
+ readBinMem,
+
+ isEOFBin,
+
+ -- for writing instances:
+ putByte,
+ getByte,
+
+ -- lazy Bin I/O
+ lazyGet,
+ lazyPut,
+
+ -- GHC only:
+ ByteArray(..),
+ getByteArray,
+ putByteArray,
+
+ getBinFileWithDict, -- :: Binary a => FilePath -> IO a
+ putBinFileWithDict, -- :: Binary a => FilePath -> ModuleName -> a -> IO ()
+
+ ) where
+
+#include "HsVersions.h"
+
+-- The *host* architecture version:
+#include "MachDeps.h"
+
+import FastString
+import Unique
+import Panic
+import UniqFM
+import FastMutInt
+import PackageConfig ( PackageId, packageIdFS, fsToPackageId )
+
+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 System.IO as IO
+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
+-- be independent of hslibs libraries.
+import GHC.Handle ( openFileEx, IOModeEx(..) )
+#else
+import System.IO ( openBinaryFile )
+#endif
+
+#if __GLASGOW_HASKELL__ < 601
+openBinaryFile f mode = openFileEx f (BinaryMode mode)
+#endif
+
+type BinArray = IOUArray Int Word8
+
+---------------------------------------------------------------
+-- 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))
+ }
+ -- XXX: should really store a "high water mark" for dumping out
+ -- the binary data to 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)
+ }
+ -- 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
+
+setUserData :: BinHandle -> UserData -> BinHandle
+setUserData bh us = bh { bh_usr = us }
+
+
+---------------------------------------------------------------
+-- Bin
+---------------------------------------------------------------
+
+newtype Bin a = BinPtr Int
+ deriving (Eq, Ord, Show, Bounded)
+
+castBin :: Bin a -> Bin b
+castBin (BinPtr i) = BinPtr i
+
+---------------------------------------------------------------
+-- class Binary
+---------------------------------------------------------------
+
+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
+
+openBinIO :: IO.Handle -> IO BinHandle
+openBinIO h = do
+ r <- newFastMutInt
+ writeFastMutInt r 0
+ return (BinIO noUserData r h)
+
+openBinMem :: Int -> IO BinHandle
+openBinMem size
+ | size <= 0 = error "Data.Binary.openBinMem: size must be >= 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
+ return (BinMem noUserData ix_r sz_r arr_r)
+
+tellBin :: BinHandle -> IO (Bin a)
+tellBin (BinIO _ r _) = do ix <- readFastMutInt r; return (BinPtr ix)
+tellBin (BinMem _ r _ _) = do ix <- readFastMutInt r; return (BinPtr ix)
+
+seekBin :: BinHandle -> Bin a -> IO ()
+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
+ sz <- readFastMutInt sz_r
+ if (p >= sz)
+ then do expandBin h p; writeFastMutInt ix_r p
+ else writeFastMutInt ix_r p
+
+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 (BinMem _ ix_r sz_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
+ hClose h
+
+readBinMem :: FilePath -> IO BinHandle
+-- Return a BinHandle with a totally undefined State
+readBinMem filename = do
+ h <- openBinaryFile filename ReadMode
+ filesize' <- hFileSize h
+ let filesize = fromIntegral filesize'
+ arr <- newArray_ (0,filesize-1)
+ count <- hGetArray h arr filesize
+ when (count /= filesize)
+ (error ("Binary.readBinMem: only read " ++ show count ++ " bytes"))
+ hClose h
+ arr_r <- newIORef arr
+ ix_r <- newFastMutInt
+ writeFastMutInt ix_r 0
+ sz_r <- newFastMutInt
+ writeFastMutInt sz_r filesize
+ return (BinMem noUserData ix_r sz_r arr_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'
+#ifdef DEBUG
+ hPutStrLn stderr ("Binary: expanding to size: " ++ show sz')
+#endif
+ 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) 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 ()
+putWord8 (BinIO _ ix_r h) w = do
+ ix <- readFastMutInt ix_r
+ hPutChar h (chr (fromIntegral w)) -- XXX not really correct
+ writeFastMutInt ix_r (ix+1)
+ return ()
+
+getWord8 :: BinHandle -> IO Word8
+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
+ arr <- readIORef arr_r
+ w <- unsafeRead arr 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
+
+putByte :: BinHandle -> Word8 -> IO ()
+putByte bh w = put_ bh w
+
+getByte :: BinHandle -> IO Word8
+getByte = getWord8
+
+-- -----------------------------------------------------------------------------
+-- 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))
+
+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)
+
+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 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 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
+
+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 (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)
+
+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)
+
+#ifdef __GLASGOW_HASKELL__
+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 ()
+
+#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 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
+ get bh = do a <- get bh; b <- get bh; return (a :% b)
+#endif
+
+instance Binary (Bin a) where
+ put_ bh (BinPtr i) = put_ bh i
+ get bh = do i <- get bh; return (BinPtr i)
+
+-- -----------------------------------------------------------------------------
+-- 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
+
+-- --------------------------------------------------------------
+-- 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 })
+
+
+undef s = panic ("Binary.UserData: no " ++ s)
+
+---------------------------------------------------------
+-- The Dictionary
+---------------------------------------------------------
+
+type Dictionary = Array Int FastString -- The dictionary
+ -- 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)
+
+---------------------------------------------------------
+-- Reading and writing FastStrings
+---------------------------------------------------------
+
+putFS bh (FastString id 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
+ go 0
+
+{- -- 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
+ 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)
+ --
+ go 0
+
+#if __GLASGOW_HASKELL__ < 600
+mallocForeignPtrBytes :: Int -> IO (ForeignPtr a)
+mallocForeignPtrBytes n = do
+ r <- mallocBytes n
+ newForeignPtr r (finalizerFree r)
+
+foreign import ccall unsafe "stdlib.h free"
+ finalizerFree :: Ptr a -> IO ()
+#endif
+
+instance Binary PackageId where
+ put_ bh pid = put_ bh (packageIdFS pid)
+ get bh = do { fs <- get bh; return (fsToPackageId fs) }
+
+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))
+ }
+
+ get bh = do
+ j <- get bh
+ return $! (ud_dict (getUserData bh) ! j)
View Lorry Controller Status