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