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 #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)