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 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 #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
 415 instance Binary a => Binary [a] where
 416     put_ bh l = do
 417         let len = length l
 418         if (len < 0xff)
 419           then putByte bh (fromIntegral len :: Word8)
 420           else do putByte bh 0xff; put_ bh (fromIntegral len :: Word32)
 421         mapM_ (put_ bh) l
 422     get bh = do
 423         b <- getByte bh
 424         len <- if b == 0xff
 425                   then get bh
 426                   else return (fromIntegral b :: Word32)
 427         let loop 0 = return []
 428             loop n = do a <- get bh; as <- loop (n-1); return (a:as)
 429         loop len
 430
 431 instance (Binary a, Binary b) => Binary (a,b) where
 432     put_ bh (a,b) = do put_ bh a; put_ bh b
 433     get bh        = do a <- get bh
 434                        b <- get bh
 435                        return (a,b)
 436
 437 instance (Binary a, Binary b, Binary c) => Binary (a,b,c) where
 438     put_ bh (a,b,c) = do put_ bh a; put_ bh b; put_ bh c
 439     get bh          = do a <- get bh
 440                          b <- get bh
 441                          c <- get bh
 442                          return (a,b,c)
 443
 444 instance (Binary a, Binary b, Binary c, Binary d) => Binary (a,b,c,d) where
 445     put_ bh (a,b,c,d) = do put_ bh a; put_ bh b; put_ bh c; put_ bh d
 446     get bh          = do a <- get bh
 447                          b <- get bh
 448                          c <- get bh
 449                          d <- get bh
 450                          return (a,b,c,d)
 451
 452 instance Binary a => Binary (Maybe a) where
 453     put_ bh Nothing  = putByte bh 0
 454     put_ bh (Just a) = do putByte bh 1; put_ bh a
 455     get bh           = do h <- getWord8 bh
 456                           case h of
 457                             0 -> return Nothing
 458                             _ -> do x <- get bh; return (Just x)
 459
 460 instance (Binary a, Binary b) => Binary (Either a b) where
 461     put_ bh (Left  a) = do putByte bh 0; put_ bh a
 462     put_ bh (Right b) = do putByte bh 1; put_ bh b
 463     get bh            = do h <- getWord8 bh
 464                            case h of
 465                              0 -> do a <- get bh ; return (Left a)
 466                              _ -> do b <- get bh ; return (Right b)
 467
 468 #if defined(__GLASGOW_HASKELL__) || 1
 469 --to quote binary-0.3 on this code idea,
 470 --
 471 -- TODO  This instance is not architecture portable.  GMP stores numbers as
 472 -- arrays of machine sized words, so the byte format is not portable across
 473 -- architectures with different endianess and word size.
 474 --
 475 -- This makes it hard (impossible) to make an equivalent instance
 476 -- with code that is compilable with non-GHC.  Do we need any instance
 477 -- Binary Integer, and if so, does it have to be blazing fast?  Or can
 478 -- we just change this instance to be portable like the rest of the
 479 -- instances? (binary package has code to steal for that)
 480 --
 481 -- yes, we need Binary Integer and Binary Rational in basicTypes/Literal.lhs
 482
 483 instance Binary Integer where
 484     -- XXX This is hideous
 485     put_ bh i = put_ bh (show i)
 486     get bh = do str <- get bh
 487                 case reads str of
 488                     [(i, "")] -> return i
 489                     _ -> fail ("Binary Integer: got " ++ show str)
 490
 491     {-
 492     put_ bh (S# i#) = do putByte bh 0; put_ bh (I# i#)
 493     put_ bh (J# s# a#) = do
 494         putByte bh 1
 495         put_ bh (I# s#)
 496         let sz# = sizeofByteArray# a#  -- in *bytes*
 497         put_ bh (I# sz#)  -- in *bytes*
 498         putByteArray bh a# sz#
 499
 500     get bh = do
 501         b <- getByte bh
 502         case b of
 503           0 -> do (I# i#) <- get bh
 504                   return (S# i#)
 505           _ -> do (I# s#) <- get bh
 506                   sz <- get bh
 507                   (BA a#) <- getByteArray bh sz
 508                   return (J# s# a#)
 509 -}
 510
 511 -- As for the rest of this code, even though this module
 512 -- exports it, it doesn't seem to be used anywhere else
 513 -- in GHC!
 514
 515 putByteArray :: BinHandle -> ByteArray# -> Int# -> IO ()
 516 putByteArray bh a s# = loop 0#
 517   where loop n#
 518            | n# ==# s# = return ()
 519            | otherwise = do
 520                 putByte bh (indexByteArray a n#)
 521                 loop (n# +# 1#)
 522
 523 getByteArray :: BinHandle -> Int -> IO ByteArray
 524 getByteArray bh (I# sz) = do
 525   (MBA arr) <- newByteArray sz
 526   let loop n
 527            | n ==# sz = return ()
 528            | otherwise = do
 529                 w <- getByte bh
 530                 writeByteArray arr n w
 531                 loop (n +# 1#)
 532   loop 0#
 533   freezeByteArray arr
 534
 535
 536 data ByteArray = BA ByteArray#
 537 data MBA = MBA (MutableByteArray# RealWorld)
 538
 539 newByteArray :: Int# -> IO MBA
 540 newByteArray sz = IO $ \s ->
 541   case newByteArray# sz s of { (# s, arr #) ->
 542   (# s, MBA arr #) }
 543
 544 freezeByteArray :: MutableByteArray# RealWorld -> IO ByteArray
 545 freezeByteArray arr = IO $ \s ->
 546   case unsafeFreezeByteArray# arr s of { (# s, arr #) ->
 547   (# s, BA arr #) }
 548
 549 writeByteArray :: MutableByteArray# RealWorld -> Int# -> Word8 -> IO ()
 550 writeByteArray arr i (W8# w) = IO $ \s ->
 551   case writeWord8Array# arr i w s of { s ->
 552   (# s, () #) }
 553
 554 indexByteArray :: ByteArray# -> Int# -> Word8
 555 indexByteArray a# n# = W8# (indexWord8Array# a# n#)
 556
 557 instance (Integral a, Binary a) => Binary (Ratio a) where
 558     put_ bh (a :% b) = do put_ bh a; put_ bh b
 559     get bh = do a <- get bh; b <- get bh; return (a :% b)
 560 #endif
 561
 562 instance Binary (Bin a) where
 563   put_ bh (BinPtr i) = put_ bh i
 564   get bh = do i <- get bh; return (BinPtr i)
 565
 566 -- -----------------------------------------------------------------------------
 567 -- Instances for Data.Typeable stuff
 568
 569 instance Binary TyCon where
 570     put_ bh ty_con = do
 571         let s = tyConString ty_con
 572         put_ bh s
 573     get bh = do
 574         s <- get bh
 575         return (mkTyCon s)
 576
 577 instance Binary TypeRep where
 578     put_ bh type_rep = do
 579         let (ty_con, child_type_reps) = splitTyConApp type_rep
 580         put_ bh ty_con
 581         put_ bh child_type_reps
 582     get bh = do
 583         ty_con <- get bh
 584         child_type_reps <- get bh
 585         return (mkTyConApp ty_con child_type_reps)
 586
 587 -- -----------------------------------------------------------------------------
 588 -- Lazy reading/writing
 589
 590 lazyPut :: Binary a => BinHandle -> a -> IO ()
 591 lazyPut bh a = do
 592     -- output the obj with a ptr to skip over it:
 593     pre_a <- tellBin bh
 594     put_ bh pre_a       -- save a slot for the ptr
 595     put_ bh a           -- dump the object
 596     q <- tellBin bh     -- q = ptr to after object
 597     putAt bh pre_a q    -- fill in slot before a with ptr to q
 598     seekBin bh q        -- finally carry on writing at q
 599
 600 lazyGet :: Binary a => BinHandle -> IO a
 601 lazyGet bh = do
 602     p <- get bh -- a BinPtr
 603     p_a <- tellBin bh
 604     a <- unsafeInterleaveIO (getAt bh p_a)
 605     seekBin bh p -- skip over the object for now
 606     return a
 607
 608 -- -----------------------------------------------------------------------------
 609 -- UserData
 610 -- -----------------------------------------------------------------------------
 611
 612 data UserData =
 613    UserData {
 614         -- for *deserialising* only:
 615         ud_dict   :: Dictionary,
 616         ud_symtab :: SymbolTable,
 617
 618         -- for *serialising* only:
 619         ud_put_name :: BinHandle -> Name       -> IO (),
 620         ud_put_fs   :: BinHandle -> FastString -> IO ()
 621    }
 622
 623 newReadState :: Dictionary -> IO UserData
 624 newReadState dict = do
 625   return UserData { ud_dict     = dict,
 626                     ud_symtab   = undef "symtab",
 627                     ud_put_name = undef "put_name",
 628                     ud_put_fs   = undef "put_fs"
 629                    }
 630
 631 newWriteState :: (BinHandle -> Name       -> IO ())
 632               -> (BinHandle -> FastString -> IO ())
 633               -> IO UserData
 634 newWriteState put_name put_fs = do
 635   return UserData { ud_dict     = undef "dict",
 636                     ud_symtab   = undef "symtab",
 637                     ud_put_name = put_name,
 638                     ud_put_fs   = put_fs
 639                    }
 640
 641 noUserData :: a
 642 noUserData = undef "UserData"
 643
 644 undef :: String -> a
 645 undef s = panic ("Binary.UserData: no " ++ s)
 646
 647 ---------------------------------------------------------
 648 -- The Dictionary
 649 ---------------------------------------------------------
 650
 651 type Dictionary = Array Int FastString -- The dictionary
 652                                        -- Should be 0-indexed
 653
 654 putDictionary :: BinHandle -> Int -> UniqFM (Int,FastString) -> IO ()
 655 putDictionary bh sz dict = do
 656   put_ bh sz
 657   mapM_ (putFS bh) (elems (array (0,sz-1) (eltsUFM dict)))
 658
 659 getDictionary :: BinHandle -> IO Dictionary
 660 getDictionary bh = do
 661   sz <- get bh
 662   elems <- sequence (take sz (repeat (getFS bh)))
 663   return (listArray (0,sz-1) elems)
 664
 665 ---------------------------------------------------------
 666 -- The Symbol Table
 667 ---------------------------------------------------------
 668
 669 -- On disk, the symbol table is an array of IfaceExtName, when
 670 -- reading it in we turn it into a SymbolTable.
 671
 672 type SymbolTable = Array Int Name
 673
 674 ---------------------------------------------------------
 675 -- Reading and writing FastStrings
 676 ---------------------------------------------------------
 677
 678 putFS :: BinHandle -> FastString -> IO ()
 679 putFS bh (FastString _ l _ buf _) = do
 680   put_ bh l
 681   withForeignPtr buf $ \ptr ->
 682     let
 683         go n | n == l    = return ()
 684              | otherwise = do
 685                 b <- peekElemOff ptr n
 686                 putByte bh b
 687                 go (n+1)
 688    in
 689    go 0
 690
 691 {- -- possible faster version, not quite there yet:
 692 getFS bh@BinMem{} = do
 693   (I# l) <- get bh
 694   arr <- readIORef (arr_r bh)
 695   off <- readFastMutInt (off_r bh)
 696   return $! (mkFastSubStringBA# arr off l)
 697 -}
 698 getFS :: BinHandle -> IO FastString
 699 getFS bh = do
 700   l <- get bh
 701   fp <- mallocForeignPtrBytes l
 702   withForeignPtr fp $ \ptr -> do
 703   let
 704         go n | n == l = mkFastStringForeignPtr ptr fp l
 705              | otherwise = do
 706                 b <- getByte bh
 707                 pokeElemOff ptr n b
 708                 go (n+1)
 709   --
 710   go 0
 711
 712 instance Binary FastString where
 713   put_ bh f =
 714     case getUserData bh of
 715         UserData { ud_put_fs = put_fs } -> put_fs bh f
 716
 717   get bh = do
 718         j <- get bh
 719         return $! (ud_dict (getUserData bh) ! j)
 720
 721 -- Here to avoid loop
 722
 723 instance Binary Fingerprint where
 724   put_ h (Fingerprint w1 w2) = do put_ h w1; put_ h w2
 725   get  h = do w1 <- get h; w2 <- get h; return (Fingerprint w1 w2)
 726
 727 instance Binary FunctionOrData where
 728     put_ bh IsFunction = putByte bh 0
 729     put_ bh IsData     = putByte bh 1
 730     get bh = do
 731         h <- getByte bh
 732         case h of
 733           0 -> return IsFunction
 734           1 -> return IsData
 735           _ -> panic "Binary FunctionOrData"
 736