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