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