ghc/compiler/utils/Binary.hs

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