fix Binary instance for TyCon following Typeable implementation
[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
22 openBinIO, openBinIO_,
23 openBinMem,
24 -- closeBin,
25
26 seekBin,
27 seekBy,
28 tellBin,
29 castBin,
30
31 writeBinMem,
32 readBinMem,
33
34 fingerprintBinMem,
35 computeFingerprint,
36
37 isEOFBin,
38
39 putAt, getAt,
40
41 -- for writing instances:
42 putByte,
43 getByte,
44
45 -- lazy Bin I/O
46 lazyGet,
47 lazyPut,
48
49 #ifdef __GLASGOW_HASKELL__
50 -- GHC only:
51 ByteArray(..),
52 getByteArray,
53 putByteArray,
54 #endif
55
56 UserData(..), getUserData, setUserData,
57 newReadState, newWriteState,
58 putDictionary, getDictionary, putFS,
59 ) where
60
61 #include "HsVersions.h"
62
63 -- The *host* architecture version:
64 #include "../includes/MachDeps.h"
65
66 import {-# SOURCE #-} Name (Name)
67 import FastString
68 import Panic
69 import UniqFM
70 import FastMutInt
71 import Fingerprint
72 import BasicTypes
73
74 import Foreign
75 import Data.Array
76 import Data.IORef
77 import Data.Char ( ord, chr )
78 import Data.Typeable
79 #if __GLASGOW_HASKELL__ >= 701
80 import Data.Typeable.Internal
81 #endif
82 import Control.Monad ( when )
83 import System.IO as IO
84 import System.IO.Unsafe ( unsafeInterleaveIO )
85 import System.IO.Error ( mkIOError, eofErrorType )
86 import GHC.Real ( Ratio(..) )
87 import GHC.Exts
88 import GHC.Word ( Word8(..) )
89
90 import GHC.IO ( IO(..) )
91
92 type BinArray = ForeignPtr Word8
93
94 ---------------------------------------------------------------
95 -- BinHandle
96 ---------------------------------------------------------------
97
98 data BinHandle
99 = BinMem { -- binary data stored in an unboxed array
100 bh_usr :: UserData, -- sigh, need parameterized modules :-)
101 _off_r :: !FastMutInt, -- the current offset
102 _sz_r :: !FastMutInt, -- size of the array (cached)
103 _arr_r :: !(IORef BinArray) -- the array (bounds: (0,size-1))
104 }
105 -- XXX: should really store a "high water mark" for dumping out
106 -- the binary data to a file.
107
108 | BinIO { -- binary data stored in a file
109 bh_usr :: UserData,
110 _off_r :: !FastMutInt, -- the current offset (cached)
111 _hdl :: !IO.Handle -- the file handle (must be seekable)
112 }
113 -- cache the file ptr in BinIO; using hTell is too expensive
114 -- to call repeatedly. If anyone else is modifying this Handle
115 -- at the same time, we'll be screwed.
116
117 getUserData :: BinHandle -> UserData
118 getUserData bh = bh_usr bh
119
120 setUserData :: BinHandle -> UserData -> BinHandle
121 setUserData bh us = bh { bh_usr = us }
122
123
124 ---------------------------------------------------------------
125 -- Bin
126 ---------------------------------------------------------------
127
128 newtype Bin a = BinPtr Int
129 deriving (Eq, Ord, Show, Bounded)
130
131 castBin :: Bin a -> Bin b
132 castBin (BinPtr i) = BinPtr i
133
134 ---------------------------------------------------------------
135 -- class Binary
136 ---------------------------------------------------------------
137
138 class Binary a where
139 put_ :: BinHandle -> a -> IO ()
140 put :: BinHandle -> a -> IO (Bin a)
141 get :: BinHandle -> IO a
142
143 -- define one of put_, put. Use of put_ is recommended because it
144 -- is more likely that tail-calls can kick in, and we rarely need the
145 -- position return value.
146 put_ bh a = do _ <- put bh a; return ()
147 put bh a = do p <- tellBin bh; put_ bh a; return p
148
149 putAt :: Binary a => BinHandle -> Bin a -> a -> IO ()
150 putAt bh p x = do seekBin bh p; put_ bh x; return ()
151
152 getAt :: Binary a => BinHandle -> Bin a -> IO a
153 getAt bh p = do seekBin bh p; get bh
154
155 openBinIO_ :: IO.Handle -> IO BinHandle
156 openBinIO_ h = openBinIO h
157
158 openBinIO :: IO.Handle -> IO BinHandle
159 openBinIO h = do
160 r <- newFastMutInt
161 writeFastMutInt r 0
162 return (BinIO noUserData r h)
163
164 openBinMem :: Int -> IO BinHandle
165 openBinMem size
166 | size <= 0 = error "Data.Binary.openBinMem: size must be >= 0"
167 | otherwise = do
168 arr <- mallocForeignPtrBytes size
169 arr_r <- newIORef arr
170 ix_r <- newFastMutInt
171 writeFastMutInt ix_r 0
172 sz_r <- newFastMutInt
173 writeFastMutInt sz_r size
174 return (BinMem noUserData ix_r sz_r arr_r)
175
176 tellBin :: BinHandle -> IO (Bin a)
177 tellBin (BinIO _ r _) = do ix <- readFastMutInt r; return (BinPtr ix)
178 tellBin (BinMem _ r _ _) = do ix <- readFastMutInt r; return (BinPtr ix)
179
180 seekBin :: BinHandle -> Bin a -> IO ()
181 seekBin (BinIO _ ix_r h) (BinPtr p) = do
182 writeFastMutInt ix_r p
183 hSeek h AbsoluteSeek (fromIntegral p)
184 seekBin h@(BinMem _ ix_r sz_r _) (BinPtr p) = do
185 sz <- readFastMutInt sz_r
186 if (p >= sz)
187 then do expandBin h p; writeFastMutInt ix_r p
188 else writeFastMutInt ix_r p
189
190 seekBy :: BinHandle -> Int -> IO ()
191 seekBy (BinIO _ ix_r h) off = do
192 ix <- readFastMutInt ix_r
193 let ix' = ix + off
194 writeFastMutInt ix_r ix'
195 hSeek h AbsoluteSeek (fromIntegral ix')
196 seekBy h@(BinMem _ ix_r sz_r _) off = do
197 sz <- readFastMutInt sz_r
198 ix <- readFastMutInt ix_r
199 let ix' = ix + off
200 if (ix' >= sz)
201 then do expandBin h ix'; writeFastMutInt ix_r ix'
202 else writeFastMutInt ix_r ix'
203
204 isEOFBin :: BinHandle -> IO Bool
205 isEOFBin (BinMem _ ix_r sz_r _) = do
206 ix <- readFastMutInt ix_r
207 sz <- readFastMutInt sz_r
208 return (ix >= sz)
209 isEOFBin (BinIO _ _ h) = hIsEOF h
210
211 writeBinMem :: BinHandle -> FilePath -> IO ()
212 writeBinMem (BinIO _ _ _) _ = error "Data.Binary.writeBinMem: not a memory handle"
213 writeBinMem (BinMem _ ix_r _ arr_r) fn = do
214 h <- openBinaryFile fn WriteMode
215 arr <- readIORef arr_r
216 ix <- readFastMutInt ix_r
217 withForeignPtr arr $ \p -> hPutBuf h p ix
218 hClose h
219
220 readBinMem :: FilePath -> IO BinHandle
221 -- Return a BinHandle with a totally undefined State
222 readBinMem filename = do
223 h <- openBinaryFile filename ReadMode
224 filesize' <- hFileSize h
225 let filesize = fromIntegral filesize'
226 arr <- mallocForeignPtrBytes (filesize*2)
227 count <- withForeignPtr arr $ \p -> hGetBuf h p filesize
228 when (count /= filesize) $
229 error ("Binary.readBinMem: only read " ++ show count ++ " bytes")
230 hClose h
231 arr_r <- newIORef arr
232 ix_r <- newFastMutInt
233 writeFastMutInt ix_r 0
234 sz_r <- newFastMutInt
235 writeFastMutInt sz_r filesize
236 return (BinMem noUserData ix_r sz_r arr_r)
237
238 fingerprintBinMem :: BinHandle -> IO Fingerprint
239 fingerprintBinMem (BinIO _ _ _) = error "Binary.md5BinMem: not a memory handle"
240 fingerprintBinMem (BinMem _ ix_r _ arr_r) = do
241 arr <- readIORef arr_r
242 ix <- readFastMutInt ix_r
243 withForeignPtr arr $ \p -> fingerprintData p ix
244
245 computeFingerprint :: Binary a
246 => (BinHandle -> Name -> IO ())
247 -> a
248 -> IO Fingerprint
249
250 computeFingerprint put_name a = do
251 bh <- openBinMem (3*1024) -- just less than a block
252 ud <- newWriteState put_name putFS
253 bh <- return $ setUserData bh ud
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_dict :: Dictionary,
638 ud_symtab :: SymbolTable,
639
640 -- for *serialising* only:
641 ud_put_name :: BinHandle -> Name -> IO (),
642 ud_put_fs :: BinHandle -> FastString -> IO ()
643 }
644
645 newReadState :: Dictionary -> IO UserData
646 newReadState dict = do
647 return UserData { ud_dict = dict,
648 ud_symtab = undef "symtab",
649 ud_put_name = undef "put_name",
650 ud_put_fs = undef "put_fs"
651 }
652
653 newWriteState :: (BinHandle -> Name -> IO ())
654 -> (BinHandle -> FastString -> IO ())
655 -> IO UserData
656 newWriteState put_name put_fs = do
657 return UserData { ud_dict = undef "dict",
658 ud_symtab = undef "symtab",
659 ud_put_name = put_name,
660 ud_put_fs = put_fs
661 }
662
663 noUserData :: a
664 noUserData = undef "UserData"
665
666 undef :: String -> a
667 undef s = panic ("Binary.UserData: no " ++ s)
668
669 ---------------------------------------------------------
670 -- The Dictionary
671 ---------------------------------------------------------
672
673 type Dictionary = Array Int FastString -- The dictionary
674 -- Should be 0-indexed
675
676 putDictionary :: BinHandle -> Int -> UniqFM (Int,FastString) -> IO ()
677 putDictionary bh sz dict = do
678 put_ bh sz
679 mapM_ (putFS bh) (elems (array (0,sz-1) (eltsUFM dict)))
680
681 getDictionary :: BinHandle -> IO Dictionary
682 getDictionary bh = do
683 sz <- get bh
684 elems <- sequence (take sz (repeat (getFS bh)))
685 return (listArray (0,sz-1) elems)
686
687 ---------------------------------------------------------
688 -- The Symbol Table
689 ---------------------------------------------------------
690
691 -- On disk, the symbol table is an array of IfaceExtName, when
692 -- reading it in we turn it into a SymbolTable.
693
694 type SymbolTable = Array Int Name
695
696 ---------------------------------------------------------
697 -- Reading and writing FastStrings
698 ---------------------------------------------------------
699
700 putFS :: BinHandle -> FastString -> IO ()
701 putFS bh (FastString _ l _ buf _) = do
702 put_ bh l
703 withForeignPtr buf $ \ptr ->
704 let
705 go n | n == l = return ()
706 | otherwise = do
707 b <- peekElemOff ptr n
708 putByte bh b
709 go (n+1)
710 in
711 go 0
712
713 {- -- possible faster version, not quite there yet:
714 getFS bh@BinMem{} = do
715 (I# l) <- get bh
716 arr <- readIORef (arr_r bh)
717 off <- readFastMutInt (off_r bh)
718 return $! (mkFastSubStringBA# arr off l)
719 -}
720 getFS :: BinHandle -> IO FastString
721 getFS bh = do
722 l <- get bh
723 fp <- mallocForeignPtrBytes l
724 withForeignPtr fp $ \ptr -> do
725 let
726 go n | n == l = mkFastStringForeignPtr ptr fp l
727 | otherwise = do
728 b <- getByte bh
729 pokeElemOff ptr n b
730 go (n+1)
731 --
732 go 0
733
734 instance Binary FastString where
735 put_ bh f =
736 case getUserData bh of
737 UserData { ud_put_fs = put_fs } -> put_fs bh f
738
739 get bh = do
740 j <- get bh
741 return $! (ud_dict (getUserData bh) ! (fromIntegral (j :: Word32)))
742
743 -- Here to avoid loop
744
745 instance Binary Fingerprint where
746 put_ h (Fingerprint w1 w2) = do put_ h w1; put_ h w2
747 get h = do w1 <- get h; w2 <- get h; return (Fingerprint w1 w2)
748
749 instance Binary FunctionOrData where
750 put_ bh IsFunction = putByte bh 0
751 put_ bh IsData = putByte bh 1
752 get bh = do
753 h <- getByte bh
754 case h of
755 0 -> return IsFunction
756 1 -> return IsData
757 _ -> panic "Binary FunctionOrData"
758