SafeHaskell: Fix recompilation avoidance to take Safe into account.
[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
22 openBinIO, openBinIO_,
23 openBinMem,
24 -- closeBin,
25
26 seekBin,
27 seekBy,
28 tellBin,
29 castBin,
30
31 writeBinMem,
32 readBinMem,
33 fingerprintBinMem,
34
35 isEOFBin,
36
37 putAt, getAt,
38
39 -- for writing instances:
40 putByte,
41 getByte,
42
43 -- lazy Bin I/O
44 lazyGet,
45 lazyPut,
46
47 #ifdef __GLASGOW_HASKELL__
48 -- GHC only:
49 ByteArray(..),
50 getByteArray,
51 putByteArray,
52 #endif
53
54 UserData(..), getUserData, setUserData,
55 newReadState, newWriteState,
56 putDictionary, getDictionary, putFS,
57 ) where
58
59 #include "HsVersions.h"
60
61 -- The *host* architecture version:
62 #include "../includes/MachDeps.h"
63
64 import {-# SOURCE #-} Name (Name)
65 import FastString
66 import Panic
67 import UniqFM
68 import FastMutInt
69 import Fingerprint
70 import BasicTypes
71
72 import Foreign
73 import Data.Array
74 import Data.IORef
75 import Data.Char ( ord, chr )
76 import Data.Typeable
77 import Control.Monad ( when )
78 import System.IO as IO
79 import System.IO.Unsafe ( unsafeInterleaveIO )
80 import System.IO.Error ( mkIOError, eofErrorType )
81 import GHC.Real ( Ratio(..) )
82 import GHC.Exts
83 import GHC.Word ( Word8(..) )
84 import GHC.IO ( IO(..) )
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 | BinIO { -- binary data stored in a file
103 bh_usr :: UserData,
104 _off_r :: !FastMutInt, -- the current offset (cached)
105 _hdl :: !IO.Handle -- the file handle (must be seekable)
106 }
107 -- cache the file ptr in BinIO; using hTell is too expensive
108 -- to call repeatedly. If anyone else is modifying this Handle
109 -- at the same time, we'll be screwed.
110
111 getUserData :: BinHandle -> UserData
112 getUserData bh = bh_usr bh
113
114 setUserData :: BinHandle -> UserData -> BinHandle
115 setUserData bh us = bh { bh_usr = us }
116
117
118 ---------------------------------------------------------------
119 -- Bin
120 ---------------------------------------------------------------
121
122 newtype Bin a = BinPtr Int
123 deriving (Eq, Ord, Show, Bounded)
124
125 castBin :: Bin a -> Bin b
126 castBin (BinPtr i) = BinPtr i
127
128 ---------------------------------------------------------------
129 -- class Binary
130 ---------------------------------------------------------------
131
132 class Binary a where
133 put_ :: BinHandle -> a -> IO ()
134 put :: BinHandle -> a -> IO (Bin a)
135 get :: BinHandle -> IO a
136
137 -- define one of put_, put. Use of put_ is recommended because it
138 -- is more likely that tail-calls can kick in, and we rarely need the
139 -- position return value.
140 put_ bh a = do _ <- put bh a; return ()
141 put bh a = do p <- tellBin bh; put_ bh a; return p
142
143 putAt :: Binary a => BinHandle -> Bin a -> a -> IO ()
144 putAt bh p x = do seekBin bh p; put_ bh x; return ()
145
146 getAt :: Binary a => BinHandle -> Bin a -> IO a
147 getAt bh p = do seekBin bh p; get bh
148
149 openBinIO_ :: IO.Handle -> IO BinHandle
150 openBinIO_ h = openBinIO h
151
152 openBinIO :: IO.Handle -> IO BinHandle
153 openBinIO h = do
154 r <- newFastMutInt
155 writeFastMutInt r 0
156 return (BinIO noUserData r h)
157
158 openBinMem :: Int -> IO BinHandle
159 openBinMem size
160 | size <= 0 = error "Data.Binary.openBinMem: size must be >= 0"
161 | otherwise = do
162 arr <- mallocForeignPtrBytes size
163 arr_r <- newIORef arr
164 ix_r <- newFastMutInt
165 writeFastMutInt ix_r 0
166 sz_r <- newFastMutInt
167 writeFastMutInt sz_r size
168 return (BinMem noUserData ix_r sz_r arr_r)
169
170 tellBin :: BinHandle -> IO (Bin a)
171 tellBin (BinIO _ r _) = do ix <- readFastMutInt r; return (BinPtr ix)
172 tellBin (BinMem _ r _ _) = do ix <- readFastMutInt r; return (BinPtr ix)
173
174 seekBin :: BinHandle -> Bin a -> IO ()
175 seekBin (BinIO _ ix_r h) (BinPtr p) = do
176 writeFastMutInt ix_r p
177 hSeek h AbsoluteSeek (fromIntegral p)
178 seekBin h@(BinMem _ ix_r sz_r _) (BinPtr p) = do
179 sz <- readFastMutInt sz_r
180 if (p >= sz)
181 then do expandBin h p; writeFastMutInt ix_r p
182 else writeFastMutInt ix_r p
183
184 seekBy :: BinHandle -> Int -> IO ()
185 seekBy (BinIO _ ix_r h) off = do
186 ix <- readFastMutInt ix_r
187 let ix' = ix + off
188 writeFastMutInt ix_r ix'
189 hSeek h AbsoluteSeek (fromIntegral ix')
190 seekBy h@(BinMem _ ix_r sz_r _) off = do
191 sz <- readFastMutInt sz_r
192 ix <- readFastMutInt ix_r
193 let ix' = ix + off
194 if (ix' >= sz)
195 then do expandBin h ix'; writeFastMutInt ix_r ix'
196 else writeFastMutInt ix_r ix'
197
198 isEOFBin :: BinHandle -> IO Bool
199 isEOFBin (BinMem _ ix_r sz_r _) = do
200 ix <- readFastMutInt ix_r
201 sz <- readFastMutInt sz_r
202 return (ix >= sz)
203 isEOFBin (BinIO _ _ h) = hIsEOF h
204
205 writeBinMem :: BinHandle -> FilePath -> IO ()
206 writeBinMem (BinIO _ _ _) _ = error "Data.Binary.writeBinMem: not a memory handle"
207 writeBinMem (BinMem _ ix_r _ arr_r) fn = do
208 h <- openBinaryFile fn WriteMode
209 arr <- readIORef arr_r
210 ix <- readFastMutInt ix_r
211 withForeignPtr arr $ \p -> hPutBuf h p ix
212 hClose h
213
214 readBinMem :: FilePath -> IO BinHandle
215 -- Return a BinHandle with a totally undefined State
216 readBinMem filename = do
217 h <- openBinaryFile filename ReadMode
218 filesize' <- hFileSize h
219 let filesize = fromIntegral filesize'
220 arr <- mallocForeignPtrBytes (filesize*2)
221 count <- withForeignPtr arr $ \p -> hGetBuf h p filesize
222 when (count /= filesize) $
223 error ("Binary.readBinMem: only read " ++ show count ++ " bytes")
224 hClose h
225 arr_r <- newIORef arr
226 ix_r <- newFastMutInt
227 writeFastMutInt ix_r 0
228 sz_r <- newFastMutInt
229 writeFastMutInt sz_r filesize
230 return (BinMem noUserData ix_r sz_r arr_r)
231
232 fingerprintBinMem :: BinHandle -> IO Fingerprint
233 fingerprintBinMem (BinIO _ _ _) = error "Binary.md5BinMem: not a memory handle"
234 fingerprintBinMem (BinMem _ ix_r _ arr_r) = do
235 arr <- readIORef arr_r
236 ix <- readFastMutInt ix_r
237 withForeignPtr arr $ \p -> fingerprintData p ix
238
239 -- expand the size of the array to include a specified offset
240 expandBin :: BinHandle -> Int -> IO ()
241 expandBin (BinMem _ _ sz_r arr_r) off = do
242 sz <- readFastMutInt sz_r
243 let sz' = head (dropWhile (<= off) (iterate (* 2) sz))
244 arr <- readIORef arr_r
245 arr' <- mallocForeignPtrBytes sz'
246 withForeignPtr arr $ \old ->
247 withForeignPtr arr' $ \new ->
248 copyBytes new old sz
249 writeFastMutInt sz_r sz'
250 writeIORef arr_r arr'
251 when False $ -- disabled
252 hPutStrLn stderr ("Binary: expanding to size: " ++ show sz')
253 return ()
254 expandBin (BinIO _ _ _) _ = return ()
255 -- no need to expand a file, we'll assume they expand by themselves.
256
257 -- -----------------------------------------------------------------------------
258 -- Low-level reading/writing of bytes
259
260 putWord8 :: BinHandle -> Word8 -> IO ()
261 putWord8 h@(BinMem _ ix_r sz_r arr_r) w = do
262 ix <- readFastMutInt ix_r
263 sz <- readFastMutInt sz_r
264 -- double the size of the array if it overflows
265 if (ix >= sz)
266 then do expandBin h ix
267 putWord8 h w
268 else do arr <- readIORef arr_r
269 withForeignPtr arr $ \p -> pokeByteOff p ix w
270 writeFastMutInt ix_r (ix+1)
271 return ()
272 putWord8 (BinIO _ ix_r h) w = do
273 ix <- readFastMutInt ix_r
274 hPutChar h (chr (fromIntegral w)) -- XXX not really correct
275 writeFastMutInt ix_r (ix+1)
276 return ()
277
278 getWord8 :: BinHandle -> IO Word8
279 getWord8 (BinMem _ ix_r sz_r arr_r) = do
280 ix <- readFastMutInt ix_r
281 sz <- readFastMutInt sz_r
282 when (ix >= sz) $
283 ioError (mkIOError eofErrorType "Data.Binary.getWord8" Nothing Nothing)
284 arr <- readIORef arr_r
285 w <- withForeignPtr arr $ \p -> peekByteOff p ix
286 writeFastMutInt ix_r (ix+1)
287 return w
288 getWord8 (BinIO _ ix_r h) = do
289 ix <- readFastMutInt ix_r
290 c <- hGetChar h
291 writeFastMutInt ix_r (ix+1)
292 return $! (fromIntegral (ord c)) -- XXX not really correct
293
294 putByte :: BinHandle -> Word8 -> IO ()
295 putByte bh w = put_ bh w
296
297 getByte :: BinHandle -> IO Word8
298 getByte = getWord8
299
300 -- -----------------------------------------------------------------------------
301 -- Primitve Word writes
302
303 instance Binary Word8 where
304 put_ = putWord8
305 get = getWord8
306
307 instance Binary Word16 where
308 put_ h w = do -- XXX too slow.. inline putWord8?
309 putByte h (fromIntegral (w `shiftR` 8))
310 putByte h (fromIntegral (w .&. 0xff))
311 get h = do
312 w1 <- getWord8 h
313 w2 <- getWord8 h
314 return $! ((fromIntegral w1 `shiftL` 8) .|. fromIntegral w2)
315
316
317 instance Binary Word32 where
318 put_ h w = do
319 putByte h (fromIntegral (w `shiftR` 24))
320 putByte h (fromIntegral ((w `shiftR` 16) .&. 0xff))
321 putByte h (fromIntegral ((w `shiftR` 8) .&. 0xff))
322 putByte h (fromIntegral (w .&. 0xff))
323 get h = do
324 w1 <- getWord8 h
325 w2 <- getWord8 h
326 w3 <- getWord8 h
327 w4 <- getWord8 h
328 return $! ((fromIntegral w1 `shiftL` 24) .|.
329 (fromIntegral w2 `shiftL` 16) .|.
330 (fromIntegral w3 `shiftL` 8) .|.
331 (fromIntegral w4))
332
333 instance Binary Word64 where
334 put_ h w = do
335 putByte h (fromIntegral (w `shiftR` 56))
336 putByte h (fromIntegral ((w `shiftR` 48) .&. 0xff))
337 putByte h (fromIntegral ((w `shiftR` 40) .&. 0xff))
338 putByte h (fromIntegral ((w `shiftR` 32) .&. 0xff))
339 putByte h (fromIntegral ((w `shiftR` 24) .&. 0xff))
340 putByte h (fromIntegral ((w `shiftR` 16) .&. 0xff))
341 putByte h (fromIntegral ((w `shiftR` 8) .&. 0xff))
342 putByte h (fromIntegral (w .&. 0xff))
343 get h = do
344 w1 <- getWord8 h
345 w2 <- getWord8 h
346 w3 <- getWord8 h
347 w4 <- getWord8 h
348 w5 <- getWord8 h
349 w6 <- getWord8 h
350 w7 <- getWord8 h
351 w8 <- getWord8 h
352 return $! ((fromIntegral w1 `shiftL` 56) .|.
353 (fromIntegral w2 `shiftL` 48) .|.
354 (fromIntegral w3 `shiftL` 40) .|.
355 (fromIntegral w4 `shiftL` 32) .|.
356 (fromIntegral w5 `shiftL` 24) .|.
357 (fromIntegral w6 `shiftL` 16) .|.
358 (fromIntegral w7 `shiftL` 8) .|.
359 (fromIntegral w8))
360
361 -- -----------------------------------------------------------------------------
362 -- Primitve Int writes
363
364 instance Binary Int8 where
365 put_ h w = put_ h (fromIntegral w :: Word8)
366 get h = do w <- get h; return $! (fromIntegral (w::Word8))
367
368 instance Binary Int16 where
369 put_ h w = put_ h (fromIntegral w :: Word16)
370 get h = do w <- get h; return $! (fromIntegral (w::Word16))
371
372 instance Binary Int32 where
373 put_ h w = put_ h (fromIntegral w :: Word32)
374 get h = do w <- get h; return $! (fromIntegral (w::Word32))
375
376 instance Binary Int64 where
377 put_ h w = put_ h (fromIntegral w :: Word64)
378 get h = do w <- get h; return $! (fromIntegral (w::Word64))
379
380 -- -----------------------------------------------------------------------------
381 -- Instances for standard types
382
383 instance Binary () where
384 put_ _ () = return ()
385 get _ = return ()
386
387 instance Binary Bool where
388 put_ bh b = putByte bh (fromIntegral (fromEnum b))
389 get bh = do x <- getWord8 bh; return $! (toEnum (fromIntegral x))
390
391 instance Binary Char where
392 put_ bh c = put_ bh (fromIntegral (ord c) :: Word32)
393 get bh = do x <- get bh; return $! (chr (fromIntegral (x :: Word32)))
394
395 instance Binary Int where
396 put_ bh i = put_ bh (fromIntegral i :: Int64)
397 get bh = do
398 x <- get bh
399 return $! (fromIntegral (x :: Int64))
400
401 instance Binary a => Binary [a] where
402 put_ bh l = do
403 let len = length l
404 if (len < 0xff)
405 then putByte bh (fromIntegral len :: Word8)
406 else do putByte bh 0xff; put_ bh (fromIntegral len :: Word32)
407 mapM_ (put_ bh) l
408 get bh = do
409 b <- getByte bh
410 len <- if b == 0xff
411 then get bh
412 else return (fromIntegral b :: Word32)
413 let loop 0 = return []
414 loop n = do a <- get bh; as <- loop (n-1); return (a:as)
415 loop len
416
417 instance (Binary a, Binary b) => Binary (a,b) where
418 put_ bh (a,b) = do put_ bh a; put_ bh b
419 get bh = do a <- get bh
420 b <- get bh
421 return (a,b)
422
423 instance (Binary a, Binary b, Binary c) => Binary (a,b,c) where
424 put_ bh (a,b,c) = do put_ bh a; put_ bh b; put_ bh c
425 get bh = do a <- get bh
426 b <- get bh
427 c <- get bh
428 return (a,b,c)
429
430 instance (Binary a, Binary b, Binary c, Binary d) => Binary (a,b,c,d) where
431 put_ bh (a,b,c,d) = do put_ bh a; put_ bh b; put_ bh c; put_ bh d
432 get bh = do a <- get bh
433 b <- get bh
434 c <- get bh
435 d <- get bh
436 return (a,b,c,d)
437
438 instance (Binary a, Binary b, Binary c, Binary d, Binary e) => Binary (a,b,c,d, e) where
439 put_ bh (a,b,c,d, e) = do put_ bh a; put_ bh b; put_ bh c; put_ bh d; put_ bh e;
440 get bh = do a <- get bh
441 b <- get bh
442 c <- get bh
443 d <- get bh
444 e <- get bh
445 return (a,b,c,d,e)
446
447 instance Binary a => Binary (Maybe a) where
448 put_ bh Nothing = putByte bh 0
449 put_ bh (Just a) = do putByte bh 1; put_ bh a
450 get bh = do h <- getWord8 bh
451 case h of
452 0 -> return Nothing
453 _ -> do x <- get bh; return (Just x)
454
455 instance (Binary a, Binary b) => Binary (Either a b) where
456 put_ bh (Left a) = do putByte bh 0; put_ bh a
457 put_ bh (Right b) = do putByte bh 1; put_ bh b
458 get bh = do h <- getWord8 bh
459 case h of
460 0 -> do a <- get bh ; return (Left a)
461 _ -> do b <- get bh ; return (Right b)
462
463 #if defined(__GLASGOW_HASKELL__) || 1
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 (Integral a, 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 #endif
556
557 instance Binary (Bin a) where
558 put_ bh (BinPtr i) = put_ bh (fromIntegral i :: Int32)
559 get bh = do i <- get bh; return (BinPtr (fromIntegral (i :: Int32)))
560
561 -- -----------------------------------------------------------------------------
562 -- Instances for Data.Typeable stuff
563
564 instance Binary TyCon where
565 put_ bh ty_con = do
566 let s = tyConString ty_con
567 put_ bh s
568 get bh = do
569 s <- get bh
570 return (mkTyCon s)
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 (getAt bh p_a)
600 seekBin bh p -- skip over the object for now
601 return a
602
603 -- -----------------------------------------------------------------------------
604 -- UserData
605 -- -----------------------------------------------------------------------------
606
607 data UserData =
608 UserData {
609 -- for *deserialising* only:
610 ud_dict :: Dictionary,
611 ud_symtab :: SymbolTable,
612
613 -- for *serialising* only:
614 ud_put_name :: BinHandle -> Name -> IO (),
615 ud_put_fs :: BinHandle -> FastString -> IO ()
616 }
617
618 newReadState :: Dictionary -> IO UserData
619 newReadState dict = do
620 return UserData { ud_dict = dict,
621 ud_symtab = undef "symtab",
622 ud_put_name = undef "put_name",
623 ud_put_fs = undef "put_fs"
624 }
625
626 newWriteState :: (BinHandle -> Name -> IO ())
627 -> (BinHandle -> FastString -> IO ())
628 -> IO UserData
629 newWriteState put_name put_fs = do
630 return UserData { ud_dict = undef "dict",
631 ud_symtab = undef "symtab",
632 ud_put_name = put_name,
633 ud_put_fs = put_fs
634 }
635
636 noUserData :: a
637 noUserData = undef "UserData"
638
639 undef :: String -> a
640 undef s = panic ("Binary.UserData: no " ++ s)
641
642 ---------------------------------------------------------
643 -- The Dictionary
644 ---------------------------------------------------------
645
646 type Dictionary = Array Int FastString -- The dictionary
647 -- Should be 0-indexed
648
649 putDictionary :: BinHandle -> Int -> UniqFM (Int,FastString) -> IO ()
650 putDictionary bh sz dict = do
651 put_ bh sz
652 mapM_ (putFS bh) (elems (array (0,sz-1) (eltsUFM dict)))
653
654 getDictionary :: BinHandle -> IO Dictionary
655 getDictionary bh = do
656 sz <- get bh
657 elems <- sequence (take sz (repeat (getFS bh)))
658 return (listArray (0,sz-1) elems)
659
660 ---------------------------------------------------------
661 -- The Symbol Table
662 ---------------------------------------------------------
663
664 -- On disk, the symbol table is an array of IfaceExtName, when
665 -- reading it in we turn it into a SymbolTable.
666
667 type SymbolTable = Array Int Name
668
669 ---------------------------------------------------------
670 -- Reading and writing FastStrings
671 ---------------------------------------------------------
672
673 putFS :: BinHandle -> FastString -> IO ()
674 putFS bh (FastString _ l _ buf _) = do
675 put_ bh l
676 withForeignPtr buf $ \ptr ->
677 let
678 go n | n == l = return ()
679 | otherwise = do
680 b <- peekElemOff ptr n
681 putByte bh b
682 go (n+1)
683 in
684 go 0
685
686 {- -- possible faster version, not quite there yet:
687 getFS bh@BinMem{} = do
688 (I# l) <- get bh
689 arr <- readIORef (arr_r bh)
690 off <- readFastMutInt (off_r bh)
691 return $! (mkFastSubStringBA# arr off l)
692 -}
693 getFS :: BinHandle -> IO FastString
694 getFS bh = do
695 l <- get bh
696 fp <- mallocForeignPtrBytes l
697 withForeignPtr fp $ \ptr -> do
698 let
699 go n | n == l = mkFastStringForeignPtr ptr fp l
700 | otherwise = do
701 b <- getByte bh
702 pokeElemOff ptr n b
703 go (n+1)
704 --
705 go 0
706
707 instance Binary FastString where
708 put_ bh f =
709 case getUserData bh of
710 UserData { ud_put_fs = put_fs } -> put_fs bh f
711
712 get bh = do
713 j <- get bh
714 return $! (ud_dict (getUserData bh) ! (fromIntegral (j :: Word32)))
715
716 -- Here to avoid loop
717
718 instance Binary Fingerprint where
719 put_ h (Fingerprint w1 w2) = do put_ h w1; put_ h w2
720 get h = do w1 <- get h; w2 <- get h; return (Fingerprint w1 w2)
721
722 instance Binary FunctionOrData where
723 put_ bh IsFunction = putByte bh 0
724 put_ bh IsData = putByte bh 1
725 get bh = do
726 h <- getByte bh
727 case h of
728 0 -> return IsFunction
729 1 -> return IsData
730 _ -> panic "Binary FunctionOrData"
731