compiler/utils/Binary.hs

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