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