{-# OPTIONS -cpp #-}
-{-# OPTIONS -w #-}
--- The above warning supression flag is a temporary kludge.
--- While working on this module you are encouraged to remove it and fix
--- any warnings in the module. See
--- http://hackage.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#Warnings
--- for details
+{-# OPTIONS_GHC -O -funbox-strict-fields #-}
+-- We always optimise this, otherwise performance of a non-optimised
+-- compiler is severely affected
--
-- (c) The University of Glasgow 2002-2006
-- closeBin,
seekBin,
+ seekBy,
tellBin,
castBin,
writeBinMem,
readBinMem,
+ fingerprintBinMem,
isEOFBin,
lazyGet,
lazyPut,
+#ifdef __GLASGOW_HASKELL__
-- GHC only:
ByteArray(..),
getByteArray,
putByteArray,
+#endif
UserData(..), getUserData, setUserData,
newReadState, newWriteState,
- putDictionary, getDictionary,
+ putDictionary, getDictionary, putFS,
) where
#include "HsVersions.h"
import {-# SOURCE #-} Name (Name)
import FastString
-import Unique
import Panic
import UniqFM
import FastMutInt
+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 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
--- be independent of hslibs libraries.
-import GHC.Handle ( openFileEx, IOModeEx(..) )
-#else
-import System.IO ( openBinaryFile )
-#endif
+import GHC.IOBase ( IO(..) )
+import GHC.Word ( Word8(..) )
+import System.IO ( openBinaryFile )
-#if __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
+ 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 False $ -- disabled
+ 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) $
- ioError (mkIOError eofErrorType "Data.Binary.getWord8" Nothing Nothing)
+ 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
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
-- UserData
-- -----------------------------------------------------------------------------
-data UserData =
+data UserData =
UserData {
-- for *deserialising* only:
- ud_dict :: Dictionary,
+ ud_dict :: Dictionary,
ud_symtab :: SymbolTable,
-- for *serialising* only:
- ud_dict_next :: !FastMutInt, -- The next index to use
- ud_dict_map :: !(IORef (UniqFM (Int,FastString))),
- -- indexed by FastString
-
- ud_symtab_next :: !FastMutInt, -- The next index to use
- ud_symtab_map :: !(IORef (UniqFM (Int,Name)))
- -- indexed by Name
+ ud_put_name :: BinHandle -> Name -> IO (),
+ ud_put_fs :: BinHandle -> FastString -> IO ()
}
newReadState :: Dictionary -> IO UserData
newReadState dict = do
- dict_next <- newFastMutInt
- dict_map <- newIORef (undef "dict_map")
- symtab_next <- newFastMutInt
- symtab_map <- newIORef (undef "symtab_map")
- return UserData { ud_dict = dict,
- ud_symtab = undef "symtab",
- ud_dict_next = dict_next,
- ud_dict_map = dict_map,
- ud_symtab_next = symtab_next,
- ud_symtab_map = symtab_map
+ return UserData { ud_dict = dict,
+ ud_symtab = undef "symtab",
+ ud_put_name = undef "put_name",
+ ud_put_fs = undef "put_fs"
}
-newWriteState :: IO UserData
-newWriteState = do
- dict_next <- newFastMutInt
- writeFastMutInt dict_next 0
- dict_map <- newIORef emptyUFM
- symtab_next <- newFastMutInt
- writeFastMutInt symtab_next 0
- symtab_map <- newIORef emptyUFM
- return UserData { ud_dict = undef "dict",
- ud_symtab = undef "symtab",
- ud_dict_next = dict_next,
- ud_dict_map = dict_map,
- ud_symtab_next = symtab_next,
- ud_symtab_map = symtab_map
+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 -> UniqFM (Int,FastString) -> IO ()
putDictionary bh sz dict = do
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)
---------------------------------------------------------
--- The Symbol Table
+-- The Symbol Table
---------------------------------------------------------
-- On disk, the symbol table is an array of IfaceExtName, when
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
instance Binary FastString where
- put_ bh f@(FastString id l _ fp _) =
- case getUserData bh of {
- UserData { ud_dict_next = j_r,
- ud_dict_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 <- readFastMutInt j_r
- put_ bh j
- writeFastMutInt j_r (j+1)
- writeIORef out_r $! addToUFM out uniq (j,f)
- }
+ put_ bh f =
+ case getUserData bh of
+ UserData { ud_put_fs = put_fs } -> put_fs bh f
+
+ get bh = do
+ j <- get bh
+ return $! (ud_dict (getUserData bh) ! j)
+
+-- Here to avoid loop
+
+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)