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