{-# 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
+{-# 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
-- closeBin,
seekBin,
+ seekBy,
tellBin,
castBin,
writeBinMem,
readBinMem,
+ fingerprintBinMem,
isEOFBin,
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
---------------------------------------------------------------
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
-- 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
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
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
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
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 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.
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
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
-- Instances for standard types
instance Binary () where
- put_ bh () = return ()
- get _ = return ()
--- getF bh p = case getBitsF bh 0 p of (_,b) -> ((),b)
+ put_ _ () = return ()
+ get _ = return ()
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
-- 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*
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
#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
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)
---------------------------------------------------------
-- 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
off <- readFastMutInt (off_r bh)
return $! (mkFastSubStringBA# arr off l)
-}
+getFS :: BinHandle -> IO FastString
getFS bh = do
l <- get bh
fp <- mallocForeignPtrBytes l
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)
+ 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"
+
projects / ghc-hetmet.git / blobdiff