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