[project @ 2005-03-09 10:38:17 by simonmar]

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

diff --git a/ghc/compiler/utils/Binary.hs b/ghc/compiler/utils/Binary.hs
index 52e1bee..c20e2aa 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,

@@ -13,8 +19,6 @@ module Binary
    openBinMem,
 --   closeBin,
 
    openBinMem,
 --   closeBin,
 

-   getUserData,
-

    seekBin,
    tellBin,
    castBin,
    seekBin,
    tellBin,
    castBin,

@@ -38,31 +42,41 @@ module Binary
    putByteArray,
 
    getBinFileWithDict, -- :: Binary a => FilePath -> IO a
    putByteArray,
 
    getBinFileWithDict, -- :: Binary a => FilePath -> IO a

-   putBinFileWithDict, -- :: Binary a => FilePath -> Module -> a -> IO ()
+   putBinFileWithDict, -- :: Binary a => FilePath -> ModuleName -> a -> IO ()

 
   ) where
 
 
   ) where
 

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

 #include "MachDeps.h"
 
 #include "MachDeps.h"
 

-import {-# SOURCE #-} Module

 import FastString
 import Unique
 import FastString
 import Unique

+import Panic

 import UniqFM
 import UniqFM

+import FastMutInt
+import PackageConfig           ( PackageId, packageIdFS, fsToPackageId )

 
 #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(..) )
 import PrelReal                        ( Ratio(..) )
 import PrelIOBase              ( IO(..) )

+import IOExts                  ( openFileEx, IOModeEx(..) )

 #else
 import Data.Array.IO
 import Data.Array
 #else
 import Data.Array.IO
 import Data.Array

@@ -73,7 +87,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 )

@@ -81,6 +95,17 @@ 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(..) )

+#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
+#endif
+
+#if __GLASGOW_HASKELL__ < 601
+openBinaryFile f mode = openFileEx f (BinaryMode mode)

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

@@ -116,9 +141,13 @@ eofErrorType = EOF
 type BinArray = IOUArray Int Word8
 #endif
 
 type BinArray = IOUArray Int Word8
 #endif
 

+---------------------------------------------------------------
+--             BinHandle
+---------------------------------------------------------------
+

 data BinHandle
   = BinMem {           -- binary data stored in an unboxed array
 data BinHandle
   = BinMem {           -- binary data stored in an unboxed array

-     state :: BinHandleState,  -- sigh, need parameterized modules :-)
+     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))
      off_r :: !FastMutInt,             -- the current offset
      sz_r  :: !FastMutInt,             -- size of the array (cached)
      arr_r :: !(IORef BinArray)        -- the array (bounds: (0,size-1))

@@ -127,7 +156,7 @@ data BinHandle
        -- the binary data to a file.
 
   | BinIO {            -- binary data stored in a file
        -- the binary data to a file.
 
   | BinIO {            -- binary data stored in a file

-     state :: BinHandleState,
+     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)
    }

@@ -135,12 +164,27 @@ data BinHandle
        -- to call repeatedly.  If anyone else is modifying this Handle
        -- at the same time, we'll be screwed.
 
        -- to call repeatedly.  If anyone else is modifying this Handle
        -- at the same time, we'll be screwed.
 

+getUserData :: BinHandle -> UserData
+getUserData bh = bh_usr bh
+
+setUserData :: BinHandle -> UserData -> BinHandle
+setUserData bh us = bh { bh_usr = us }
+
+
+---------------------------------------------------------------
+--             Bin
+---------------------------------------------------------------
+

 newtype Bin a = BinPtr Int 
   deriving (Eq, Ord, Show, Bounded)
 
 castBin :: Bin a -> Bin b
 castBin (BinPtr i) = BinPtr i
 
 newtype Bin a = BinPtr Int 
   deriving (Eq, Ord, Show, Bounded)
 
 castBin :: Bin a -> Bin b
 castBin (BinPtr i) = BinPtr i
 

+---------------------------------------------------------------
+--             class Binary
+---------------------------------------------------------------
+

 class Binary a where
     put_   :: BinHandle -> a -> IO ()
     put    :: BinHandle -> a -> IO (Bin a)
 class Binary a where
     put_   :: BinHandle -> a -> IO ()
     put    :: BinHandle -> a -> IO (Bin a)

@@ -159,17 +203,16 @@ getAt  :: Binary a => BinHandle -> Bin a -> IO a
 getAt bh p = do seekBin bh p; get bh
 
 openBinIO_ :: IO.Handle -> IO BinHandle
 getAt bh p = do seekBin bh p; get bh
 
 openBinIO_ :: IO.Handle -> IO BinHandle

-openBinIO_ h = openBinIO h noBinHandleUserData
+openBinIO_ h = openBinIO h 

 
 

-openBinIO :: IO.Handle -> Module -> IO BinHandle
-openBinIO h mod = do
+openBinIO :: IO.Handle -> IO BinHandle
+openBinIO h = do

   r <- newFastMutInt
   writeFastMutInt r 0
   r <- newFastMutInt
   writeFastMutInt r 0

-  state <- newWriteState mod
-  return (BinIO state r h)
+  return (BinIO noUserData r h)

 
 

-openBinMem :: Int -> Module -> IO BinHandle
-openBinMem size mod
+openBinMem :: Int -> IO BinHandle
+openBinMem size

  | size <= 0 = error "Data.Binary.openBinMem: size must be >= 0"
  | otherwise = do
    arr <- newArray_ (0,size-1)
  | size <= 0 = error "Data.Binary.openBinMem: size must be >= 0"
  | otherwise = do
    arr <- newArray_ (0,size-1)

@@ -178,13 +221,7 @@ openBinMem size mod
    writeFastMutInt ix_r 0
    sz_r <- newFastMutInt
    writeFastMutInt sz_r size
    writeFastMutInt ix_r 0
    sz_r <- newFastMutInt
    writeFastMutInt sz_r size

-   state <- newWriteState mod
-   return (BinMem state ix_r sz_r arr_r)
-
-noBinHandleUserData = error "Binary.BinHandle: no user data"
-
-getUserData :: BinHandle -> BinHandleState
-getUserData bh = state bh
+   return (BinMem noUserData ix_r sz_r arr_r)

 
 tellBin :: BinHandle -> IO (Bin a)
 tellBin (BinIO  _ r _)   = do ix <- readFastMutInt r; return (BinPtr ix)
 
 tellBin :: BinHandle -> IO (Bin a)
 tellBin (BinIO  _ r _)   = do ix <- readFastMutInt r; return (BinPtr ix)

@@ -210,12 +247,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'

@@ -223,8 +260,9 @@ writeBinMem (BinMem _ ix_r sz_r arr_r) fn = do
   hClose h
 
 readBinMem :: FilePath -> IO BinHandle
   hClose h
 
 readBinMem :: FilePath -> IO BinHandle

+-- Return a BinHandle with a totally undefined State

 readBinMem filename = do
 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)

@@ -237,7 +275,7 @@ readBinMem filename = do
   writeFastMutInt ix_r 0
   sz_r <- newFastMutInt
   writeFastMutInt sz_r filesize
   writeFastMutInt ix_r 0
   sz_r <- newFastMutInt
   writeFastMutInt sz_r filesize

-  return (BinMem initReadState ix_r sz_r arr_r)
+  return (BinMem noUserData ix_r sz_r arr_r)

 
 -- expand the size of the array to include a specified offset
 expandBin :: BinHandle -> Int -> IO ()
 
 -- expand the size of the array to include a specified offset
 expandBin :: BinHandle -> Int -> IO ()

@@ -250,7 +288,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.

@@ -281,7 +321,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)

@@ -290,7 +334,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

@@ -312,7 +356,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

@@ -326,10 +370,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

@@ -351,33 +395,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

@@ -389,12 +433,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

@@ -402,12 +446,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

@@ -543,26 +587,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 ()

@@ -583,59 +607,115 @@ lazyGet bh = do
     seekBin bh p -- skip over the object for now
     return a
 
     seekBin bh p -- skip over the object for now
     return a
 

--- -----------------------------------------------------------------------------
--- BinHandleState
-
-type BinHandleState = 
-       (Module, 
-        IORef Int,
-        IORef (UniqFM (Int,FastString)),
-        Array Int FastString)
-
-initReadState :: BinHandleState
-initReadState = (undef, undef, undef, undef)
-
-newWriteState :: Module -> IO BinHandleState
-newWriteState m = do
-  j_r <- newIORef 0
-  out_r <- newIORef emptyUFM
-  return (m,j_r,out_r,undef)
+-- --------------------------------------------------------------
+--     Main wrappers: getBinFileWithDict, putBinFileWithDict
+--
+--     This layer is built on top of the stuff above, 
+--     and should not know anything about BinHandles
+-- --------------------------------------------------------------

 
 

-undef = error "Binary.BinHandleState"
+initBinMemSize       = (1024*1024) :: Int

 
 

--- -----------------------------------------------------------------------------
--- FastString binary interface
+#if   WORD_SIZE_IN_BITS == 32
+binaryInterfaceMagic = 0x1face :: Word32
+#elif WORD_SIZE_IN_BITS == 64
+binaryInterfaceMagic = 0x1face64 :: Word32
+#endif

 
 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

-  dict_p <- Binary.get bh              -- get the dictionary ptr
-  data_p <- tellBin bh
+
+       -- Read the magic number to check that this really is a GHC .hi file
+       -- (This magic number does not change when we change 
+       --  GHC interface file format)
+  magic <- get bh
+  when (magic /= binaryInterfaceMagic) $
+       throwDyn (ProgramError (
+          "magic number mismatch: old/corrupt interface file?"))
+
+       -- Read the dictionary
+       -- The next word in the file is a pointer to where the dictionary is
+       -- (probably at the end of the file)
+  dict_p <- Binary.get bh      -- Get the dictionary ptr
+  data_p <- tellBin bh         -- Remember where we are now

   seekBin bh dict_p
   dict <- getDictionary bh
   seekBin bh dict_p
   dict <- getDictionary bh

-  seekBin bh data_p
-  let (mod, j_r, out_r, _) = state bh
-  get bh{ state = (mod,j_r,out_r,dict) }
-
-initBinMemSize = (1024*1024) :: Int
-
-putBinFileWithDict :: Binary a => FilePath -> Module -> a -> IO ()
-putBinFileWithDict file_path mod a = do
-  bh <- openBinMem initBinMemSize mod
-  p <- tellBin bh
-  put_ bh p            -- placeholder for ptr to dictionary
-  put_ bh a
-  let (_, j_r, fm_r, _) = state bh
-  j <- readIORef j_r
-  fm <- readIORef fm_r
-  dict_p <- tellBin bh
-  putAt bh p dict_p    -- fill in the placeholder
-  seekBin bh dict_p    -- seek back to the end of the file
+  seekBin bh data_p            -- Back to where we were before
+
+       -- Initialise the user-data field of bh
+  let bh' = setUserData bh (initReadState dict)
+       
+       -- At last, get the thing 
+  get bh'
+
+putBinFileWithDict :: Binary a => FilePath -> a -> IO ()
+putBinFileWithDict file_path the_thing = do
+  bh <- openBinMem initBinMemSize
+  put_ bh binaryInterfaceMagic
+
+       -- Remember where the dictionary pointer will go
+  dict_p_p <- tellBin bh
+  put_ bh dict_p_p     -- Placeholder for ptr to dictionary
+
+       -- Make some intial state
+  usr_state <- newWriteState
+
+       -- Put the main thing, 
+  put_ (setUserData bh usr_state) the_thing
+
+       -- Get the final-state
+  j <- readIORef  (ud_next usr_state)
+  fm <- readIORef (ud_map  usr_state)
+  dict_p <- tellBin bh -- This is where the dictionary will start
+
+       -- Write the dictionary pointer at the fornt of the file
+  putAt bh dict_p_p dict_p     -- Fill in the placeholder
+  seekBin bh dict_p            -- Seek back to the end of the file
+
+       -- Write the dictionary itself

   putDictionary bh j (constructDictionary j fm)
   putDictionary bh j (constructDictionary j fm)

+
+       -- And send the result to the file

   writeBinMem bh file_path
   
   writeBinMem bh file_path
   

-type Dictionary = Array Int FastString
-       -- should be 0-indexed
+-- -----------------------------------------------------------------------------
+-- UserData
+-- -----------------------------------------------------------------------------
+
+data UserData = 
+   UserData {  -- This field is used only when reading
+             ud_dict :: Dictionary,
+
+               -- The next two fields are only used when writing
+             ud_next :: IORef Int,     -- The next index to use
+             ud_map  :: IORef (UniqFM (Int,FastString))
+       }
+
+noUserData = error "Binary.UserData: no user data"
+
+initReadState :: Dictionary -> UserData
+initReadState dict = UserData{ ud_dict = dict,
+                              ud_next = undef "next",
+                              ud_map  = undef "map" }
+
+newWriteState :: IO UserData
+newWriteState = do
+  j_r <- newIORef 0
+  out_r <- newIORef emptyUFM
+  return (UserData { ud_dict = panic "dict",
+                    ud_next = j_r,
+                    ud_map  = out_r })
+
+
+undef s = panic ("Binary.UserData: no " ++ s)
+
+---------------------------------------------------------
+--             The Dictionary 
+---------------------------------------------------------
+
+type Dictionary = Array Int FastString -- The dictionary
+                                       -- Should be 0-indexed

 
 putDictionary :: BinHandle -> Int -> Dictionary -> IO ()
 putDictionary bh sz dict = do
 
 putDictionary :: BinHandle -> Int -> Dictionary -> IO ()
 putDictionary bh sz dict = do

@@ -651,6 +731,10 @@ getDictionary bh = do
 constructDictionary :: Int -> UniqFM (Int,FastString) -> Dictionary
 constructDictionary j fm = array (0,j-1) (eltsUFM fm)
 
 constructDictionary :: Int -> UniqFM (Int,FastString) -> Dictionary
 constructDictionary j fm = array (0,j-1) (eltsUFM fm)
 

+---------------------------------------------------------
+--             Reading and writing FastStrings
+---------------------------------------------------------
+

 putFS bh (FastString id l ba) = do
   put_ bh (I# l)
   putByteArray bh ba l
 putFS bh (FastString id l ba) = do
   put_ bh (I# l)
   putByteArray bh ba l

@@ -659,15 +743,26 @@ 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 PackageId where
+  put_ bh pid = put_ bh (packageIdFS pid)
+  get bh = do { fs <- get bh; return (fsToPackageId fs) }

 
 instance Binary FastString where
   put_ bh f@(FastString id l ba) =
 
 instance Binary FastString where
   put_ bh f@(FastString id l ba) =

-    case getUserData bh of { (_, j_r, out_r, dict) -> do
+    case getUserData bh of { 
+       UserData { ud_next = j_r, ud_map = out_r, ud_dict = dict} -> do

     out <- readIORef out_r
     let uniq = getUnique f
     case lookupUFM out uniq of
     out <- readIORef out_r
     let uniq = getUnique f
     case lookupUFM out uniq of

@@ -682,4 +777,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)
+       return $! (ud_dict (getUserData bh) ! j)