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