) where
+#include "HsVersions.h"
#include "MachDeps.h"
import {-# SOURCE #-} Module
import FastString
import Unique
+import Panic
import UniqFM
+import FastMutInt
#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 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 )
import GHC.Exts
import GHC.IOBase ( IO(..) )
import GHC.Word ( Word8(..) )
+import GHC.Handle ( openFileEx, IOModeEx(..) )
#endif
#if __GLASGOW_HASKELL__ < 503
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 <- openFileEx fn (BinaryMode 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'
readBinMem :: FilePath -> IO BinHandle
readBinMem filename = do
- h <- openFile filename ReadMode
+ h <- openFileEx filename (BinaryMode ReadMode)
filesize' <- hFileSize h
let filesize = fromIntegral filesize'
arr <- newArray_ (0,filesize-1)
| 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.
ix <- readFastMutInt ix_r
sz <- readFastMutInt sz_r
when (ix >= sz) $
- throw (mkIOError eofErrorType "Data.Binary.getWord8" Nothing Nothing)
+ ioError (mkIOError eofErrorType "Data.Binary.getWord8" Nothing Nothing)
arr <- readIORef arr_r
w <- unsafeRead arr ix
writeFastMutInt ix_r (ix+1)
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
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
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
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
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
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
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 ()
getBinFileWithDict :: Binary a => FilePath -> IO a
getBinFileWithDict file_path = do
bh <- Binary.readBinMem file_path
+ magic <- get bh
+ when (magic /= binaryInterfaceMagic) $
+ throwDyn (ProgramError (
+ "magic number mismatch: old/corrupt interface file?"))
dict_p <- Binary.get bh -- get the dictionary ptr
data_p <- tellBin bh
seekBin bh dict_p
initBinMemSize = (1024*1024) :: Int
+binaryInterfaceMagic = 0x1face :: Word32
+
putBinFileWithDict :: Binary a => FilePath -> Module -> a -> IO ()
putBinFileWithDict file_path mod a = do
bh <- openBinMem initBinMemSize mod
+ put_ bh binaryInterfaceMagic
p <- tellBin bh
put_ bh p -- placeholder for ptr to dictionary
put_ bh a
-- 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 FastString where
put_ bh f@(FastString id l ba) =
get bh = do
j <- get bh
- case getUserData bh of (_, _, _, arr) -> return (arr ! j)
+ case getUserData bh of (_, _, _, arr) -> return $! (arr ! j)
projects / ghc-hetmet.git / blobdiff