compiler/utils/Binary.hs

   1 {-# OPTIONS -cpp #-}
   2 --
   3 -- (c) The University of Glasgow 2002
   4 --
   5 -- Binary I/O library, with special tweaks for GHC
   6 --
   7 -- Based on the nhc98 Binary library, which is copyright
   8 -- (c) Malcolm Wallace and Colin Runciman, University of York, 1998.
   9 -- Under the terms of the license for that software, we must tell you
  10 -- where you can obtain the original version of the Binary library, namely
  11 --     http://www.cs.york.ac.uk/fp/nhc98/
  12
  13 module Binary
  14   ( {-type-}  Bin,
  15     {-class-} Binary(..),
  16     {-type-}  BinHandle,
  17
  18    openBinIO, openBinIO_,
  19    openBinMem,
  20 --   closeBin,
  21
  22    seekBin,
  23    tellBin,
  24    castBin,
  25
  26    writeBinMem,
  27    readBinMem,
  28
  29    isEOFBin,
  30
  31    putAt, getAt,
  32
  33    -- for writing instances:
  34    putByte,
  35    getByte,
  36
  37    -- lazy Bin I/O
  38    lazyGet,
  39    lazyPut,
  40
  41    -- GHC only:
  42    ByteArray(..),
  43    getByteArray,
  44    putByteArray,
  45
  46    UserData(..), getUserData, setUserData,
  47    newReadState, newWriteState,
  48    putDictionary, getDictionary,
  49   ) where
  50
  51 #include "HsVersions.h"
  52
  53 -- The *host* architecture version:
  54 #include "MachDeps.h"
  55
  56 import {-# SOURCE #-} Name (Name)
  57 import FastString
  58 import Unique
  59 import Panic
  60 import UniqFM
  61 import FastMutInt
  62 import PackageConfig            ( PackageId, packageIdFS, fsToPackageId )
  63
  64 import Foreign
  65 import Data.Array.IO
  66 import Data.Array
  67 import Data.Bits
  68 import Data.Int
  69 import Data.Word
  70 import Data.IORef
  71 import Data.Char                ( ord, chr )
  72 import Data.Array.Base          ( unsafeRead, unsafeWrite )
  73 import Control.Monad            ( when )
  74 import System.IO as IO
  75 import System.IO.Unsafe         ( unsafeInterleaveIO )
  76 import System.IO.Error          ( mkIOError, eofErrorType )
  77 import GHC.Real                 ( Ratio(..) )
  78 import GHC.Exts
  79 import GHC.IOBase               ( IO(..) )
  80 import GHC.Word                 ( Word8(..) )
  81 #if __GLASGOW_HASKELL__ < 601
  82 -- openFileEx is available from the lang package, but we want to
  83 -- be independent of hslibs libraries.
  84 import GHC.Handle               ( openFileEx, IOModeEx(..) )
  85 #else
  86 import System.IO                ( openBinaryFile )
  87 #endif
  88
  89 #if __GLASGOW_HASKELL__ < 601
  90 openBinaryFile f mode = openFileEx f (BinaryMode mode)
  91 #endif
  92
  93 type BinArray = IOUArray Int Word8
  94
  95 ---------------------------------------------------------------
  96 --              BinHandle
  97 ---------------------------------------------------------------
  98
  99 data BinHandle
 100   = BinMem {            -- binary data stored in an unboxed array
 101      bh_usr :: UserData,        -- sigh, need parameterized modules :-)
 102      off_r :: !FastMutInt,              -- the current offset
 103      sz_r  :: !FastMutInt,              -- size of the array (cached)
 104      arr_r :: !(IORef BinArray)         -- the array (bounds: (0,size-1))
 105     }
 106         -- XXX: should really store a "high water mark" for dumping out
 107         -- the binary data to a file.
 108
 109   | BinIO {             -- binary data stored in a file
 110      bh_usr :: UserData,
 111      off_r :: !FastMutInt,              -- the current offset (cached)
 112      hdl   :: !IO.Handle                -- the file handle (must be seekable)
 113    }
 114         -- cache the file ptr in BinIO; using hTell is too expensive
 115         -- to call repeatedly.  If anyone else is modifying this Handle
 116         -- at the same time, we'll be screwed.
 117
 118 getUserData :: BinHandle -> UserData
 119 getUserData bh = bh_usr bh
 120
 121 setUserData :: BinHandle -> UserData -> BinHandle
 122 setUserData bh us = bh { bh_usr = us }
 123
 124
 125 ---------------------------------------------------------------
 126 --              Bin
 127 ---------------------------------------------------------------
 128
 129 newtype Bin a = BinPtr Int
 130   deriving (Eq, Ord, Show, Bounded)
 131
 132 castBin :: Bin a -> Bin b
 133 castBin (BinPtr i) = BinPtr i
 134
 135 ---------------------------------------------------------------
 136 --              class Binary
 137 ---------------------------------------------------------------
 138
 139 class Binary a where
 140     put_   :: BinHandle -> a -> IO ()
 141     put    :: BinHandle -> a -> IO (Bin a)
 142     get    :: BinHandle -> IO a
 143
 144     -- define one of put_, put.  Use of put_ is recommended because it
 145     -- is more likely that tail-calls can kick in, and we rarely need the
 146     -- position return value.
 147     put_ bh a = do put bh a; return ()
 148     put bh a  = do p <- tellBin bh; put_ bh a; return p
 149
 150 putAt  :: Binary a => BinHandle -> Bin a -> a -> IO ()
 151 putAt bh p x = do seekBin bh p; put bh x; return ()
 152
 153 getAt  :: Binary a => BinHandle -> Bin a -> IO a
 154 getAt bh p = do seekBin bh p; get bh
 155
 156 openBinIO_ :: IO.Handle -> IO BinHandle
 157 openBinIO_ h = openBinIO h
 158
 159 openBinIO :: IO.Handle -> IO BinHandle
 160 openBinIO h = do
 161   r <- newFastMutInt
 162   writeFastMutInt r 0
 163   return (BinIO noUserData r h)
 164
 165 openBinMem :: Int -> IO BinHandle
 166 openBinMem size
 167  | size <= 0 = error "Data.Binary.openBinMem: size must be >= 0"
 168  | otherwise = do
 169    arr <- newArray_ (0,size-1)
 170    arr_r <- newIORef arr
 171    ix_r <- newFastMutInt
 172    writeFastMutInt ix_r 0
 173    sz_r <- newFastMutInt
 174    writeFastMutInt sz_r size
 175    return (BinMem noUserData ix_r sz_r arr_r)
 176
 177 tellBin :: BinHandle -> IO (Bin a)
 178 tellBin (BinIO  _ r _)   = do ix <- readFastMutInt r; return (BinPtr ix)
 179 tellBin (BinMem _ r _ _) = do ix <- readFastMutInt r; return (BinPtr ix)
 180
 181 seekBin :: BinHandle -> Bin a -> IO ()
 182 seekBin (BinIO _ ix_r h) (BinPtr p) = do
 183   writeFastMutInt ix_r p
 184   hSeek h AbsoluteSeek (fromIntegral p)
 185 seekBin h@(BinMem _ ix_r sz_r a) (BinPtr p) = do
 186   sz <- readFastMutInt sz_r
 187   if (p >= sz)
 188         then do expandBin h p; writeFastMutInt ix_r p
 189         else writeFastMutInt ix_r p
 190
 191 isEOFBin :: BinHandle -> IO Bool
 192 isEOFBin (BinMem _ ix_r sz_r a) = do
 193   ix <- readFastMutInt ix_r
 194   sz <- readFastMutInt sz_r
 195   return (ix >= sz)
 196 isEOFBin (BinIO _ ix_r h) = hIsEOF h
 197
 198 writeBinMem :: BinHandle -> FilePath -> IO ()
 199 writeBinMem (BinIO _ _ _) _ = error "Data.Binary.writeBinMem: not a memory handle"
 200 writeBinMem (BinMem _ ix_r sz_r arr_r) fn = do
 201   h <- openBinaryFile fn WriteMode
 202   arr <- readIORef arr_r
 203   ix  <- readFastMutInt ix_r
 204   hPutArray h arr ix
 205 #if __GLASGOW_HASKELL__ <= 500
 206   -- workaround a bug in old implementation of hPutBuf (it doesn't
 207   -- set the FILEOBJ_RW_WRITTEN flag on the file object, so the file doens't
 208   -- get flushed properly).  Adding an extra '\0' doens't do any harm.
 209   hPutChar h '\0'
 210 #endif
 211   hClose h
 212
 213 readBinMem :: FilePath -> IO BinHandle
 214 -- Return a BinHandle with a totally undefined State
 215 readBinMem filename = do
 216   h <- openBinaryFile filename ReadMode
 217   filesize' <- hFileSize h
 218   let filesize = fromIntegral filesize'
 219   arr <- newArray_ (0,filesize-1)
 220   count <- hGetArray h arr filesize
 221   when (count /= filesize)
 222         (error ("Binary.readBinMem: only read " ++ show count ++ " bytes"))
 223   hClose h
 224   arr_r <- newIORef arr
 225   ix_r <- newFastMutInt
 226   writeFastMutInt ix_r 0
 227   sz_r <- newFastMutInt
 228   writeFastMutInt sz_r filesize
 229   return (BinMem noUserData ix_r sz_r arr_r)
 230
 231 -- expand the size of the array to include a specified offset
 232 expandBin :: BinHandle -> Int -> IO ()
 233 expandBin (BinMem _ ix_r sz_r arr_r) off = do
 234    sz <- readFastMutInt sz_r
 235    let sz' = head (dropWhile (<= off) (iterate (* 2) sz))
 236    arr <- readIORef arr_r
 237    arr' <- newArray_ (0,sz'-1)
 238    sequence_ [ unsafeRead arr i >>= unsafeWrite arr' i
 239              | i <- [ 0 .. sz-1 ] ]
 240    writeFastMutInt sz_r sz'
 241    writeIORef arr_r arr'
 242 #ifdef DEBUG
 243    hPutStrLn stderr ("Binary: expanding to size: " ++ show sz')
 244 #endif
 245    return ()
 246 expandBin (BinIO _ _ _) _ = return ()
 247         -- no need to expand a file, we'll assume they expand by themselves.
 248
 249 -- -----------------------------------------------------------------------------
 250 -- Low-level reading/writing of bytes
 251
 252 putWord8 :: BinHandle -> Word8 -> IO ()
 253 putWord8 h@(BinMem _ ix_r sz_r arr_r) w = do
 254     ix <- readFastMutInt ix_r
 255     sz <- readFastMutInt sz_r
 256         -- double the size of the array if it overflows
 257     if (ix >= sz)
 258         then do expandBin h ix
 259                 putWord8 h w
 260         else do arr <- readIORef arr_r
 261                 unsafeWrite arr ix w
 262                 writeFastMutInt ix_r (ix+1)
 263                 return ()
 264 putWord8 (BinIO _ ix_r h) w = do
 265     ix <- readFastMutInt ix_r
 266     hPutChar h (chr (fromIntegral w))   -- XXX not really correct
 267     writeFastMutInt ix_r (ix+1)
 268     return ()
 269
 270 getWord8 :: BinHandle -> IO Word8
 271 getWord8 (BinMem _ ix_r sz_r arr_r) = do
 272     ix <- readFastMutInt ix_r
 273     sz <- readFastMutInt sz_r
 274     when (ix >= sz)  $
 275 #if __GLASGOW_HASKELL__ <= 408
 276         throw (mkIOError eofErrorType "Data.Binary.getWord8" Nothing Nothing)
 277 #else
 278         ioError (mkIOError eofErrorType "Data.Binary.getWord8" Nothing Nothing)
 279 #endif
 280     arr <- readIORef arr_r
 281     w <- unsafeRead arr ix
 282     writeFastMutInt ix_r (ix+1)
 283     return w
 284 getWord8 (BinIO _ ix_r h) = do
 285     ix <- readFastMutInt ix_r
 286     c <- hGetChar h
 287     writeFastMutInt ix_r (ix+1)
 288     return $! (fromIntegral (ord c))    -- XXX not really correct
 289
 290 putByte :: BinHandle -> Word8 -> IO ()
 291 putByte bh w = put_ bh w
 292
 293 getByte :: BinHandle -> IO Word8
 294 getByte = getWord8
 295
 296 -- -----------------------------------------------------------------------------
 297 -- Primitve Word writes
 298
 299 instance Binary Word8 where
 300   put_ = putWord8
 301   get  = getWord8
 302
 303 instance Binary Word16 where
 304   put_ h w = do -- XXX too slow.. inline putWord8?
 305     putByte h (fromIntegral (w `shiftR` 8))
 306     putByte h (fromIntegral (w .&. 0xff))
 307   get h = do
 308     w1 <- getWord8 h
 309     w2 <- getWord8 h
 310     return $! ((fromIntegral w1 `shiftL` 8) .|. fromIntegral w2)
 311
 312
 313 instance Binary Word32 where
 314   put_ h w = do
 315     putByte h (fromIntegral (w `shiftR` 24))
 316     putByte h (fromIntegral ((w `shiftR` 16) .&. 0xff))
 317     putByte h (fromIntegral ((w `shiftR` 8)  .&. 0xff))
 318     putByte h (fromIntegral (w .&. 0xff))
 319   get h = do
 320     w1 <- getWord8 h
 321     w2 <- getWord8 h
 322     w3 <- getWord8 h
 323     w4 <- getWord8 h
 324     return $! ((fromIntegral w1 `shiftL` 24) .|.
 325                (fromIntegral w2 `shiftL` 16) .|.
 326                (fromIntegral w3 `shiftL`  8) .|.
 327                (fromIntegral w4))
 328
 329
 330 instance Binary Word64 where
 331   put_ h w = do
 332     putByte h (fromIntegral (w `shiftR` 56))
 333     putByte h (fromIntegral ((w `shiftR` 48) .&. 0xff))
 334     putByte h (fromIntegral ((w `shiftR` 40) .&. 0xff))
 335     putByte h (fromIntegral ((w `shiftR` 32) .&. 0xff))
 336     putByte h (fromIntegral ((w `shiftR` 24) .&. 0xff))
 337     putByte h (fromIntegral ((w `shiftR` 16) .&. 0xff))
 338     putByte h (fromIntegral ((w `shiftR`  8) .&. 0xff))
 339     putByte h (fromIntegral (w .&. 0xff))
 340   get h = do
 341     w1 <- getWord8 h
 342     w2 <- getWord8 h
 343     w3 <- getWord8 h
 344     w4 <- getWord8 h
 345     w5 <- getWord8 h
 346     w6 <- getWord8 h
 347     w7 <- getWord8 h
 348     w8 <- getWord8 h
 349     return $! ((fromIntegral w1 `shiftL` 56) .|.
 350                (fromIntegral w2 `shiftL` 48) .|.
 351                (fromIntegral w3 `shiftL` 40) .|.
 352                (fromIntegral w4 `shiftL` 32) .|.
 353                (fromIntegral w5 `shiftL` 24) .|.
 354                (fromIntegral w6 `shiftL` 16) .|.
 355                (fromIntegral w7 `shiftL`  8) .|.
 356                (fromIntegral w8))
 357
 358 -- -----------------------------------------------------------------------------
 359 -- Primitve Int writes
 360
 361 instance Binary Int8 where
 362   put_ h w = put_ h (fromIntegral w :: Word8)
 363   get h    = do w <- get h; return $! (fromIntegral (w::Word8))
 364
 365 instance Binary Int16 where
 366   put_ h w = put_ h (fromIntegral w :: Word16)
 367   get h    = do w <- get h; return $! (fromIntegral (w::Word16))
 368
 369 instance Binary Int32 where
 370   put_ h w = put_ h (fromIntegral w :: Word32)
 371   get h    = do w <- get h; return $! (fromIntegral (w::Word32))
 372
 373 instance Binary Int64 where
 374   put_ h w = put_ h (fromIntegral w :: Word64)
 375   get h    = do w <- get h; return $! (fromIntegral (w::Word64))
 376
 377 -- -----------------------------------------------------------------------------
 378 -- Instances for standard types
 379
 380 instance Binary () where
 381     put_ bh () = return ()
 382     get  _     = return ()
 383 --    getF bh p  = case getBitsF bh 0 p of (_,b) -> ((),b)
 384
 385 instance Binary Bool where
 386     put_ bh b = putByte bh (fromIntegral (fromEnum b))
 387     get  bh   = do x <- getWord8 bh; return $! (toEnum (fromIntegral x))
 388 --    getF bh p = case getBitsF bh 1 p of (x,b) -> (toEnum x,b)
 389
 390 instance Binary Char where
 391     put_  bh c = put_ bh (fromIntegral (ord c) :: Word32)
 392     get  bh   = do x <- get bh; return $! (chr (fromIntegral (x :: Word32)))
 393 --    getF bh p = case getBitsF bh 8 p of (x,b) -> (toEnum x,b)
 394
 395 instance Binary Int where
 396 #if SIZEOF_HSINT == 4
 397     put_ bh i = put_ bh (fromIntegral i :: Int32)
 398     get  bh = do
 399         x <- get bh
 400         return $! (fromIntegral (x :: Int32))
 401 #elif SIZEOF_HSINT == 8
 402     put_ bh i = put_ bh (fromIntegral i :: Int64)
 403     get  bh = do
 404         x <- get bh
 405         return $! (fromIntegral (x :: Int64))
 406 #else
 407 #error "unsupported sizeof(HsInt)"
 408 #endif
 409 --    getF bh   = getBitsF bh 32
 410
 411 instance Binary a => Binary [a] where
 412     put_ bh l = do
 413         let len = length l
 414         if (len < 0xff)
 415           then putByte bh (fromIntegral len :: Word8)
 416           else do putByte bh 0xff; put_ bh (fromIntegral len :: Word32)
 417         mapM_ (put_ bh) l
 418     get bh = do
 419         b <- getByte bh
 420         len <- if b == 0xff
 421                   then get bh
 422                   else return (fromIntegral b :: Word32)
 423         let loop 0 = return []
 424             loop n = do a <- get bh; as <- loop (n-1); return (a:as)
 425         loop len
 426
 427 instance (Binary a, Binary b) => Binary (a,b) where
 428     put_ bh (a,b) = do put_ bh a; put_ bh b
 429     get bh        = do a <- get bh
 430                        b <- get bh
 431                        return (a,b)
 432
 433 instance (Binary a, Binary b, Binary c) => Binary (a,b,c) where
 434     put_ bh (a,b,c) = do put_ bh a; put_ bh b; put_ bh c
 435     get bh          = do a <- get bh
 436                          b <- get bh
 437                          c <- get bh
 438                          return (a,b,c)
 439
 440 instance (Binary a, Binary b, Binary c, Binary d) => Binary (a,b,c,d) where
 441     put_ bh (a,b,c,d) = do put_ bh a; put_ bh b; put_ bh c; put_ bh d
 442     get bh          = do a <- get bh
 443                          b <- get bh
 444                          c <- get bh
 445                          d <- get bh
 446                          return (a,b,c,d)
 447
 448 instance Binary a => Binary (Maybe a) where
 449     put_ bh Nothing  = putByte bh 0
 450     put_ bh (Just a) = do putByte bh 1; put_ bh a
 451     get bh           = do h <- getWord8 bh
 452                           case h of
 453                             0 -> return Nothing
 454                             _ -> do x <- get bh; return (Just x)
 455
 456 instance (Binary a, Binary b) => Binary (Either a b) where
 457     put_ bh (Left  a) = do putByte bh 0; put_ bh a
 458     put_ bh (Right b) = do putByte bh 1; put_ bh b
 459     get bh            = do h <- getWord8 bh
 460                            case h of
 461                              0 -> do a <- get bh ; return (Left a)
 462                              _ -> do b <- get bh ; return (Right b)
 463
 464 #ifdef __GLASGOW_HASKELL__
 465 instance Binary Integer where
 466     put_ bh (S# i#) = do putByte bh 0; put_ bh (I# i#)
 467     put_ bh (J# s# a#) = do
 468         p <- putByte bh 1;
 469         put_ bh (I# s#)
 470         let sz# = sizeofByteArray# a#  -- in *bytes*
 471         put_ bh (I# sz#)  -- in *bytes*
 472         putByteArray bh a# sz#
 473
 474     get bh = do
 475         b <- getByte bh
 476         case b of
 477           0 -> do (I# i#) <- get bh
 478                   return (S# i#)
 479           _ -> do (I# s#) <- get bh
 480                   sz <- get bh
 481                   (BA a#) <- getByteArray bh sz
 482                   return (J# s# a#)
 483
 484 putByteArray :: BinHandle -> ByteArray# -> Int# -> IO ()
 485 putByteArray bh a s# = loop 0#
 486   where loop n#
 487            | n# ==# s# = return ()
 488            | otherwise = do
 489                 putByte bh (indexByteArray a n#)
 490                 loop (n# +# 1#)
 491
 492 getByteArray :: BinHandle -> Int -> IO ByteArray
 493 getByteArray bh (I# sz) = do
 494   (MBA arr) <- newByteArray sz
 495   let loop n
 496            | n ==# sz = return ()
 497            | otherwise = do
 498                 w <- getByte bh
 499                 writeByteArray arr n w
 500                 loop (n +# 1#)
 501   loop 0#
 502   freezeByteArray arr
 503
 504
 505 data ByteArray = BA ByteArray#
 506 data MBA = MBA (MutableByteArray# RealWorld)
 507
 508 newByteArray :: Int# -> IO MBA
 509 newByteArray sz = IO $ \s ->
 510   case newByteArray# sz s of { (# s, arr #) ->
 511   (# s, MBA arr #) }
 512
 513 freezeByteArray :: MutableByteArray# RealWorld -> IO ByteArray
 514 freezeByteArray arr = IO $ \s ->
 515   case unsafeFreezeByteArray# arr s of { (# s, arr #) ->
 516   (# s, BA arr #) }
 517
 518 writeByteArray :: MutableByteArray# RealWorld -> Int# -> Word8 -> IO ()
 519
 520 #if __GLASGOW_HASKELL__ < 503
 521 writeByteArray arr i w8 = IO $ \s ->
 522   case word8ToWord w8 of { W# w# ->
 523   case writeCharArray# arr i (chr# (word2Int# w#)) s  of { s ->
 524   (# s , () #) }}
 525 #else
 526 writeByteArray arr i (W8# w) = IO $ \s ->
 527   case writeWord8Array# arr i w s of { s ->
 528   (# s, () #) }
 529 #endif
 530
 531 #if __GLASGOW_HASKELL__ < 503
 532 indexByteArray a# n# = fromIntegral (I# (ord# (indexCharArray# a# n#)))
 533 #else
 534 indexByteArray a# n# = W8# (indexWord8Array# a# n#)
 535 #endif
 536
 537 instance (Integral a, Binary a) => Binary (Ratio a) where
 538     put_ bh (a :% b) = do put_ bh a; put_ bh b
 539     get bh = do a <- get bh; b <- get bh; return (a :% b)
 540 #endif
 541
 542 instance Binary (Bin a) where
 543   put_ bh (BinPtr i) = put_ bh i
 544   get bh = do i <- get bh; return (BinPtr i)
 545
 546 -- -----------------------------------------------------------------------------
 547 -- Lazy reading/writing
 548
 549 lazyPut :: Binary a => BinHandle -> a -> IO ()
 550 lazyPut bh a = do
 551         -- output the obj with a ptr to skip over it:
 552     pre_a <- tellBin bh
 553     put_ bh pre_a       -- save a slot for the ptr
 554     put_ bh a           -- dump the object
 555     q <- tellBin bh     -- q = ptr to after object
 556     putAt bh pre_a q    -- fill in slot before a with ptr to q
 557     seekBin bh q        -- finally carry on writing at q
 558
 559 lazyGet :: Binary a => BinHandle -> IO a
 560 lazyGet bh = do
 561     p <- get bh         -- a BinPtr
 562     p_a <- tellBin bh
 563     a <- unsafeInterleaveIO (getAt bh p_a)
 564     seekBin bh p -- skip over the object for now
 565     return a
 566
 567 -- -----------------------------------------------------------------------------
 568 -- UserData
 569 -- -----------------------------------------------------------------------------
 570
 571 data UserData =
 572    UserData {
 573         -- for *deserialising* only:
 574         ud_dict   :: Dictionary,
 575         ud_symtab :: SymbolTable,
 576
 577         -- for *serialising* only:
 578         ud_dict_next :: !FastMutInt,    -- The next index to use
 579         ud_dict_map  :: !(IORef (UniqFM (Int,FastString))),
 580                                 -- indexed by FastString
 581
 582         ud_symtab_next :: !FastMutInt,  -- The next index to use
 583         ud_symtab_map  :: !(IORef (UniqFM (Int,Name)))
 584                                 -- indexed by Name
 585    }
 586
 587 newReadState :: Dictionary -> IO UserData
 588 newReadState dict = do
 589   dict_next <- newFastMutInt
 590   dict_map <- newIORef (undef "dict_map")
 591   symtab_next <- newFastMutInt
 592   symtab_map <- newIORef (undef "symtab_map")
 593   return UserData { ud_dict = dict,
 594                     ud_symtab = undef "symtab",
 595                     ud_dict_next = dict_next,
 596                     ud_dict_map = dict_map,
 597                     ud_symtab_next = symtab_next,
 598                     ud_symtab_map = symtab_map
 599                    }
 600
 601 newWriteState :: IO UserData
 602 newWriteState = do
 603   dict_next <- newFastMutInt
 604   writeFastMutInt dict_next 0
 605   dict_map <- newIORef emptyUFM
 606   symtab_next <- newFastMutInt
 607   writeFastMutInt symtab_next 0
 608   symtab_map <- newIORef emptyUFM
 609   return UserData { ud_dict = undef "dict",
 610                     ud_symtab = undef "symtab",
 611                     ud_dict_next = dict_next,
 612                     ud_dict_map = dict_map,
 613                     ud_symtab_next = symtab_next,
 614                     ud_symtab_map = symtab_map
 615                    }
 616
 617 noUserData = undef "UserData"
 618
 619 undef s = panic ("Binary.UserData: no " ++ s)
 620
 621 ---------------------------------------------------------
 622 --              The Dictionary
 623 ---------------------------------------------------------
 624
 625 type Dictionary = Array Int FastString  -- The dictionary
 626                                         -- Should be 0-indexed
 627
 628 putDictionary :: BinHandle -> Int -> UniqFM (Int,FastString) -> IO ()
 629 putDictionary bh sz dict = do
 630   put_ bh sz
 631   mapM_ (putFS bh) (elems (array (0,sz-1) (eltsUFM dict)))
 632
 633 getDictionary :: BinHandle -> IO Dictionary
 634 getDictionary bh = do
 635   sz <- get bh
 636   elems <- sequence (take sz (repeat (getFS bh)))
 637   return (listArray (0,sz-1) elems)
 638
 639 ---------------------------------------------------------
 640 --              The Symbol Table
 641 ---------------------------------------------------------
 642
 643 -- On disk, the symbol table is an array of IfaceExtName, when
 644 -- reading it in we turn it into a SymbolTable.
 645
 646 type SymbolTable = Array Int Name
 647
 648 ---------------------------------------------------------
 649 --              Reading and writing FastStrings
 650 ---------------------------------------------------------
 651
 652 putFS bh (FastString id l _ buf _) = do
 653   put_ bh l
 654   withForeignPtr buf $ \ptr ->
 655     let
 656         go n | n == l    = return ()
 657              | otherwise = do
 658                 b <- peekElemOff ptr n
 659                 putByte bh b
 660                 go (n+1)
 661    in
 662    go 0
 663
 664 {- -- possible faster version, not quite there yet:
 665 getFS bh@BinMem{} = do
 666   (I# l) <- get bh
 667   arr <- readIORef (arr_r bh)
 668   off <- readFastMutInt (off_r bh)
 669   return $! (mkFastSubStringBA# arr off l)
 670 -}
 671 getFS bh = do
 672   l <- get bh
 673   fp <- mallocForeignPtrBytes l
 674   withForeignPtr fp $ \ptr -> do
 675   let
 676         go n | n == l = mkFastStringForeignPtr ptr fp l
 677              | otherwise = do
 678                 b <- getByte bh
 679                 pokeElemOff ptr n b
 680                 go (n+1)
 681   --
 682   go 0
 683
 684 #if __GLASGOW_HASKELL__ < 600
 685 mallocForeignPtrBytes :: Int -> IO (ForeignPtr a)
 686 mallocForeignPtrBytes n = do
 687   r <- mallocBytes n
 688   newForeignPtr r (finalizerFree r)
 689
 690 foreign import ccall unsafe "stdlib.h free"
 691   finalizerFree :: Ptr a -> IO ()
 692 #endif
 693
 694 instance Binary PackageId where
 695   put_ bh pid = put_ bh (packageIdFS pid)
 696   get bh = do { fs <- get bh; return (fsToPackageId fs) }
 697
 698 instance Binary FastString where
 699   put_ bh f@(FastString id l _ fp _) =
 700     case getUserData bh of {
 701         UserData { ud_dict_next = j_r,
 702                    ud_dict_map = out_r,
 703                    ud_dict = dict} -> do
 704     out <- readIORef out_r
 705     let uniq = getUnique f
 706     case lookupUFM out uniq of
 707         Just (j,f)  -> put_ bh j
 708         Nothing -> do
 709            j <- readFastMutInt j_r
 710            put_ bh j
 711            writeFastMutInt j_r (j+1)
 712            writeIORef out_r $! addToUFM out uniq (j,f)
 713     }
 714
 715   get bh = do
 716         j <- get bh
 717         return $! (ud_dict (getUserData bh) ! j)