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    hPutStrLn stderr ("expanding to size: " ++ show sz')
 267    return ()
 268 expandBin (BinIO _ _ _) _ = return ()
 269         -- no need to expand a file, we'll assume they expand by themselves.
 270
 271 -- -----------------------------------------------------------------------------
 272 -- Low-level reading/writing of bytes
 273
 274 putWord8 :: BinHandle -> Word8 -> IO ()
 275 putWord8 h@(BinMem _ ix_r sz_r arr_r) w = do
 276     ix <- readFastMutInt ix_r
 277     sz <- readFastMutInt sz_r
 278         -- double the size of the array if it overflows
 279     if (ix >= sz)
 280         then do expandBin h ix
 281                 putWord8 h w
 282         else do arr <- readIORef arr_r
 283                 unsafeWrite arr ix w
 284                 writeFastMutInt ix_r (ix+1)
 285                 return ()
 286 putWord8 (BinIO _ ix_r h) w = do
 287     ix <- readFastMutInt ix_r
 288     hPutChar h (chr (fromIntegral w))   -- XXX not really correct
 289     writeFastMutInt ix_r (ix+1)
 290     return ()
 291
 292 getWord8 :: BinHandle -> IO Word8
 293 getWord8 (BinMem _ ix_r sz_r arr_r) = do
 294     ix <- readFastMutInt ix_r
 295     sz <- readFastMutInt sz_r
 296     when (ix >= sz)  $
 297         throw (mkIOError eofErrorType "Data.Binary.getWord8" Nothing Nothing)
 298     arr <- readIORef arr_r
 299     w <- unsafeRead arr ix
 300     writeFastMutInt ix_r (ix+1)
 301     return w
 302 getWord8 (BinIO _ ix_r h) = do
 303     ix <- readFastMutInt ix_r
 304     c <- hGetChar h
 305     writeFastMutInt ix_r (ix+1)
 306     return $! (fromIntegral (ord c))    -- XXX not really correct
 307
 308 putByte :: BinHandle -> Word8 -> IO ()
 309 putByte bh w = put_ bh w
 310
 311 getByte :: BinHandle -> IO Word8
 312 getByte = getWord8
 313
 314 -- -----------------------------------------------------------------------------
 315 -- Primitve Word writes
 316
 317 instance Binary Word8 where
 318   put_ = putWord8
 319   get  = getWord8
 320
 321 instance Binary Word16 where
 322   put_ h w = do -- XXX too slow.. inline putWord8?
 323     putByte h (fromIntegral (w `shiftR` 8))
 324     putByte h (fromIntegral (w .&. 0xff))
 325   get h = do
 326     w1 <- getWord8 h
 327     w2 <- getWord8 h
 328     return $! ((fromIntegral w1 `shiftL` 8) .|. fromIntegral w2)
 329
 330
 331 instance Binary Word32 where
 332   put_ h w = do
 333     putByte h (fromIntegral (w `shiftR` 24))
 334     putByte h (fromIntegral ((w `shiftR` 16) .&. 0xff))
 335     putByte h (fromIntegral ((w `shiftR` 8)  .&. 0xff))
 336     putByte h (fromIntegral (w .&. 0xff))
 337   get h = do
 338     w1 <- getWord8 h
 339     w2 <- getWord8 h
 340     w3 <- getWord8 h
 341     w4 <- getWord8 h
 342     return $! ((fromIntegral w1 `shiftL` 24) .|.
 343                (fromIntegral w2 `shiftL` 16) .|.
 344                (fromIntegral w3 `shiftL`  8) .|.
 345                (fromIntegral w4))
 346
 347
 348 instance Binary Word64 where
 349   put_ h w = do
 350     putByte h (fromIntegral (w `shiftR` 56))
 351     putByte h (fromIntegral ((w `shiftR` 48) .&. 0xff))
 352     putByte h (fromIntegral ((w `shiftR` 40) .&. 0xff))
 353     putByte h (fromIntegral ((w `shiftR` 32) .&. 0xff))
 354     putByte h (fromIntegral ((w `shiftR` 24) .&. 0xff))
 355     putByte h (fromIntegral ((w `shiftR` 16) .&. 0xff))
 356     putByte h (fromIntegral ((w `shiftR`  8) .&. 0xff))
 357     putByte h (fromIntegral (w .&. 0xff))
 358   get h = do
 359     w1 <- getWord8 h
 360     w2 <- getWord8 h
 361     w3 <- getWord8 h
 362     w4 <- getWord8 h
 363     w5 <- getWord8 h
 364     w6 <- getWord8 h
 365     w7 <- getWord8 h
 366     w8 <- getWord8 h
 367     return $! ((fromIntegral w1 `shiftL` 56) .|.
 368                (fromIntegral w2 `shiftL` 48) .|.
 369                (fromIntegral w3 `shiftL` 40) .|.
 370                (fromIntegral w4 `shiftL` 32) .|.
 371                (fromIntegral w5 `shiftL` 24) .|.
 372                (fromIntegral w6 `shiftL` 16) .|.
 373                (fromIntegral w7 `shiftL`  8) .|.
 374                (fromIntegral w8))
 375
 376 -- -----------------------------------------------------------------------------
 377 -- Primitve Int writes
 378
 379 instance Binary Int8 where
 380   put_ h w = put_ h (fromIntegral w :: Word8)
 381   get h    = do w <- get h; return $! (fromIntegral (w::Word8))
 382
 383 instance Binary Int16 where
 384   put_ h w = put_ h (fromIntegral w :: Word16)
 385   get h    = do w <- get h; return $! (fromIntegral (w::Word16))
 386
 387 instance Binary Int32 where
 388   put_ h w = put_ h (fromIntegral w :: Word32)
 389   get h    = do w <- get h; return $! (fromIntegral (w::Word32))
 390
 391 instance Binary Int64 where
 392   put_ h w = put_ h (fromIntegral w :: Word64)
 393   get h    = do w <- get h; return $! (fromIntegral (w::Word64))
 394
 395 -- -----------------------------------------------------------------------------
 396 -- Instances for standard types
 397
 398 instance Binary () where
 399     put_ bh () = return ()
 400     get  _     = return ()
 401 --    getF bh p  = case getBitsF bh 0 p of (_,b) -> ((),b)
 402
 403 instance Binary Bool where
 404     put_ bh b = putByte bh (fromIntegral (fromEnum b))
 405     get  bh   = do x <- getWord8 bh; return $! (toEnum (fromIntegral x))
 406 --    getF bh p = case getBitsF bh 1 p of (x,b) -> (toEnum x,b)
 407
 408 instance Binary Char where
 409     put_  bh c = put_ bh (fromIntegral (ord c) :: Word32)
 410     get  bh   = do x <- get bh; return $! (chr (fromIntegral (x :: Word32)))
 411 --    getF bh p = case getBitsF bh 8 p of (x,b) -> (toEnum x,b)
 412
 413 instance Binary Int where
 414 #if SIZEOF_HSINT == 4
 415     put_ bh i = put_ bh (fromIntegral i :: Int32)
 416     get  bh = do
 417         x <- get bh
 418         return $! (fromIntegral (x :: Int32))
 419 #elif SIZEOF_HSINT == 8
 420     put_ bh i = put_ bh (fromIntegral i :: Int64)
 421     get  bh = do
 422         x <- get bh
 423         return $! (fromIntegral (x :: Int64))
 424 #else
 425 #error "unsupported sizeof(HsInt)"
 426 #endif
 427 --    getF bh   = getBitsF bh 32
 428
 429 instance Binary a => Binary [a] where
 430     put_ bh []     = putByte bh 0
 431     put_ bh (x:xs) = do putByte bh 1; put_ bh x; put_ bh xs
 432     get bh         = do h <- getWord8 bh
 433                         case h of
 434                           0 -> return []
 435                           _ -> do x  <- get bh
 436                                   xs <- get bh
 437                                   return (x:xs)
 438
 439 instance (Binary a, Binary b) => Binary (a,b) where
 440     put_ bh (a,b) = do put_ bh a; put_ bh b
 441     get bh        = do a <- get bh
 442                        b <- get bh
 443                        return (a,b)
 444
 445 instance (Binary a, Binary b, Binary c) => Binary (a,b,c) where
 446     put_ bh (a,b,c) = do put_ bh a; put_ bh b; put_ bh c
 447     get bh          = do a <- get bh
 448                          b <- get bh
 449                          c <- get bh
 450                          return (a,b,c)
 451
 452 instance (Binary a, Binary b, Binary c, Binary d) => Binary (a,b,c,d) where
 453     put_ bh (a,b,c,d) = do put_ bh a; put_ bh b; put_ bh c; put_ bh d
 454     get bh          = do a <- get bh
 455                          b <- get bh
 456                          c <- get bh
 457                          d <- get bh
 458                          return (a,b,c,d)
 459
 460 instance Binary a => Binary (Maybe a) where
 461     put_ bh Nothing  = putByte bh 0
 462     put_ bh (Just a) = do putByte bh 1; put_ bh a
 463     get bh           = do h <- getWord8 bh
 464                           case h of
 465                             0 -> return Nothing
 466                             _ -> do x <- get bh; return (Just x)
 467
 468 instance (Binary a, Binary b) => Binary (Either a b) where
 469     put_ bh (Left  a) = do putByte bh 0; put_ bh a
 470     put_ bh (Right b) = do putByte bh 1; put_ bh b
 471     get bh            = do h <- getWord8 bh
 472                            case h of
 473                              0 -> do a <- get bh ; return (Left a)
 474                              _ -> do b <- get bh ; return (Right b)
 475
 476 #ifdef __GLASGOW_HASKELL__
 477 instance Binary Integer where
 478     put_ bh (S# i#) = do putByte bh 0; put_ bh (I# i#)
 479     put_ bh (J# s# a#) = do
 480         p <- putByte bh 1;
 481         put_ bh (I# s#)
 482         let sz# = sizeofByteArray# a#  -- in *bytes*
 483         put_ bh (I# sz#)  -- in *bytes*
 484         putByteArray bh a# sz#
 485
 486     get bh = do
 487         b <- getByte bh
 488         case b of
 489           0 -> do (I# i#) <- get bh
 490                   return (S# i#)
 491           _ -> do (I# s#) <- get bh
 492                   sz <- get bh
 493                   (BA a#) <- getByteArray bh sz
 494                   return (J# s# a#)
 495
 496 putByteArray :: BinHandle -> ByteArray# -> Int# -> IO ()
 497 putByteArray bh a s# = loop 0#
 498   where loop n#
 499            | n# ==# s# = return ()
 500            | otherwise = do
 501                 putByte bh (indexByteArray a n#)
 502                 loop (n# +# 1#)
 503
 504 getByteArray :: BinHandle -> Int -> IO ByteArray
 505 getByteArray bh (I# sz) = do
 506   (MBA arr) <- newByteArray sz
 507   let loop n
 508            | n ==# sz = return ()
 509            | otherwise = do
 510                 w <- getByte bh
 511                 writeByteArray arr n w
 512                 loop (n +# 1#)
 513   loop 0#
 514   freezeByteArray arr
 515
 516
 517 data ByteArray = BA ByteArray#
 518 data MBA = MBA (MutableByteArray# RealWorld)
 519
 520 newByteArray :: Int# -> IO MBA
 521 newByteArray sz = IO $ \s ->
 522   case newByteArray# sz s of { (# s, arr #) ->
 523   (# s, MBA arr #) }
 524
 525 freezeByteArray :: MutableByteArray# RealWorld -> IO ByteArray
 526 freezeByteArray arr = IO $ \s ->
 527   case unsafeFreezeByteArray# arr s of { (# s, arr #) ->
 528   (# s, BA arr #) }
 529
 530 writeByteArray :: MutableByteArray# RealWorld -> Int# -> Word8 -> IO ()
 531
 532 #if __GLASGOW_HASKELL__ < 503
 533 writeByteArray arr i w8 = IO $ \s ->
 534   case word8ToWord w8 of { W# w# ->
 535   case writeCharArray# arr i (chr# (word2Int# w#)) s  of { s ->
 536   (# s , () #) }}
 537 #else
 538 writeByteArray arr i (W8# w) = IO $ \s ->
 539   case writeWord8Array# arr i w s of { s ->
 540   (# s, () #) }
 541 #endif
 542
 543 #if __GLASGOW_HASKELL__ < 503
 544 indexByteArray a# n# = fromIntegral (I# (ord# (indexCharArray# a# n#)))
 545 #else
 546 indexByteArray a# n# = W8# (indexWord8Array# a# n#)
 547 #endif
 548
 549 instance (Integral a, Binary a) => Binary (Ratio a) where
 550     put_ bh (a :% b) = do put_ bh a; put_ bh b
 551     get bh = do a <- get bh; b <- get bh; return (a :% b)
 552 #endif
 553
 554 instance Binary (Bin a) where
 555   put_ bh (BinPtr i) = put_ bh i
 556   get bh = do i <- get bh; return (BinPtr i)
 557
 558 -- -----------------------------------------------------------------------------
 559 -- Lazy reading/writing
 560
 561 lazyPut :: Binary a => BinHandle -> a -> IO ()
 562 lazyPut bh a = do
 563         -- output the obj with a ptr to skip over it:
 564     pre_a <- tellBin bh
 565     put_ bh pre_a       -- save a slot for the ptr
 566     put_ bh a           -- dump the object
 567     q <- tellBin bh     -- q = ptr to after object
 568     putAt bh pre_a q    -- fill in slot before a with ptr to q
 569     seekBin bh q        -- finally carry on writing at q
 570
 571 lazyGet :: Binary a => BinHandle -> IO a
 572 lazyGet bh = do
 573     p <- get bh         -- a BinPtr
 574     p_a <- tellBin bh
 575     a <- unsafeInterleaveIO (getAt bh p_a)
 576     seekBin bh p -- skip over the object for now
 577     return a
 578
 579 -- -----------------------------------------------------------------------------
 580 -- BinHandleState
 581
 582 type BinHandleState =
 583         (Module,
 584          IORef Int,
 585          IORef (UniqFM (Int,FastString)),
 586          Array Int FastString)
 587
 588 initReadState :: BinHandleState
 589 initReadState = (undef, undef, undef, undef)
 590
 591 newWriteState :: Module -> IO BinHandleState
 592 newWriteState m = do
 593   j_r <- newIORef 0
 594   out_r <- newIORef emptyUFM
 595   return (m,j_r,out_r,undef)
 596
 597 undef = error "Binary.BinHandleState"
 598
 599 -- -----------------------------------------------------------------------------
 600 -- FastString binary interface
 601
 602 getBinFileWithDict :: Binary a => FilePath -> IO a
 603 getBinFileWithDict file_path = do
 604   bh <- Binary.readBinMem file_path
 605   magic <- get bh
 606   when (magic /= binaryInterfaceMagic) $
 607         throwDyn (ProgramError (
 608            "magic number mismatch: old/corrupt interface file?"))
 609   dict_p <- Binary.get bh               -- get the dictionary ptr
 610   data_p <- tellBin bh
 611   seekBin bh dict_p
 612   dict <- getDictionary bh
 613   seekBin bh data_p
 614   let (mod, j_r, out_r, _) = state bh
 615   get bh{ state = (mod,j_r,out_r,dict) }
 616
 617 initBinMemSize = (1024*1024) :: Int
 618
 619 binaryInterfaceMagic = 0x1face :: Word32
 620
 621 putBinFileWithDict :: Binary a => FilePath -> Module -> a -> IO ()
 622 putBinFileWithDict file_path mod a = do
 623   bh <- openBinMem initBinMemSize mod
 624   put_ bh binaryInterfaceMagic
 625   p <- tellBin bh
 626   put_ bh p             -- placeholder for ptr to dictionary
 627   put_ bh a
 628   let (_, j_r, fm_r, _) = state bh
 629   j <- readIORef j_r
 630   fm <- readIORef fm_r
 631   dict_p <- tellBin bh
 632   putAt bh p dict_p     -- fill in the placeholder
 633   seekBin bh dict_p     -- seek back to the end of the file
 634   putDictionary bh j (constructDictionary j fm)
 635   writeBinMem bh file_path
 636
 637 type Dictionary = Array Int FastString
 638         -- should be 0-indexed
 639
 640 putDictionary :: BinHandle -> Int -> Dictionary -> IO ()
 641 putDictionary bh sz dict = do
 642   put_ bh sz
 643   mapM_ (putFS bh) (elems dict)
 644
 645 getDictionary :: BinHandle -> IO Dictionary
 646 getDictionary bh = do
 647   sz <- get bh
 648   elems <- sequence (take sz (repeat (getFS bh)))
 649   return (listArray (0,sz-1) elems)
 650
 651 constructDictionary :: Int -> UniqFM (Int,FastString) -> Dictionary
 652 constructDictionary j fm = array (0,j-1) (eltsUFM fm)
 653
 654 putFS bh (FastString id l ba) = do
 655   put_ bh (I# l)
 656   putByteArray bh ba l
 657 putFS bh s = error ("Binary.put_(FastString): " ++ unpackFS s)
 658         -- Note: the length of the FastString is *not* the same as
 659         -- the size of the ByteArray: the latter is rounded up to a
 660         -- multiple of the word size.
 661
 662 {- -- possible faster version, not quite there yet:
 663 getFS bh@BinMem{} = do
 664   (I# l) <- get bh
 665   arr <- readIORef (arr_r bh)
 666   off <- readFastMutInt (off_r bh)
 667   return $! (mkFastSubStringBA# arr off l)
 668 -}
 669 getFS bh = do
 670   (I# l) <- get bh
 671   (BA ba) <- getByteArray bh (I# l)
 672   return $! (mkFastSubStringBA# ba 0# l)
 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)