merge
[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 b, Binary c, Binary d, Binary e, Binary f) => Binary (a,b,c,d, e, f) where
466 put_ bh (a,b,c,d, e, f) = do put_ bh a; put_ bh b; put_ bh c; put_ bh d; put_ bh e; put_ bh f;
467 get bh = do a <- get bh
468 b <- get bh
469 c <- get bh
470 d <- get bh
471 e <- get bh
472 f <- get bh
473 return (a,b,c,d,e,f)
474
475 instance Binary a => Binary (Maybe a) where
476 put_ bh Nothing = putByte bh 0
477 put_ bh (Just a) = do putByte bh 1; put_ bh a
478 get bh = do h <- getWord8 bh
479 case h of
480 0 -> return Nothing
481 _ -> do x <- get bh; return (Just x)
482
483 instance (Binary a, Binary b) => Binary (Either a b) where
484 put_ bh (Left a) = do putByte bh 0; put_ bh a
485 put_ bh (Right b) = do putByte bh 1; put_ bh b
486 get bh = do h <- getWord8 bh
487 case h of
488 0 -> do a <- get bh ; return (Left a)
489 _ -> do b <- get bh ; return (Right b)
490
491 #if defined(__GLASGOW_HASKELL__) || 1
492 --to quote binary-0.3 on this code idea,
493 --
494 -- TODO This instance is not architecture portable. GMP stores numbers as
495 -- arrays of machine sized words, so the byte format is not portable across
496 -- architectures with different endianess and word size.
497 --
498 -- This makes it hard (impossible) to make an equivalent instance
499 -- with code that is compilable with non-GHC. Do we need any instance
500 -- Binary Integer, and if so, does it have to be blazing fast? Or can
501 -- we just change this instance to be portable like the rest of the
502 -- instances? (binary package has code to steal for that)
503 --
504 -- yes, we need Binary Integer and Binary Rational in basicTypes/Literal.lhs
505
506 instance Binary Integer where
507 -- XXX This is hideous
508 put_ bh i = put_ bh (show i)
509 get bh = do str <- get bh
510 case reads str of
511 [(i, "")] -> return i
512 _ -> fail ("Binary Integer: got " ++ show str)
513
514 {-
515 put_ bh (S# i#) = do putByte bh 0; put_ bh (I# i#)
516 put_ bh (J# s# a#) = do
517 putByte bh 1
518 put_ bh (I# s#)
519 let sz# = sizeofByteArray# a# -- in *bytes*
520 put_ bh (I# sz#) -- in *bytes*
521 putByteArray bh a# sz#
522
523 get bh = do
524 b <- getByte bh
525 case b of
526 0 -> do (I# i#) <- get bh
527 return (S# i#)
528 _ -> do (I# s#) <- get bh
529 sz <- get bh
530 (BA a#) <- getByteArray bh sz
531 return (J# s# a#)
532 -}
533
534 -- As for the rest of this code, even though this module
535 -- exports it, it doesn't seem to be used anywhere else
536 -- in GHC!
537
538 putByteArray :: BinHandle -> ByteArray# -> Int# -> IO ()
539 putByteArray bh a s# = loop 0#
540 where loop n#
541 | n# ==# s# = return ()
542 | otherwise = do
543 putByte bh (indexByteArray a n#)
544 loop (n# +# 1#)
545
546 getByteArray :: BinHandle -> Int -> IO ByteArray
547 getByteArray bh (I# sz) = do
548 (MBA arr) <- newByteArray sz
549 let loop n
550 | n ==# sz = return ()
551 | otherwise = do
552 w <- getByte bh
553 writeByteArray arr n w
554 loop (n +# 1#)
555 loop 0#
556 freezeByteArray arr
557
558
559 data ByteArray = BA ByteArray#
560 data MBA = MBA (MutableByteArray# RealWorld)
561
562 newByteArray :: Int# -> IO MBA
563 newByteArray sz = IO $ \s ->
564 case newByteArray# sz s of { (# s, arr #) ->
565 (# s, MBA arr #) }
566
567 freezeByteArray :: MutableByteArray# RealWorld -> IO ByteArray
568 freezeByteArray arr = IO $ \s ->
569 case unsafeFreezeByteArray# arr s of { (# s, arr #) ->
570 (# s, BA arr #) }
571
572 writeByteArray :: MutableByteArray# RealWorld -> Int# -> Word8 -> IO ()
573 writeByteArray arr i (W8# w) = IO $ \s ->
574 case writeWord8Array# arr i w s of { s ->
575 (# s, () #) }
576
577 indexByteArray :: ByteArray# -> Int# -> Word8
578 indexByteArray a# n# = W8# (indexWord8Array# a# n#)
579
580 instance (Integral a, Binary a) => Binary (Ratio a) where
581 put_ bh (a :% b) = do put_ bh a; put_ bh b
582 get bh = do a <- get bh; b <- get bh; return (a :% b)
583 #endif
584
585 instance Binary (Bin a) where
586 put_ bh (BinPtr i) = put_ bh (fromIntegral i :: Int32)
587 get bh = do i <- get bh; return (BinPtr (fromIntegral (i :: Int32)))
588
589 -- -----------------------------------------------------------------------------
590 -- Instances for Data.Typeable stuff
591
592 #if __GLASGOW_HASKELL__ >= 701
593 instance Binary TyCon where
594 put_ bh (TyCon _ p m n) = do
595 put_ bh (p,m,n)
596 get bh = do
597 (p,m,n) <- get bh
598 return (mkTyCon3 p m n)
599 #else
600 instance Binary TyCon where
601 put_ bh ty_con = do
602 let s = tyConString ty_con
603 put_ bh s
604 get bh = do
605 s <- get bh
606 return (mkTyCon s)
607 #endif
608
609 instance Binary TypeRep where
610 put_ bh type_rep = do
611 let (ty_con, child_type_reps) = splitTyConApp type_rep
612 put_ bh ty_con
613 put_ bh child_type_reps
614 get bh = do
615 ty_con <- get bh
616 child_type_reps <- get bh
617 return (mkTyConApp ty_con child_type_reps)
618
619 -- -----------------------------------------------------------------------------
620 -- Lazy reading/writing
621
622 lazyPut :: Binary a => BinHandle -> a -> IO ()
623 lazyPut bh a = do
624 -- output the obj with a ptr to skip over it:
625 pre_a <- tellBin bh
626 put_ bh pre_a -- save a slot for the ptr
627 put_ bh a -- dump the object
628 q <- tellBin bh -- q = ptr to after object
629 putAt bh pre_a q -- fill in slot before a with ptr to q
630 seekBin bh q -- finally carry on writing at q
631
632 lazyGet :: Binary a => BinHandle -> IO a
633 lazyGet bh = do
634 p <- get bh -- a BinPtr
635 p_a <- tellBin bh
636 a <- unsafeInterleaveIO (getAt bh p_a)
637 seekBin bh p -- skip over the object for now
638 return a
639
640 -- -----------------------------------------------------------------------------
641 -- UserData
642 -- -----------------------------------------------------------------------------
643
644 data UserData =
645 UserData {
646 -- for *deserialising* only:
647 ud_get_name :: BinHandle -> IO Name,
648 ud_get_fs :: BinHandle -> IO FastString,
649
650 -- for *serialising* only:
651 ud_put_name :: BinHandle -> Name -> IO (),
652 ud_put_fs :: BinHandle -> FastString -> IO ()
653 }
654
655 newReadState :: (BinHandle -> IO Name)
656 -> (BinHandle -> IO FastString)
657 -> UserData
658 newReadState get_name get_fs
659 = UserData { ud_get_name = get_name,
660 ud_get_fs = get_fs,
661 ud_put_name = undef "put_name",
662 ud_put_fs = undef "put_fs"
663 }
664
665 newWriteState :: (BinHandle -> Name -> IO ())
666 -> (BinHandle -> FastString -> IO ())
667 -> UserData
668 newWriteState put_name put_fs
669 = UserData { ud_get_name = undef "get_name",
670 ud_get_fs = undef "get_fs",
671 ud_put_name = put_name,
672 ud_put_fs = put_fs
673 }
674
675 noUserData :: a
676 noUserData = undef "UserData"
677
678 undef :: String -> a
679 undef s = panic ("Binary.UserData: no " ++ s)
680
681 ---------------------------------------------------------
682 -- The Dictionary
683 ---------------------------------------------------------
684
685 type Dictionary = Array Int FastString -- The dictionary
686 -- Should be 0-indexed
687
688 putDictionary :: BinHandle -> Int -> UniqFM (Int,FastString) -> IO ()
689 putDictionary bh sz dict = do
690 put_ bh sz
691 mapM_ (putFS bh) (elems (array (0,sz-1) (eltsUFM dict)))
692
693 getDictionary :: BinHandle -> IO Dictionary
694 getDictionary bh = do
695 sz <- get bh
696 elems <- sequence (take sz (repeat (getFS bh)))
697 return (listArray (0,sz-1) elems)
698
699 ---------------------------------------------------------
700 -- The Symbol Table
701 ---------------------------------------------------------
702
703 -- On disk, the symbol table is an array of IfaceExtName, when
704 -- reading it in we turn it into a SymbolTable.
705
706 type SymbolTable = Array Int Name
707
708 ---------------------------------------------------------
709 -- Reading and writing FastStrings
710 ---------------------------------------------------------
711
712 putFS :: BinHandle -> FastString -> IO ()
713 putFS bh (FastString _ l _ buf _) = do
714 put_ bh l
715 withForeignPtr buf $ \ptr ->
716 let
717 go n | n == l = return ()
718 | otherwise = do
719 b <- peekElemOff ptr n
720 putByte bh b
721 go (n+1)
722 in
723 go 0
724
725 {- -- possible faster version, not quite there yet:
726 getFS bh@BinMem{} = do
727 (I# l) <- get bh
728 arr <- readIORef (arr_r bh)
729 off <- readFastMutInt (off_r bh)
730 return $! (mkFastSubStringBA# arr off l)
731 -}
732 getFS :: BinHandle -> IO FastString
733 getFS bh = do
734 l <- get bh
735 fp <- mallocForeignPtrBytes l
736 withForeignPtr fp $ \ptr -> do
737 let
738 go n | n == l = mkFastStringForeignPtr ptr fp l
739 | otherwise = do
740 b <- getByte bh
741 pokeElemOff ptr n b
742 go (n+1)
743 --
744 go 0
745
746 instance Binary FastString where
747 put_ bh f =
748 case getUserData bh of
749 UserData { ud_put_fs = put_fs } -> put_fs bh f
750
751 get bh =
752 case getUserData bh of
753 UserData { ud_get_fs = get_fs } -> get_fs bh
754
755 -- Here to avoid loop
756
757 instance Binary Fingerprint where
758 put_ h (Fingerprint w1 w2) = do put_ h w1; put_ h w2
759 get h = do w1 <- get h; w2 <- get h; return (Fingerprint w1 w2)
760
761 instance Binary FunctionOrData where
762 put_ bh IsFunction = putByte bh 0
763 put_ bh IsData = putByte bh 1
764 get bh = do
765 h <- getByte bh
766 case h of
767 0 -> return IsFunction
768 1 -> return IsData
769 _ -> panic "Binary FunctionOrData"
770