Fold base.git into ghc.git (re #8545)
[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 openBinMem,
24 -- closeBin,
25
26 seekBin,
27 seekBy,
28 tellBin,
29 castBin,
30
31 writeBinMem,
32 readBinMem,
33
34 fingerprintBinMem,
35 computeFingerprint,
36
37 isEOFBin,
38
39 putAt, getAt,
40
41 -- for writing instances:
42 putByte,
43 getByte,
44
45 -- lazy Bin I/O
46 lazyGet,
47 lazyPut,
48
49 #ifdef __GLASGOW_HASKELL__
50 -- GHC only:
51 ByteArray(..),
52 getByteArray,
53 putByteArray,
54 #endif
55
56 UserData(..), getUserData, setUserData,
57 newReadState, newWriteState,
58 putDictionary, getDictionary, putFS,
59 ) where
60
61 #include "HsVersions.h"
62
63 -- The *host* architecture version:
64 #include "../includes/MachDeps.h"
65
66 import {-# SOURCE #-} Name (Name)
67 import FastString
68 import Panic
69 import UniqFM
70 import FastMutInt
71 import Fingerprint
72 import BasicTypes
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 #if defined(__GLASGOW_HASKELL__) || 1
465 --to quote binary-0.3 on this code idea,
466 --
467 -- TODO This instance is not architecture portable. GMP stores numbers as
468 -- arrays of machine sized words, so the byte format is not portable across
469 -- architectures with different endianess and word size.
470 --
471 -- This makes it hard (impossible) to make an equivalent instance
472 -- with code that is compilable with non-GHC. Do we need any instance
473 -- Binary Integer, and if so, does it have to be blazing fast? Or can
474 -- we just change this instance to be portable like the rest of the
475 -- instances? (binary package has code to steal for that)
476 --
477 -- yes, we need Binary Integer and Binary Rational in basicTypes/Literal.lhs
478
479 instance Binary Integer where
480 -- XXX This is hideous
481 put_ bh i = put_ bh (show i)
482 get bh = do str <- get bh
483 case reads str of
484 [(i, "")] -> return i
485 _ -> fail ("Binary Integer: got " ++ show str)
486
487 {-
488 put_ bh (S# i#) = do putByte bh 0; put_ bh (I# i#)
489 put_ bh (J# s# a#) = do
490 putByte bh 1
491 put_ bh (I# s#)
492 let sz# = sizeofByteArray# a# -- in *bytes*
493 put_ bh (I# sz#) -- in *bytes*
494 putByteArray bh a# sz#
495
496 get bh = do
497 b <- getByte bh
498 case b of
499 0 -> do (I# i#) <- get bh
500 return (S# i#)
501 _ -> do (I# s#) <- get bh
502 sz <- get bh
503 (BA a#) <- getByteArray bh sz
504 return (J# s# a#)
505 -}
506
507 -- As for the rest of this code, even though this module
508 -- exports it, it doesn't seem to be used anywhere else
509 -- in GHC!
510
511 putByteArray :: BinHandle -> ByteArray# -> Int# -> IO ()
512 putByteArray bh a s# = loop 0#
513 where loop n#
514 | n# ==# s# = return ()
515 | otherwise = do
516 putByte bh (indexByteArray a n#)
517 loop (n# +# 1#)
518
519 getByteArray :: BinHandle -> Int -> IO ByteArray
520 getByteArray bh (I# sz) = do
521 (MBA arr) <- newByteArray sz
522 let loop n
523 | n ==# sz = return ()
524 | otherwise = do
525 w <- getByte bh
526 writeByteArray arr n w
527 loop (n +# 1#)
528 loop 0#
529 freezeByteArray arr
530
531
532 data ByteArray = BA ByteArray#
533 data MBA = MBA (MutableByteArray# RealWorld)
534
535 newByteArray :: Int# -> IO MBA
536 newByteArray sz = IO $ \s ->
537 case newByteArray# sz s of { (# s, arr #) ->
538 (# s, MBA arr #) }
539
540 freezeByteArray :: MutableByteArray# RealWorld -> IO ByteArray
541 freezeByteArray arr = IO $ \s ->
542 case unsafeFreezeByteArray# arr s of { (# s, arr #) ->
543 (# s, BA arr #) }
544
545 writeByteArray :: MutableByteArray# RealWorld -> Int# -> Word8 -> IO ()
546 writeByteArray arr i (W8# w) = IO $ \s ->
547 case writeWord8Array# arr i w s of { s ->
548 (# s, () #) }
549
550 indexByteArray :: ByteArray# -> Int# -> Word8
551 indexByteArray a# n# = W8# (indexWord8Array# a# n#)
552
553 instance (Integral a, Binary a) => Binary (Ratio a) where
554 put_ bh (a :% b) = do put_ bh a; put_ bh b
555 get bh = do a <- get bh; b <- get bh; return (a :% b)
556 #endif
557
558 instance Binary (Bin a) where
559 put_ bh (BinPtr i) = put_ bh (fromIntegral i :: Int32)
560 get bh = do i <- get bh; return (BinPtr (fromIntegral (i :: Int32)))
561
562 -- -----------------------------------------------------------------------------
563 -- Instances for Data.Typeable stuff
564
565 instance Binary TyCon where
566 put_ bh (TyCon _ p m n) = do
567 put_ bh (p,m,n)
568 get bh = do
569 (p,m,n) <- get bh
570 return (mkTyCon3 p m n)
571
572 instance Binary TypeRep where
573 put_ bh type_rep = do
574 let (ty_con, child_type_reps) = splitTyConApp type_rep
575 put_ bh ty_con
576 put_ bh child_type_reps
577 get bh = do
578 ty_con <- get bh
579 child_type_reps <- get bh
580 return (mkTyConApp ty_con child_type_reps)
581
582 -- -----------------------------------------------------------------------------
583 -- Lazy reading/writing
584
585 lazyPut :: Binary a => BinHandle -> a -> IO ()
586 lazyPut bh a = do
587 -- output the obj with a ptr to skip over it:
588 pre_a <- tellBin bh
589 put_ bh pre_a -- save a slot for the ptr
590 put_ bh a -- dump the object
591 q <- tellBin bh -- q = ptr to after object
592 putAt bh pre_a q -- fill in slot before a with ptr to q
593 seekBin bh q -- finally carry on writing at q
594
595 lazyGet :: Binary a => BinHandle -> IO a
596 lazyGet bh = do
597 p <- get bh -- a BinPtr
598 p_a <- tellBin bh
599 a <- unsafeInterleaveIO $ do
600 -- NB: Use a fresh off_r variable in the child thread, for thread
601 -- safety.
602 off_r <- newFastMutInt
603 getAt bh { _off_r = off_r } p_a
604 seekBin bh p -- skip over the object for now
605 return a
606
607 -- -----------------------------------------------------------------------------
608 -- UserData
609 -- -----------------------------------------------------------------------------
610
611 data UserData =
612 UserData {
613 -- for *deserialising* only:
614 ud_get_name :: BinHandle -> IO Name,
615 ud_get_fs :: BinHandle -> IO FastString,
616
617 -- for *serialising* only:
618 ud_put_name :: BinHandle -> Name -> IO (),
619 ud_put_fs :: BinHandle -> FastString -> IO ()
620 }
621
622 newReadState :: (BinHandle -> IO Name)
623 -> (BinHandle -> IO FastString)
624 -> UserData
625 newReadState get_name get_fs
626 = UserData { ud_get_name = get_name,
627 ud_get_fs = get_fs,
628 ud_put_name = undef "put_name",
629 ud_put_fs = undef "put_fs"
630 }
631
632 newWriteState :: (BinHandle -> Name -> IO ())
633 -> (BinHandle -> FastString -> IO ())
634 -> UserData
635 newWriteState put_name put_fs
636 = UserData { ud_get_name = undef "get_name",
637 ud_get_fs = undef "get_fs",
638 ud_put_name = put_name,
639 ud_put_fs = put_fs
640 }
641
642 noUserData :: a
643 noUserData = undef "UserData"
644
645 undef :: String -> a
646 undef s = panic ("Binary.UserData: no " ++ s)
647
648 ---------------------------------------------------------
649 -- The Dictionary
650 ---------------------------------------------------------
651
652 type Dictionary = Array Int FastString -- The dictionary
653 -- Should be 0-indexed
654
655 putDictionary :: BinHandle -> Int -> UniqFM (Int,FastString) -> IO ()
656 putDictionary bh sz dict = do
657 put_ bh sz
658 mapM_ (putFS bh) (elems (array (0,sz-1) (eltsUFM dict)))
659
660 getDictionary :: BinHandle -> IO Dictionary
661 getDictionary bh = do
662 sz <- get bh
663 elems <- sequence (take sz (repeat (getFS bh)))
664 return (listArray (0,sz-1) elems)
665
666 ---------------------------------------------------------
667 -- The Symbol Table
668 ---------------------------------------------------------
669
670 -- On disk, the symbol table is an array of IfaceExtName, when
671 -- reading it in we turn it into a SymbolTable.
672
673 type SymbolTable = Array Int Name
674
675 ---------------------------------------------------------
676 -- Reading and writing FastStrings
677 ---------------------------------------------------------
678
679 putFS :: BinHandle -> FastString -> IO ()
680 putFS bh fs = putBS bh $ fastStringToByteString fs
681
682 getFS :: BinHandle -> IO FastString
683 getFS bh = do bs <- getBS bh
684 mkFastStringByteString bs
685
686 putBS :: BinHandle -> ByteString -> IO ()
687 putBS bh bs =
688 BS.unsafeUseAsCStringLen bs $ \(ptr, l) -> do
689 put_ bh l
690 let
691 go n | n == l = return ()
692 | otherwise = do
693 b <- peekElemOff (castPtr ptr) n
694 putByte bh b
695 go (n+1)
696 go 0
697
698 {- -- possible faster version, not quite there yet:
699 getBS bh@BinMem{} = do
700 (I# l) <- get bh
701 arr <- readIORef (arr_r bh)
702 off <- readFastMutInt (off_r bh)
703 return $! (mkFastSubBytesBA# arr off l)
704 -}
705 getBS :: BinHandle -> IO ByteString
706 getBS bh = do
707 l <- get bh
708 fp <- mallocForeignPtrBytes l
709 withForeignPtr fp $ \ptr -> do
710 let
711 go n | n == l = return $ BS.fromForeignPtr fp 0 l
712 | otherwise = do
713 b <- getByte bh
714 pokeElemOff ptr n b
715 go (n+1)
716 --
717 go 0
718
719 instance Binary ByteString where
720 put_ bh f = putBS bh f
721 get bh = getBS bh
722
723 instance Binary FastString where
724 put_ bh f =
725 case getUserData bh of
726 UserData { ud_put_fs = put_fs } -> put_fs bh f
727
728 get bh =
729 case getUserData bh of
730 UserData { ud_get_fs = get_fs } -> get_fs bh
731
732 -- Here to avoid loop
733
734 instance Binary Fingerprint where
735 put_ h (Fingerprint w1 w2) = do put_ h w1; put_ h w2
736 get h = do w1 <- get h; w2 <- get h; return (Fingerprint w1 w2)
737
738 instance Binary FunctionOrData where
739 put_ bh IsFunction = putByte bh 0
740 put_ bh IsData = putByte bh 1
741 get bh = do
742 h <- getByte bh
743 case h of
744 0 -> return IsFunction
745 1 -> return IsData
746 _ -> panic "Binary FunctionOrData"
747
748 instance Binary TupleSort where
749 put_ bh BoxedTuple = putByte bh 0
750 put_ bh UnboxedTuple = putByte bh 1
751 put_ bh ConstraintTuple = putByte bh 2
752 get bh = do
753 h <- getByte bh
754 case h of
755 0 -> do return BoxedTuple
756 1 -> do return UnboxedTuple
757 _ -> do return ConstraintTuple
758
759 instance Binary Activation where
760 put_ bh NeverActive = do
761 putByte bh 0
762 put_ bh AlwaysActive = do
763 putByte bh 1
764 put_ bh (ActiveBefore aa) = do
765 putByte bh 2
766 put_ bh aa
767 put_ bh (ActiveAfter ab) = do
768 putByte bh 3
769 put_ bh ab
770 get bh = do
771 h <- getByte bh
772 case h of
773 0 -> do return NeverActive
774 1 -> do return AlwaysActive
775 2 -> do aa <- get bh
776 return (ActiveBefore aa)
777 _ -> do ab <- get bh
778 return (ActiveAfter ab)
779
780 instance Binary InlinePragma where
781 put_ bh (InlinePragma a b c d) = do
782 put_ bh a
783 put_ bh b
784 put_ bh c
785 put_ bh d
786
787 get bh = do
788 a <- get bh
789 b <- get bh
790 c <- get bh
791 d <- get bh
792 return (InlinePragma a b c d)
793
794 instance Binary RuleMatchInfo where
795 put_ bh FunLike = putByte bh 0
796 put_ bh ConLike = putByte bh 1
797 get bh = do
798 h <- getByte bh
799 if h == 1 then return ConLike
800 else return FunLike
801
802 instance Binary InlineSpec where
803 put_ bh EmptyInlineSpec = putByte bh 0
804 put_ bh Inline = putByte bh 1
805 put_ bh Inlinable = putByte bh 2
806 put_ bh NoInline = putByte bh 3
807
808 get bh = do h <- getByte bh
809 case h of
810 0 -> return EmptyInlineSpec
811 1 -> return Inline
812 2 -> return Inlinable
813 _ -> return NoInline
814
815 instance Binary DefMethSpec where
816 put_ bh NoDM = putByte bh 0
817 put_ bh VanillaDM = putByte bh 1
818 put_ bh GenericDM = putByte bh 2
819 get bh = do
820 h <- getByte bh
821 case h of
822 0 -> return NoDM
823 1 -> return VanillaDM
824 _ -> return GenericDM
825
826 instance Binary RecFlag where
827 put_ bh Recursive = do
828 putByte bh 0
829 put_ bh NonRecursive = do
830 putByte bh 1
831 get bh = do
832 h <- getByte bh
833 case h of
834 0 -> do return Recursive
835 _ -> do return NonRecursive
836
837 instance Binary OverlapFlag where
838 put_ bh (NoOverlap b) = putByte bh 0 >> put_ bh b
839 put_ bh (OverlapOk b) = putByte bh 1 >> put_ bh b
840 put_ bh (Incoherent b) = putByte bh 2 >> put_ bh b
841 get bh = do
842 h <- getByte bh
843 b <- get bh
844 case h of
845 0 -> return $ NoOverlap b
846 1 -> return $ OverlapOk b
847 2 -> return $ Incoherent b
848 _ -> panic ("get OverlapFlag " ++ show h)
849
850 instance Binary FixityDirection where
851 put_ bh InfixL = do
852 putByte bh 0
853 put_ bh InfixR = do
854 putByte bh 1
855 put_ bh InfixN = do
856 putByte bh 2
857 get bh = do
858 h <- getByte bh
859 case h of
860 0 -> do return InfixL
861 1 -> do return InfixR
862 _ -> do return InfixN
863
864 instance Binary Fixity where
865 put_ bh (Fixity aa ab) = do
866 put_ bh aa
867 put_ bh ab
868 get bh = do
869 aa <- get bh
870 ab <- get bh
871 return (Fixity aa ab)
872
873 instance Binary WarningTxt where
874 put_ bh (WarningTxt w) = do
875 putByte bh 0
876 put_ bh w
877 put_ bh (DeprecatedTxt d) = do
878 putByte bh 1
879 put_ bh d
880
881 get bh = do
882 h <- getByte bh
883 case h of
884 0 -> do w <- get bh
885 return (WarningTxt w)
886 _ -> do d <- get bh
887 return (DeprecatedTxt d)
888