compiler/utils/Binary.hs

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