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