Generate Typeable info at definition sites
[ghc.git] / compiler / utils / Binary.hs
index 8fdc21a..5083804 100644 (file)
@@ -1,4 +1,10 @@
-{-# OPTIONS -cpp #-}
+{-# LANGUAGE CPP, MagicHash, UnboxedTuples #-}
+{-# LANGUAGE FlexibleInstances #-}
+
+{-# OPTIONS_GHC -O -funbox-strict-fields #-}
+-- We always optimise this, otherwise performance of a non-optimised
+-- compiler is severely affected
+
 --
 -- (c) The University of Glasgow 2002-2006
 --
 -- where you can obtain the original version of the Binary library, namely
 --     http://www.cs.york.ac.uk/fp/nhc98/
 
-{-# OPTIONS -w #-}
--- The above warning supression flag is a temporary kludge.
--- While working on this module you are encouraged to remove it and fix
--- any warnings in the module. See
---     http://hackage.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#Warnings
--- for details
-
 module Binary
   ( {-type-}  Bin,
     {-class-} Binary(..),
     {-type-}  BinHandle,
+    SymbolTable, Dictionary,
 
-   openBinIO, openBinIO_,
    openBinMem,
 --   closeBin,
 
    seekBin,
+   seekBy,
    tellBin,
    castBin,
 
    writeBinMem,
    readBinMem,
 
+   fingerprintBinMem,
+   computeFingerprint,
+
    isEOFBin,
 
    putAt, getAt,
@@ -45,82 +48,55 @@ module Binary
    lazyGet,
    lazyPut,
 
-   -- GHC only:
-   ByteArray(..),
-   getByteArray,
-   putByteArray,
-
    UserData(..), getUserData, setUserData,
    newReadState, newWriteState,
-   putDictionary, getDictionary,
+   putDictionary, getDictionary, putFS,
   ) where
 
 #include "HsVersions.h"
 
 -- The *host* architecture version:
-#include "MachDeps.h"
+#include "../includes/MachDeps.h"
 
 import {-# SOURCE #-} Name (Name)
 import FastString
-import Unique
 import Panic
 import UniqFM
 import FastMutInt
-import PackageConfig
+import Fingerprint
+import BasicTypes
+import SrcLoc
 
 import Foreign
-import Data.Array.IO
 import Data.Array
-import Data.Bits
-import Data.Int
-import Data.Word
+import Data.ByteString (ByteString)
+import qualified Data.ByteString.Internal as BS
+import qualified Data.ByteString.Unsafe   as BS
 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.Time
+import Data.Typeable
+import Control.Monad            ( when )
 import System.IO as IO
-import System.IO.Unsafe                ( unsafeInterleaveIO )
-import System.IO.Error         ( mkIOError, eofErrorType )
-import GHC.Real                        ( Ratio(..) )
-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
-
-#if __GLASGOW_HASKELL__ < 601
-openBinaryFile f mode = openFileEx f (BinaryMode mode)
-#endif
-
-type BinArray = IOUArray Int Word8
+import System.IO.Unsafe         ( unsafeInterleaveIO )
+import System.IO.Error          ( mkIOError, eofErrorType )
+import GHC.Real                 ( Ratio(..) )
+
+type BinArray = ForeignPtr Word8
 
 ---------------------------------------------------------------
---             BinHandle
+-- BinHandle
 ---------------------------------------------------------------
 
 data BinHandle
-  = BinMem {           -- binary data stored in an unboxed array
-     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))
+  = BinMem {                     -- binary data stored in an unboxed array
+     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))
     }
-       -- XXX: should really store a "high water mark" for dumping out
-       -- the binary data to a file.
-
-  | BinIO {            -- binary data stored in a file
-     bh_usr :: UserData,
-     off_r :: !FastMutInt,             -- the current offset (cached)
-     hdl   :: !IO.Handle               -- the file handle (must be seekable)
-   }
-       -- cache the file ptr in BinIO; using hTell is too expensive
-       -- to call repeatedly.  If anyone else is modifying this Handle
-       -- at the same time, we'll be screwed.
+        -- XXX: should really store a "high water mark" for dumping out
+        -- the binary data to a file.
 
 getUserData :: BinHandle -> UserData
 getUserData bh = bh_usr bh
@@ -130,17 +106,17 @@ setUserData bh us = bh { bh_usr = us }
 
 
 ---------------------------------------------------------------
---             Bin
+-- Bin
 ---------------------------------------------------------------
 
-newtype Bin a = BinPtr Int 
+newtype Bin a = BinPtr Int
   deriving (Eq, Ord, Show, Bounded)
 
 castBin :: Bin a -> Bin b
 castBin (BinPtr i) = BinPtr i
 
 ---------------------------------------------------------------
---             class Binary
+-- class Binary
 ---------------------------------------------------------------
 
 class Binary a where
@@ -151,29 +127,20 @@ class Binary a where
     -- define one of put_, put.  Use of put_ is recommended because it
     -- is more likely that tail-calls can kick in, and we rarely need the
     -- position return value.
-    put_ bh a = do put bh a; return ()
+    put_ bh a = do _ <- put bh a; return ()
     put bh a  = do p <- tellBin bh; put_ bh a; return p
 
 putAt  :: Binary a => BinHandle -> Bin a -> a -> IO ()
-putAt bh p x = do seekBin bh p; put bh x; return ()
+putAt bh p x = do seekBin bh p; put_ bh x; return ()
 
 getAt  :: Binary a => BinHandle -> Bin a -> IO a
 getAt bh p = do seekBin bh p; get bh
 
-openBinIO_ :: IO.Handle -> IO BinHandle
-openBinIO_ h = openBinIO h 
-
-openBinIO :: IO.Handle -> IO BinHandle
-openBinIO h = do
-  r <- newFastMutInt
-  writeFastMutInt r 0
-  return (BinIO noUserData r h)
-
 openBinMem :: Int -> IO BinHandle
 openBinMem size
  | size <= 0 = error "Data.Binary.openBinMem: size must be >= 0"
  | otherwise = do
-   arr <- newArray_ (0,size-1)
+   arr <- mallocForeignPtrBytes size
    arr_r <- newIORef arr
    ix_r <- newFastMutInt
    writeFastMutInt ix_r 0
@@ -182,33 +149,36 @@ openBinMem size
    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 (BinMem _ r _ _) = do ix <- readFastMutInt r; return (BinPtr ix)
 
 seekBin :: BinHandle -> Bin a -> IO ()
-seekBin (BinIO _ ix_r h) (BinPtr p) = do 
-  writeFastMutInt ix_r p
-  hSeek h AbsoluteSeek (fromIntegral p)
-seekBin h@(BinMem _ ix_r sz_r a) (BinPtr p) = do
+seekBin h@(BinMem _ ix_r sz_r _) (BinPtr p) = do
   sz <- readFastMutInt sz_r
   if (p >= sz)
-       then do expandBin h p; writeFastMutInt ix_r p
-       else writeFastMutInt ix_r p
+        then do expandBin h p; writeFastMutInt ix_r p
+        else writeFastMutInt ix_r p
+
+seekBy :: BinHandle -> Int -> IO ()
+seekBy h@(BinMem _ ix_r sz_r _) off = do
+  sz <- readFastMutInt sz_r
+  ix <- readFastMutInt ix_r
+  let ix' = ix + off
+  if (ix' >= sz)
+        then do expandBin h ix'; writeFastMutInt ix_r ix'
+        else writeFastMutInt ix_r ix'
 
 isEOFBin :: BinHandle -> IO Bool
-isEOFBin (BinMem _ ix_r sz_r a) = do
+isEOFBin (BinMem _ ix_r sz_r _) = do
   ix <- readFastMutInt ix_r
   sz <- readFastMutInt sz_r
   return (ix >= sz)
-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 (BinMem _ ix_r _ arr_r) fn = do
   h <- openBinaryFile fn WriteMode
   arr <- readIORef arr_r
   ix  <- readFastMutInt ix_r
-  hPutArray h arr ix
+  withForeignPtr arr $ \p -> hPutBuf h p ix
   hClose h
 
 readBinMem :: FilePath -> IO BinHandle
@@ -217,10 +187,10 @@ readBinMem filename = do
   h <- openBinaryFile filename ReadMode
   filesize' <- hFileSize h
   let filesize = fromIntegral filesize'
-  arr <- newArray_ (0,filesize-1)
-  count <- hGetArray h arr filesize
-  when (count /= filesize)
-       (error ("Binary.readBinMem: only read " ++ show count ++ " bytes"))
+  arr <- mallocForeignPtrBytes (filesize*2)
+  count <- withForeignPtr arr $ \p -> hGetBuf h p filesize
+  when (count /= filesize) $
+       error ("Binary.readBinMem: only read " ++ show count ++ " bytes")
   hClose h
   arr_r <- newIORef arr
   ix_r <- newFastMutInt
@@ -229,23 +199,35 @@ readBinMem filename = do
   writeFastMutInt sz_r filesize
   return (BinMem noUserData ix_r sz_r arr_r)
 
+fingerprintBinMem :: BinHandle -> IO Fingerprint
+fingerprintBinMem (BinMem _ ix_r _ arr_r) = do
+  arr <- readIORef arr_r
+  ix <- readFastMutInt ix_r
+  withForeignPtr arr $ \p -> fingerprintData p ix
+
+computeFingerprint :: Binary a
+                   => (BinHandle -> Name -> IO ())
+                   -> a
+                   -> IO Fingerprint
+
+computeFingerprint put_name a = do
+  bh <- openBinMem (3*1024) -- just less than a block
+  bh <- return $ setUserData bh $ newWriteState put_name putFS
+  put_ bh a
+  fingerprintBinMem bh
+
 -- expand the size of the array to include a specified offset
 expandBin :: BinHandle -> Int -> IO ()
-expandBin (BinMem _ ix_r sz_r arr_r) off = do
+expandBin (BinMem _ _ sz_r arr_r) off = do
    sz <- readFastMutInt sz_r
    let sz' = head (dropWhile (<= off) (iterate (* 2) sz))
    arr <- readIORef arr_r
-   arr' <- newArray_ (0,sz'-1)
-   sequence_ [ unsafeRead arr i >>= unsafeWrite arr' i
-            | i <- [ 0 .. sz-1 ] ]
+   arr' <- mallocForeignPtrBytes sz'
+   withForeignPtr arr $ \old ->
+     withForeignPtr arr' $ \new ->
+       copyBytes new old sz
    writeFastMutInt sz_r sz'
    writeIORef arr_r arr'
-#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.
 
 -- -----------------------------------------------------------------------------
 -- Low-level reading/writing of bytes
@@ -254,35 +236,25 @@ putWord8 :: BinHandle -> Word8 -> IO ()
 putWord8 h@(BinMem _ ix_r sz_r arr_r) w = do
     ix <- readFastMutInt ix_r
     sz <- readFastMutInt sz_r
-       -- double the size of the array if it overflows
-    if (ix >= sz) 
-       then do expandBin h ix
-               putWord8 h w
-       else do arr <- readIORef arr_r
-               unsafeWrite arr ix w
-               writeFastMutInt ix_r (ix+1)
-               return ()
-putWord8 (BinIO _ ix_r h) w = do
-    ix <- readFastMutInt ix_r
-    hPutChar h (chr (fromIntegral w))  -- XXX not really correct
-    writeFastMutInt ix_r (ix+1)
-    return ()
+    -- double the size of the array if it overflows
+    if (ix >= sz)
+        then do expandBin h ix
+                putWord8 h w
+        else do arr <- readIORef arr_r
+                withForeignPtr arr $ \p -> pokeByteOff p ix w
+                writeFastMutInt ix_r (ix+1)
+                return ()
 
 getWord8 :: BinHandle -> IO Word8
 getWord8 (BinMem _ ix_r sz_r arr_r) = do
     ix <- readFastMutInt ix_r
     sz <- readFastMutInt sz_r
-    when (ix >= sz)  $
-       ioError (mkIOError eofErrorType "Data.Binary.getWord8" Nothing Nothing)
+    when (ix >= sz) $
+        ioError (mkIOError eofErrorType "Data.Binary.getWord8" Nothing Nothing)
     arr <- readIORef arr_r
-    w <- unsafeRead arr ix
+    w <- withForeignPtr arr $ \p -> peekByteOff p ix
     writeFastMutInt ix_r (ix+1)
     return w
-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
 
 putByte :: BinHandle -> Word8 -> IO ()
 putByte bh w = put_ bh w
@@ -318,11 +290,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
   put_ h w = do
@@ -343,14 +314,14 @@ 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
@@ -375,51 +346,38 @@ instance Binary Int64 where
 -- Instances for standard types
 
 instance Binary () where
-    put_ bh () = return ()
-    get  _     = return ()
---    getF bh p  = case getBitsF bh 0 p of (_,b) -> ((),b)
+    put_ _ () = return ()
+    get  _    = return ()
 
 instance Binary Bool where
     put_ bh b = putByte bh (fromIntegral (fromEnum b))
     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)))
---    getF bh p = case getBitsF bh 8 p of (x,b) -> (toEnum x,b)
 
 instance Binary Int where
-#if SIZEOF_HSINT == 4
-    put_ bh i = put_ bh (fromIntegral i :: Int32)
-    get  bh = do
-       x <- get bh
-       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))
-#else
-#error "unsupported sizeof(HsInt)"
-#endif
---    getF bh   = getBitsF bh 32
+        x <- get bh
+        return $! (fromIntegral (x :: Int64))
 
 instance Binary a => Binary [a] where
-    put_ bh l = do 
-       let len = length l
-       if (len < 0xff) 
-         then putByte bh (fromIntegral len :: Word8)
-         else do putByte bh 0xff; put_ bh (fromIntegral len :: Word32)
-       mapM_ (put_ bh) l
+    put_ bh l = do
+        let len = length l
+        if (len < 0xff)
+          then putByte bh (fromIntegral len :: Word8)
+          else do putByte bh 0xff; put_ bh (fromIntegral len :: Word32)
+        mapM_ (put_ bh) l
     get bh = do
-       b <- getByte bh
-       len <- if b == 0xff 
-                 then get bh
-                 else return (fromIntegral b :: Word32)
-       let loop 0 = return []
-           loop n = do a <- get bh; as <- loop (n-1); return (a:as)
-       loop len
+        b <- getByte bh
+        len <- if b == 0xff
+                  then get bh
+                  else return (fromIntegral b :: Word32)
+        let loop 0 = return []
+            loop n = do a <- get bh; as <- loop (n-1); return (a:as)
+        loop len
 
 instance (Binary a, Binary b) => Binary (a,b) where
     put_ bh (a,b) = do put_ bh a; put_ bh b
@@ -436,11 +394,30 @@ instance (Binary a, Binary b, Binary c) => Binary (a,b,c) where
 
 instance (Binary a, Binary b, Binary c, Binary d) => Binary (a,b,c,d) where
     put_ bh (a,b,c,d) = do put_ bh a; put_ bh b; put_ bh c; put_ bh d
-    get bh          = do a <- get bh
-                         b <- get bh
-                         c <- get bh
-                         d <- get bh
-                         return (a,b,c,d)
+    get bh            = do a <- get bh
+                           b <- get bh
+                           c <- get bh
+                           d <- get bh
+                           return (a,b,c,d)
+
+instance (Binary a, Binary b, Binary c, Binary d, Binary e) => Binary (a,b,c,d, e) where
+    put_ bh (a,b,c,d, e) = do put_ bh a; put_ bh b; put_ bh c; put_ bh d; put_ bh e;
+    get bh               = do a <- get bh
+                              b <- get bh
+                              c <- get bh
+                              d <- get bh
+                              e <- get bh
+                              return (a,b,c,d,e)
+
+instance (Binary a, Binary b, Binary c, Binary d, Binary e, Binary f) => Binary (a,b,c,d, e, f) where
+    put_ bh (a,b,c,d, e, f) = do put_ bh a; put_ bh b; put_ bh c; put_ bh d; put_ bh e; put_ bh f;
+    get bh                  = do a <- get bh
+                                 b <- get bh
+                                 c <- get bh
+                                 d <- get bh
+                                 e <- get bh
+                                 f <- get bh
+                                 return (a,b,c,d,e,f)
 
 instance Binary a => Binary (Maybe a) where
     put_ bh Nothing  = putByte bh 0
@@ -458,47 +435,90 @@ instance (Binary a, Binary b) => Binary (Either a b) where
                              0 -> do a <- get bh ; return (Left a)
                              _ -> do b <- get bh ; return (Right b)
 
-#ifdef __GLASGOW_HASKELL__
+instance Binary UTCTime where
+    put_ bh u = do put_ bh (utctDay u)
+                   put_ bh (utctDayTime u)
+    get bh = do day <- get bh
+                dayTime <- get bh
+                return $ UTCTime { utctDay = day, utctDayTime = dayTime }
+
+instance Binary Day where
+    put_ bh d = put_ bh (toModifiedJulianDay d)
+    get bh = do i <- get bh
+                return $ ModifiedJulianDay { toModifiedJulianDay = i }
+
+instance Binary DiffTime where
+    put_ bh dt = put_ bh (toRational dt)
+    get bh = do r <- get bh
+                return $ fromRational r
+
+--to quote binary-0.3 on this code idea,
+--
+-- TODO  This instance is not architecture portable.  GMP stores numbers as
+-- arrays of machine sized words, so the byte format is not portable across
+-- architectures with different endianess and word size.
+--
+-- This makes it hard (impossible) to make an equivalent instance
+-- with code that is compilable with non-GHC.  Do we need any instance
+-- Binary Integer, and if so, does it have to be blazing fast?  Or can
+-- we just change this instance to be portable like the rest of the
+-- instances? (binary package has code to steal for that)
+--
+-- yes, we need Binary Integer and Binary Rational in basicTypes/Literal.hs
+
 instance Binary Integer where
+    -- XXX This is hideous
+    put_ bh i = put_ bh (show i)
+    get bh = do str <- get bh
+                case reads str of
+                    [(i, "")] -> return i
+                    _ -> fail ("Binary Integer: got " ++ show str)
+
+    {-
+    -- This code is currently commented out.
+    -- See https://ghc.haskell.org/trac/ghc/ticket/3379#comment:10 for
+    -- discussion.
+
     put_ bh (S# i#) = do putByte bh 0; put_ bh (I# i#)
     put_ bh (J# s# a#) = do
-       p <- putByte bh 1;
-       put_ bh (I# s#)
-       let sz# = sizeofByteArray# a#  -- in *bytes*
-       put_ bh (I# sz#)  -- in *bytes*
-       putByteArray bh a# sz#
-   
-    get bh = do 
-       b <- getByte bh
-       case b of
-         0 -> do (I# i#) <- get bh
-                 return (S# i#)
-         _ -> do (I# s#) <- get bh
-                 sz <- get bh
-                 (BA a#) <- getByteArray bh sz
-                 return (J# s# a#)
+        putByte bh 1
+        put_ bh (I# s#)
+        let sz# = sizeofByteArray# a#  -- in *bytes*
+        put_ bh (I# sz#)  -- in *bytes*
+        putByteArray bh a# sz#
+
+    get bh = do
+        b <- getByte bh
+        case b of
+          0 -> do (I# i#) <- get bh
+                  return (S# i#)
+          _ -> do (I# s#) <- get bh
+                  sz <- get bh
+                  (BA a#) <- getByteArray bh sz
+                  return (J# s# a#)
 
 putByteArray :: BinHandle -> ByteArray# -> Int# -> IO ()
 putByteArray bh a s# = loop 0#
-  where loop n# 
-          | n# ==# s# = return ()
-          | otherwise = do
-               putByte bh (indexByteArray a n#)
-               loop (n# +# 1#)
+  where loop n#
+           | n# ==# s# = return ()
+           | otherwise = do
+                putByte bh (indexByteArray a n#)
+                loop (n# +# 1#)
 
 getByteArray :: BinHandle -> Int -> IO ByteArray
 getByteArray bh (I# sz) = do
-  (MBA arr) <- newByteArray sz 
+  (MBA arr) <- newByteArray sz
   let loop n
-          | n ==# sz = return ()
-          | otherwise = do
-               w <- getByte bh 
-               writeByteArray arr n w
-               loop (n +# 1#)
+           | n ==# sz = return ()
+           | otherwise = do
+                w <- getByte bh
+                writeByteArray arr n w
+                loop (n +# 1#)
   loop 0#
   freezeByteArray arr
+    -}
 
-
+{-
 data ByteArray = BA ByteArray#
 data MBA = MBA (MutableByteArray# RealWorld)
 
@@ -520,33 +540,61 @@ writeByteArray arr i (W8# w) = IO $ \s ->
 indexByteArray :: ByteArray# -> Int# -> Word8
 indexByteArray a# n# = W8# (indexWord8Array# a# n#)
 
-instance (Integral a, Binary a) => Binary (Ratio a) where
+-}
+instance (Binary a) => Binary (Ratio a) where
     put_ bh (a :% b) = do put_ bh a; put_ bh b
     get bh = do a <- get bh; b <- get bh; return (a :% b)
-#endif
 
 instance Binary (Bin a) where
-  put_ bh (BinPtr i) = put_ bh i
-  get bh = do i <- get bh; return (BinPtr i)
+  put_ bh (BinPtr i) = put_ bh (fromIntegral i :: Int32)
+  get bh = do i <- get bh; return (BinPtr (fromIntegral (i :: Int32)))
+
+-- -----------------------------------------------------------------------------
+-- Instances for Data.Typeable stuff
+
+instance Binary TyCon where
+    put_ bh tc = do
+        put_ bh (tyConPackage tc)
+        put_ bh (tyConModule tc)
+        put_ bh (tyConName tc)
+    get bh = do
+        p <- get bh
+        m <- get bh
+        n <- get bh
+        return (mkTyCon3 p m n)
+
+instance Binary TypeRep where
+    put_ bh type_rep = do
+        let (ty_con, child_type_reps) = splitTyConApp type_rep
+        put_ bh ty_con
+        put_ bh child_type_reps
+    get bh = do
+        ty_con <- get bh
+        child_type_reps <- get bh
+        return (mkTyConApp ty_con child_type_reps)
 
 -- -----------------------------------------------------------------------------
 -- Lazy reading/writing
 
 lazyPut :: Binary a => BinHandle -> a -> IO ()
 lazyPut bh a = do
-       -- output the obj with a ptr to skip over it:
+    -- output the obj with a ptr to skip over it:
     pre_a <- tellBin bh
-    put_ bh pre_a      -- save a slot for the ptr
-    put_ bh a          -- dump the object
-    q <- tellBin bh    -- q = ptr to after object
-    putAt bh pre_a q   -- fill in slot before a with ptr to q
-    seekBin bh q       -- finally carry on writing at q
+    put_ bh pre_a       -- save a slot for the ptr
+    put_ bh a           -- dump the object
+    q <- tellBin bh     -- q = ptr to after object
+    putAt bh pre_a q    -- fill in slot before a with ptr to q
+    seekBin bh q        -- finally carry on writing at q
 
 lazyGet :: Binary a => BinHandle -> IO a
 lazyGet bh = do
-    p <- get bh                -- a BinPtr
+    p <- get bh -- a BinPtr
     p_a <- tellBin bh
-    a <- unsafeInterleaveIO (getAt bh p_a)
+    a <- unsafeInterleaveIO $ do
+        -- NB: Use a fresh off_r variable in the child thread, for thread
+        -- safety.
+        off_r <- newFastMutInt
+        getAt bh { _off_r = off_r } p_a
     seekBin bh p -- skip over the object for now
     return a
 
@@ -554,62 +602,49 @@ lazyGet bh = do
 -- UserData
 -- -----------------------------------------------------------------------------
 
-data UserData = 
+data UserData =
    UserData {
         -- for *deserialising* only:
-       ud_dict   :: Dictionary,
-        ud_symtab :: SymbolTable,
+        ud_get_name :: BinHandle -> IO Name,
+        ud_get_fs   :: BinHandle -> IO FastString,
 
         -- for *serialising* only:
-       ud_dict_next :: !FastMutInt,    -- The next index to use
-       ud_dict_map  :: !(IORef (UniqFM (Int,FastString))),
-                                -- indexed by FastString
-
-        ud_symtab_next :: !FastMutInt,         -- The next index to use
-       ud_symtab_map  :: !(IORef (UniqFM (Int,Name)))
-                                -- indexed by Name
+        ud_put_name :: BinHandle -> Name       -> IO (),
+        ud_put_fs   :: BinHandle -> FastString -> IO ()
    }
 
-newReadState :: Dictionary -> IO UserData
-newReadState dict = do
-  dict_next <- newFastMutInt
-  dict_map <- newIORef (undef "dict_map")
-  symtab_next <- newFastMutInt
-  symtab_map <- newIORef (undef "symtab_map")
-  return UserData { ud_dict = dict,
-                    ud_symtab = undef "symtab",
-                    ud_dict_next = dict_next,
-                    ud_dict_map = dict_map,
-                    ud_symtab_next = symtab_next,
-                    ud_symtab_map = symtab_map
-                   }
-
-newWriteState :: IO UserData
-newWriteState = do
-  dict_next <- newFastMutInt
-  writeFastMutInt dict_next 0
-  dict_map <- newIORef emptyUFM
-  symtab_next <- newFastMutInt
-  writeFastMutInt symtab_next 0
-  symtab_map <- newIORef emptyUFM
-  return UserData { ud_dict = undef "dict",
-                    ud_symtab = undef "symtab",
-                    ud_dict_next = dict_next,
-                    ud_dict_map = dict_map,
-                    ud_symtab_next = symtab_next,
-                    ud_symtab_map = symtab_map
-                   }
-
+newReadState :: (BinHandle -> IO Name)
+             -> (BinHandle -> IO FastString)
+             -> UserData
+newReadState get_name get_fs
+  = UserData { ud_get_name = get_name,
+               ud_get_fs   = get_fs,
+               ud_put_name = undef "put_name",
+               ud_put_fs   = undef "put_fs"
+             }
+
+newWriteState :: (BinHandle -> Name       -> IO ())
+              -> (BinHandle -> FastString -> IO ())
+              -> UserData
+newWriteState put_name put_fs
+  = UserData { ud_get_name = undef "get_name",
+               ud_get_fs   = undef "get_fs",
+               ud_put_name = put_name,
+               ud_put_fs   = put_fs
+             }
+
+noUserData :: a
 noUserData = undef "UserData"
 
+undef :: String -> a
 undef s = panic ("Binary.UserData: no " ++ s)
 
 ---------------------------------------------------------
---             The Dictionary 
+-- The Dictionary
 ---------------------------------------------------------
 
-type Dictionary = Array Int FastString -- The dictionary
-                                       -- Should be 0-indexed
+type Dictionary = Array Int FastString -- The dictionary
+                                       -- Should be 0-indexed
 
 putDictionary :: BinHandle -> Int -> UniqFM (Int,FastString) -> IO ()
 putDictionary bh sz dict = do
@@ -617,13 +652,13 @@ putDictionary bh sz dict = do
   mapM_ (putFS bh) (elems (array (0,sz-1) (eltsUFM dict)))
 
 getDictionary :: BinHandle -> IO Dictionary
-getDictionary bh = do 
+getDictionary bh = do
   sz <- get bh
   elems <- sequence (take sz (repeat (getFS bh)))
   return (listArray (0,sz-1) elems)
 
 ---------------------------------------------------------
---             The Symbol Table
+-- The Symbol Table
 ---------------------------------------------------------
 
 -- On disk, the symbol table is an array of IfaceExtName, when
@@ -632,62 +667,277 @@ getDictionary bh = do
 type SymbolTable = Array Int Name
 
 ---------------------------------------------------------
---             Reading and writing FastStrings
+-- Reading and writing FastStrings
 ---------------------------------------------------------
 
-putFS bh (FastString id l _ buf _) = do
+putFS :: BinHandle -> FastString -> IO ()
+putFS bh fs = putBS bh $ fastStringToByteString fs
+
+getFS :: BinHandle -> IO FastString
+getFS bh = do bs <- getBS bh
+              return $! mkFastStringByteString bs
+
+putBS :: BinHandle -> ByteString -> IO ()
+putBS bh bs =
+  BS.unsafeUseAsCStringLen bs $ \(ptr, l) -> do
   put_ bh l
-  withForeignPtr buf $ \ptr -> 
-    let 
-       go n | n == l    = return ()
-            | otherwise = do
-               b <- peekElemOff ptr n
-               putByte bh b
-               go (n+1)
-   in 
-   go 0
-  
+  let
+        go n | n == l    = return ()
+             | otherwise = do
+                b <- peekElemOff (castPtr ptr) n
+                putByte bh b
+                go (n+1)
+  go 0
+
 {- -- possible faster version, not quite there yet:
-getFS bh@BinMem{} = do
+getBS bh@BinMem{} = do
   (I# l) <- get bh
   arr <- readIORef (arr_r bh)
   off <- readFastMutInt (off_r bh)
-  return $! (mkFastSubStringBA# arr off l)
+  return $! (mkFastSubBytesBA# arr off l)
 -}
-getFS bh = do
+getBS :: BinHandle -> IO ByteString
+getBS bh = do
   l <- get bh
   fp <- mallocForeignPtrBytes l
   withForeignPtr fp $ \ptr -> do
-  let 
-       go n | n == l = mkFastStringForeignPtr ptr fp l
-            | otherwise = do
-               b <- getByte bh
-               pokeElemOff ptr n b
-               go (n+1)
-  --
-  go 0
-
-instance Binary PackageId where
-  put_ bh pid = put_ bh (packageIdFS pid)
-  get bh = do { fs <- get bh; return (fsToPackageId fs) }
+    let go n | n == l = return $ BS.fromForeignPtr fp 0 l
+             | otherwise = do
+                b <- getByte bh
+                pokeElemOff ptr n b
+                go (n+1)
+    --
+    go 0
+
+instance Binary ByteString where
+  put_ bh f = putBS bh f
+  get bh = getBS bh
 
 instance Binary FastString where
-  put_ bh f@(FastString id l _ fp _) =
-    case getUserData bh of { 
-       UserData { ud_dict_next = j_r, 
-                   ud_dict_map = out_r, 
-                   ud_dict = dict} -> do
-    out <- readIORef out_r
-    let uniq = getUnique f
-    case lookupUFM out uniq of
-       Just (j,f)  -> put_ bh j
-       Nothing -> do
-          j <- readFastMutInt j_r
-          put_ bh j
-          writeFastMutInt j_r (j+1)
-          writeIORef out_r $! addToUFM out uniq (j,f)
-    }
+  put_ bh f =
+    case getUserData bh of
+        UserData { ud_put_fs = put_fs } -> put_fs bh f
+
+  get bh =
+    case getUserData bh of
+        UserData { ud_get_fs = get_fs } -> get_fs bh
 
-  get bh = do 
-       j <- get bh
-       return $! (ud_dict (getUserData bh) ! j)
+-- Here to avoid loop
+
+instance Binary Fingerprint where
+  put_ h (Fingerprint w1 w2) = do put_ h w1; put_ h w2
+  get  h = do w1 <- get h; w2 <- get h; return (Fingerprint w1 w2)
+
+instance Binary FunctionOrData where
+    put_ bh IsFunction = putByte bh 0
+    put_ bh IsData     = putByte bh 1
+    get bh = do
+        h <- getByte bh
+        case h of
+          0 -> return IsFunction
+          1 -> return IsData
+          _ -> panic "Binary FunctionOrData"
+
+instance Binary TupleSort where
+    put_ bh BoxedTuple      = putByte bh 0
+    put_ bh UnboxedTuple    = putByte bh 1
+    put_ bh ConstraintTuple = putByte bh 2
+    get bh = do
+      h <- getByte bh
+      case h of
+        0 -> do return BoxedTuple
+        1 -> do return UnboxedTuple
+        _ -> do return ConstraintTuple
+
+instance Binary Activation where
+    put_ bh NeverActive = do
+            putByte bh 0
+    put_ bh AlwaysActive = do
+            putByte bh 1
+    put_ bh (ActiveBefore aa) = do
+            putByte bh 2
+            put_ bh aa
+    put_ bh (ActiveAfter ab) = do
+            putByte bh 3
+            put_ bh ab
+    get bh = do
+            h <- getByte bh
+            case h of
+              0 -> do return NeverActive
+              1 -> do return AlwaysActive
+              2 -> do aa <- get bh
+                      return (ActiveBefore aa)
+              _ -> do ab <- get bh
+                      return (ActiveAfter ab)
+
+instance Binary InlinePragma where
+    put_ bh (InlinePragma s a b c d) = do
+            put_ bh s
+            put_ bh a
+            put_ bh b
+            put_ bh c
+            put_ bh d
+
+    get bh = do
+           s <- get bh
+           a <- get bh
+           b <- get bh
+           c <- get bh
+           d <- get bh
+           return (InlinePragma s a b c d)
+
+instance Binary RuleMatchInfo where
+    put_ bh FunLike = putByte bh 0
+    put_ bh ConLike = putByte bh 1
+    get bh = do
+            h <- getByte bh
+            if h == 1 then return ConLike
+                      else return FunLike
+
+instance Binary InlineSpec where
+    put_ bh EmptyInlineSpec = putByte bh 0
+    put_ bh Inline          = putByte bh 1
+    put_ bh Inlinable       = putByte bh 2
+    put_ bh NoInline        = putByte bh 3
+
+    get bh = do h <- getByte bh
+                case h of
+                  0 -> return EmptyInlineSpec
+                  1 -> return Inline
+                  2 -> return Inlinable
+                  _ -> return NoInline
+
+instance Binary DefMethSpec where
+    put_ bh NoDM      = putByte bh 0
+    put_ bh VanillaDM = putByte bh 1
+    put_ bh GenericDM = putByte bh 2
+    get bh = do
+            h <- getByte bh
+            case h of
+              0 -> return NoDM
+              1 -> return VanillaDM
+              _ -> return GenericDM
+
+instance Binary RecFlag where
+    put_ bh Recursive = do
+            putByte bh 0
+    put_ bh NonRecursive = do
+            putByte bh 1
+    get bh = do
+            h <- getByte bh
+            case h of
+              0 -> do return Recursive
+              _ -> do return NonRecursive
+
+instance Binary OverlapMode where
+    put_ bh (NoOverlap    s) = putByte bh 0 >> put_ bh s
+    put_ bh (Overlaps     s) = putByte bh 1 >> put_ bh s
+    put_ bh (Incoherent   s) = putByte bh 2 >> put_ bh s
+    put_ bh (Overlapping  s) = putByte bh 3 >> put_ bh s
+    put_ bh (Overlappable s) = putByte bh 4 >> put_ bh s
+    get bh = do
+        h <- getByte bh
+        case h of
+            0 -> (get bh) >>= \s -> return $ NoOverlap s
+            1 -> (get bh) >>= \s -> return $ Overlaps s
+            2 -> (get bh) >>= \s -> return $ Incoherent s
+            3 -> (get bh) >>= \s -> return $ Overlapping s
+            4 -> (get bh) >>= \s -> return $ Overlappable s
+            _ -> panic ("get OverlapMode" ++ show h)
+
+
+instance Binary OverlapFlag where
+    put_ bh flag = do put_ bh (overlapMode flag)
+                      put_ bh (isSafeOverlap flag)
+    get bh = do
+        h <- get bh
+        b <- get bh
+        return OverlapFlag { overlapMode = h, isSafeOverlap = b }
+
+instance Binary FixityDirection where
+    put_ bh InfixL = do
+            putByte bh 0
+    put_ bh InfixR = do
+            putByte bh 1
+    put_ bh InfixN = do
+            putByte bh 2
+    get bh = do
+            h <- getByte bh
+            case h of
+              0 -> do return InfixL
+              1 -> do return InfixR
+              _ -> do return InfixN
+
+instance Binary Fixity where
+    put_ bh (Fixity aa ab) = do
+            put_ bh aa
+            put_ bh ab
+    get bh = do
+          aa <- get bh
+          ab <- get bh
+          return (Fixity aa ab)
+
+instance Binary WarningTxt where
+    put_ bh (WarningTxt s w) = do
+            putByte bh 0
+            put_ bh s
+            put_ bh w
+    put_ bh (DeprecatedTxt s d) = do
+            putByte bh 1
+            put_ bh s
+            put_ bh d
+
+    get bh = do
+            h <- getByte bh
+            case h of
+              0 -> do s <- get bh
+                      w <- get bh
+                      return (WarningTxt s w)
+              _ -> do s <- get bh
+                      d <- get bh
+                      return (DeprecatedTxt s d)
+
+instance Binary StringLiteral where
+  put_ bh (StringLiteral st fs) = do
+            put_ bh st
+            put_ bh fs
+  get bh = do
+            st <- get bh
+            fs <- get bh
+            return (StringLiteral st fs)
+
+instance Binary a => Binary (GenLocated SrcSpan a) where
+    put_ bh (L l x) = do
+            put_ bh l
+            put_ bh x
+
+    get bh = do
+            l <- get bh
+            x <- get bh
+            return (L l x)
+
+instance Binary SrcSpan where
+  put_ bh (RealSrcSpan ss) = do
+          putByte bh 0
+          put_ bh (srcSpanFile ss)
+          put_ bh (srcSpanStartLine ss)
+          put_ bh (srcSpanStartCol ss)
+          put_ bh (srcSpanEndLine ss)
+          put_ bh (srcSpanEndCol ss)
+
+  put_ bh (UnhelpfulSpan s) = do
+          putByte bh 1
+          put_ bh s
+
+  get bh = do
+          h <- getByte bh
+          case h of
+            0 -> do f <- get bh
+                    sl <- get bh
+                    sc <- get bh
+                    el <- get bh
+                    ec <- get bh
+                    return (mkSrcSpan (mkSrcLoc f sl sc)
+                                      (mkSrcLoc f el ec))
+            _ -> do s <- get bh
+                    return (UnhelpfulSpan s)