X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=blobdiff_plain;f=compiler%2Futils%2FBinary.hs;h=378595796691acb7770fe00aa31073b7ed4bef52;hp=7a1ca515b7f0ae7d45dff37482dcd03dbda648be;hb=18691d440f90a3dff4ef538091c886af505e5cf5;hpb=0065d5ab628975892cea1ec7303f968c3338cbe1 diff --git a/compiler/utils/Binary.hs b/compiler/utils/Binary.hs index 7a1ca51..3785957 100644 --- a/compiler/utils/Binary.hs +++ b/compiler/utils/Binary.hs @@ -1,6 +1,10 @@ {-# OPTIONS -cpp #-} +{-# 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 +-- (c) The University of Glasgow 2002-2006 -- -- Binary I/O library, with special tweaks for GHC -- @@ -20,14 +24,18 @@ module Binary -- closeBin, seekBin, + seekBy, tellBin, castBin, writeBinMem, readBinMem, + fingerprintBinMem, isEOFBin, + putAt, getAt, + -- for writing instances: putByte, getByte, @@ -36,82 +44,69 @@ module Binary 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" +#include "../includes/MachDeps.h" +import {-# SOURCE #-} Name (Name) import FastString -import Unique import Panic import UniqFM import FastMutInt -import PackageConfig ( PackageId, packageIdFS, fsToPackageId ) +import Fingerprint +import BasicTypes 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 Data.Typeable +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 - -#if __GLASGOW_HASKELL__ < 601 -openBinaryFile f mode = openFileEx f (BinaryMode mode) -#endif +import GHC.Word ( Word8(..) ) +import GHC.IO ( IO(..) ) -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 @@ -121,17 +116,17 @@ setUserData bh us = bh { bh_usr = us } --------------------------------------------------------------- --- 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 @@ -142,17 +137,17 @@ class Binary a where -- 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 _ <- 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 () +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_ h = openBinIO h openBinIO :: IO.Handle -> IO BinHandle openBinIO h = do @@ -164,7 +159,7 @@ openBinMem :: Int -> IO BinHandle 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 @@ -177,35 +172,43 @@ 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 +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 @@ -214,10 +217,10 @@ 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")) + 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 @@ -226,23 +229,30 @@ readBinMem filename = do 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 @@ -251,17 +261,17 @@ 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 () + -- 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 () @@ -269,21 +279,17 @@ 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 + 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 @@ -319,11 +325,10 @@ instance Binary Word32 where 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 @@ -344,14 +349,14 @@ instance Binary Word64 where 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 @@ -376,51 +381,38 @@ instance Binary Int64 where -- Instances for standard types instance Binary () where - put_ bh () = return () - get _ = return () --- getF bh p = case getBitsF bh 0 p of (_,b) -> ((),b) + put_ _ () = return () + get _ = return () 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 + x <- get bh + return $! (fromIntegral (x :: Int64)) 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 @@ -459,43 +451,70 @@ instance (Binary a, Binary b) => Binary (Either a b) where 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 @@ -514,23 +533,12 @@ freezeByteArray arr = IO $ \s -> (# 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 @@ -538,170 +546,134 @@ instance (Integral a, Binary a) => Binary (Ratio a) where #endif instance Binary (Bin a) where - put_ bh (BinPtr i) = put_ bh i - get bh = do i <- get bh; return (BinPtr i) + put_ bh (BinPtr i) = put_ bh (fromIntegral i :: Int32) + get bh = do i <- get bh; return (BinPtr (fromIntegral (i :: Int32))) + +-- ----------------------------------------------------------------------------- +-- Instances for Data.Typeable stuff + +instance Binary TyCon where + put_ bh ty_con = do + let s = tyConString ty_con + put_ bh s + get bh = do + s <- get bh + return (mkTyCon s) + +instance Binary TypeRep where + put_ bh type_rep = do + let (ty_con, child_type_reps) = splitTyConApp type_rep + put_ bh ty_con + put_ bh child_type_reps + get bh = do + ty_con <- get bh + child_type_reps <- get bh + return (mkTyConApp ty_con child_type_reps) -- ----------------------------------------------------------------------------- -- Lazy reading/writing 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 @@ -709,48 +681,42 @@ getFS bh@BinMem{} = do 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) ! (fromIntegral (j :: Word32))) -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) + +instance Binary FunctionOrData where + put_ bh IsFunction = putByte bh 0 + put_ bh IsData = putByte bh 1 + get bh = do + h <- getByte bh + case h of + 0 -> return IsFunction + 1 -> return IsData + _ -> panic "Binary FunctionOrData" - get bh = do - j <- get bh - return $! (ud_dict (getUserData bh) ! j)