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