compiler/utils/Binary.hs

   1 {-# OPTIONS -cpp #-}
   2 --
   3 -- (c) The University of Glasgow 2002-2006
   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
  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   hClose h
 206
 207 readBinMem :: FilePath -> IO BinHandle
 208 -- Return a BinHandle with a totally undefined State
 209 readBinMem filename = do
 210   h <- openBinaryFile filename ReadMode
 211   filesize' <- hFileSize h
 212   let filesize = fromIntegral filesize'
 213   arr <- newArray_ (0,filesize-1)
 214   count <- hGetArray h arr filesize
 215   when (count /= filesize)
 216         (error ("Binary.readBinMem: only read " ++ show count ++ " bytes"))
 217   hClose h
 218   arr_r <- newIORef arr
 219   ix_r <- newFastMutInt
 220   writeFastMutInt ix_r 0
 221   sz_r <- newFastMutInt
 222   writeFastMutInt sz_r filesize
 223   return (BinMem noUserData ix_r sz_r arr_r)
 224
 225 -- expand the size of the array to include a specified offset
 226 expandBin :: BinHandle -> Int -> IO ()
 227 expandBin (BinMem _ ix_r sz_r arr_r) off = do
 228    sz <- readFastMutInt sz_r
 229    let sz' = head (dropWhile (<= off) (iterate (* 2) sz))
 230    arr <- readIORef arr_r
 231    arr' <- newArray_ (0,sz'-1)
 232    sequence_ [ unsafeRead arr i >>= unsafeWrite arr' i
 233              | i <- [ 0 .. sz-1 ] ]
 234    writeFastMutInt sz_r sz'
 235    writeIORef arr_r arr'
 236 #ifdef DEBUG
 237    hPutStrLn stderr ("Binary: expanding to size: " ++ show sz')
 238 #endif
 239    return ()
 240 expandBin (BinIO _ _ _) _ = return ()
 241         -- no need to expand a file, we'll assume they expand by themselves.
 242
 243 -- -----------------------------------------------------------------------------
 244 -- Low-level reading/writing of bytes
 245
 246 putWord8 :: BinHandle -> Word8 -> IO ()
 247 putWord8 h@(BinMem _ ix_r sz_r arr_r) w = do
 248     ix <- readFastMutInt ix_r
 249     sz <- readFastMutInt sz_r
 250         -- double the size of the array if it overflows
 251     if (ix >= sz)
 252         then do expandBin h ix
 253                 putWord8 h w
 254         else do arr <- readIORef arr_r
 255                 unsafeWrite arr ix w
 256                 writeFastMutInt ix_r (ix+1)
 257                 return ()
 258 putWord8 (BinIO _ ix_r h) w = do
 259     ix <- readFastMutInt ix_r
 260     hPutChar h (chr (fromIntegral w))   -- XXX not really correct
 261     writeFastMutInt ix_r (ix+1)
 262     return ()
 263
 264 getWord8 :: BinHandle -> IO Word8
 265 getWord8 (BinMem _ ix_r sz_r arr_r) = do
 266     ix <- readFastMutInt ix_r
 267     sz <- readFastMutInt sz_r
 268     when (ix >= sz)  $
 269         ioError (mkIOError eofErrorType "Data.Binary.getWord8" Nothing Nothing)
 270     arr <- readIORef arr_r
 271     w <- unsafeRead arr ix
 272     writeFastMutInt ix_r (ix+1)
 273     return w
 274 getWord8 (BinIO _ ix_r h) = do
 275     ix <- readFastMutInt ix_r
 276     c <- hGetChar h
 277     writeFastMutInt ix_r (ix+1)
 278     return $! (fromIntegral (ord c))    -- XXX not really correct
 279
 280 putByte :: BinHandle -> Word8 -> IO ()
 281 putByte bh w = put_ bh w
 282
 283 getByte :: BinHandle -> IO Word8
 284 getByte = getWord8
 285
 286 -- -----------------------------------------------------------------------------
 287 -- Primitve Word writes
 288
 289 instance Binary Word8 where
 290   put_ = putWord8
 291   get  = getWord8
 292
 293 instance Binary Word16 where
 294   put_ h w = do -- XXX too slow.. inline putWord8?
 295     putByte h (fromIntegral (w `shiftR` 8))
 296     putByte h (fromIntegral (w .&. 0xff))
 297   get h = do
 298     w1 <- getWord8 h
 299     w2 <- getWord8 h
 300     return $! ((fromIntegral w1 `shiftL` 8) .|. fromIntegral w2)
 301
 302
 303 instance Binary Word32 where
 304   put_ h w = do
 305     putByte h (fromIntegral (w `shiftR` 24))
 306     putByte h (fromIntegral ((w `shiftR` 16) .&. 0xff))
 307     putByte h (fromIntegral ((w `shiftR` 8)  .&. 0xff))
 308     putByte h (fromIntegral (w .&. 0xff))
 309   get h = do
 310     w1 <- getWord8 h
 311     w2 <- getWord8 h
 312     w3 <- getWord8 h
 313     w4 <- getWord8 h
 314     return $! ((fromIntegral w1 `shiftL` 24) .|.
 315                (fromIntegral w2 `shiftL` 16) .|.
 316                (fromIntegral w3 `shiftL`  8) .|.
 317                (fromIntegral w4))
 318
 319
 320 instance Binary Word64 where
 321   put_ h w = do
 322     putByte h (fromIntegral (w `shiftR` 56))
 323     putByte h (fromIntegral ((w `shiftR` 48) .&. 0xff))
 324     putByte h (fromIntegral ((w `shiftR` 40) .&. 0xff))
 325     putByte h (fromIntegral ((w `shiftR` 32) .&. 0xff))
 326     putByte h (fromIntegral ((w `shiftR` 24) .&. 0xff))
 327     putByte h (fromIntegral ((w `shiftR` 16) .&. 0xff))
 328     putByte h (fromIntegral ((w `shiftR`  8) .&. 0xff))
 329     putByte h (fromIntegral (w .&. 0xff))
 330   get h = do
 331     w1 <- getWord8 h
 332     w2 <- getWord8 h
 333     w3 <- getWord8 h
 334     w4 <- getWord8 h
 335     w5 <- getWord8 h
 336     w6 <- getWord8 h
 337     w7 <- getWord8 h
 338     w8 <- getWord8 h
 339     return $! ((fromIntegral w1 `shiftL` 56) .|.
 340                (fromIntegral w2 `shiftL` 48) .|.
 341                (fromIntegral w3 `shiftL` 40) .|.
 342                (fromIntegral w4 `shiftL` 32) .|.
 343                (fromIntegral w5 `shiftL` 24) .|.
 344                (fromIntegral w6 `shiftL` 16) .|.
 345                (fromIntegral w7 `shiftL`  8) .|.
 346                (fromIntegral w8))
 347
 348 -- -----------------------------------------------------------------------------
 349 -- Primitve Int writes
 350
 351 instance Binary Int8 where
 352   put_ h w = put_ h (fromIntegral w :: Word8)
 353   get h    = do w <- get h; return $! (fromIntegral (w::Word8))
 354
 355 instance Binary Int16 where
 356   put_ h w = put_ h (fromIntegral w :: Word16)
 357   get h    = do w <- get h; return $! (fromIntegral (w::Word16))
 358
 359 instance Binary Int32 where
 360   put_ h w = put_ h (fromIntegral w :: Word32)
 361   get h    = do w <- get h; return $! (fromIntegral (w::Word32))
 362
 363 instance Binary Int64 where
 364   put_ h w = put_ h (fromIntegral w :: Word64)
 365   get h    = do w <- get h; return $! (fromIntegral (w::Word64))
 366
 367 -- -----------------------------------------------------------------------------
 368 -- Instances for standard types
 369
 370 instance Binary () where
 371     put_ bh () = return ()
 372     get  _     = return ()
 373 --    getF bh p  = case getBitsF bh 0 p of (_,b) -> ((),b)
 374
 375 instance Binary Bool where
 376     put_ bh b = putByte bh (fromIntegral (fromEnum b))
 377     get  bh   = do x <- getWord8 bh; return $! (toEnum (fromIntegral x))
 378 --    getF bh p = case getBitsF bh 1 p of (x,b) -> (toEnum x,b)
 379
 380 instance Binary Char where
 381     put_  bh c = put_ bh (fromIntegral (ord c) :: Word32)
 382     get  bh   = do x <- get bh; return $! (chr (fromIntegral (x :: Word32)))
 383 --    getF bh p = case getBitsF bh 8 p of (x,b) -> (toEnum x,b)
 384
 385 instance Binary Int where
 386 #if SIZEOF_HSINT == 4
 387     put_ bh i = put_ bh (fromIntegral i :: Int32)
 388     get  bh = do
 389         x <- get bh
 390         return $! (fromIntegral (x :: Int32))
 391 #elif SIZEOF_HSINT == 8
 392     put_ bh i = put_ bh (fromIntegral i :: Int64)
 393     get  bh = do
 394         x <- get bh
 395         return $! (fromIntegral (x :: Int64))
 396 #else
 397 #error "unsupported sizeof(HsInt)"
 398 #endif
 399 --    getF bh   = getBitsF bh 32
 400
 401 instance Binary a => Binary [a] where
 402     put_ bh l = do
 403         let len = length l
 404         if (len < 0xff)
 405           then putByte bh (fromIntegral len :: Word8)
 406           else do putByte bh 0xff; put_ bh (fromIntegral len :: Word32)
 407         mapM_ (put_ bh) l
 408     get bh = do
 409         b <- getByte bh
 410         len <- if b == 0xff
 411                   then get bh
 412                   else return (fromIntegral b :: Word32)
 413         let loop 0 = return []
 414             loop n = do a <- get bh; as <- loop (n-1); return (a:as)
 415         loop len
 416
 417 instance (Binary a, Binary b) => Binary (a,b) where
 418     put_ bh (a,b) = do put_ bh a; put_ bh b
 419     get bh        = do a <- get bh
 420                        b <- get bh
 421                        return (a,b)
 422
 423 instance (Binary a, Binary b, Binary c) => Binary (a,b,c) where
 424     put_ bh (a,b,c) = do put_ bh a; put_ bh b; put_ bh c
 425     get bh          = do a <- get bh
 426                          b <- get bh
 427                          c <- get bh
 428                          return (a,b,c)
 429
 430 instance (Binary a, Binary b, Binary c, Binary d) => Binary (a,b,c,d) where
 431     put_ bh (a,b,c,d) = do put_ bh a; put_ bh b; put_ bh c; put_ bh d
 432     get bh          = do a <- get bh
 433                          b <- get bh
 434                          c <- get bh
 435                          d <- get bh
 436                          return (a,b,c,d)
 437
 438 instance Binary a => Binary (Maybe a) where
 439     put_ bh Nothing  = putByte bh 0
 440     put_ bh (Just a) = do putByte bh 1; put_ bh a
 441     get bh           = do h <- getWord8 bh
 442                           case h of
 443                             0 -> return Nothing
 444                             _ -> do x <- get bh; return (Just x)
 445
 446 instance (Binary a, Binary b) => Binary (Either a b) where
 447     put_ bh (Left  a) = do putByte bh 0; put_ bh a
 448     put_ bh (Right b) = do putByte bh 1; put_ bh b
 449     get bh            = do h <- getWord8 bh
 450                            case h of
 451                              0 -> do a <- get bh ; return (Left a)
 452                              _ -> do b <- get bh ; return (Right b)
 453
 454 #ifdef __GLASGOW_HASKELL__
 455 instance Binary Integer where
 456     put_ bh (S# i#) = do putByte bh 0; put_ bh (I# i#)
 457     put_ bh (J# s# a#) = do
 458         p <- putByte bh 1;
 459         put_ bh (I# s#)
 460         let sz# = sizeofByteArray# a#  -- in *bytes*
 461         put_ bh (I# sz#)  -- in *bytes*
 462         putByteArray bh a# sz#
 463
 464     get bh = do
 465         b <- getByte bh
 466         case b of
 467           0 -> do (I# i#) <- get bh
 468                   return (S# i#)
 469           _ -> do (I# s#) <- get bh
 470                   sz <- get bh
 471                   (BA a#) <- getByteArray bh sz
 472                   return (J# s# a#)
 473
 474 putByteArray :: BinHandle -> ByteArray# -> Int# -> IO ()
 475 putByteArray bh a s# = loop 0#
 476   where loop n#
 477            | n# ==# s# = return ()
 478            | otherwise = do
 479                 putByte bh (indexByteArray a n#)
 480                 loop (n# +# 1#)
 481
 482 getByteArray :: BinHandle -> Int -> IO ByteArray
 483 getByteArray bh (I# sz) = do
 484   (MBA arr) <- newByteArray sz
 485   let loop n
 486            | n ==# sz = return ()
 487            | otherwise = do
 488                 w <- getByte bh
 489                 writeByteArray arr n w
 490                 loop (n +# 1#)
 491   loop 0#
 492   freezeByteArray arr
 493
 494
 495 data ByteArray = BA ByteArray#
 496 data MBA = MBA (MutableByteArray# RealWorld)
 497
 498 newByteArray :: Int# -> IO MBA
 499 newByteArray sz = IO $ \s ->
 500   case newByteArray# sz s of { (# s, arr #) ->
 501   (# s, MBA arr #) }
 502
 503 freezeByteArray :: MutableByteArray# RealWorld -> IO ByteArray
 504 freezeByteArray arr = IO $ \s ->
 505   case unsafeFreezeByteArray# arr s of { (# s, arr #) ->
 506   (# s, BA arr #) }
 507
 508 writeByteArray :: MutableByteArray# RealWorld -> Int# -> Word8 -> IO ()
 509 writeByteArray arr i (W8# w) = IO $ \s ->
 510   case writeWord8Array# arr i w s of { s ->
 511   (# s, () #) }
 512
 513 indexByteArray :: ByteArray# -> Int# -> Word8
 514 indexByteArray a# n# = W8# (indexWord8Array# a# n#)
 515
 516 instance (Integral a, Binary a) => Binary (Ratio a) where
 517     put_ bh (a :% b) = do put_ bh a; put_ bh b
 518     get bh = do a <- get bh; b <- get bh; return (a :% b)
 519 #endif
 520
 521 instance Binary (Bin a) where
 522   put_ bh (BinPtr i) = put_ bh i
 523   get bh = do i <- get bh; return (BinPtr i)
 524
 525 -- -----------------------------------------------------------------------------
 526 -- Lazy reading/writing
 527
 528 lazyPut :: Binary a => BinHandle -> a -> IO ()
 529 lazyPut bh a = do
 530         -- output the obj with a ptr to skip over it:
 531     pre_a <- tellBin bh
 532     put_ bh pre_a       -- save a slot for the ptr
 533     put_ bh a           -- dump the object
 534     q <- tellBin bh     -- q = ptr to after object
 535     putAt bh pre_a q    -- fill in slot before a with ptr to q
 536     seekBin bh q        -- finally carry on writing at q
 537
 538 lazyGet :: Binary a => BinHandle -> IO a
 539 lazyGet bh = do
 540     p <- get bh         -- a BinPtr
 541     p_a <- tellBin bh
 542     a <- unsafeInterleaveIO (getAt bh p_a)
 543     seekBin bh p -- skip over the object for now
 544     return a
 545
 546 -- -----------------------------------------------------------------------------
 547 -- UserData
 548 -- -----------------------------------------------------------------------------
 549
 550 data UserData =
 551    UserData {
 552         -- for *deserialising* only:
 553         ud_dict   :: Dictionary,
 554         ud_symtab :: SymbolTable,
 555
 556         -- for *serialising* only:
 557         ud_dict_next :: !FastMutInt,    -- The next index to use
 558         ud_dict_map  :: !(IORef (UniqFM (Int,FastString))),
 559                                 -- indexed by FastString
 560
 561         ud_symtab_next :: !FastMutInt,  -- The next index to use
 562         ud_symtab_map  :: !(IORef (UniqFM (Int,Name)))
 563                                 -- indexed by Name
 564    }
 565
 566 newReadState :: Dictionary -> IO UserData
 567 newReadState dict = do
 568   dict_next <- newFastMutInt
 569   dict_map <- newIORef (undef "dict_map")
 570   symtab_next <- newFastMutInt
 571   symtab_map <- newIORef (undef "symtab_map")
 572   return UserData { ud_dict = dict,
 573                     ud_symtab = undef "symtab",
 574                     ud_dict_next = dict_next,
 575                     ud_dict_map = dict_map,
 576                     ud_symtab_next = symtab_next,
 577                     ud_symtab_map = symtab_map
 578                    }
 579
 580 newWriteState :: IO UserData
 581 newWriteState = do
 582   dict_next <- newFastMutInt
 583   writeFastMutInt dict_next 0
 584   dict_map <- newIORef emptyUFM
 585   symtab_next <- newFastMutInt
 586   writeFastMutInt symtab_next 0
 587   symtab_map <- newIORef emptyUFM
 588   return UserData { ud_dict = undef "dict",
 589                     ud_symtab = undef "symtab",
 590                     ud_dict_next = dict_next,
 591                     ud_dict_map = dict_map,
 592                     ud_symtab_next = symtab_next,
 593                     ud_symtab_map = symtab_map
 594                    }
 595
 596 noUserData = undef "UserData"
 597
 598 undef s = panic ("Binary.UserData: no " ++ s)
 599
 600 ---------------------------------------------------------
 601 --              The Dictionary
 602 ---------------------------------------------------------
 603
 604 type Dictionary = Array Int FastString  -- The dictionary
 605                                         -- Should be 0-indexed
 606
 607 putDictionary :: BinHandle -> Int -> UniqFM (Int,FastString) -> IO ()
 608 putDictionary bh sz dict = do
 609   put_ bh sz
 610   mapM_ (putFS bh) (elems (array (0,sz-1) (eltsUFM dict)))
 611
 612 getDictionary :: BinHandle -> IO Dictionary
 613 getDictionary bh = do
 614   sz <- get bh
 615   elems <- sequence (take sz (repeat (getFS bh)))
 616   return (listArray (0,sz-1) elems)
 617
 618 ---------------------------------------------------------
 619 --              The Symbol Table
 620 ---------------------------------------------------------
 621
 622 -- On disk, the symbol table is an array of IfaceExtName, when
 623 -- reading it in we turn it into a SymbolTable.
 624
 625 type SymbolTable = Array Int Name
 626
 627 ---------------------------------------------------------
 628 --              Reading and writing FastStrings
 629 ---------------------------------------------------------
 630
 631 putFS bh (FastString id l _ buf _) = do
 632   put_ bh l
 633   withForeignPtr buf $ \ptr ->
 634     let
 635         go n | n == l    = return ()
 636              | otherwise = do
 637                 b <- peekElemOff ptr n
 638                 putByte bh b
 639                 go (n+1)
 640    in
 641    go 0
 642
 643 {- -- possible faster version, not quite there yet:
 644 getFS bh@BinMem{} = do
 645   (I# l) <- get bh
 646   arr <- readIORef (arr_r bh)
 647   off <- readFastMutInt (off_r bh)
 648   return $! (mkFastSubStringBA# arr off l)
 649 -}
 650 getFS bh = do
 651   l <- get bh
 652   fp <- mallocForeignPtrBytes l
 653   withForeignPtr fp $ \ptr -> do
 654   let
 655         go n | n == l = mkFastStringForeignPtr ptr fp l
 656              | otherwise = do
 657                 b <- getByte bh
 658                 pokeElemOff ptr n b
 659                 go (n+1)
 660   --
 661   go 0
 662
 663 instance Binary PackageId where
 664   put_ bh pid = put_ bh (packageIdFS pid)
 665   get bh = do { fs <- get bh; return (fsToPackageId fs) }
 666
 667 instance Binary FastString where
 668   put_ bh f@(FastString id l _ fp _) =
 669     case getUserData bh of {
 670         UserData { ud_dict_next = j_r,
 671                    ud_dict_map = out_r,
 672                    ud_dict = dict} -> do
 673     out <- readIORef out_r
 674     let uniq = getUnique f
 675     case lookupUFM out uniq of
 676         Just (j,f)  -> put_ bh j
 677         Nothing -> do
 678            j <- readFastMutInt j_r
 679            put_ bh j
 680            writeFastMutInt j_r (j+1)
 681            writeIORef out_r $! addToUFM out uniq (j,f)
 682     }
 683
 684   get bh = do
 685         j <- get bh
 686         return $! (ud_dict (getUserData bh) ! j)