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