X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2Futils%2FBinary.hs;h=7d5990b98406134e4fee78a4177925b5dc4dd784;hb=9d5c1a04f9dbee3819f5ccd3def215c7da8a1d70;hp=7609ff46d855d91a5ab97e1825c4427e20759b79;hpb=8277eb70e14be49b9f1e8e0d6e333192428e90d7;p=ghc-hetmet.git diff --git a/ghc/compiler/utils/Binary.hs b/ghc/compiler/utils/Binary.hs index 7609ff4..7d5990b 100644 --- a/ghc/compiler/utils/Binary.hs +++ b/ghc/compiler/utils/Binary.hs @@ -48,6 +48,9 @@ module Binary ) where +#include "HsVersions.h" + +-- The *host* architecture version: #include "MachDeps.h" import {-# SOURCE #-} Module @@ -55,12 +58,13 @@ 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 @@ -84,7 +88,7 @@ import Data.IORef import Data.Char ( ord, chr ) import Data.Array.Base ( unsafeRead, unsafeWrite ) import Control.Monad ( when ) -import Control.Exception ( throw, throwDyn ) +import Control.Exception ( throwDyn ) import System.IO as IO import System.IO.Unsafe ( unsafeInterleaveIO ) import System.IO.Error ( mkIOError, eofErrorType ) @@ -92,7 +96,18 @@ import GHC.Real ( Ratio(..) ) import GHC.Exts import GHC.IOBase ( IO(..) ) import GHC.Word ( Word8(..) ) +#endif + +#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__ < 601 +openBinaryFile f mode = openFileEx f (BinaryMode mode) #endif #if __GLASGOW_HASKELL__ < 503 @@ -222,12 +237,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' @@ -236,7 +251,7 @@ writeBinMem (BinMem _ ix_r sz_r arr_r) fn = do readBinMem :: FilePath -> IO BinHandle readBinMem filename = do - h <- openFileEx filename (BinaryMode ReadMode) + h <- openBinaryFile filename ReadMode filesize' <- hFileSize h let filesize = fromIntegral filesize' arr <- newArray_ (0,filesize-1) @@ -262,7 +277,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. @@ -293,7 +310,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) @@ -302,7 +323,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 @@ -324,7 +345,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 @@ -338,10 +359,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 @@ -363,33 +384,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 @@ -401,12 +422,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 @@ -414,12 +435,12 @@ 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 @@ -555,26 +576,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 () @@ -678,11 +679,17 @@ putFS bh s = error ("Binary.put_(FastString): " ++ unpackFS s) -- 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) = @@ -701,4 +708,4 @@ instance Binary FastString where get bh = do j <- get bh - case getUserData bh of (_, _, _, arr) -> return (arr ! j) + case getUserData bh of (_, _, _, arr) -> return $! (arr ! j)