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