{-# LANGUAGE CPP, ScopedTypeVariables #-} -- -- (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, putSharedString, getSharedString, -- lazy Bin I/O lazyGet, lazyPut, #if __GLASGOW_HASKELL__<610 -- GHC only: ByteArray(..), getByteArray, putByteArray, #endif getBinFileWithDict, -- :: Binary a => FilePath -> IO a putBinFileWithDict, -- :: Binary a => FilePath -> ModuleName -> a -> IO () ) where #if __GLASGOW_HASKELL__>=604 #include "ghcconfig.h" #else #include "config.h" #endif import FastMutInt import Map (Map) import qualified Map as Map #if __GLASGOW_HASKELL__>=602 # if __GLASGOW_HASKELL__>=707 import Data.HashTable.Class as HashTable (HashTable) import Data.HashTable.IO as HashTable (BasicHashTable, toList, new, insert, lookup) # else import Data.HashTable as HashTable # endif #endif 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, liftM ) import System.IO as IO import System.IO.Unsafe ( unsafeInterleaveIO ) import System.IO.Error ( mkIOError, eofErrorType ) import GHC.Real ( Ratio(..) ) import GHC.Exts # if __GLASGOW_HASKELL__>=612 import GHC.IO (IO(IO)) #else import GHC.IOBase (IO(IO)) #endif import GHC.Word ( Word8(..) ) # if __GLASGOW_HASKELL__<602 import GHC.Handle ( hSetBinaryMode ) # endif -- for debug import System.CPUTime (getCPUTime) import Numeric (showFFloat) #define SIZEOF_HSINT SIZEOF_VOID_P 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 <- openFile fn WriteMode hSetBinaryMode h True arr <- readIORef arr_r ix <- readFastMutInt ix_r hPutArray h arr ix hClose h readBinMem :: FilePath -> IO BinHandle -- Return a BinHandle with a totally undefined State readBinMem filename = do h <- openFile filename ReadMode hSetBinaryMode h True 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) $ ioError (mkIOError eofErrorType "Data.Binary.getWord8" Nothing Nothing) 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) :: Word8) get bh = do x <- get bh; return $! (chr (fromIntegral (x :: Word8))) -- 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 list = do put_ bh (length list) mapM_ (put_ bh) list get bh = do len <- get bh let getMany :: Int -> IO [a] getMany 0 = return [] getMany n = do x <- get bh xs <- getMany (n-1) return (x:xs) getMany 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) instance (Binary a, Binary i, Ix i) => Binary (Array i a) where put_ bh arr = do put_ bh (Data.Array.bounds arr) put_ bh (Data.Array.elems arr) get bh = do bounds <- get bh elems <- get bh return $ listArray bounds elems instance (Binary key, Ord key, Binary elem) => Binary (Map key elem) where -- put_ bh fm = put_ bh (Map.toList fm) -- get bh = do list <- get bh -- return (Map.fromList list) put_ bh fm = do let list = Map.toList fm put_ bh (length list) mapM_ (\(key, val) -> do put_ bh key lazyPut bh val) list get bh = do len <- get bh let getMany :: Int -> IO [(key,elem)] getMany 0 = return [] getMany n = do key <- get bh val <- lazyGet bh xs <- getMany (n-1) return ((key,val):xs) -- printElapsedTime "before get Map" list <- getMany len -- printElapsedTime "after get Map" return (Map.fromList list) #ifdef __GLASGOW_HASKELL__ #if __GLASGOW_HASKELL__<610 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) #else instance Binary Integer where put_ h n = do put h ((fromIntegral $ signum n) :: Int8) when (n /= 0) $ do let n' = abs n nBytes = byteSize n' put h (fromIntegral nBytes :: Word64) mapM_ (putByte h) [ fromIntegral ((n' `shiftR` (b * 8)) .&. 0xff) | b <- [ nBytes-1, nBytes-2 .. 0 ] ] where byteSize n = let f b = if (1 `shiftL` (b * 8)) > n then b else f (b + 1) in f 0 get h = do sign :: Int8 <- get h if sign == 0 then return 0 else do nBytes :: Word64 <- get h n <- accumBytes nBytes 0 return $ fromIntegral sign * n where accumBytes nBytes acc | nBytes == 0 = return acc | otherwise = do b <- getByte h accumBytes (nBytes - 1) ((acc `shiftL` 8) .|. fromIntegral b) #endif #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 binaryInterfaceMagic = 0x1face :: Word32 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) $ error "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 -- hnd <- openBinaryFile file_path WriteMode -- bh <- openBinIO hnd 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) #if __GLASGOW_HASKELL__>=602 fm <- HashTable.toList (ud_map usr_state) #else fm <- liftM Map.toList $ readIORef (ud_map usr_state) #endif 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 -- hClose hnd -- ----------------------------------------------------------------------------- -- 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 #if __GLASGOW_HASKELL__>=602 # if __GLASGOW_HASKELL__>=707 ud_map :: BasicHashTable String Int -- The index of each string # else ud_map :: HashTable String Int -- The index of each string # endif #else ud_map :: IORef (Map String Int) #endif } 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 #if __GLASGOW_HASKELL__>=602 # if __GLASGOW_HASKELL__>=707 out_r <- HashTable.new # else out_r <- HashTable.new (==) HashTable.hashString # endif #else out_r <- newIORef Map.empty #endif return (UserData { ud_dict = error "dict", ud_next = j_r, ud_map = out_r }) undef s = error ("Binary.UserData: no " ++ s) --------------------------------------------------------- -- The Dictionary --------------------------------------------------------- type Dictionary = Array Int String -- The dictionary -- Should be 0-indexed putDictionary :: BinHandle -> Int -> Dictionary -> IO () putDictionary bh sz dict = do put_ bh sz mapM_ (put_ bh) (elems dict) getDictionary :: BinHandle -> IO Dictionary getDictionary bh = do sz <- get bh elems <- sequence (take sz (repeat (get bh))) return (listArray (0,sz-1) elems) constructDictionary :: Int -> [(String,Int)] -> Dictionary constructDictionary j fm = array (0,j-1) (map (\(x,y) -> (y,x)) fm) --------------------------------------------------------- -- Reading and writing memoised Strings --------------------------------------------------------- putSharedString :: BinHandle -> String -> IO () putSharedString bh str = case getUserData bh of UserData { ud_next = j_r, ud_map = out_r, ud_dict = dict} -> do #if __GLASGOW_HASKELL__>=602 entry <- HashTable.lookup out_r str #else fm <- readIORef out_r let entry = Map.lookup str fm #endif case entry of Just j -> put_ bh j Nothing -> do j <- readIORef j_r put_ bh j writeIORef j_r (j+1) #if __GLASGOW_HASKELL__>=602 HashTable.insert out_r str j #else modifyIORef out_r (\fm -> Map.insert str j fm) #endif getSharedString :: BinHandle -> IO String getSharedString bh = do j <- get bh return $! (ud_dict (getUserData bh) ! j) {- --------------------------------------------------------- -- Reading and writing FastStrings --------------------------------------------------------- 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 { 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)) } put_ bh s = error ("Binary.put_(FastString): " ++ show (unpackFS s)) get bh = do j <- get bh return $! (ud_dict (getUserData bh) ! j) -} printElapsedTime :: String -> IO () printElapsedTime msg = do time <- getCPUTime hPutStr stderr $ "elapsed time: " ++ Numeric.showFFloat (Just 2) ((fromIntegral time) / 10^12) " (" ++ msg ++ ")\n"