compiler/utils/Binary.hs

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