Merge branch 'master' of darcs.haskell.org:/home/darcs/ghc
[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.Time
80 import Data.Typeable
81 import Data.Typeable.Internal
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 bh <- return $ setUserData bh $ newWriteState put_name putFS
253 put_ bh a
254 fingerprintBinMem bh
255
256 -- expand the size of the array to include a specified offset
257 expandBin :: BinHandle -> Int -> IO ()
258 expandBin (BinMem _ _ sz_r arr_r) off = do
259 sz <- readFastMutInt sz_r
260 let sz' = head (dropWhile (<= off) (iterate (* 2) sz))
261 arr <- readIORef arr_r
262 arr' <- mallocForeignPtrBytes sz'
263 withForeignPtr arr $ \old ->
264 withForeignPtr arr' $ \new ->
265 copyBytes new old sz
266 writeFastMutInt sz_r sz'
267 writeIORef arr_r arr'
268 expandBin (BinIO _ _ _) _ = return ()
269 -- no need to expand a file, we'll assume they expand by themselves.
270
271 -- -----------------------------------------------------------------------------
272 -- Low-level reading/writing of bytes
273
274 putWord8 :: BinHandle -> Word8 -> IO ()
275 putWord8 h@(BinMem _ ix_r sz_r arr_r) w = do
276 ix <- readFastMutInt ix_r
277 sz <- readFastMutInt sz_r
278 -- double the size of the array if it overflows
279 if (ix >= sz)
280 then do expandBin h ix
281 putWord8 h w
282 else do arr <- readIORef arr_r
283 withForeignPtr arr $ \p -> pokeByteOff p ix w
284 writeFastMutInt ix_r (ix+1)
285 return ()
286 putWord8 (BinIO _ ix_r h) w = do
287 ix <- readFastMutInt ix_r
288 hPutChar h (chr (fromIntegral w)) -- XXX not really correct
289 writeFastMutInt ix_r (ix+1)
290 return ()
291
292 getWord8 :: BinHandle -> IO Word8
293 getWord8 (BinMem _ ix_r sz_r arr_r) = do
294 ix <- readFastMutInt ix_r
295 sz <- readFastMutInt sz_r
296 when (ix >= sz) $
297 ioError (mkIOError eofErrorType "Data.Binary.getWord8" Nothing Nothing)
298 arr <- readIORef arr_r
299 w <- withForeignPtr arr $ \p -> peekByteOff p ix
300 writeFastMutInt ix_r (ix+1)
301 return w
302 getWord8 (BinIO _ ix_r h) = do
303 ix <- readFastMutInt ix_r
304 c <- hGetChar h
305 writeFastMutInt ix_r (ix+1)
306 return $! (fromIntegral (ord c)) -- XXX not really correct
307
308 putByte :: BinHandle -> Word8 -> IO ()
309 putByte bh w = put_ bh w
310
311 getByte :: BinHandle -> IO Word8
312 getByte = getWord8
313
314 -- -----------------------------------------------------------------------------
315 -- Primitve Word writes
316
317 instance Binary Word8 where
318 put_ = putWord8
319 get = getWord8
320
321 instance Binary Word16 where
322 put_ h w = do -- XXX too slow.. inline putWord8?
323 putByte h (fromIntegral (w `shiftR` 8))
324 putByte h (fromIntegral (w .&. 0xff))
325 get h = do
326 w1 <- getWord8 h
327 w2 <- getWord8 h
328 return $! ((fromIntegral w1 `shiftL` 8) .|. fromIntegral w2)
329
330
331 instance Binary Word32 where
332 put_ h w = do
333 putByte h (fromIntegral (w `shiftR` 24))
334 putByte h (fromIntegral ((w `shiftR` 16) .&. 0xff))
335 putByte h (fromIntegral ((w `shiftR` 8) .&. 0xff))
336 putByte h (fromIntegral (w .&. 0xff))
337 get h = do
338 w1 <- getWord8 h
339 w2 <- getWord8 h
340 w3 <- getWord8 h
341 w4 <- getWord8 h
342 return $! ((fromIntegral w1 `shiftL` 24) .|.
343 (fromIntegral w2 `shiftL` 16) .|.
344 (fromIntegral w3 `shiftL` 8) .|.
345 (fromIntegral w4))
346
347 instance Binary Word64 where
348 put_ h w = do
349 putByte h (fromIntegral (w `shiftR` 56))
350 putByte h (fromIntegral ((w `shiftR` 48) .&. 0xff))
351 putByte h (fromIntegral ((w `shiftR` 40) .&. 0xff))
352 putByte h (fromIntegral ((w `shiftR` 32) .&. 0xff))
353 putByte h (fromIntegral ((w `shiftR` 24) .&. 0xff))
354 putByte h (fromIntegral ((w `shiftR` 16) .&. 0xff))
355 putByte h (fromIntegral ((w `shiftR` 8) .&. 0xff))
356 putByte h (fromIntegral (w .&. 0xff))
357 get h = do
358 w1 <- getWord8 h
359 w2 <- getWord8 h
360 w3 <- getWord8 h
361 w4 <- getWord8 h
362 w5 <- getWord8 h
363 w6 <- getWord8 h
364 w7 <- getWord8 h
365 w8 <- getWord8 h
366 return $! ((fromIntegral w1 `shiftL` 56) .|.
367 (fromIntegral w2 `shiftL` 48) .|.
368 (fromIntegral w3 `shiftL` 40) .|.
369 (fromIntegral w4 `shiftL` 32) .|.
370 (fromIntegral w5 `shiftL` 24) .|.
371 (fromIntegral w6 `shiftL` 16) .|.
372 (fromIntegral w7 `shiftL` 8) .|.
373 (fromIntegral w8))
374
375 -- -----------------------------------------------------------------------------
376 -- Primitve Int writes
377
378 instance Binary Int8 where
379 put_ h w = put_ h (fromIntegral w :: Word8)
380 get h = do w <- get h; return $! (fromIntegral (w::Word8))
381
382 instance Binary Int16 where
383 put_ h w = put_ h (fromIntegral w :: Word16)
384 get h = do w <- get h; return $! (fromIntegral (w::Word16))
385
386 instance Binary Int32 where
387 put_ h w = put_ h (fromIntegral w :: Word32)
388 get h = do w <- get h; return $! (fromIntegral (w::Word32))
389
390 instance Binary Int64 where
391 put_ h w = put_ h (fromIntegral w :: Word64)
392 get h = do w <- get h; return $! (fromIntegral (w::Word64))
393
394 -- -----------------------------------------------------------------------------
395 -- Instances for standard types
396
397 instance Binary () where
398 put_ _ () = return ()
399 get _ = return ()
400
401 instance Binary Bool where
402 put_ bh b = putByte bh (fromIntegral (fromEnum b))
403 get bh = do x <- getWord8 bh; return $! (toEnum (fromIntegral x))
404
405 instance Binary Char where
406 put_ bh c = put_ bh (fromIntegral (ord c) :: Word32)
407 get bh = do x <- get bh; return $! (chr (fromIntegral (x :: Word32)))
408
409 instance Binary Int where
410 put_ bh i = put_ bh (fromIntegral i :: Int64)
411 get bh = do
412 x <- get bh
413 return $! (fromIntegral (x :: Int64))
414
415 instance Binary a => Binary [a] where
416 put_ bh l = do
417 let len = length l
418 if (len < 0xff)
419 then putByte bh (fromIntegral len :: Word8)
420 else do putByte bh 0xff; put_ bh (fromIntegral len :: Word32)
421 mapM_ (put_ bh) l
422 get bh = do
423 b <- getByte bh
424 len <- if b == 0xff
425 then get bh
426 else return (fromIntegral b :: Word32)
427 let loop 0 = return []
428 loop n = do a <- get bh; as <- loop (n-1); return (a:as)
429 loop len
430
431 instance (Binary a, Binary b) => Binary (a,b) where
432 put_ bh (a,b) = do put_ bh a; put_ bh b
433 get bh = do a <- get bh
434 b <- get bh
435 return (a,b)
436
437 instance (Binary a, Binary b, Binary c) => Binary (a,b,c) where
438 put_ bh (a,b,c) = do put_ bh a; put_ bh b; put_ bh c
439 get bh = do a <- get bh
440 b <- get bh
441 c <- get bh
442 return (a,b,c)
443
444 instance (Binary a, Binary b, Binary c, Binary d) => Binary (a,b,c,d) where
445 put_ bh (a,b,c,d) = do put_ bh a; put_ bh b; put_ bh c; put_ bh d
446 get bh = do a <- get bh
447 b <- get bh
448 c <- get bh
449 d <- get bh
450 return (a,b,c,d)
451
452 instance (Binary a, Binary b, Binary c, Binary d, Binary e) => Binary (a,b,c,d, e) where
453 put_ bh (a,b,c,d, e) = do put_ bh a; put_ bh b; put_ bh c; put_ bh d; put_ bh e;
454 get bh = do a <- get bh
455 b <- get bh
456 c <- get bh
457 d <- get bh
458 e <- get bh
459 return (a,b,c,d,e)
460
461 instance (Binary a, Binary b, Binary c, Binary d, Binary e, Binary f) => Binary (a,b,c,d, e, f) where
462 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;
463 get bh = do a <- get bh
464 b <- get bh
465 c <- get bh
466 d <- get bh
467 e <- get bh
468 f <- get bh
469 return (a,b,c,d,e,f)
470
471 instance Binary a => Binary (Maybe a) where
472 put_ bh Nothing = putByte bh 0
473 put_ bh (Just a) = do putByte bh 1; put_ bh a
474 get bh = do h <- getWord8 bh
475 case h of
476 0 -> return Nothing
477 _ -> do x <- get bh; return (Just x)
478
479 instance (Binary a, Binary b) => Binary (Either a b) where
480 put_ bh (Left a) = do putByte bh 0; put_ bh a
481 put_ bh (Right b) = do putByte bh 1; put_ bh b
482 get bh = do h <- getWord8 bh
483 case h of
484 0 -> do a <- get bh ; return (Left a)
485 _ -> do b <- get bh ; return (Right b)
486
487 instance Binary UTCTime where
488 put_ bh u = do put_ bh (utctDay u)
489 put_ bh (utctDayTime u)
490 get bh = do day <- get bh
491 dayTime <- get bh
492 return $ UTCTime { utctDay = day, utctDayTime = dayTime }
493
494 instance Binary Day where
495 put_ bh d = put_ bh (toModifiedJulianDay d)
496 get bh = do i <- get bh
497 return $ ModifiedJulianDay { toModifiedJulianDay = i }
498
499 instance Binary DiffTime where
500 put_ bh dt = put_ bh (toRational dt)
501 get bh = do r <- get bh
502 return $ fromRational r
503
504 #if defined(__GLASGOW_HASKELL__) || 1
505 --to quote binary-0.3 on this code idea,
506 --
507 -- TODO This instance is not architecture portable. GMP stores numbers as
508 -- arrays of machine sized words, so the byte format is not portable across
509 -- architectures with different endianess and word size.
510 --
511 -- This makes it hard (impossible) to make an equivalent instance
512 -- with code that is compilable with non-GHC. Do we need any instance
513 -- Binary Integer, and if so, does it have to be blazing fast? Or can
514 -- we just change this instance to be portable like the rest of the
515 -- instances? (binary package has code to steal for that)
516 --
517 -- yes, we need Binary Integer and Binary Rational in basicTypes/Literal.lhs
518
519 instance Binary Integer where
520 -- XXX This is hideous
521 put_ bh i = put_ bh (show i)
522 get bh = do str <- get bh
523 case reads str of
524 [(i, "")] -> return i
525 _ -> fail ("Binary Integer: got " ++ show str)
526
527 {-
528 put_ bh (S# i#) = do putByte bh 0; put_ bh (I# i#)
529 put_ bh (J# s# a#) = do
530 putByte bh 1
531 put_ bh (I# s#)
532 let sz# = sizeofByteArray# a# -- in *bytes*
533 put_ bh (I# sz#) -- in *bytes*
534 putByteArray bh a# sz#
535
536 get bh = do
537 b <- getByte bh
538 case b of
539 0 -> do (I# i#) <- get bh
540 return (S# i#)
541 _ -> do (I# s#) <- get bh
542 sz <- get bh
543 (BA a#) <- getByteArray bh sz
544 return (J# s# a#)
545 -}
546
547 -- As for the rest of this code, even though this module
548 -- exports it, it doesn't seem to be used anywhere else
549 -- in GHC!
550
551 putByteArray :: BinHandle -> ByteArray# -> Int# -> IO ()
552 putByteArray bh a s# = loop 0#
553 where loop n#
554 | n# ==# s# = return ()
555 | otherwise = do
556 putByte bh (indexByteArray a n#)
557 loop (n# +# 1#)
558
559 getByteArray :: BinHandle -> Int -> IO ByteArray
560 getByteArray bh (I# sz) = do
561 (MBA arr) <- newByteArray sz
562 let loop n
563 | n ==# sz = return ()
564 | otherwise = do
565 w <- getByte bh
566 writeByteArray arr n w
567 loop (n +# 1#)
568 loop 0#
569 freezeByteArray arr
570
571
572 data ByteArray = BA ByteArray#
573 data MBA = MBA (MutableByteArray# RealWorld)
574
575 newByteArray :: Int# -> IO MBA
576 newByteArray sz = IO $ \s ->
577 case newByteArray# sz s of { (# s, arr #) ->
578 (# s, MBA arr #) }
579
580 freezeByteArray :: MutableByteArray# RealWorld -> IO ByteArray
581 freezeByteArray arr = IO $ \s ->
582 case unsafeFreezeByteArray# arr s of { (# s, arr #) ->
583 (# s, BA arr #) }
584
585 writeByteArray :: MutableByteArray# RealWorld -> Int# -> Word8 -> IO ()
586 writeByteArray arr i (W8# w) = IO $ \s ->
587 case writeWord8Array# arr i w s of { s ->
588 (# s, () #) }
589
590 indexByteArray :: ByteArray# -> Int# -> Word8
591 indexByteArray a# n# = W8# (indexWord8Array# a# n#)
592
593 instance (Integral a, Binary a) => Binary (Ratio a) where
594 put_ bh (a :% b) = do put_ bh a; put_ bh b
595 get bh = do a <- get bh; b <- get bh; return (a :% b)
596 #endif
597
598 instance Binary (Bin a) where
599 put_ bh (BinPtr i) = put_ bh (fromIntegral i :: Int32)
600 get bh = do i <- get bh; return (BinPtr (fromIntegral (i :: Int32)))
601
602 -- -----------------------------------------------------------------------------
603 -- Instances for Data.Typeable stuff
604
605 instance Binary TyCon where
606 put_ bh (TyCon _ p m n) = do
607 put_ bh (p,m,n)
608 get bh = do
609 (p,m,n) <- get bh
610 return (mkTyCon3 p m n)
611
612 instance Binary TypeRep where
613 put_ bh type_rep = do
614 let (ty_con, child_type_reps) = splitTyConApp type_rep
615 put_ bh ty_con
616 put_ bh child_type_reps
617 get bh = do
618 ty_con <- get bh
619 child_type_reps <- get bh
620 return (mkTyConApp ty_con child_type_reps)
621
622 -- -----------------------------------------------------------------------------
623 -- Lazy reading/writing
624
625 lazyPut :: Binary a => BinHandle -> a -> IO ()
626 lazyPut bh a = do
627 -- output the obj with a ptr to skip over it:
628 pre_a <- tellBin bh
629 put_ bh pre_a -- save a slot for the ptr
630 put_ bh a -- dump the object
631 q <- tellBin bh -- q = ptr to after object
632 putAt bh pre_a q -- fill in slot before a with ptr to q
633 seekBin bh q -- finally carry on writing at q
634
635 lazyGet :: Binary a => BinHandle -> IO a
636 lazyGet bh = do
637 p <- get bh -- a BinPtr
638 p_a <- tellBin bh
639 a <- unsafeInterleaveIO (getAt bh p_a)
640 seekBin bh p -- skip over the object for now
641 return a
642
643 -- -----------------------------------------------------------------------------
644 -- UserData
645 -- -----------------------------------------------------------------------------
646
647 data UserData =
648 UserData {
649 -- for *deserialising* only:
650 ud_get_name :: BinHandle -> IO Name,
651 ud_get_fs :: BinHandle -> IO FastString,
652
653 -- for *serialising* only:
654 ud_put_name :: BinHandle -> Name -> IO (),
655 ud_put_fs :: BinHandle -> FastString -> IO ()
656 }
657
658 newReadState :: (BinHandle -> IO Name)
659 -> (BinHandle -> IO FastString)
660 -> UserData
661 newReadState get_name get_fs
662 = UserData { ud_get_name = get_name,
663 ud_get_fs = get_fs,
664 ud_put_name = undef "put_name",
665 ud_put_fs = undef "put_fs"
666 }
667
668 newWriteState :: (BinHandle -> Name -> IO ())
669 -> (BinHandle -> FastString -> IO ())
670 -> UserData
671 newWriteState put_name put_fs
672 = UserData { ud_get_name = undef "get_name",
673 ud_get_fs = undef "get_fs",
674 ud_put_name = put_name,
675 ud_put_fs = put_fs
676 }
677
678 noUserData :: a
679 noUserData = undef "UserData"
680
681 undef :: String -> a
682 undef s = panic ("Binary.UserData: no " ++ s)
683
684 ---------------------------------------------------------
685 -- The Dictionary
686 ---------------------------------------------------------
687
688 type Dictionary = Array Int FastString -- The dictionary
689 -- Should be 0-indexed
690
691 putDictionary :: BinHandle -> Int -> UniqFM (Int,FastString) -> IO ()
692 putDictionary bh sz dict = do
693 put_ bh sz
694 mapM_ (putFS bh) (elems (array (0,sz-1) (eltsUFM dict)))
695
696 getDictionary :: BinHandle -> IO Dictionary
697 getDictionary bh = do
698 sz <- get bh
699 elems <- sequence (take sz (repeat (getFS bh)))
700 return (listArray (0,sz-1) elems)
701
702 ---------------------------------------------------------
703 -- The Symbol Table
704 ---------------------------------------------------------
705
706 -- On disk, the symbol table is an array of IfaceExtName, when
707 -- reading it in we turn it into a SymbolTable.
708
709 type SymbolTable = Array Int Name
710
711 ---------------------------------------------------------
712 -- Reading and writing FastStrings
713 ---------------------------------------------------------
714
715 putFS :: BinHandle -> FastString -> IO ()
716 putFS bh fs = putFB bh $ fastStringToFastBytes fs
717
718 getFS :: BinHandle -> IO FastString
719 getFS bh = do fb <- getFB bh
720 mkFastStringFastBytes fb
721
722 putFB :: BinHandle -> FastBytes -> IO ()
723 putFB bh (FastBytes l buf) = do
724 put_ bh l
725 withForeignPtr buf $ \ptr ->
726 let
727 go n | n == l = return ()
728 | otherwise = do
729 b <- peekElemOff ptr n
730 putByte bh b
731 go (n+1)
732 in
733 go 0
734
735 {- -- possible faster version, not quite there yet:
736 getFB bh@BinMem{} = do
737 (I# l) <- get bh
738 arr <- readIORef (arr_r bh)
739 off <- readFastMutInt (off_r bh)
740 return $! (mkFastSubBytesBA# arr off l)
741 -}
742 getFB :: BinHandle -> IO FastBytes
743 getFB bh = do
744 l <- get bh
745 fp <- mallocForeignPtrBytes l
746 withForeignPtr fp $ \ptr -> do
747 let
748 go n | n == l = return $ foreignPtrToFastBytes fp l
749 | otherwise = do
750 b <- getByte bh
751 pokeElemOff ptr n b
752 go (n+1)
753 --
754 go 0
755
756 instance Binary FastBytes where
757 put_ bh f = putFB bh f
758 get bh = getFB bh
759
760 instance Binary FastString where
761 put_ bh f =
762 case getUserData bh of
763 UserData { ud_put_fs = put_fs } -> put_fs bh f
764
765 get bh =
766 case getUserData bh of
767 UserData { ud_get_fs = get_fs } -> get_fs bh
768
769 -- Here to avoid loop
770
771 instance Binary Fingerprint where
772 put_ h (Fingerprint w1 w2) = do put_ h w1; put_ h w2
773 get h = do w1 <- get h; w2 <- get h; return (Fingerprint w1 w2)
774
775 instance Binary FunctionOrData where
776 put_ bh IsFunction = putByte bh 0
777 put_ bh IsData = putByte bh 1
778 get bh = do
779 h <- getByte bh
780 case h of
781 0 -> return IsFunction
782 1 -> return IsData
783 _ -> panic "Binary FunctionOrData"
784