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