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