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