compiler/utils/Binary.hs

   1 {-# OPTIONS -cpp #-}
   2 --
   3 -- (c) The University of Glasgow 2002-2006
   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    putAt, getAt,
  32
  33    -- for writing instances:
  34    putByte,
  35    getByte,
  36
  37    -- lazy Bin I/O
  38    lazyGet,
  39    lazyPut,
  40
  41 #ifdef __GLASGOW_HASKELL__
  42    -- GHC only:
  43    ByteArray(..),
  44    getByteArray,
  45    putByteArray,
  46 #endif
  47
  48    UserData(..), getUserData, setUserData,
  49    newReadState, newWriteState,
  50    putDictionary, getDictionary,
  51   ) where
  52
  53 #include "HsVersions.h"
  54
  55 -- The *host* architecture version:
  56 #include "MachDeps.h"
  57
  58 import {-# SOURCE #-} Name (Name)
  59 import FastString
  60 import Unique
  61 import Panic
  62 import UniqFM
  63 import FastMutInt
  64
  65 import Foreign
  66 import Data.Array.IO
  67 import Data.Array
  68 import Data.Bits
  69 import Data.Int
  70 import Data.Word
  71 import Data.IORef
  72 import Data.Char                ( ord, chr )
  73 import Data.Array.Base          ( unsafeRead, unsafeWrite )
  74 import Control.Monad            ( when )
  75 import System.IO as IO
  76 import System.IO.Unsafe         ( unsafeInterleaveIO )
  77 import System.IO.Error          ( mkIOError, eofErrorType )
  78 import GHC.Real                 ( Ratio(..) )
  79 import GHC.Exts
  80 import GHC.IOBase               ( IO(..) )
  81 import GHC.Word                 ( Word8(..) )
  82 #if defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ < 601
  83 -- openFileEx is available from the lang package, but we want to
  84 -- be independent of hslibs libraries.
  85 import GHC.Handle               ( openFileEx, IOModeEx(..) )
  86 #else
  87 import System.IO                ( openBinaryFile )
  88 #endif
  89
  90 #if defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ < 601
  91 openBinaryFile f mode = openFileEx f (BinaryMode mode)
  92 #endif
  93
  94 type BinArray = IOUArray Int Word8
  95
  96 ---------------------------------------------------------------
  97 -- BinHandle
  98 ---------------------------------------------------------------
  99
 100 data BinHandle
 101   = BinMem {                     -- binary data stored in an unboxed array
 102      bh_usr :: UserData,         -- sigh, need parameterized modules :-)
 103      _off_r :: !FastMutInt,      -- the current offset
 104      _sz_r  :: !FastMutInt,      -- size of the array (cached)
 105      _arr_r :: !(IORef BinArray) -- the array (bounds: (0,size-1))
 106     }
 107         -- XXX: should really store a "high water mark" for dumping out
 108         -- the binary data to a file.
 109
 110   | BinIO {                     -- binary data stored in a file
 111      bh_usr :: UserData,
 112      _off_r :: !FastMutInt,     -- the current offset (cached)
 113      _hdl   :: !IO.Handle       -- the file handle (must be seekable)
 114    }
 115         -- cache the file ptr in BinIO; using hTell is too expensive
 116         -- to call repeatedly.  If anyone else is modifying this Handle
 117         -- at the same time, we'll be screwed.
 118
 119 getUserData :: BinHandle -> UserData
 120 getUserData bh = bh_usr bh
 121
 122 setUserData :: BinHandle -> UserData -> BinHandle
 123 setUserData bh us = bh { bh_usr = us }
 124
 125
 126 ---------------------------------------------------------------
 127 -- Bin
 128 ---------------------------------------------------------------
 129
 130 newtype Bin a = BinPtr Int
 131   deriving (Eq, Ord, Show, Bounded)
 132
 133 castBin :: Bin a -> Bin b
 134 castBin (BinPtr i) = BinPtr i
 135
 136 ---------------------------------------------------------------
 137 -- class Binary
 138 ---------------------------------------------------------------
 139
 140 class Binary a where
 141     put_   :: BinHandle -> a -> IO ()
 142     put    :: BinHandle -> a -> IO (Bin a)
 143     get    :: BinHandle -> IO a
 144
 145     -- define one of put_, put.  Use of put_ is recommended because it
 146     -- is more likely that tail-calls can kick in, and we rarely need the
 147     -- position return value.
 148     put_ bh a = do put bh a; return ()
 149     put bh a  = do p <- tellBin bh; put_ bh a; return p
 150
 151 putAt  :: Binary a => BinHandle -> Bin a -> a -> IO ()
 152 putAt bh p x = do seekBin bh p; put bh x; return ()
 153
 154 getAt  :: Binary a => BinHandle -> Bin a -> IO a
 155 getAt bh p = do seekBin bh p; get bh
 156
 157 openBinIO_ :: IO.Handle -> IO BinHandle
 158 openBinIO_ h = openBinIO h
 159
 160 openBinIO :: IO.Handle -> IO BinHandle
 161 openBinIO h = do
 162   r <- newFastMutInt
 163   writeFastMutInt r 0
 164   return (BinIO noUserData r h)
 165
 166 openBinMem :: Int -> IO BinHandle
 167 openBinMem size
 168  | size <= 0 = error "Data.Binary.openBinMem: size must be >= 0"
 169  | otherwise = do
 170    arr <- newArray_ (0,size-1)
 171    arr_r <- newIORef arr
 172    ix_r <- newFastMutInt
 173    writeFastMutInt ix_r 0
 174    sz_r <- newFastMutInt
 175    writeFastMutInt sz_r size
 176    return (BinMem noUserData ix_r sz_r arr_r)
 177
 178 tellBin :: BinHandle -> IO (Bin a)
 179 tellBin (BinIO  _ r _)   = do ix <- readFastMutInt r; return (BinPtr ix)
 180 tellBin (BinMem _ r _ _) = do ix <- readFastMutInt r; return (BinPtr ix)
 181
 182 seekBin :: BinHandle -> Bin a -> IO ()
 183 seekBin (BinIO _ ix_r h) (BinPtr p) = do
 184   writeFastMutInt ix_r p
 185   hSeek h AbsoluteSeek (fromIntegral p)
 186 seekBin h@(BinMem _ ix_r sz_r _) (BinPtr p) = do
 187   sz <- readFastMutInt sz_r
 188   if (p >= sz)
 189         then do expandBin h p; writeFastMutInt ix_r p
 190         else writeFastMutInt ix_r p
 191
 192 isEOFBin :: BinHandle -> IO Bool
 193 isEOFBin (BinMem _ ix_r sz_r _) = do
 194   ix <- readFastMutInt ix_r
 195   sz <- readFastMutInt sz_r
 196   return (ix >= sz)
 197 isEOFBin (BinIO _ _ h) = hIsEOF h
 198
 199 writeBinMem :: BinHandle -> FilePath -> IO ()
 200 writeBinMem (BinIO _ _ _) _ = error "Data.Binary.writeBinMem: not a memory handle"
 201 writeBinMem (BinMem _ ix_r _ arr_r) fn = do
 202   h <- openBinaryFile fn WriteMode
 203   arr <- readIORef arr_r
 204   ix  <- readFastMutInt ix_r
 205   hPutArray h arr ix
 206   hClose h
 207
 208 readBinMem :: FilePath -> IO BinHandle
 209 -- Return a BinHandle with a totally undefined State
 210 readBinMem filename = do
 211   h <- openBinaryFile filename ReadMode
 212   filesize' <- hFileSize h
 213   let filesize = fromIntegral filesize'
 214   arr <- newArray_ (0,filesize-1)
 215   count <- hGetArray h arr filesize
 216   when (count /= filesize)
 217        (error ("Binary.readBinMem: only read " ++ show count ++ " bytes"))
 218   hClose h
 219   arr_r <- newIORef arr
 220   ix_r <- newFastMutInt
 221   writeFastMutInt ix_r 0
 222   sz_r <- newFastMutInt
 223   writeFastMutInt sz_r filesize
 224   return (BinMem noUserData ix_r sz_r arr_r)
 225
 226 -- expand the size of the array to include a specified offset
 227 expandBin :: BinHandle -> Int -> IO ()
 228 expandBin (BinMem _ _ sz_r arr_r) off = do
 229    sz <- readFastMutInt sz_r
 230    let sz' = head (dropWhile (<= off) (iterate (* 2) sz))
 231    arr <- readIORef arr_r
 232    arr' <- newArray_ (0,sz'-1)
 233    sequence_ [ unsafeRead arr i >>= unsafeWrite arr' i
 234              | i <- [ 0 .. sz-1 ] ]
 235    writeFastMutInt sz_r sz'
 236    writeIORef arr_r arr'
 237 #ifdef DEBUG
 238    hPutStrLn stderr ("Binary: expanding to size: " ++ show sz')
 239 #endif
 240    return ()
 241 expandBin (BinIO _ _ _) _ = return ()
 242 -- no need to expand a file, we'll assume they expand by themselves.
 243
 244 -- -----------------------------------------------------------------------------
 245 -- Low-level reading/writing of bytes
 246
 247 putWord8 :: BinHandle -> Word8 -> IO ()
 248 putWord8 h@(BinMem _ ix_r sz_r arr_r) w = do
 249     ix <- readFastMutInt ix_r
 250     sz <- readFastMutInt sz_r
 251     -- double the size of the array if it overflows
 252     if (ix >= sz)
 253         then do expandBin h ix
 254                 putWord8 h w
 255         else do arr <- readIORef arr_r
 256                 unsafeWrite arr ix w
 257                 writeFastMutInt ix_r (ix+1)
 258                 return ()
 259 putWord8 (BinIO _ ix_r h) w = do
 260     ix <- readFastMutInt ix_r
 261     hPutChar h (chr (fromIntegral w)) -- XXX not really correct
 262     writeFastMutInt ix_r (ix+1)
 263     return ()
 264
 265 getWord8 :: BinHandle -> IO Word8
 266 getWord8 (BinMem _ ix_r sz_r arr_r) = do
 267     ix <- readFastMutInt ix_r
 268     sz <- readFastMutInt sz_r
 269     when (ix >= sz) $
 270         ioError (mkIOError eofErrorType "Data.Binary.getWord8" Nothing Nothing)
 271     arr <- readIORef arr_r
 272     w <- unsafeRead arr ix
 273     writeFastMutInt ix_r (ix+1)
 274     return w
 275 getWord8 (BinIO _ ix_r h) = do
 276     ix <- readFastMutInt ix_r
 277     c <- hGetChar h
 278     writeFastMutInt ix_r (ix+1)
 279     return $! (fromIntegral (ord c)) -- XXX not really correct
 280
 281 putByte :: BinHandle -> Word8 -> IO ()
 282 putByte bh w = put_ bh w
 283
 284 getByte :: BinHandle -> IO Word8
 285 getByte = getWord8
 286
 287 -- -----------------------------------------------------------------------------
 288 -- Primitve Word writes
 289
 290 instance Binary Word8 where
 291   put_ = putWord8
 292   get  = getWord8
 293
 294 instance Binary Word16 where
 295   put_ h w = do -- XXX too slow.. inline putWord8?
 296     putByte h (fromIntegral (w `shiftR` 8))
 297     putByte h (fromIntegral (w .&. 0xff))
 298   get h = do
 299     w1 <- getWord8 h
 300     w2 <- getWord8 h
 301     return $! ((fromIntegral w1 `shiftL` 8) .|. fromIntegral w2)
 302
 303
 304 instance Binary Word32 where
 305   put_ h w = do
 306     putByte h (fromIntegral (w `shiftR` 24))
 307     putByte h (fromIntegral ((w `shiftR` 16) .&. 0xff))
 308     putByte h (fromIntegral ((w `shiftR` 8)  .&. 0xff))
 309     putByte h (fromIntegral (w .&. 0xff))
 310   get h = do
 311     w1 <- getWord8 h
 312     w2 <- getWord8 h
 313     w3 <- getWord8 h
 314     w4 <- getWord8 h
 315     return $! ((fromIntegral w1 `shiftL` 24) .|.
 316                (fromIntegral w2 `shiftL` 16) .|.
 317                (fromIntegral w3 `shiftL`  8) .|.
 318                (fromIntegral w4))
 319
 320 instance Binary Word64 where
 321   put_ h w = do
 322     putByte h (fromIntegral (w `shiftR` 56))
 323     putByte h (fromIntegral ((w `shiftR` 48) .&. 0xff))
 324     putByte h (fromIntegral ((w `shiftR` 40) .&. 0xff))
 325     putByte h (fromIntegral ((w `shiftR` 32) .&. 0xff))
 326     putByte h (fromIntegral ((w `shiftR` 24) .&. 0xff))
 327     putByte h (fromIntegral ((w `shiftR` 16) .&. 0xff))
 328     putByte h (fromIntegral ((w `shiftR`  8) .&. 0xff))
 329     putByte h (fromIntegral (w .&. 0xff))
 330   get h = do
 331     w1 <- getWord8 h
 332     w2 <- getWord8 h
 333     w3 <- getWord8 h
 334     w4 <- getWord8 h
 335     w5 <- getWord8 h
 336     w6 <- getWord8 h
 337     w7 <- getWord8 h
 338     w8 <- getWord8 h
 339     return $! ((fromIntegral w1 `shiftL` 56) .|.
 340                (fromIntegral w2 `shiftL` 48) .|.
 341                (fromIntegral w3 `shiftL` 40) .|.
 342                (fromIntegral w4 `shiftL` 32) .|.
 343                (fromIntegral w5 `shiftL` 24) .|.
 344                (fromIntegral w6 `shiftL` 16) .|.
 345                (fromIntegral w7 `shiftL`  8) .|.
 346                (fromIntegral w8))
 347
 348 -- -----------------------------------------------------------------------------
 349 -- Primitve Int writes
 350
 351 instance Binary Int8 where
 352   put_ h w = put_ h (fromIntegral w :: Word8)
 353   get h    = do w <- get h; return $! (fromIntegral (w::Word8))
 354
 355 instance Binary Int16 where
 356   put_ h w = put_ h (fromIntegral w :: Word16)
 357   get h    = do w <- get h; return $! (fromIntegral (w::Word16))
 358
 359 instance Binary Int32 where
 360   put_ h w = put_ h (fromIntegral w :: Word32)
 361   get h    = do w <- get h; return $! (fromIntegral (w::Word32))
 362
 363 instance Binary Int64 where
 364   put_ h w = put_ h (fromIntegral w :: Word64)
 365   get h    = do w <- get h; return $! (fromIntegral (w::Word64))
 366
 367 -- -----------------------------------------------------------------------------
 368 -- Instances for standard types
 369
 370 instance Binary () where
 371     put_ _ () = return ()
 372     get  _    = return ()
 373 --    getF bh p  = case getBitsF bh 0 p of (_,b) -> ((),b)
 374
 375 instance Binary Bool where
 376     put_ bh b = putByte bh (fromIntegral (fromEnum b))
 377     get  bh   = do x <- getWord8 bh; return $! (toEnum (fromIntegral x))
 378 --    getF bh p = case getBitsF bh 1 p of (x,b) -> (toEnum x,b)
 379
 380 instance Binary Char where
 381     put_  bh c = put_ bh (fromIntegral (ord c) :: Word32)
 382     get  bh   = do x <- get bh; return $! (chr (fromIntegral (x :: Word32)))
 383 --    getF bh p = case getBitsF bh 8 p of (x,b) -> (toEnum x,b)
 384
 385 instance Binary Int where
 386 #if SIZEOF_HSINT == 4
 387     put_ bh i = put_ bh (fromIntegral i :: Int32)
 388     get  bh = do
 389         x <- get bh
 390         return $! (fromIntegral (x :: Int32))
 391 #elif SIZEOF_HSINT == 8
 392     put_ bh i = put_ bh (fromIntegral i :: Int64)
 393     get  bh = do
 394         x <- get bh
 395         return $! (fromIntegral (x :: Int64))
 396 #else
 397 #error "unsupported sizeof(HsInt)"
 398 #endif
 399 --    getF bh   = getBitsF bh 32
 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 i
 550   get bh = do i <- get bh; return (BinPtr i)
 551
 552 -- -----------------------------------------------------------------------------
 553 -- Lazy reading/writing
 554
 555 lazyPut :: Binary a => BinHandle -> a -> IO ()
 556 lazyPut bh a = do
 557     -- output the obj with a ptr to skip over it:
 558     pre_a <- tellBin bh
 559     put_ bh pre_a       -- save a slot for the ptr
 560     put_ bh a           -- dump the object
 561     q <- tellBin bh     -- q = ptr to after object
 562     putAt bh pre_a q    -- fill in slot before a with ptr to q
 563     seekBin bh q        -- finally carry on writing at q
 564
 565 lazyGet :: Binary a => BinHandle -> IO a
 566 lazyGet bh = do
 567     p <- get bh -- a BinPtr
 568     p_a <- tellBin bh
 569     a <- unsafeInterleaveIO (getAt bh p_a)
 570     seekBin bh p -- skip over the object for now
 571     return a
 572
 573 -- -----------------------------------------------------------------------------
 574 -- UserData
 575 -- -----------------------------------------------------------------------------
 576
 577 data UserData =
 578    UserData {
 579         -- for *deserialising* only:
 580         ud_dict   :: Dictionary,
 581         ud_symtab :: SymbolTable,
 582
 583         -- for *serialising* only:
 584         ud_dict_next :: !FastMutInt, -- The next index to use
 585         ud_dict_map  :: !(IORef (UniqFM (Int,FastString))),
 586                                 -- indexed by FastString
 587
 588         ud_symtab_next :: !FastMutInt, -- The next index to use
 589         ud_symtab_map  :: !(IORef (UniqFM (Int,Name)))
 590                                 -- indexed by Name
 591    }
 592
 593 newReadState :: Dictionary -> IO UserData
 594 newReadState dict = do
 595   dict_next <- newFastMutInt
 596   dict_map <- newIORef (undef "dict_map")
 597   symtab_next <- newFastMutInt
 598   symtab_map <- newIORef (undef "symtab_map")
 599   return UserData { ud_dict = dict,
 600                     ud_symtab = undef "symtab",
 601                     ud_dict_next = dict_next,
 602                     ud_dict_map = dict_map,
 603                     ud_symtab_next = symtab_next,
 604                     ud_symtab_map = symtab_map
 605                    }
 606
 607 newWriteState :: IO UserData
 608 newWriteState = do
 609   dict_next <- newFastMutInt
 610   writeFastMutInt dict_next 0
 611   dict_map <- newIORef emptyUFM
 612   symtab_next <- newFastMutInt
 613   writeFastMutInt symtab_next 0
 614   symtab_map <- newIORef emptyUFM
 615   return UserData { ud_dict = undef "dict",
 616                     ud_symtab = undef "symtab",
 617                     ud_dict_next = dict_next,
 618                     ud_dict_map = dict_map,
 619                     ud_symtab_next = symtab_next,
 620                     ud_symtab_map = symtab_map
 621                    }
 622
 623 noUserData :: a
 624 noUserData = undef "UserData"
 625
 626 undef :: String -> a
 627 undef s = panic ("Binary.UserData: no " ++ s)
 628
 629 ---------------------------------------------------------
 630 -- The Dictionary
 631 ---------------------------------------------------------
 632
 633 type Dictionary = Array Int FastString -- The dictionary
 634                                        -- Should be 0-indexed
 635
 636 putDictionary :: BinHandle -> Int -> UniqFM (Int,FastString) -> IO ()
 637 putDictionary bh sz dict = do
 638   put_ bh sz
 639   mapM_ (putFS bh) (elems (array (0,sz-1) (eltsUFM dict)))
 640
 641 getDictionary :: BinHandle -> IO Dictionary
 642 getDictionary bh = do
 643   sz <- get bh
 644   elems <- sequence (take sz (repeat (getFS bh)))
 645   return (listArray (0,sz-1) elems)
 646
 647 ---------------------------------------------------------
 648 -- The Symbol Table
 649 ---------------------------------------------------------
 650
 651 -- On disk, the symbol table is an array of IfaceExtName, when
 652 -- reading it in we turn it into a SymbolTable.
 653
 654 type SymbolTable = Array Int Name
 655
 656 ---------------------------------------------------------
 657 -- Reading and writing FastStrings
 658 ---------------------------------------------------------
 659
 660 putFS :: BinHandle -> FastString -> IO ()
 661 putFS bh (FastString _ l _ buf _) = do
 662   put_ bh l
 663   withForeignPtr buf $ \ptr ->
 664     let
 665         go n | n == l    = return ()
 666              | otherwise = do
 667                 b <- peekElemOff ptr n
 668                 putByte bh b
 669                 go (n+1)
 670    in
 671    go 0
 672
 673 {- -- possible faster version, not quite there yet:
 674 getFS bh@BinMem{} = do
 675   (I# l) <- get bh
 676   arr <- readIORef (arr_r bh)
 677   off <- readFastMutInt (off_r bh)
 678   return $! (mkFastSubStringBA# arr off l)
 679 -}
 680 getFS :: BinHandle -> IO FastString
 681 getFS bh = do
 682   l <- get bh
 683   fp <- mallocForeignPtrBytes l
 684   withForeignPtr fp $ \ptr -> do
 685   let
 686         go n | n == l = mkFastStringForeignPtr ptr fp l
 687              | otherwise = do
 688                 b <- getByte bh
 689                 pokeElemOff ptr n b
 690                 go (n+1)
 691   --
 692   go 0
 693
 694 instance Binary FastString where
 695   put_ bh f =
 696     case getUserData bh of {
 697         UserData { ud_dict_next = j_r,
 698                    ud_dict_map = out_r} -> do
 699     out <- readIORef out_r
 700     let uniq = getUnique f
 701     case lookupUFM out uniq of
 702         Just (j, _)  -> put_ bh j
 703         Nothing -> do
 704            j <- readFastMutInt j_r
 705            put_ bh j
 706            writeFastMutInt j_r (j + 1)
 707            writeIORef out_r $! addToUFM out uniq (j, f)
 708     }
 709
 710   get bh = do
 711         j <- get bh
 712         return $! (ud_dict (getUserData bh) ! j)