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