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