compiler/utils/Binary.hs

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