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