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