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