X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2Futils%2FBinary.hs;h=6003923c5cb5d6ba171dfc44f8a70147532facb0;hb=206b4dec78250efef3cd927d64dc6cbc54a16c3d;hp=7a1ca515b7f0ae7d45dff37482dcd03dbda648be;hpb=0065d5ab628975892cea1ec7303f968c3338cbe1;p=ghc-hetmet.git diff --git a/compiler/utils/Binary.hs b/compiler/utils/Binary.hs index 7a1ca51..6003923 100644 --- a/compiler/utils/Binary.hs +++ b/compiler/utils/Binary.hs @@ -1,6 +1,13 @@ {-# 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 + -- --- (c) The University of Glasgow 2002 +-- (c) The University of Glasgow 2002-2006 -- -- Binary I/O library, with special tweaks for GHC -- @@ -28,6 +35,8 @@ module Binary isEOFBin, + putAt, getAt, + -- for writing instances: putByte, getByte, @@ -36,14 +45,16 @@ 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, ) where #include "HsVersions.h" @@ -51,12 +62,12 @@ module Binary -- The *host* architecture version: #include "MachDeps.h" +import {-# SOURCE #-} Name (Name) import FastString import Unique import Panic import UniqFM import FastMutInt -import PackageConfig ( PackageId, packageIdFS, fsToPackageId ) import Foreign import Data.Array.IO @@ -68,7 +79,6 @@ 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 ) @@ -76,7 +86,7 @@ import GHC.Real ( Ratio(..) ) import GHC.Exts import GHC.IOBase ( IO(..) ) import GHC.Word ( Word8(..) ) -#if __GLASGOW_HASKELL__ < 601 +#if defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ < 601 -- openFileEx is available from the lang package, but we want to -- be independent of hslibs libraries. import GHC.Handle ( openFileEx, IOModeEx(..) ) @@ -84,7 +94,7 @@ import GHC.Handle ( openFileEx, IOModeEx(..) ) import System.IO ( openBinaryFile ) #endif -#if __GLASGOW_HASKELL__ < 601 +#if defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ < 601 openBinaryFile f mode = openFileEx f (BinaryMode mode) #endif @@ -200,12 +210,6 @@ writeBinMem (BinMem _ ix_r sz_r arr_r) fn = do 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 @@ -270,11 +274,7 @@ 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) @@ -459,7 +459,21 @@ 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 put_ bh (S# i#) = do putByte bh 0; put_ bh (I# i#) put_ bh (J# s# a#) = do @@ -479,6 +493,10 @@ instance Binary Integer where (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# @@ -514,23 +532,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 @@ -562,106 +569,57 @@ lazyGet bh = do 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" + UserData { + -- for *deserialising* only: + 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 + } -initReadState :: Dictionary -> UserData -initReadState dict = UserData{ ud_dict = dict, - ud_next = undef "next", - ud_map = undef "map" } +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 + } 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 }) - + 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 + } + +noUserData = undef "UserData" undef s = panic ("Binary.UserData: no " ++ s) @@ -672,10 +630,10 @@ undef s = panic ("Binary.UserData: no " ++ s) 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 @@ -683,8 +641,14 @@ getDictionary bh = do 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 @@ -722,33 +686,21 @@ getFS bh = do -- 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 + 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 <- readIORef j_r + j <- readFastMutInt j_r put_ bh j - writeIORef j_r (j+1) - writeIORef out_r (addToUFM out uniq (j,f)) + writeFastMutInt j_r (j+1) + writeIORef out_r $! addToUFM out uniq (j,f) } get bh = do