X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=blobdiff_plain;f=compiler%2Futils%2FBinary.hs;h=076ae166402a11affa9abf1d85c79780d10fe7c0;hp=f20ee129d6b00119f636182528807b5f640c4190;hb=526c3af1dc98987b6949f4df73c0debccf9875bd;hpb=3629180909c5ffcc9056b8fca262021021dbfab6 diff --git a/compiler/utils/Binary.hs b/compiler/utils/Binary.hs index f20ee12..076ae16 100644 --- a/compiler/utils/Binary.hs +++ b/compiler/utils/Binary.hs @@ -1,11 +1,4 @@ {-# 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-2006 -- @@ -27,11 +20,13 @@ module Binary -- closeBin, seekBin, + seekBy, tellBin, castBin, writeBinMem, readBinMem, + fingerprintBinMem, isEOFBin, @@ -54,7 +49,7 @@ module Binary UserData(..), getUserData, setUserData, newReadState, newWriteState, - putDictionary, getDictionary, + putDictionary, getDictionary, putFS, ) where #include "HsVersions.h" @@ -64,20 +59,19 @@ module Binary import {-# SOURCE #-} Name (Name) import FastString -import Unique import Panic import UniqFM import FastMutInt +import Util +import Fingerprint 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 Control.Monad ( when ) import System.IO as IO import System.IO.Unsafe ( unsafeInterleaveIO ) @@ -98,26 +92,26 @@ import System.IO ( openBinaryFile ) openBinaryFile f mode = openFileEx f (BinaryMode mode) #endif -type BinArray = IOUArray Int Word8 +type BinArray = ForeignPtr Word8 --------------------------------------------------------------- -- BinHandle --------------------------------------------------------------- data BinHandle - = BinMem { -- binary data stored in an unboxed array - 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)) + = BinMem { -- binary data stored in an unboxed array + 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)) } -- XXX: should really store a "high water mark" for dumping out -- the binary data to a file. | BinIO { -- binary data stored in a file bh_usr :: UserData, - off_r :: !FastMutInt, -- the current offset (cached) - hdl :: !IO.Handle -- the file handle (must be seekable) + _off_r :: !FastMutInt, -- the current offset (cached) + _hdl :: !IO.Handle -- the file handle (must be seekable) } -- cache the file ptr in BinIO; using hTell is too expensive -- to call repeatedly. If anyone else is modifying this Handle @@ -174,7 +168,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 @@ -190,26 +184,40 @@ seekBin :: BinHandle -> Bin a -> IO () seekBin (BinIO _ ix_r h) (BinPtr p) = do writeFastMutInt ix_r p hSeek h AbsoluteSeek (fromIntegral p) -seekBin h@(BinMem _ ix_r sz_r a) (BinPtr p) = do +seekBin h@(BinMem _ ix_r sz_r _) (BinPtr p) = do sz <- readFastMutInt sz_r if (p >= sz) 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 a) = do +isEOFBin (BinMem _ ix_r sz_r _) = do ix <- readFastMutInt ix_r sz <- readFastMutInt sz_r return (ix >= sz) -isEOFBin (BinIO _ ix_r h) = hIsEOF h +isEOFBin (BinIO _ _ 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 +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 @@ -218,10 +226,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 @@ -230,20 +238,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 _ ix_r sz_r arr_r) off = do +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 debugIsOn $ + 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. @@ -260,7 +275,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 @@ -276,7 +291,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 @@ -375,8 +390,8 @@ instance Binary Int64 where -- Instances for standard types instance Binary () where - put_ bh () = return () - get _ = return () + put_ _ () = return () + get _ = return () -- getF bh p = case getBitsF bh 0 p of (_,b) -> ((),b) instance Binary Bool where @@ -474,9 +489,17 @@ instance (Binary a, Binary b) => Binary (Either a b) where -- yes, we need Binary Integer and Binary Rational in basicTypes/Literal.lhs instance Binary Integer where + -- XXX This is hideous + put_ bh i = put_ bh (show i) + get bh = do str <- get bh + case reads str of + [(i, "")] -> return i + _ -> fail ("Binary Integer: got " ++ show str) + + {- put_ bh (S# i#) = do putByte bh 0; put_ bh (I# i#) put_ bh (J# s# a#) = do - p <- putByte bh 1; + putByte bh 1 put_ bh (I# s#) let sz# = sizeofByteArray# a# -- in *bytes* put_ bh (I# sz#) -- in *bytes* @@ -491,6 +514,7 @@ instance Binary Integer where sz <- get bh (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 @@ -579,47 +603,32 @@ 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 noUserData = undef "UserData" +undef :: String -> a undef s = panic ("Binary.UserData: no " ++ s) --------------------------------------------------------- @@ -653,7 +662,8 @@ type SymbolTable = Array Int Name -- Reading and writing FastStrings --------------------------------------------------------- -putFS bh (FastString id l _ buf _) = do +putFS :: BinHandle -> FastString -> IO () +putFS bh (FastString _ l _ buf _) = do put_ bh l withForeignPtr buf $ \ptr -> let @@ -672,6 +682,7 @@ getFS bh@BinMem{} = do off <- readFastMutInt (off_r bh) return $! (mkFastSubStringBA# arr off l) -} +getFS :: BinHandle -> IO FastString getFS bh = do l <- get bh fp <- mallocForeignPtrBytes l @@ -686,22 +697,17 @@ getFS bh = do go 0 instance Binary FastString where - put_ bh f@(FastString id l _ fp _) = - case getUserData bh of { - 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 <- readFastMutInt j_r - put_ bh j - writeFastMutInt j_r (j+1) - writeIORef out_r $! addToUFM out uniq (j,f) - } + put_ bh 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) + +-- 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) +