X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2Futils%2FBinary.hs;h=7b40bd279d22042f498a349e6cf47d9301d5d223;hb=9d7da331989abcd1844e9d03b8d1e4163796fa85;hp=3ac01eaa90109d8249d7c8dcb21b110e37691557;hpb=9af77fa423926fbda946b31e174173d0ec5ebac8;p=ghc-hetmet.git diff --git a/ghc/compiler/utils/Binary.hs b/ghc/compiler/utils/Binary.hs index 3ac01ea..7b40bd2 100644 --- a/ghc/compiler/utils/Binary.hs +++ b/ghc/compiler/utils/Binary.hs @@ -19,8 +19,6 @@ module Binary openBinMem, -- closeBin, - getUserData, - seekBin, tellBin, castBin, @@ -44,39 +42,23 @@ module Binary putByteArray, getBinFileWithDict, -- :: Binary a => FilePath -> IO a - putBinFileWithDict, -- :: Binary a => FilePath -> Module -> a -> IO () + putBinFileWithDict, -- :: Binary a => FilePath -> ModuleName -> a -> IO () ) where #include "HsVersions.h" + +-- The *host* architecture version: #include "MachDeps.h" -import {-# SOURCE #-} Module import FastString import Unique import Panic import UniqFM import FastMutInt +import PackageConfig ( PackageId, packageIdFS, fsToPackageId ) -#if __GLASGOW_HASKELL__ < 503 -import DATA_IOREF -import DATA_BITS -import DATA_INT -import DATA_WORD -import Char -import Monad -import Exception -import GlaExts hiding (ByteArray, newByteArray, freezeByteArray) -import Array -import IO -import PrelIOBase ( IOError(..), IOErrorType(..) -#if __GLASGOW_HASKELL__ > 411 - , IOException(..) -#endif - ) -import PrelReal ( Ratio(..) ) -import PrelIOBase ( IO(..) ) -#else +import Foreign import Data.Array.IO import Data.Array import Data.Bits @@ -86,7 +68,7 @@ import Data.IORef import Data.Char ( ord, chr ) import Data.Array.Base ( unsafeRead, unsafeWrite ) import Control.Monad ( when ) -import Control.Exception ( throw, throwDyn ) +import Control.Exception ( throwDyn ) import System.IO as IO import System.IO.Unsafe ( unsafeInterleaveIO ) import System.IO.Error ( mkIOError, eofErrorType ) @@ -94,45 +76,27 @@ 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__ < 503 -type BinArray = MutableByteArray RealWorld Int -newArray_ bounds = stToIO (newCharArray bounds) -unsafeWrite arr ix e = stToIO (writeWord8Array arr ix e) -unsafeRead arr ix = stToIO (readWord8Array arr ix) -#if __GLASGOW_HASKELL__ < 411 -newByteArray# = newCharArray# -#endif -hPutArray h arr sz = hPutBufBAFull h arr sz -hGetArray h sz = hGetBufBAFull h sz - -mkIOError :: IOErrorType -> String -> Maybe Handle -> Maybe FilePath -> Exception -mkIOError t location maybe_hdl maybe_filename - = IOException (IOError maybe_hdl t location "" -#if __GLASGOW_HASKELL__ > 411 - maybe_filename -#endif - ) - -eofErrorType = EOF - -#ifndef SIZEOF_HSINT -#define SIZEOF_HSINT INT_SIZE_IN_BYTES -#endif - -#ifndef SIZEOF_HSWORD -#define SIZEOF_HSWORD WORD_SIZE_IN_BYTES +#if __GLASGOW_HASKELL__ < 601 +openBinaryFile f mode = openFileEx f (BinaryMode mode) #endif -#else type BinArray = IOUArray Int Word8 -#endif + +--------------------------------------------------------------- +-- BinHandle +--------------------------------------------------------------- data BinHandle = BinMem { -- binary data stored in an unboxed array - state :: BinHandleState, -- sigh, need parameterized modules :-) + 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)) @@ -141,7 +105,7 @@ data BinHandle -- the binary data to a file. | BinIO { -- binary data stored in a file - state :: BinHandleState, + bh_usr :: UserData, off_r :: !FastMutInt, -- the current offset (cached) hdl :: !IO.Handle -- the file handle (must be seekable) } @@ -149,12 +113,27 @@ data BinHandle -- 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) @@ -173,17 +152,16 @@ 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 noBinHandleUserData +openBinIO_ h = openBinIO h -openBinIO :: IO.Handle -> Module -> IO BinHandle -openBinIO h mod = do +openBinIO :: IO.Handle -> IO BinHandle +openBinIO h = do r <- newFastMutInt writeFastMutInt r 0 - state <- newWriteState mod - return (BinIO state r h) + return (BinIO noUserData r h) -openBinMem :: Int -> Module -> IO BinHandle -openBinMem size mod +openBinMem :: Int -> IO BinHandle +openBinMem size | size <= 0 = error "Data.Binary.openBinMem: size must be >= 0" | otherwise = do arr <- newArray_ (0,size-1) @@ -192,13 +170,7 @@ openBinMem size mod writeFastMutInt ix_r 0 sz_r <- newFastMutInt writeFastMutInt sz_r size - state <- newWriteState mod - return (BinMem state ix_r sz_r arr_r) - -noBinHandleUserData = error "Binary.BinHandle: no user data" - -getUserData :: BinHandle -> BinHandleState -getUserData bh = state bh + return (BinMem noUserData ix_r sz_r arr_r) tellBin :: BinHandle -> IO (Bin a) tellBin (BinIO _ r _) = do ix <- readFastMutInt r; return (BinPtr ix) @@ -224,7 +196,7 @@ 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 <- openFileEx fn (BinaryMode WriteMode) + h <- openBinaryFile fn WriteMode arr <- readIORef arr_r ix <- readFastMutInt ix_r hPutArray h arr ix @@ -237,8 +209,9 @@ writeBinMem (BinMem _ ix_r sz_r arr_r) fn = do hClose h readBinMem :: FilePath -> IO BinHandle +-- Return a BinHandle with a totally undefined State readBinMem filename = do - h <- openFileEx filename (BinaryMode ReadMode) + h <- openBinaryFile filename ReadMode filesize' <- hFileSize h let filesize = fromIntegral filesize' arr <- newArray_ (0,filesize-1) @@ -251,7 +224,7 @@ readBinMem filename = do writeFastMutInt ix_r 0 sz_r <- newFastMutInt writeFastMutInt sz_r filesize - return (BinMem initReadState ix_r sz_r arr_r) + return (BinMem noUserData ix_r sz_r arr_r) -- expand the size of the array to include a specified offset expandBin :: BinHandle -> Int -> IO () @@ -297,7 +270,11 @@ 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) @@ -430,14 +407,20 @@ instance Binary Int where -- getF bh = getBitsF bh 32 instance Binary a => Binary [a] where - put_ bh [] = putByte bh 0 - put_ bh (x:xs) = do putByte bh 1; put_ bh x; put_ bh xs - get bh = do h <- getWord8 bh - case h of - 0 -> return [] - _ -> do x <- get bh - xs <- get bh - return (x:xs) + 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 @@ -579,66 +562,115 @@ lazyGet bh = do seekBin bh p -- skip over the object for now return a --- ----------------------------------------------------------------------------- --- BinHandleState - -type BinHandleState = - (Module, - IORef Int, - IORef (UniqFM (Int,FastString)), - Array Int FastString) - -initReadState :: BinHandleState -initReadState = (undef, undef, undef, undef) - -newWriteState :: Module -> IO BinHandleState -newWriteState m = do - j_r <- newIORef 0 - out_r <- newIORef emptyUFM - return (m,j_r,out_r,undef) +-- -------------------------------------------------------------- +-- Main wrappers: getBinFileWithDict, putBinFileWithDict +-- +-- This layer is built on top of the stuff above, +-- and should not know anything about BinHandles +-- -------------------------------------------------------------- -undef = error "Binary.BinHandleState" +initBinMemSize = (1024*1024) :: Int --- ----------------------------------------------------------------------------- --- FastString binary interface +#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?")) - dict_p <- Binary.get bh -- get the dictionary ptr - data_p <- tellBin bh + + -- 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 - let (mod, j_r, out_r, _) = state bh - get bh{ state = (mod,j_r,out_r,dict) } + seekBin bh data_p -- Back to where we were before -initBinMemSize = (1024*1024) :: Int + -- Initialise the user-data field of bh + let bh' = setUserData bh (initReadState dict) + + -- At last, get the thing + get bh' -binaryInterfaceMagic = 0x1face :: Word32 - -putBinFileWithDict :: Binary a => FilePath -> Module -> a -> IO () -putBinFileWithDict file_path mod a = do - bh <- openBinMem initBinMemSize mod +putBinFileWithDict :: Binary a => FilePath -> a -> IO () +putBinFileWithDict file_path the_thing = do + bh <- openBinMem initBinMemSize put_ bh binaryInterfaceMagic - p <- tellBin bh - put_ bh p -- placeholder for ptr to dictionary - put_ bh a - let (_, j_r, fm_r, _) = state bh - j <- readIORef j_r - fm <- readIORef fm_r - dict_p <- tellBin bh - putAt bh p dict_p -- fill in the placeholder - seekBin bh dict_p -- seek back to the end of the file + + -- 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 -type Dictionary = Array Int FastString - -- should be 0-indexed +-- ----------------------------------------------------------------------------- +-- 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 @@ -654,13 +686,21 @@ getDictionary bh = do constructDictionary :: Int -> UniqFM (Int,FastString) -> Dictionary constructDictionary j fm = array (0,j-1) (eltsUFM fm) -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. +--------------------------------------------------------- +-- 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 @@ -670,13 +710,26 @@ getFS bh@BinMem{} = do return $! (mkFastSubStringBA# arr off l) -} getFS bh = do - (I# l) <- get bh - (BA ba) <- getByteArray bh (I# l) - return $! (mkFastSubStringBA# ba 0# l) + 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 + +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 ba) = - case getUserData bh of { (_, j_r, out_r, dict) -> do + 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 @@ -691,4 +744,4 @@ instance Binary FastString where get bh = do j <- get bh - case getUserData bh of (_, _, _, arr) -> return $! (arr ! j) + return $! (ud_dict (getUserData bh) ! j)