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