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