X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2Futils%2FBinary.hs;h=c20e2aa22b6e501ebeb08523e2a9d3a89f5d001e;hb=d04c4288dfc76c3cc593a37824bf2e996663abfb;hp=a963c0c7d3a2005b74741ffbfd8269fd3ff5509d;hpb=0171936c9092666692c69a7f93fa75af976330cb;p=ghc-hetmet.git diff --git a/ghc/compiler/utils/Binary.hs b/ghc/compiler/utils/Binary.hs index a963c0c..c20e2aa 100644 --- a/ghc/compiler/utils/Binary.hs +++ b/ghc/compiler/utils/Binary.hs @@ -3,6 +3,12 @@ -- (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, @@ -13,8 +19,6 @@ module Binary openBinMem, -- closeBin, - getUserData, - seekBin, tellBin, castBin, @@ -38,31 +42,41 @@ 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 IOExts -import Bits -import Int -import Word +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(..) ) +import PrelIOBase ( IOError(..), IOErrorType(..) +#if __GLASGOW_HASKELL__ > 411 + , IOException(..) +#endif + ) import PrelReal ( Ratio(..) ) import PrelIOBase ( IO(..) ) +import IOExts ( openFileEx, IOModeEx(..) ) #else import Data.Array.IO import Data.Array @@ -73,7 +87,7 @@ import Data.IORef import Data.Char ( ord, chr ) import Data.Array.Base ( unsafeRead, unsafeWrite ) import Control.Monad ( when ) -import Control.Exception ( throw ) +import Control.Exception ( throwDyn ) import System.IO as IO import System.IO.Unsafe ( unsafeInterleaveIO ) import System.IO.Error ( mkIOError, eofErrorType ) @@ -81,6 +95,17 @@ 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 +#endif + +#if __GLASGOW_HASKELL__ < 601 +openBinaryFile f mode = openFileEx f (BinaryMode mode) #endif #if __GLASGOW_HASKELL__ < 503 @@ -88,13 +113,19 @@ 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 "") + = IOException (IOError maybe_hdl t location "" +#if __GLASGOW_HASKELL__ > 411 + maybe_filename +#endif + ) eofErrorType = EOF @@ -110,9 +141,13 @@ eofErrorType = EOF 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)) @@ -121,7 +156,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) } @@ -129,12 +164,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) @@ -153,17 +203,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) @@ -172,13 +221,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) @@ -204,12 +247,12 @@ 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 + h <- openBinaryFile fn WriteMode arr <- readIORef arr_r ix <- readFastMutInt ix_r hPutArray h arr ix -#if __GLASGOW_HASKELL__ < 500 - -- workaround a bug in ghc 4.08's implementation of hPutBuf (it doesn't +#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' @@ -217,8 +260,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 <- openFile filename ReadMode + h <- openBinaryFile filename ReadMode filesize' <- hFileSize h let filesize = fromIntegral filesize' arr <- newArray_ (0,filesize-1) @@ -231,7 +275,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 () @@ -244,7 +288,9 @@ expandBin (BinMem _ ix_r sz_r arr_r) off = do | i <- [ 0 .. sz-1 ] ] writeFastMutInt sz_r sz' writeIORef arr_r arr' - hPutStrLn stderr ("expanding to size: " ++ show sz') +#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. @@ -275,7 +321,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) @@ -284,7 +334,7 @@ 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 @@ -306,7 +356,7 @@ instance Binary Word16 where get h = do w1 <- getWord8 h w2 <- getWord8 h - return ((fromIntegral w1 `shiftL` 8) .|. fromIntegral w2) + return $! ((fromIntegral w1 `shiftL` 8) .|. fromIntegral w2) instance Binary Word32 where @@ -320,10 +370,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 @@ -345,33 +395,33 @@ 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 instance Binary Int8 where put_ h w = put_ h (fromIntegral w :: Word8) - get h = do w <- get h; return (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)) + 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)) + 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)) + get h = do w <- get h; return $! (fromIntegral (w::Word64)) -- ----------------------------------------------------------------------------- -- Instances for standard types @@ -383,12 +433,12 @@ instance Binary () where instance Binary Bool where put_ bh b = putByte bh (fromIntegral (fromEnum b)) - get bh = do x <- getWord8 bh; return (toEnum (fromIntegral x)) + 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))) + 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 @@ -396,12 +446,12 @@ instance Binary Int where put_ bh i = put_ bh (fromIntegral i :: Int32) get bh = do x <- get bh - return (fromIntegral (x :: Int32)) + 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)) + return $! (fromIntegral (x :: Int64)) #else #error "unsupported sizeof(HsInt)" #endif @@ -537,26 +587,6 @@ instance Binary (Bin a) where get bh = do i <- get bh; return (BinPtr i) -- ----------------------------------------------------------------------------- --- unboxed mutable Ints - -#ifdef __GLASGOW_HASKELL__ -data FastMutInt = FastMutInt (MutableByteArray# RealWorld) - -newFastMutInt = IO $ \s -> - case newByteArray# size s of { (# s, arr #) -> - (# s, FastMutInt arr #) } - where I# size = SIZEOF_HSWORD - -readFastMutInt (FastMutInt arr) = IO $ \s -> - case readIntArray# arr 0# s of { (# s, i #) -> - (# s, I# i #) } - -writeFastMutInt (FastMutInt arr) (I# i) = IO $ \s -> - case writeIntArray# arr 0# i s of { s -> - (# s, () #) } -#endif - --- ----------------------------------------------------------------------------- -- Lazy reading/writing lazyPut :: Binary a => BinHandle -> a -> IO () @@ -577,59 +607,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 - dict_p <- Binary.get bh -- get the dictionary ptr - data_p <- tellBin bh + + -- 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 - let (mod, j_r, out_r, _) = state bh - get bh{ state = (mod,j_r,out_r,dict) } - -initBinMemSize = (1024*1024) :: Int - -putBinFileWithDict :: Binary a => FilePath -> Module -> a -> IO () -putBinFileWithDict file_path mod a = do - bh <- openBinMem initBinMemSize mod - 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 + 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 -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 @@ -645,6 +731,10 @@ getDictionary bh = do constructDictionary :: Int -> UniqFM (Int,FastString) -> Dictionary constructDictionary j fm = array (0,j-1) (eltsUFM fm) +--------------------------------------------------------- +-- Reading and writing FastStrings +--------------------------------------------------------- + putFS bh (FastString id l ba) = do put_ bh (I# l) putByteArray bh ba l @@ -653,15 +743,26 @@ putFS bh s = error ("Binary.put_(FastString): " ++ unpackFS s) -- 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) - -- XXX ToDo: one too many copies here + return $! (mkFastSubStringBA# ba 0# l) + +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 + 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 @@ -676,4 +777,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)