compiler/utils/Binary.hs

   1 {-# OPTIONS -cpp #-}
   2 {-# OPTIONS_GHC -O -funbox-strict-fields #-}
   3 -- We always optimise this, otherwise performance of a non-optimised
   4 -- compiler is severely affected
   5
   6 --
   7 -- (c) The University of Glasgow 2002-2006
   8 --
   9 -- Binary I/O library, with special tweaks for GHC
  10 --
  11 -- Based on the nhc98 Binary library, which is copyright
  12 -- (c) Malcolm Wallace and Colin Runciman, University of York, 1998.
  13 -- Under the terms of the license for that software, we must tell you
  14 -- where you can obtain the original version of the Binary library, namely
  15 --     http://www.cs.york.ac.uk/fp/nhc98/
  16
  17 module Binary
  18   ( {-type-}  Bin,
  19     {-class-} Binary(..),
  20     {-type-}  BinHandle,
  21
  22    openBinIO, openBinIO_,
  23    openBinMem,
  24 --   closeBin,
  25
  26    seekBin,
  27    seekBy,
  28    tellBin,
  29    castBin,
  30
  31    writeBinMem,
  32    readBinMem,
  33    fingerprintBinMem,
  34
  35    isEOFBin,
  36
  37    putAt, getAt,
  38
  39    -- for writing instances:
  40    putByte,
  41    getByte,
  42
  43    -- lazy Bin I/O
  44    lazyGet,
  45    lazyPut,
  46
  47 #ifdef __GLASGOW_HASKELL__
  48    -- GHC only:
  49    ByteArray(..),
  50    getByteArray,
  51    putByteArray,
  52 #endif
  53
  54    UserData(..), getUserData, setUserData,
  55    newReadState, newWriteState,
  56    putDictionary, getDictionary, putFS,
  57   ) where
  58
  59 #include "HsVersions.h"
  60
  61 -- The *host* architecture version:
  62 #include "../includes/MachDeps.h"
  63
  64 import {-# SOURCE #-} Name (Name)
  65 import FastString
  66 import Panic
  67 import UniqFM
  68 import FastMutInt
  69 import Fingerprint
  70 import BasicTypes
  71
  72 import Foreign
  73 import Data.Array
  74 import Data.IORef
  75 import Data.Char                ( ord, chr )
  76 import Data.Typeable
  77 import Control.Monad            ( when )
  78 import System.IO as IO
  79 import System.IO.Unsafe         ( unsafeInterleaveIO )
  80 import System.IO.Error          ( mkIOError, eofErrorType )
  81 import GHC.Real                 ( Ratio(..) )
  82 import GHC.Exts
  83 import GHC.Word                 ( Word8(..) )
  84 import GHC.IO ( IO(..) )
  85
  86 type BinArray = ForeignPtr Word8
  87
  88 ---------------------------------------------------------------
  89 -- BinHandle
  90 ---------------------------------------------------------------
  91
  92 data BinHandle
  93   = BinMem {                     -- binary data stored in an unboxed array
  94      bh_usr :: UserData,         -- sigh, need parameterized modules :-)
  95      _off_r :: !FastMutInt,      -- the current offset
  96      _sz_r  :: !FastMutInt,      -- size of the array (cached)
  97      _arr_r :: !(IORef BinArray) -- the array (bounds: (0,size-1))
  98     }
  99         -- XXX: should really store a "high water mark" for dumping out
 100         -- the binary data to a file.
 101
 102   | BinIO {                     -- binary data stored in a file
 103      bh_usr :: UserData,
 104      _off_r :: !FastMutInt,     -- the current offset (cached)
 105      _hdl   :: !IO.Handle       -- the file handle (must be seekable)
 106    }
 107         -- cache the file ptr in BinIO; using hTell is too expensive
 108         -- to call repeatedly.  If anyone else is modifying this Handle
 109         -- at the same time, we'll be screwed.
 110
 111 getUserData :: BinHandle -> UserData
 112 getUserData bh = bh_usr bh
 113
 114 setUserData :: BinHandle -> UserData -> BinHandle
 115 setUserData bh us = bh { bh_usr = us }
 116
 117
 118 ---------------------------------------------------------------
 119 -- Bin
 120 ---------------------------------------------------------------
 121
 122 newtype Bin a = BinPtr Int
 123   deriving (Eq, Ord, Show, Bounded)
 124
 125 castBin :: Bin a -> Bin b
 126 castBin (BinPtr i) = BinPtr i
 127
 128 ---------------------------------------------------------------
 129 -- class Binary
 130 ---------------------------------------------------------------
 131
 132 class Binary a where
 133     put_   :: BinHandle -> a -> IO ()
 134     put    :: BinHandle -> a -> IO (Bin a)
 135     get    :: BinHandle -> IO a
 136
 137     -- define one of put_, put.  Use of put_ is recommended because it
 138     -- is more likely that tail-calls can kick in, and we rarely need the
 139     -- position return value.
 140     put_ bh a = do _ <- put bh a; return ()
 141     put bh a  = do p <- tellBin bh; put_ bh a; return p
 142
 143 putAt  :: Binary a => BinHandle -> Bin a -> a -> IO ()
 144 putAt bh p x = do seekBin bh p; put_ bh x; return ()
 145
 146 getAt  :: Binary a => BinHandle -> Bin a -> IO a
 147 getAt bh p = do seekBin bh p; get bh
 148
 149 openBinIO_ :: IO.Handle -> IO BinHandle
 150 openBinIO_ h = openBinIO h
 151
 152 openBinIO :: IO.Handle -> IO BinHandle
 153 openBinIO h = do
 154   r <- newFastMutInt
 155   writeFastMutInt r 0
 156   return (BinIO noUserData r h)
 157
 158 openBinMem :: Int -> IO BinHandle
 159 openBinMem size
 160  | size <= 0 = error "Data.Binary.openBinMem: size must be >= 0"
 161  | otherwise = do
 162    arr <- mallocForeignPtrBytes size
 163    arr_r <- newIORef arr
 164    ix_r <- newFastMutInt
 165    writeFastMutInt ix_r 0
 166    sz_r <- newFastMutInt
 167    writeFastMutInt sz_r size
 168    return (BinMem noUserData ix_r sz_r arr_r)
 169
 170 tellBin :: BinHandle -> IO (Bin a)
 171 tellBin (BinIO  _ r _)   = do ix <- readFastMutInt r; return (BinPtr ix)
 172 tellBin (BinMem _ r _ _) = do ix <- readFastMutInt r; return (BinPtr ix)
 173
 174 seekBin :: BinHandle -> Bin a -> IO ()
 175 seekBin (BinIO _ ix_r h) (BinPtr p) = do
 176   writeFastMutInt ix_r p
 177   hSeek h AbsoluteSeek (fromIntegral p)
 178 seekBin h@(BinMem _ ix_r sz_r _) (BinPtr p) = do
 179   sz <- readFastMutInt sz_r
 180   if (p >= sz)
 181         then do expandBin h p; writeFastMutInt ix_r p
 182         else writeFastMutInt ix_r p
 183
 184 seekBy :: BinHandle -> Int -> IO ()
 185 seekBy (BinIO _ ix_r h) off = do
 186   ix <- readFastMutInt ix_r
 187   let ix' = ix + off
 188   writeFastMutInt ix_r ix'
 189   hSeek h AbsoluteSeek (fromIntegral ix')
 190 seekBy h@(BinMem _ ix_r sz_r _) off = do
 191   sz <- readFastMutInt sz_r
 192   ix <- readFastMutInt ix_r
 193   let ix' = ix + off
 194   if (ix' >= sz)
 195         then do expandBin h ix'; writeFastMutInt ix_r ix'
 196         else writeFastMutInt ix_r ix'
 197
 198 isEOFBin :: BinHandle -> IO Bool
 199 isEOFBin (BinMem _ ix_r sz_r _) = do
 200   ix <- readFastMutInt ix_r
 201   sz <- readFastMutInt sz_r
 202   return (ix >= sz)
 203 isEOFBin (BinIO _ _ h) = hIsEOF h
 204
 205 writeBinMem :: BinHandle -> FilePath -> IO ()
 206 writeBinMem (BinIO _ _ _) _ = error "Data.Binary.writeBinMem: not a memory handle"
 207 writeBinMem (BinMem _ ix_r _ arr_r) fn = do
 208   h <- openBinaryFile fn WriteMode
 209   arr <- readIORef arr_r
 210   ix  <- readFastMutInt ix_r
 211   withForeignPtr arr $ \p -> hPutBuf h p ix
 212   hClose h
 213
 214 readBinMem :: FilePath -> IO BinHandle
 215 -- Return a BinHandle with a totally undefined State
 216 readBinMem filename = do
 217   h <- openBinaryFile filename ReadMode
 218   filesize' <- hFileSize h
 219   let filesize = fromIntegral filesize'
 220   arr <- mallocForeignPtrBytes (filesize*2)
 221   count <- withForeignPtr arr $ \p -> hGetBuf h p filesize
 222   when (count /= filesize) $
 223        error ("Binary.readBinMem: only read " ++ show count ++ " bytes")
 224   hClose h
 225   arr_r <- newIORef arr
 226   ix_r <- newFastMutInt
 227   writeFastMutInt ix_r 0
 228   sz_r <- newFastMutInt
 229   writeFastMutInt sz_r filesize
 230   return (BinMem noUserData ix_r sz_r arr_r)
 231
 232 fingerprintBinMem :: BinHandle -> IO Fingerprint
 233 fingerprintBinMem (BinIO _ _ _) = error "Binary.md5BinMem: not a memory handle"
 234 fingerprintBinMem (BinMem _ ix_r _ arr_r) = do
 235   arr <- readIORef arr_r
 236   ix <- readFastMutInt ix_r
 237   withForeignPtr arr $ \p -> fingerprintData p ix
 238
 239 -- expand the size of the array to include a specified offset
 240 expandBin :: BinHandle -> Int -> IO ()
 241 expandBin (BinMem _ _ sz_r arr_r) off = do
 242    sz <- readFastMutInt sz_r
 243    let sz' = head (dropWhile (<= off) (iterate (* 2) sz))
 244    arr <- readIORef arr_r
 245    arr' <- mallocForeignPtrBytes sz'
 246    withForeignPtr arr $ \old ->
 247      withForeignPtr arr' $ \new ->
 248        copyBytes new old sz
 249    writeFastMutInt sz_r sz'
 250    writeIORef arr_r arr'
 251    when False $ -- disabled
 252       hPutStrLn stderr ("Binary: expanding to size: " ++ show sz')
 253    return ()
 254 expandBin (BinIO _ _ _) _ = return ()
 255 -- no need to expand a file, we'll assume they expand by themselves.
 256
 257 -- -----------------------------------------------------------------------------
 258 -- Low-level reading/writing of bytes
 259
 260 putWord8 :: BinHandle -> Word8 -> IO ()
 261 putWord8 h@(BinMem _ ix_r sz_r arr_r) w = do
 262     ix <- readFastMutInt ix_r
 263     sz <- readFastMutInt sz_r
 264     -- double the size of the array if it overflows
 265     if (ix >= sz)
 266         then do expandBin h ix
 267                 putWord8 h w
 268         else do arr <- readIORef arr_r
 269                 withForeignPtr arr $ \p -> pokeByteOff p ix w
 270                 writeFastMutInt ix_r (ix+1)
 271                 return ()
 272 putWord8 (BinIO _ ix_r h) w = do
 273     ix <- readFastMutInt ix_r
 274     hPutChar h (chr (fromIntegral w)) -- XXX not really correct
 275     writeFastMutInt ix_r (ix+1)
 276     return ()
 277
 278 getWord8 :: BinHandle -> IO Word8
 279 getWord8 (BinMem _ ix_r sz_r arr_r) = do
 280     ix <- readFastMutInt ix_r
 281     sz <- readFastMutInt sz_r
 282     when (ix >= sz) $
 283         ioError (mkIOError eofErrorType "Data.Binary.getWord8" Nothing Nothing)
 284     arr <- readIORef arr_r
 285     w <- withForeignPtr arr $ \p -> peekByteOff p ix
 286     writeFastMutInt ix_r (ix+1)
 287     return w
 288 getWord8 (BinIO _ ix_r h) = do
 289     ix <- readFastMutInt ix_r
 290     c <- hGetChar h
 291     writeFastMutInt ix_r (ix+1)
 292     return $! (fromIntegral (ord c)) -- XXX not really correct
 293
 294 putByte :: BinHandle -> Word8 -> IO ()
 295 putByte bh w = put_ bh w
 296
 297 getByte :: BinHandle -> IO Word8
 298 getByte = getWord8
 299
 300 -- -----------------------------------------------------------------------------
 301 -- Primitve Word writes
 302
 303 instance Binary Word8 where
 304   put_ = putWord8
 305   get  = getWord8
 306
 307 instance Binary Word16 where
 308   put_ h w = do -- XXX too slow.. inline putWord8?
 309     putByte h (fromIntegral (w `shiftR` 8))
 310     putByte h (fromIntegral (w .&. 0xff))
 311   get h = do
 312     w1 <- getWord8 h
 313     w2 <- getWord8 h
 314     return $! ((fromIntegral w1 `shiftL` 8) .|. fromIntegral w2)
 315
 316
 317 instance Binary Word32 where
 318   put_ h w = do
 319     putByte h (fromIntegral (w `shiftR` 24))
 320     putByte h (fromIntegral ((w `shiftR` 16) .&. 0xff))
 321     putByte h (fromIntegral ((w `shiftR` 8)  .&. 0xff))
 322     putByte h (fromIntegral (w .&. 0xff))
 323   get h = do
 324     w1 <- getWord8 h
 325     w2 <- getWord8 h
 326     w3 <- getWord8 h
 327     w4 <- getWord8 h
 328     return $! ((fromIntegral w1 `shiftL` 24) .|.
 329                (fromIntegral w2 `shiftL` 16) .|.
 330                (fromIntegral w3 `shiftL`  8) .|.
 331                (fromIntegral w4))
 332
 333 instance Binary Word64 where
 334   put_ h w = do
 335     putByte h (fromIntegral (w `shiftR` 56))
 336     putByte h (fromIntegral ((w `shiftR` 48) .&. 0xff))
 337     putByte h (fromIntegral ((w `shiftR` 40) .&. 0xff))
 338     putByte h (fromIntegral ((w `shiftR` 32) .&. 0xff))
 339     putByte h (fromIntegral ((w `shiftR` 24) .&. 0xff))
 340     putByte h (fromIntegral ((w `shiftR` 16) .&. 0xff))
 341     putByte h (fromIntegral ((w `shiftR`  8) .&. 0xff))
 342     putByte h (fromIntegral (w .&. 0xff))
 343   get h = do
 344     w1 <- getWord8 h
 345     w2 <- getWord8 h
 346     w3 <- getWord8 h
 347     w4 <- getWord8 h
 348     w5 <- getWord8 h
 349     w6 <- getWord8 h
 350     w7 <- getWord8 h
 351     w8 <- getWord8 h
 352     return $! ((fromIntegral w1 `shiftL` 56) .|.
 353                (fromIntegral w2 `shiftL` 48) .|.
 354                (fromIntegral w3 `shiftL` 40) .|.
 355                (fromIntegral w4 `shiftL` 32) .|.
 356                (fromIntegral w5 `shiftL` 24) .|.
 357                (fromIntegral w6 `shiftL` 16) .|.
 358                (fromIntegral w7 `shiftL`  8) .|.
 359                (fromIntegral w8))
 360
 361 -- -----------------------------------------------------------------------------
 362 -- Primitve Int writes
 363
 364 instance Binary Int8 where
 365   put_ h w = put_ h (fromIntegral w :: Word8)
 366   get h    = do w <- get h; return $! (fromIntegral (w::Word8))
 367
 368 instance Binary Int16 where
 369   put_ h w = put_ h (fromIntegral w :: Word16)
 370   get h    = do w <- get h; return $! (fromIntegral (w::Word16))
 371
 372 instance Binary Int32 where
 373   put_ h w = put_ h (fromIntegral w :: Word32)
 374   get h    = do w <- get h; return $! (fromIntegral (w::Word32))
 375
 376 instance Binary Int64 where
 377   put_ h w = put_ h (fromIntegral w :: Word64)
 378   get h    = do w <- get h; return $! (fromIntegral (w::Word64))
 379
 380 -- -----------------------------------------------------------------------------
 381 -- Instances for standard types
 382
 383 instance Binary () where
 384     put_ _ () = return ()
 385     get  _    = return ()
 386
 387 instance Binary Bool where
 388     put_ bh b = putByte bh (fromIntegral (fromEnum b))
 389     get  bh   = do x <- getWord8 bh; return $! (toEnum (fromIntegral x))
 390
 391 instance Binary Char where
 392     put_  bh c = put_ bh (fromIntegral (ord c) :: Word32)
 393     get  bh   = do x <- get bh; return $! (chr (fromIntegral (x :: Word32)))
 394
 395 instance Binary Int where
 396     put_ bh i = put_ bh (fromIntegral i :: Int64)
 397     get  bh = do
 398         x <- get bh
 399         return $! (fromIntegral (x :: Int64))
 400
 401 instance Binary a => Binary [a] where
 402     put_ bh l = do
 403         let len = length l
 404         if (len < 0xff)
 405           then putByte bh (fromIntegral len :: Word8)
 406           else do putByte bh 0xff; put_ bh (fromIntegral len :: Word32)
 407         mapM_ (put_ bh) l
 408     get bh = do
 409         b <- getByte bh
 410         len <- if b == 0xff
 411                   then get bh
 412                   else return (fromIntegral b :: Word32)
 413         let loop 0 = return []
 414             loop n = do a <- get bh; as <- loop (n-1); return (a:as)
 415         loop len
 416
 417 instance (Binary a, Binary b) => Binary (a,b) where
 418     put_ bh (a,b) = do put_ bh a; put_ bh b
 419     get bh        = do a <- get bh
 420                        b <- get bh
 421                        return (a,b)
 422
 423 instance (Binary a, Binary b, Binary c) => Binary (a,b,c) where
 424     put_ bh (a,b,c) = do put_ bh a; put_ bh b; put_ bh c
 425     get bh          = do a <- get bh
 426                          b <- get bh
 427                          c <- get bh
 428                          return (a,b,c)
 429
 430 instance (Binary a, Binary b, Binary c, Binary d) => Binary (a,b,c,d) where
 431     put_ bh (a,b,c,d) = do put_ bh a; put_ bh b; put_ bh c; put_ bh d
 432     get bh          = do a <- get bh
 433                          b <- get bh
 434                          c <- get bh
 435                          d <- get bh
 436                          return (a,b,c,d)
 437
 438 instance Binary a => Binary (Maybe a) where
 439     put_ bh Nothing  = putByte bh 0
 440     put_ bh (Just a) = do putByte bh 1; put_ bh a
 441     get bh           = do h <- getWord8 bh
 442                           case h of
 443                             0 -> return Nothing
 444                             _ -> do x <- get bh; return (Just x)
 445
 446 instance (Binary a, Binary b) => Binary (Either a b) where
 447     put_ bh (Left  a) = do putByte bh 0; put_ bh a
 448     put_ bh (Right b) = do putByte bh 1; put_ bh b
 449     get bh            = do h <- getWord8 bh
 450                            case h of
 451                              0 -> do a <- get bh ; return (Left a)
 452                              _ -> do b <- get bh ; return (Right b)
 453
 454 #if defined(__GLASGOW_HASKELL__) || 1
 455 --to quote binary-0.3 on this code idea,
 456 --
 457 -- TODO  This instance is not architecture portable.  GMP stores numbers as
 458 -- arrays of machine sized words, so the byte format is not portable across
 459 -- architectures with different endianess and word size.
 460 --
 461 -- This makes it hard (impossible) to make an equivalent instance
 462 -- with code that is compilable with non-GHC.  Do we need any instance
 463 -- Binary Integer, and if so, does it have to be blazing fast?  Or can
 464 -- we just change this instance to be portable like the rest of the
 465 -- instances? (binary package has code to steal for that)
 466 --
 467 -- yes, we need Binary Integer and Binary Rational in basicTypes/Literal.lhs
 468
 469 instance Binary Integer where
 470     -- XXX This is hideous
 471     put_ bh i = put_ bh (show i)
 472     get bh = do str <- get bh
 473                 case reads str of
 474                     [(i, "")] -> return i
 475                     _ -> fail ("Binary Integer: got " ++ show str)
 476
 477     {-
 478     put_ bh (S# i#) = do putByte bh 0; put_ bh (I# i#)
 479     put_ bh (J# s# a#) = do
 480         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
 497 -- As for the rest of this code, even though this module
 498 -- exports it, it doesn't seem to be used anywhere else
 499 -- in GHC!
 500
 501 putByteArray :: BinHandle -> ByteArray# -> Int# -> IO ()
 502 putByteArray bh a s# = loop 0#
 503   where loop n#
 504            | n# ==# s# = return ()
 505            | otherwise = do
 506                 putByte bh (indexByteArray a n#)
 507                 loop (n# +# 1#)
 508
 509 getByteArray :: BinHandle -> Int -> IO ByteArray
 510 getByteArray bh (I# sz) = do
 511   (MBA arr) <- newByteArray sz
 512   let loop n
 513            | n ==# sz = return ()
 514            | otherwise = do
 515                 w <- getByte bh
 516                 writeByteArray arr n w
 517                 loop (n +# 1#)
 518   loop 0#
 519   freezeByteArray arr
 520
 521
 522 data ByteArray = BA ByteArray#
 523 data MBA = MBA (MutableByteArray# RealWorld)
 524
 525 newByteArray :: Int# -> IO MBA
 526 newByteArray sz = IO $ \s ->
 527   case newByteArray# sz s of { (# s, arr #) ->
 528   (# s, MBA arr #) }
 529
 530 freezeByteArray :: MutableByteArray# RealWorld -> IO ByteArray
 531 freezeByteArray arr = IO $ \s ->
 532   case unsafeFreezeByteArray# arr s of { (# s, arr #) ->
 533   (# s, BA arr #) }
 534
 535 writeByteArray :: MutableByteArray# RealWorld -> Int# -> Word8 -> IO ()
 536 writeByteArray arr i (W8# w) = IO $ \s ->
 537   case writeWord8Array# arr i w s of { s ->
 538   (# s, () #) }
 539
 540 indexByteArray :: ByteArray# -> Int# -> Word8
 541 indexByteArray a# n# = W8# (indexWord8Array# a# n#)
 542
 543 instance (Integral a, Binary a) => Binary (Ratio a) where
 544     put_ bh (a :% b) = do put_ bh a; put_ bh b
 545     get bh = do a <- get bh; b <- get bh; return (a :% b)
 546 #endif
 547
 548 instance Binary (Bin a) where
 549   put_ bh (BinPtr i) = put_ bh (fromIntegral i :: Int32)
 550   get bh = do i <- get bh; return (BinPtr (fromIntegral (i :: Int32)))
 551
 552 -- -----------------------------------------------------------------------------
 553 -- Instances for Data.Typeable stuff
 554
 555 instance Binary TyCon where
 556     put_ bh ty_con = do
 557         let s = tyConString ty_con
 558         put_ bh s
 559     get bh = do
 560         s <- get bh
 561         return (mkTyCon s)
 562
 563 instance Binary TypeRep where
 564     put_ bh type_rep = do
 565         let (ty_con, child_type_reps) = splitTyConApp type_rep
 566         put_ bh ty_con
 567         put_ bh child_type_reps
 568     get bh = do
 569         ty_con <- get bh
 570         child_type_reps <- get bh
 571         return (mkTyConApp ty_con child_type_reps)
 572
 573 -- -----------------------------------------------------------------------------
 574 -- Lazy reading/writing
 575
 576 lazyPut :: Binary a => BinHandle -> a -> IO ()
 577 lazyPut bh a = do
 578     -- output the obj with a ptr to skip over it:
 579     pre_a <- tellBin bh
 580     put_ bh pre_a       -- save a slot for the ptr
 581     put_ bh a           -- dump the object
 582     q <- tellBin bh     -- q = ptr to after object
 583     putAt bh pre_a q    -- fill in slot before a with ptr to q
 584     seekBin bh q        -- finally carry on writing at q
 585
 586 lazyGet :: Binary a => BinHandle -> IO a
 587 lazyGet bh = do
 588     p <- get bh -- a BinPtr
 589     p_a <- tellBin bh
 590     a <- unsafeInterleaveIO (getAt bh p_a)
 591     seekBin bh p -- skip over the object for now
 592     return a
 593
 594 -- -----------------------------------------------------------------------------
 595 -- UserData
 596 -- -----------------------------------------------------------------------------
 597
 598 data UserData =
 599    UserData {
 600         -- for *deserialising* only:
 601         ud_dict   :: Dictionary,
 602         ud_symtab :: SymbolTable,
 603
 604         -- for *serialising* only:
 605         ud_put_name :: BinHandle -> Name       -> IO (),
 606         ud_put_fs   :: BinHandle -> FastString -> IO ()
 607    }
 608
 609 newReadState :: Dictionary -> IO UserData
 610 newReadState dict = do
 611   return UserData { ud_dict     = dict,
 612                     ud_symtab   = undef "symtab",
 613                     ud_put_name = undef "put_name",
 614                     ud_put_fs   = undef "put_fs"
 615                    }
 616
 617 newWriteState :: (BinHandle -> Name       -> IO ())
 618               -> (BinHandle -> FastString -> IO ())
 619               -> IO UserData
 620 newWriteState put_name put_fs = do
 621   return UserData { ud_dict     = undef "dict",
 622                     ud_symtab   = undef "symtab",
 623                     ud_put_name = put_name,
 624                     ud_put_fs   = put_fs
 625                    }
 626
 627 noUserData :: a
 628 noUserData = undef "UserData"
 629
 630 undef :: String -> a
 631 undef s = panic ("Binary.UserData: no " ++ s)
 632
 633 ---------------------------------------------------------
 634 -- The Dictionary
 635 ---------------------------------------------------------
 636
 637 type Dictionary = Array Int FastString -- The dictionary
 638                                        -- Should be 0-indexed
 639
 640 putDictionary :: BinHandle -> Int -> UniqFM (Int,FastString) -> IO ()
 641 putDictionary bh sz dict = do
 642   put_ bh sz
 643   mapM_ (putFS bh) (elems (array (0,sz-1) (eltsUFM 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 ---------------------------------------------------------
 652 -- The Symbol Table
 653 ---------------------------------------------------------
 654
 655 -- On disk, the symbol table is an array of IfaceExtName, when
 656 -- reading it in we turn it into a SymbolTable.
 657
 658 type SymbolTable = Array Int Name
 659
 660 ---------------------------------------------------------
 661 -- Reading and writing FastStrings
 662 ---------------------------------------------------------
 663
 664 putFS :: BinHandle -> FastString -> IO ()
 665 putFS bh (FastString _ l _ buf _) = do
 666   put_ bh l
 667   withForeignPtr buf $ \ptr ->
 668     let
 669         go n | n == l    = return ()
 670              | otherwise = do
 671                 b <- peekElemOff ptr n
 672                 putByte bh b
 673                 go (n+1)
 674    in
 675    go 0
 676
 677 {- -- possible faster version, not quite there yet:
 678 getFS bh@BinMem{} = do
 679   (I# l) <- get bh
 680   arr <- readIORef (arr_r bh)
 681   off <- readFastMutInt (off_r bh)
 682   return $! (mkFastSubStringBA# arr off l)
 683 -}
 684 getFS :: BinHandle -> IO FastString
 685 getFS bh = do
 686   l <- get bh
 687   fp <- mallocForeignPtrBytes l
 688   withForeignPtr fp $ \ptr -> do
 689   let
 690         go n | n == l = mkFastStringForeignPtr ptr fp l
 691              | otherwise = do
 692                 b <- getByte bh
 693                 pokeElemOff ptr n b
 694                 go (n+1)
 695   --
 696   go 0
 697
 698 instance Binary FastString where
 699   put_ bh f =
 700     case getUserData bh of
 701         UserData { ud_put_fs = put_fs } -> put_fs bh f
 702
 703   get bh = do
 704         j <- get bh
 705         return $! (ud_dict (getUserData bh) ! (fromIntegral (j :: Word32)))
 706
 707 -- Here to avoid loop
 708
 709 instance Binary Fingerprint where
 710   put_ h (Fingerprint w1 w2) = do put_ h w1; put_ h w2
 711   get  h = do w1 <- get h; w2 <- get h; return (Fingerprint w1 w2)
 712
 713 instance Binary FunctionOrData where
 714     put_ bh IsFunction = putByte bh 0
 715     put_ bh IsData     = putByte bh 1
 716     get bh = do
 717         h <- getByte bh
 718         case h of
 719           0 -> return IsFunction
 720           1 -> return IsData
 721           _ -> panic "Binary FunctionOrData"
 722