X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=blobdiff_plain;f=compiler%2Futils%2FBinary.hs;h=378595796691acb7770fe00aa31073b7ed4bef52;hp=466a515dfc631324b059f059e6c39f37bbf299f1;hb=18691d440f90a3dff4ef538091c886af505e5cf5;hpb=fcf6b22d0478be20e27c2245f3e34dd272e12522 diff --git a/compiler/utils/Binary.hs b/compiler/utils/Binary.hs index 466a515..3785957 100644 --- a/compiler/utils/Binary.hs +++ b/compiler/utils/Binary.hs @@ -1,4 +1,8 @@ {-# 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-2006 -- @@ -20,11 +24,13 @@ module Binary -- closeBin, seekBin, + seekBy, tellBin, castBin, writeBinMem, readBinMem, + fingerprintBinMem, isEOFBin, @@ -47,51 +53,37 @@ module Binary UserData(..), getUserData, setUserData, newReadState, newWriteState, - putDictionary, getDictionary, + 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 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 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 GHC.Exts -import GHC.IOBase ( IO(..) ) import GHC.Word ( Word8(..) ) -#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(..) ) -#else -import System.IO ( openBinaryFile ) -#endif - -#if defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ < 601 -openBinaryFile f mode = openFileEx f (BinaryMode mode) -#endif +import GHC.IO ( IO(..) ) -type BinArray = IOUArray Int Word8 +type BinArray = ForeignPtr Word8 --------------------------------------------------------------- -- BinHandle @@ -145,11 +137,11 @@ 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 @@ -167,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 @@ -189,6 +181,20 @@ seekBin h@(BinMem _ ix_r sz_r _) (BinPtr p) = do 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 _) = do ix <- readFastMutInt ix_r @@ -202,7 +208,7 @@ writeBinMem (BinMem _ ix_r _ arr_r) fn = do h <- openBinaryFile fn WriteMode arr <- readIORef arr_r ix <- readFastMutInt ix_r - hPutArray h arr ix + withForeignPtr arr $ \p -> hPutBuf h p ix hClose h readBinMem :: FilePath -> IO BinHandle @@ -211,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 @@ -223,20 +229,27 @@ 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 _ _ 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. @@ -253,7 +266,7 @@ putWord8 h@(BinMem _ ix_r sz_r arr_r) w = do then do expandBin h ix putWord8 h w else do arr <- readIORef arr_r - unsafeWrite arr ix w + withForeignPtr arr $ \p -> pokeByteOff p ix w writeFastMutInt ix_r (ix+1) return () putWord8 (BinIO _ ix_r h) w = do @@ -269,7 +282,7 @@ getWord8 (BinMem _ ix_r sz_r arr_r) = do 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 @@ -370,33 +383,20 @@ instance Binary Int64 where instance Binary () where put_ _ () = return () get _ = return () --- getF bh p = case getBitsF bh 0 p of (_,b) -> ((),b) 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 instance Binary a => Binary [a] where put_ bh l = do @@ -546,8 +546,29 @@ 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 @@ -581,43 +602,26 @@ data UserData = 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 + ud_put_name :: BinHandle -> Name -> IO (), + ud_put_fs :: BinHandle -> FastString -> IO () } 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 + return UserData { ud_dict = dict, + ud_symtab = undef "symtab", + ud_put_name = undef "put_name", + ud_put_fs = undef "put_fs" } -newWriteState :: IO UserData -newWriteState = do - 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 +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 @@ -693,20 +697,26 @@ getFS bh = do instance Binary FastString where put_ bh f = - case getUserData bh of { - UserData { ud_dict_next = j_r, - ud_dict_map = out_r} -> do - out <- readIORef out_r - let uniq = getUnique f - case lookupUFM out uniq of - Just (j, _) -> put_ bh j - Nothing -> do - j <- readFastMutInt j_r - put_ bh j - writeFastMutInt j_r (j + 1) - writeIORef out_r $! addToUFM out uniq (j, f) - } + case getUserData bh of + UserData { ud_put_fs = put_fs } -> put_fs bh f get bh = do j <- get bh - return $! (ud_dict (getUserData bh) ! j) + return $! (ud_dict (getUserData bh) ! (fromIntegral (j :: Word32))) + +-- Here to avoid loop + +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" +