X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2Futils%2FBinary.hs;h=7b40bd279d22042f498a349e6cf47d9301d5d223;hb=9d7da331989abcd1844e9d03b8d1e4163796fa85;hp=207394b88ffd9a2132eebd35a430f60a9d7f089d;hpb=354f17ec86e2e11f2e77a159916b2e7be74979c9;p=ghc-hetmet.git diff --git a/ghc/compiler/utils/Binary.hs b/ghc/compiler/utils/Binary.hs index 207394b..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,36 +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 IOExts -import Bits -import Int -import 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 @@ -83,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 ) +import Control.Exception ( throwDyn ) import System.IO as IO import System.IO.Unsafe ( unsafeInterleaveIO ) import System.IO.Error ( mkIOError, eofErrorType ) @@ -91,44 +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)) @@ -137,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) } @@ -145,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) @@ -169,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) @@ -188,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) @@ -220,12 +196,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 <- openFileEx fn (BinaryMode 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' @@ -233,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) @@ -247,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 () @@ -260,7 +237,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. @@ -291,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) @@ -300,7 +283,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 @@ -322,7 +305,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 @@ -336,10 +319,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 @@ -361,33 +344,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 @@ -399,12 +382,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 @@ -412,26 +395,32 @@ 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 -- 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 @@ -553,26 +542,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 () @@ -593,59 +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 - 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 @@ -661,23 +686,50 @@ 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 -getFS bh = do +{- -- possible faster version, not quite there yet: +getFS bh@BinMem{} = do (I# l) <- get bh - (BA ba) <- getByteArray bh (I# l) - return (mkFastSubStringBA# ba 0# l) - -- XXX ToDo: one too many copies here + arr <- readIORef (arr_r bh) + off <- readFastMutInt (off_r bh) + return $! (mkFastSubStringBA# arr off l) +-} +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) + -- + 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 @@ -692,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)