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