[project @ 2002-11-19 12:34:55 by simonpj]

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

diff --git a/ghc/compiler/utils/Binary.hs b/ghc/compiler/utils/Binary.hs
index a963c0c..3ac01ea 100644 (file)
--- a/ghc/compiler/utils/Binary.hs
+++ b/ghc/compiler/utils/Binary.hs
@@ -3,6 +3,12 @@
 -- (c) The University of Glasgow 2002
 --
 -- Binary I/O library, with special tweaks for GHC
 -- (c) The University of Glasgow 2002
 --
 -- Binary I/O library, with special tweaks for GHC

+--
+-- Based on the nhc98 Binary library, which is copyright
+-- (c) Malcolm Wallace and Colin Runciman, University of York, 1998.
+-- Under the terms of the license for that software, we must tell you
+-- where you can obtain the original version of the Binary library, namely
+--     http://www.cs.york.ac.uk/fp/nhc98/

 
 module Binary
   ( {-type-}  Bin,
 
 module Binary
   ( {-type-}  Bin,

@@ -42,25 +48,32 @@ module Binary
 
   ) where
 
 
   ) where
 

+#include "HsVersions.h"

 #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(..) )
+import PrelIOBase              ( IOError(..), IOErrorType(..)
+#if __GLASGOW_HASKELL__ > 411
+                               , IOException(..)
+#endif
+                               )

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

@@ -73,7 +86,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       ( throw, 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 )

@@ -81,6 +94,7 @@ import GHC.Real                       ( Ratio(..) )
 import GHC.Exts
 import GHC.IOBase              ( IO(..) )
 import GHC.Word                        ( Word8(..) )
 import GHC.Exts
 import GHC.IOBase              ( IO(..) )
 import GHC.Word                        ( Word8(..) )

+import GHC.Handle              ( openFileEx, IOModeEx(..) )

 #endif
 
 #if __GLASGOW_HASKELL__ < 503
 #endif
 
 #if __GLASGOW_HASKELL__ < 503

@@ -88,13 +102,19 @@ type BinArray = MutableByteArray RealWorld Int
 newArray_ bounds     = stToIO (newCharArray bounds)
 unsafeWrite arr ix e = stToIO (writeWord8Array arr ix e)
 unsafeRead  arr ix   = stToIO (readWord8Array arr ix)
 newArray_ bounds     = stToIO (newCharArray bounds)
 unsafeWrite arr ix e = stToIO (writeWord8Array arr ix e)
 unsafeRead  arr ix   = stToIO (readWord8Array arr ix)

+#if __GLASGOW_HASKELL__ < 411

 newByteArray#        = newCharArray#
 newByteArray#        = newCharArray#

+#endif

 hPutArray h arr sz   = hPutBufBAFull h arr sz
 hGetArray h sz       = hGetBufBAFull h sz
 
 mkIOError :: IOErrorType -> String -> Maybe Handle -> Maybe FilePath -> Exception
 mkIOError t location maybe_hdl maybe_filename
 hPutArray h arr sz   = hPutBufBAFull h arr sz
 hGetArray h sz       = hGetBufBAFull h sz
 
 mkIOError :: IOErrorType -> String -> Maybe Handle -> Maybe FilePath -> Exception
 mkIOError t location maybe_hdl maybe_filename

-  = IOException (IOError maybe_hdl t location "")
+  = IOException (IOError maybe_hdl t location ""
+#if __GLASGOW_HASKELL__ > 411
+                        maybe_filename
+#endif
+               )

 
 eofErrorType = EOF
 
 
 eofErrorType = EOF
 

@@ -204,12 +224,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 <- openFileEx fn (BinaryMode 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'

@@ -218,7 +238,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 <- openFileEx filename (BinaryMode 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)

@@ -244,7 +264,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.

@@ -284,7 +306,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

@@ -306,7 +328,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

@@ -320,10 +342,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

@@ -345,33 +367,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

@@ -383,12 +405,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

@@ -396,12 +418,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

@@ -537,26 +559,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 ()

@@ -603,6 +605,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

@@ -613,9 +619,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

@@ -653,11 +662,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) =

@@ -676,4 +691,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)