ghc/compiler/utils/Binary.hs

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