Remove the trivial mkFastStringFastBytes wrapper
[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 lazyGet :: Binary a => BinHandle -> IO a
639 lazyGet bh = do
640 p <- get bh -- a BinPtr
641 p_a <- tellBin bh
642 a <- unsafeInterleaveIO (getAt bh p_a)
643 seekBin bh p -- skip over the object for now
644 return a
645
646 -- -----------------------------------------------------------------------------
647 -- UserData
648 -- -----------------------------------------------------------------------------
649
650 data UserData =
651 UserData {
652 -- for *deserialising* only:
653 ud_get_name :: BinHandle -> IO Name,
654 ud_get_fs :: BinHandle -> IO FastString,
655
656 -- for *serialising* only:
657 ud_put_name :: BinHandle -> Name -> IO (),
658 ud_put_fs :: BinHandle -> FastString -> IO ()
659 }
660
661 newReadState :: (BinHandle -> IO Name)
662 -> (BinHandle -> IO FastString)
663 -> UserData
664 newReadState get_name get_fs
665 = UserData { ud_get_name = get_name,
666 ud_get_fs = get_fs,
667 ud_put_name = undef "put_name",
668 ud_put_fs = undef "put_fs"
669 }
670
671 newWriteState :: (BinHandle -> Name -> IO ())
672 -> (BinHandle -> FastString -> IO ())
673 -> UserData
674 newWriteState put_name put_fs
675 = UserData { ud_get_name = undef "get_name",
676 ud_get_fs = undef "get_fs",
677 ud_put_name = put_name,
678 ud_put_fs = put_fs
679 }
680
681 noUserData :: a
682 noUserData = undef "UserData"
683
684 undef :: String -> a
685 undef s = panic ("Binary.UserData: no " ++ s)
686
687 ---------------------------------------------------------
688 -- The Dictionary
689 ---------------------------------------------------------
690
691 type Dictionary = Array Int FastString -- The dictionary
692 -- Should be 0-indexed
693
694 putDictionary :: BinHandle -> Int -> UniqFM (Int,FastString) -> IO ()
695 putDictionary bh sz dict = do
696 put_ bh sz
697 mapM_ (putFS bh) (elems (array (0,sz-1) (eltsUFM dict)))
698
699 getDictionary :: BinHandle -> IO Dictionary
700 getDictionary bh = do
701 sz <- get bh
702 elems <- sequence (take sz (repeat (getFS bh)))
703 return (listArray (0,sz-1) elems)
704
705 ---------------------------------------------------------
706 -- The Symbol Table
707 ---------------------------------------------------------
708
709 -- On disk, the symbol table is an array of IfaceExtName, when
710 -- reading it in we turn it into a SymbolTable.
711
712 type SymbolTable = Array Int Name
713
714 ---------------------------------------------------------
715 -- Reading and writing FastStrings
716 ---------------------------------------------------------
717
718 putFS :: BinHandle -> FastString -> IO ()
719 putFS bh fs = putBS bh $ fastStringToFastBytes fs
720
721 getFS :: BinHandle -> IO FastString
722 getFS bh = do bs <- getBS bh
723 mkFastStringByteString bs
724
725 putBS :: BinHandle -> ByteString -> IO ()
726 putBS bh bs =
727 BS.unsafeUseAsCStringLen bs $ \(ptr, l) -> do
728 put_ bh l
729 let
730 go n | n == l = return ()
731 | otherwise = do
732 b <- peekElemOff (castPtr ptr) n
733 putByte bh b
734 go (n+1)
735 go 0
736
737 {- -- possible faster version, not quite there yet:
738 getBS bh@BinMem{} = do
739 (I# l) <- get bh
740 arr <- readIORef (arr_r bh)
741 off <- readFastMutInt (off_r bh)
742 return $! (mkFastSubBytesBA# arr off l)
743 -}
744 getBS :: BinHandle -> IO ByteString
745 getBS bh = do
746 l <- get bh
747 fp <- mallocForeignPtrBytes l
748 withForeignPtr fp $ \ptr -> do
749 let
750 go n | n == l = return $ BS.fromForeignPtr fp 0 l
751 | otherwise = do
752 b <- getByte bh
753 pokeElemOff ptr n b
754 go (n+1)
755 --
756 go 0
757
758 instance Binary ByteString where
759 put_ bh f = putBS bh f
760 get bh = getBS bh
761
762 instance Binary FastString where
763 put_ bh f =
764 case getUserData bh of
765 UserData { ud_put_fs = put_fs } -> put_fs bh f
766
767 get bh =
768 case getUserData bh of
769 UserData { ud_get_fs = get_fs } -> get_fs bh
770
771 -- Here to avoid loop
772
773 instance Binary Fingerprint where
774 put_ h (Fingerprint w1 w2) = do put_ h w1; put_ h w2
775 get h = do w1 <- get h; w2 <- get h; return (Fingerprint w1 w2)
776
777 instance Binary FunctionOrData where
778 put_ bh IsFunction = putByte bh 0
779 put_ bh IsData = putByte bh 1
780 get bh = do
781 h <- getByte bh
782 case h of
783 0 -> return IsFunction
784 1 -> return IsData
785 _ -> panic "Binary FunctionOrData"
786