[project @ 2003-06-24 09:32:34 by stolz]

[ghc-hetmet.git] / ghc / compiler / utils / Binary.hs

diff --git a/ghc/compiler/utils/Binary.hs b/ghc/compiler/utils/Binary.hs
index 9aaea23..7d5990b 100644 (file)
--- a/ghc/compiler/utils/Binary.hs
+++ b/ghc/compiler/utils/Binary.hs
@@ -48,25 +48,34 @@ module Binary
 
   ) where
 
 
   ) where
 

+#include "HsVersions.h"
+
+-- The *host* architecture version:

 #include "MachDeps.h"
 
 import {-# SOURCE #-} Module
 import FastString
 import Unique
 #include "MachDeps.h"
 
 import {-# SOURCE #-} Module
 import FastString
 import Unique

+import Panic

 import UniqFM
 import UniqFM

+import FastMutInt

 
 #if __GLASGOW_HASKELL__ < 503
 
 #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 GlaExts hiding (ByteArray, newByteArray, freezeByteArray)
 import Array
 import IO
 import Char
 import Monad
 import Exception
 import GlaExts hiding (ByteArray, newByteArray, freezeByteArray)
 import Array
 import IO

-import PrelIOBase              ( IOError(..), IOErrorType(..), IOException(..) )
+import PrelIOBase              ( IOError(..), IOErrorType(..)
+#if __GLASGOW_HASKELL__ > 411
+                               , IOException(..)
+#endif
+                               )

 import PrelReal                        ( Ratio(..) )
 import PrelIOBase              ( IO(..) )
 #else
 import PrelReal                        ( Ratio(..) )
 import PrelIOBase              ( IO(..) )
 #else

@@ -79,7 +88,7 @@ import Data.IORef
 import Data.Char               ( ord, chr )
 import Data.Array.Base         ( unsafeRead, unsafeWrite )
 import Control.Monad           ( when )
 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 System.IO as IO
 import System.IO.Unsafe                ( unsafeInterleaveIO )
 import System.IO.Error         ( mkIOError, eofErrorType )

@@ -89,6 +98,18 @@ import GHC.IOBase            ( IO(..) )
 import GHC.Word                        ( Word8(..) )
 #endif
 
 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
 type BinArray = MutableByteArray RealWorld Int
 newArray_ bounds     = stToIO (newCharArray bounds)
 #if __GLASGOW_HASKELL__ < 503
 type BinArray = MutableByteArray RealWorld Int
 newArray_ bounds     = stToIO (newCharArray bounds)

@@ -216,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
 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 <- openBinaryFile fn WriteMode

   arr <- readIORef arr_r
   ix  <- readFastMutInt ix_r
   hPutArray h arr ix
   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'
   -- 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'

@@ -230,7 +251,7 @@ writeBinMem (BinMem _ ix_r sz_r arr_r) fn = do
 
 readBinMem :: FilePath -> IO BinHandle
 readBinMem filename = do
 
 readBinMem :: FilePath -> IO BinHandle
 readBinMem filename = do

-  h <- openFile filename ReadMode
+  h <- openBinaryFile filename ReadMode

   filesize' <- hFileSize h
   let filesize = fromIntegral filesize'
   arr <- newArray_ (0,filesize-1)
   filesize' <- hFileSize h
   let filesize = fromIntegral filesize'
   arr <- newArray_ (0,filesize-1)

@@ -256,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'
             | 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.
    return ()
 expandBin (BinIO _ _ _) _ = return ()
        -- no need to expand a file, we'll assume they expand by themselves.

@@ -287,7 +310,11 @@ getWord8 (BinMem _ ix_r sz_r arr_r) = do
     ix <- readFastMutInt ix_r
     sz <- readFastMutInt sz_r
     when (ix >= sz)  $
     ix <- readFastMutInt ix_r
     sz <- readFastMutInt sz_r
     when (ix >= sz)  $

+#if __GLASGOW_HASKELL__ <= 408

        throw (mkIOError eofErrorType "Data.Binary.getWord8" Nothing Nothing)
        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)
     arr <- readIORef arr_r
     w <- unsafeRead arr ix
     writeFastMutInt ix_r (ix+1)

@@ -296,7 +323,7 @@ getWord8 (BinIO _ ix_r h) = do
     ix <- readFastMutInt ix_r
     c <- hGetChar h
     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
 
 putByte :: BinHandle -> Word8 -> IO ()
 putByte bh w = put_ bh w

@@ -318,7 +345,7 @@ instance Binary Word16 where
   get h = do
     w1 <- getWord8 h
     w2 <- getWord8 h
   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
 
 
 instance Binary Word32 where

@@ -332,10 +359,10 @@ instance Binary Word32 where
     w2 <- getWord8 h
     w3 <- getWord8 h
     w4 <- getWord8 h
     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
 
 
 instance Binary Word64 where

@@ -357,33 +384,33 @@ instance Binary Word64 where
     w6 <- getWord8 h
     w7 <- getWord8 h
     w8 <- getWord8 h
     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)
 
 -- -----------------------------------------------------------------------------
 -- 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)
 
 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)
 
 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)
 
 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
 
 -- -----------------------------------------------------------------------------
 -- Instances for standard types

@@ -395,12 +422,12 @@ instance Binary () where
 
 instance Binary Bool where
     put_ bh b = putByte bh (fromIntegral (fromEnum b))
 
 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)
 --    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
 --    getF bh p = case getBitsF bh 8 p of (x,b) -> (toEnum x,b)
 
 instance Binary Int where

@@ -408,12 +435,12 @@ instance Binary Int where
     put_ bh i = put_ bh (fromIntegral i :: Int32)
     get  bh = do
        x <- get bh
     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
 #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
 #else
 #error "unsupported sizeof(HsInt)"
 #endif

@@ -549,26 +576,6 @@ instance Binary (Bin a) where
   get bh = do i <- get bh; return (BinPtr i)
 
 -- -----------------------------------------------------------------------------
   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 ()
 -- Lazy reading/writing
 
 lazyPut :: Binary a => BinHandle -> a -> IO ()

@@ -615,6 +622,10 @@ undef = error "Binary.BinHandleState"
 getBinFileWithDict :: Binary a => FilePath -> IO a
 getBinFileWithDict file_path = do
   bh <- Binary.readBinMem file_path
 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
   dict_p <- Binary.get bh              -- get the dictionary ptr
   data_p <- tellBin bh
   seekBin bh dict_p

@@ -625,9 +636,12 @@ getBinFileWithDict file_path = do
 
 initBinMemSize = (1024*1024) :: Int
 
 
 initBinMemSize = (1024*1024) :: Int
 

+binaryInterfaceMagic = 0x1face :: Word32
+

 putBinFileWithDict :: Binary a => FilePath -> Module -> a -> IO ()
 putBinFileWithDict file_path mod a = do
   bh <- openBinMem initBinMemSize mod
 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
   p <- tellBin bh
   put_ bh p            -- placeholder for ptr to dictionary
   put_ bh a

@@ -665,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.
   
        -- 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)
 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) =
 
 instance Binary FastString where
   put_ bh f@(FastString id l ba) =

@@ -688,4 +708,4 @@ instance Binary FastString where
 
   get bh = do 
        j <- get bh
 
   get bh = do 
        j <- get bh

-       case getUserData bh of (_, _, _, arr) -> return (arr ! j)
+       case getUserData bh of (_, _, _, arr) -> return $! (arr ! j)