Trim unused imports detected by new unused-import code
[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 "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
85 #if __GLASGOW_HASKELL__ >= 611
86 import GHC.IO ( IO(..) )
87 #else
88 import GHC.IOBase ( IO(..) )
89 #endif
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 | BinIO { -- binary data stored in a file
108 bh_usr :: UserData,
109 _off_r :: !FastMutInt, -- the current offset (cached)
110 _hdl :: !IO.Handle -- the file handle (must be seekable)
111 }
112 -- cache the file ptr in BinIO; using hTell is too expensive
113 -- to call repeatedly. If anyone else is modifying this Handle
114 -- at the same time, we'll be screwed.
115
116 getUserData :: BinHandle -> UserData
117 getUserData bh = bh_usr bh
118
119 setUserData :: BinHandle -> UserData -> BinHandle
120 setUserData bh us = bh { bh_usr = us }
121
122
123 ---------------------------------------------------------------
124 -- Bin
125 ---------------------------------------------------------------
126
127 newtype Bin a = BinPtr Int
128 deriving (Eq, Ord, Show, Bounded)
129
130 castBin :: Bin a -> Bin b
131 castBin (BinPtr i) = BinPtr i
132
133 ---------------------------------------------------------------
134 -- class Binary
135 ---------------------------------------------------------------
136
137 class Binary a where
138 put_ :: BinHandle -> a -> IO ()
139 put :: BinHandle -> a -> IO (Bin a)
140 get :: BinHandle -> IO a
141
142 -- define one of put_, put. Use of put_ is recommended because it
143 -- is more likely that tail-calls can kick in, and we rarely need the
144 -- position return value.
145 put_ bh a = do _ <- put bh a; return ()
146 put bh a = do p <- tellBin bh; put_ bh a; return p
147
148 putAt :: Binary a => BinHandle -> Bin a -> a -> IO ()
149 putAt bh p x = do seekBin bh p; put_ bh x; return ()
150
151 getAt :: Binary a => BinHandle -> Bin a -> IO a
152 getAt bh p = do seekBin bh p; get bh
153
154 openBinIO_ :: IO.Handle -> IO BinHandle
155 openBinIO_ h = openBinIO h
156
157 openBinIO :: IO.Handle -> IO BinHandle
158 openBinIO h = do
159 r <- newFastMutInt
160 writeFastMutInt r 0
161 return (BinIO noUserData r h)
162
163 openBinMem :: Int -> IO BinHandle
164 openBinMem size
165 | size <= 0 = error "Data.Binary.openBinMem: size must be >= 0"
166 | otherwise = do
167 arr <- mallocForeignPtrBytes size
168 arr_r <- newIORef arr
169 ix_r <- newFastMutInt
170 writeFastMutInt ix_r 0
171 sz_r <- newFastMutInt
172 writeFastMutInt sz_r size
173 return (BinMem noUserData ix_r sz_r arr_r)
174
175 tellBin :: BinHandle -> IO (Bin a)
176 tellBin (BinIO _ r _) = do ix <- readFastMutInt r; return (BinPtr ix)
177 tellBin (BinMem _ r _ _) = do ix <- readFastMutInt r; return (BinPtr ix)
178
179 seekBin :: BinHandle -> Bin a -> IO ()
180 seekBin (BinIO _ ix_r h) (BinPtr p) = do
181 writeFastMutInt ix_r p
182 hSeek h AbsoluteSeek (fromIntegral p)
183 seekBin h@(BinMem _ ix_r sz_r _) (BinPtr p) = do
184 sz <- readFastMutInt sz_r
185 if (p >= sz)
186 then do expandBin h p; writeFastMutInt ix_r p
187 else writeFastMutInt ix_r p
188
189 seekBy :: BinHandle -> Int -> IO ()
190 seekBy (BinIO _ ix_r h) off = do
191 ix <- readFastMutInt ix_r
192 let ix' = ix + off
193 writeFastMutInt ix_r ix'
194 hSeek h AbsoluteSeek (fromIntegral ix')
195 seekBy h@(BinMem _ ix_r sz_r _) off = do
196 sz <- readFastMutInt sz_r
197 ix <- readFastMutInt ix_r
198 let ix' = ix + off
199 if (ix' >= sz)
200 then do expandBin h ix'; writeFastMutInt ix_r ix'
201 else writeFastMutInt ix_r ix'
202
203 isEOFBin :: BinHandle -> IO Bool
204 isEOFBin (BinMem _ ix_r sz_r _) = do
205 ix <- readFastMutInt ix_r
206 sz <- readFastMutInt sz_r
207 return (ix >= sz)
208 isEOFBin (BinIO _ _ h) = hIsEOF h
209
210 writeBinMem :: BinHandle -> FilePath -> IO ()
211 writeBinMem (BinIO _ _ _) _ = error "Data.Binary.writeBinMem: not a memory handle"
212 writeBinMem (BinMem _ ix_r _ arr_r) fn = do
213 h <- openBinaryFile fn WriteMode
214 arr <- readIORef arr_r
215 ix <- readFastMutInt ix_r
216 withForeignPtr arr $ \p -> hPutBuf h p ix
217 hClose h
218
219 readBinMem :: FilePath -> IO BinHandle
220 -- Return a BinHandle with a totally undefined State
221 readBinMem filename = do
222 h <- openBinaryFile filename ReadMode
223 filesize' <- hFileSize h
224 let filesize = fromIntegral filesize'
225 arr <- mallocForeignPtrBytes (filesize*2)
226 count <- withForeignPtr arr $ \p -> hGetBuf h p filesize
227 when (count /= filesize) $
228 error ("Binary.readBinMem: only read " ++ show count ++ " bytes")
229 hClose h
230 arr_r <- newIORef arr
231 ix_r <- newFastMutInt
232 writeFastMutInt ix_r 0
233 sz_r <- newFastMutInt
234 writeFastMutInt sz_r filesize
235 return (BinMem noUserData ix_r sz_r arr_r)
236
237 fingerprintBinMem :: BinHandle -> IO Fingerprint
238 fingerprintBinMem (BinIO _ _ _) = error "Binary.md5BinMem: not a memory handle"
239 fingerprintBinMem (BinMem _ ix_r _ arr_r) = do
240 arr <- readIORef arr_r
241 ix <- readFastMutInt ix_r
242 withForeignPtr arr $ \p -> fingerprintData p ix
243
244 -- expand the size of the array to include a specified offset
245 expandBin :: BinHandle -> Int -> IO ()
246 expandBin (BinMem _ _ sz_r arr_r) off = do
247 sz <- readFastMutInt sz_r
248 let sz' = head (dropWhile (<= off) (iterate (* 2) sz))
249 arr <- readIORef arr_r
250 arr' <- mallocForeignPtrBytes sz'
251 withForeignPtr arr $ \old ->
252 withForeignPtr arr' $ \new ->
253 copyBytes new old sz
254 writeFastMutInt sz_r sz'
255 writeIORef arr_r arr'
256 when False $ -- disabled
257 hPutStrLn stderr ("Binary: expanding to size: " ++ show sz')
258 return ()
259 expandBin (BinIO _ _ _) _ = return ()
260 -- no need to expand a file, we'll assume they expand by themselves.
261
262 -- -----------------------------------------------------------------------------
263 -- Low-level reading/writing of bytes
264
265 putWord8 :: BinHandle -> Word8 -> IO ()
266 putWord8 h@(BinMem _ ix_r sz_r arr_r) w = do
267 ix <- readFastMutInt ix_r
268 sz <- readFastMutInt sz_r
269 -- double the size of the array if it overflows
270 if (ix >= sz)
271 then do expandBin h ix
272 putWord8 h w
273 else do arr <- readIORef arr_r
274 withForeignPtr arr $ \p -> pokeByteOff p ix w
275 writeFastMutInt ix_r (ix+1)
276 return ()
277 putWord8 (BinIO _ ix_r h) w = do
278 ix <- readFastMutInt ix_r
279 hPutChar h (chr (fromIntegral w)) -- XXX not really correct
280 writeFastMutInt ix_r (ix+1)
281 return ()
282
283 getWord8 :: BinHandle -> IO Word8
284 getWord8 (BinMem _ ix_r sz_r arr_r) = do
285 ix <- readFastMutInt ix_r
286 sz <- readFastMutInt sz_r
287 when (ix >= sz) $
288 ioError (mkIOError eofErrorType "Data.Binary.getWord8" Nothing Nothing)
289 arr <- readIORef arr_r
290 w <- withForeignPtr arr $ \p -> peekByteOff p ix
291 writeFastMutInt ix_r (ix+1)
292 return w
293 getWord8 (BinIO _ ix_r h) = do
294 ix <- readFastMutInt ix_r
295 c <- hGetChar h
296 writeFastMutInt ix_r (ix+1)
297 return $! (fromIntegral (ord c)) -- XXX not really correct
298
299 putByte :: BinHandle -> Word8 -> IO ()
300 putByte bh w = put_ bh w
301
302 getByte :: BinHandle -> IO Word8
303 getByte = getWord8
304
305 -- -----------------------------------------------------------------------------
306 -- Primitve Word writes
307
308 instance Binary Word8 where
309 put_ = putWord8
310 get = getWord8
311
312 instance Binary Word16 where
313 put_ h w = do -- XXX too slow.. inline putWord8?
314 putByte h (fromIntegral (w `shiftR` 8))
315 putByte h (fromIntegral (w .&. 0xff))
316 get h = do
317 w1 <- getWord8 h
318 w2 <- getWord8 h
319 return $! ((fromIntegral w1 `shiftL` 8) .|. fromIntegral w2)
320
321
322 instance Binary Word32 where
323 put_ h w = do
324 putByte h (fromIntegral (w `shiftR` 24))
325 putByte h (fromIntegral ((w `shiftR` 16) .&. 0xff))
326 putByte h (fromIntegral ((w `shiftR` 8) .&. 0xff))
327 putByte h (fromIntegral (w .&. 0xff))
328 get h = do
329 w1 <- getWord8 h
330 w2 <- getWord8 h
331 w3 <- getWord8 h
332 w4 <- getWord8 h
333 return $! ((fromIntegral w1 `shiftL` 24) .|.
334 (fromIntegral w2 `shiftL` 16) .|.
335 (fromIntegral w3 `shiftL` 8) .|.
336 (fromIntegral w4))
337
338 instance Binary Word64 where
339 put_ h w = do
340 putByte h (fromIntegral (w `shiftR` 56))
341 putByte h (fromIntegral ((w `shiftR` 48) .&. 0xff))
342 putByte h (fromIntegral ((w `shiftR` 40) .&. 0xff))
343 putByte h (fromIntegral ((w `shiftR` 32) .&. 0xff))
344 putByte h (fromIntegral ((w `shiftR` 24) .&. 0xff))
345 putByte h (fromIntegral ((w `shiftR` 16) .&. 0xff))
346 putByte h (fromIntegral ((w `shiftR` 8) .&. 0xff))
347 putByte h (fromIntegral (w .&. 0xff))
348 get h = do
349 w1 <- getWord8 h
350 w2 <- getWord8 h
351 w3 <- getWord8 h
352 w4 <- getWord8 h
353 w5 <- getWord8 h
354 w6 <- getWord8 h
355 w7 <- getWord8 h
356 w8 <- getWord8 h
357 return $! ((fromIntegral w1 `shiftL` 56) .|.
358 (fromIntegral w2 `shiftL` 48) .|.
359 (fromIntegral w3 `shiftL` 40) .|.
360 (fromIntegral w4 `shiftL` 32) .|.
361 (fromIntegral w5 `shiftL` 24) .|.
362 (fromIntegral w6 `shiftL` 16) .|.
363 (fromIntegral w7 `shiftL` 8) .|.
364 (fromIntegral w8))
365
366 -- -----------------------------------------------------------------------------
367 -- Primitve Int writes
368
369 instance Binary Int8 where
370 put_ h w = put_ h (fromIntegral w :: Word8)
371 get h = do w <- get h; return $! (fromIntegral (w::Word8))
372
373 instance Binary Int16 where
374 put_ h w = put_ h (fromIntegral w :: Word16)
375 get h = do w <- get h; return $! (fromIntegral (w::Word16))
376
377 instance Binary Int32 where
378 put_ h w = put_ h (fromIntegral w :: Word32)
379 get h = do w <- get h; return $! (fromIntegral (w::Word32))
380
381 instance Binary Int64 where
382 put_ h w = put_ h (fromIntegral w :: Word64)
383 get h = do w <- get h; return $! (fromIntegral (w::Word64))
384
385 -- -----------------------------------------------------------------------------
386 -- Instances for standard types
387
388 instance Binary () where
389 put_ _ () = return ()
390 get _ = return ()
391 -- getF bh p = case getBitsF bh 0 p of (_,b) -> ((),b)
392
393 instance Binary Bool where
394 put_ bh b = putByte bh (fromIntegral (fromEnum b))
395 get bh = do x <- getWord8 bh; return $! (toEnum (fromIntegral x))
396 -- getF bh p = case getBitsF bh 1 p of (x,b) -> (toEnum x,b)
397
398 instance Binary Char where
399 put_ bh c = put_ bh (fromIntegral (ord c) :: Word32)
400 get bh = do x <- get bh; return $! (chr (fromIntegral (x :: Word32)))
401 -- getF bh p = case getBitsF bh 8 p of (x,b) -> (toEnum x,b)
402
403 instance Binary Int where
404 #if SIZEOF_HSINT == 4
405 put_ bh i = put_ bh (fromIntegral i :: Int32)
406 get bh = do
407 x <- get bh
408 return $! (fromIntegral (x :: Int32))
409 #elif SIZEOF_HSINT == 8
410 put_ bh i = put_ bh (fromIntegral i :: Int64)
411 get bh = do
412 x <- get bh
413 return $! (fromIntegral (x :: Int64))
414 #else
415 #error "unsupported sizeof(HsInt)"
416 #endif
417 -- getF bh = getBitsF bh 32
418
419 instance Binary a => Binary [a] where
420 put_ bh l = do
421 let len = length l
422 if (len < 0xff)
423 then putByte bh (fromIntegral len :: Word8)
424 else do putByte bh 0xff; put_ bh (fromIntegral len :: Word32)
425 mapM_ (put_ bh) l
426 get bh = do
427 b <- getByte bh
428 len <- if b == 0xff
429 then get bh
430 else return (fromIntegral b :: Word32)
431 let loop 0 = return []
432 loop n = do a <- get bh; as <- loop (n-1); return (a:as)
433 loop len
434
435 instance (Binary a, Binary b) => Binary (a,b) where
436 put_ bh (a,b) = do put_ bh a; put_ bh b
437 get bh = do a <- get bh
438 b <- get bh
439 return (a,b)
440
441 instance (Binary a, Binary b, Binary c) => Binary (a,b,c) where
442 put_ bh (a,b,c) = do put_ bh a; put_ bh b; put_ bh c
443 get bh = do a <- get bh
444 b <- get bh
445 c <- get bh
446 return (a,b,c)
447
448 instance (Binary a, Binary b, Binary c, Binary d) => Binary (a,b,c,d) where
449 put_ bh (a,b,c,d) = do put_ bh a; put_ bh b; put_ bh c; put_ bh d
450 get bh = do a <- get bh
451 b <- get bh
452 c <- get bh
453 d <- get bh
454 return (a,b,c,d)
455
456 instance Binary a => Binary (Maybe a) where
457 put_ bh Nothing = putByte bh 0
458 put_ bh (Just a) = do putByte bh 1; put_ bh a
459 get bh = do h <- getWord8 bh
460 case h of
461 0 -> return Nothing
462 _ -> do x <- get bh; return (Just x)
463
464 instance (Binary a, Binary b) => Binary (Either a b) where
465 put_ bh (Left a) = do putByte bh 0; put_ bh a
466 put_ bh (Right b) = do putByte bh 1; put_ bh b
467 get bh = do h <- getWord8 bh
468 case h of
469 0 -> do a <- get bh ; return (Left a)
470 _ -> do b <- get bh ; return (Right b)
471
472 #if defined(__GLASGOW_HASKELL__) || 1
473 --to quote binary-0.3 on this code idea,
474 --
475 -- TODO This instance is not architecture portable. GMP stores numbers as
476 -- arrays of machine sized words, so the byte format is not portable across
477 -- architectures with different endianess and word size.
478 --
479 -- This makes it hard (impossible) to make an equivalent instance
480 -- with code that is compilable with non-GHC. Do we need any instance
481 -- Binary Integer, and if so, does it have to be blazing fast? Or can
482 -- we just change this instance to be portable like the rest of the
483 -- instances? (binary package has code to steal for that)
484 --
485 -- yes, we need Binary Integer and Binary Rational in basicTypes/Literal.lhs
486
487 instance Binary Integer where
488 -- XXX This is hideous
489 put_ bh i = put_ bh (show i)
490 get bh = do str <- get bh
491 case reads str of
492 [(i, "")] -> return i
493 _ -> fail ("Binary Integer: got " ++ show str)
494
495 {-
496 put_ bh (S# i#) = do putByte bh 0; put_ bh (I# i#)
497 put_ bh (J# s# a#) = do
498 putByte bh 1
499 put_ bh (I# s#)
500 let sz# = sizeofByteArray# a# -- in *bytes*
501 put_ bh (I# sz#) -- in *bytes*
502 putByteArray bh a# sz#
503
504 get bh = do
505 b <- getByte bh
506 case b of
507 0 -> do (I# i#) <- get bh
508 return (S# i#)
509 _ -> do (I# s#) <- get bh
510 sz <- get bh
511 (BA a#) <- getByteArray bh sz
512 return (J# s# a#)
513 -}
514
515 -- As for the rest of this code, even though this module
516 -- exports it, it doesn't seem to be used anywhere else
517 -- in GHC!
518
519 putByteArray :: BinHandle -> ByteArray# -> Int# -> IO ()
520 putByteArray bh a s# = loop 0#
521 where loop n#
522 | n# ==# s# = return ()
523 | otherwise = do
524 putByte bh (indexByteArray a n#)
525 loop (n# +# 1#)
526
527 getByteArray :: BinHandle -> Int -> IO ByteArray
528 getByteArray bh (I# sz) = do
529 (MBA arr) <- newByteArray sz
530 let loop n
531 | n ==# sz = return ()
532 | otherwise = do
533 w <- getByte bh
534 writeByteArray arr n w
535 loop (n +# 1#)
536 loop 0#
537 freezeByteArray arr
538
539
540 data ByteArray = BA ByteArray#
541 data MBA = MBA (MutableByteArray# RealWorld)
542
543 newByteArray :: Int# -> IO MBA
544 newByteArray sz = IO $ \s ->
545 case newByteArray# sz s of { (# s, arr #) ->
546 (# s, MBA arr #) }
547
548 freezeByteArray :: MutableByteArray# RealWorld -> IO ByteArray
549 freezeByteArray arr = IO $ \s ->
550 case unsafeFreezeByteArray# arr s of { (# s, arr #) ->
551 (# s, BA arr #) }
552
553 writeByteArray :: MutableByteArray# RealWorld -> Int# -> Word8 -> IO ()
554 writeByteArray arr i (W8# w) = IO $ \s ->
555 case writeWord8Array# arr i w s of { s ->
556 (# s, () #) }
557
558 indexByteArray :: ByteArray# -> Int# -> Word8
559 indexByteArray a# n# = W8# (indexWord8Array# a# n#)
560
561 instance (Integral a, Binary a) => Binary (Ratio a) where
562 put_ bh (a :% b) = do put_ bh a; put_ bh b
563 get bh = do a <- get bh; b <- get bh; return (a :% b)
564 #endif
565
566 instance Binary (Bin a) where
567 put_ bh (BinPtr i) = put_ bh i
568 get bh = do i <- get bh; return (BinPtr i)
569
570 -- -----------------------------------------------------------------------------
571 -- Instances for Data.Typeable stuff
572
573 instance Binary TyCon where
574 put_ bh ty_con = do
575 let s = tyConString ty_con
576 put_ bh s
577 get bh = do
578 s <- get bh
579 return (mkTyCon s)
580
581 instance Binary TypeRep where
582 put_ bh type_rep = do
583 let (ty_con, child_type_reps) = splitTyConApp type_rep
584 put_ bh ty_con
585 put_ bh child_type_reps
586 get bh = do
587 ty_con <- get bh
588 child_type_reps <- get bh
589 return (mkTyConApp ty_con child_type_reps)
590
591 -- -----------------------------------------------------------------------------
592 -- Lazy reading/writing
593
594 lazyPut :: Binary a => BinHandle -> a -> IO ()
595 lazyPut bh a = do
596 -- output the obj with a ptr to skip over it:
597 pre_a <- tellBin bh
598 put_ bh pre_a -- save a slot for the ptr
599 put_ bh a -- dump the object
600 q <- tellBin bh -- q = ptr to after object
601 putAt bh pre_a q -- fill in slot before a with ptr to q
602 seekBin bh q -- finally carry on writing at q
603
604 lazyGet :: Binary a => BinHandle -> IO a
605 lazyGet bh = do
606 p <- get bh -- a BinPtr
607 p_a <- tellBin bh
608 a <- unsafeInterleaveIO (getAt bh p_a)
609 seekBin bh p -- skip over the object for now
610 return a
611
612 -- -----------------------------------------------------------------------------
613 -- UserData
614 -- -----------------------------------------------------------------------------
615
616 data UserData =
617 UserData {
618 -- for *deserialising* only:
619 ud_dict :: Dictionary,
620 ud_symtab :: SymbolTable,
621
622 -- for *serialising* only:
623 ud_put_name :: BinHandle -> Name -> IO (),
624 ud_put_fs :: BinHandle -> FastString -> IO ()
625 }
626
627 newReadState :: Dictionary -> IO UserData
628 newReadState dict = do
629 return UserData { ud_dict = dict,
630 ud_symtab = undef "symtab",
631 ud_put_name = undef "put_name",
632 ud_put_fs = undef "put_fs"
633 }
634
635 newWriteState :: (BinHandle -> Name -> IO ())
636 -> (BinHandle -> FastString -> IO ())
637 -> IO UserData
638 newWriteState put_name put_fs = do
639 return UserData { ud_dict = undef "dict",
640 ud_symtab = undef "symtab",
641 ud_put_name = put_name,
642 ud_put_fs = put_fs
643 }
644
645 noUserData :: a
646 noUserData = undef "UserData"
647
648 undef :: String -> a
649 undef s = panic ("Binary.UserData: no " ++ s)
650
651 ---------------------------------------------------------
652 -- The Dictionary
653 ---------------------------------------------------------
654
655 type Dictionary = Array Int FastString -- The dictionary
656 -- Should be 0-indexed
657
658 putDictionary :: BinHandle -> Int -> UniqFM (Int,FastString) -> IO ()
659 putDictionary bh sz dict = do
660 put_ bh sz
661 mapM_ (putFS bh) (elems (array (0,sz-1) (eltsUFM dict)))
662
663 getDictionary :: BinHandle -> IO Dictionary
664 getDictionary bh = do
665 sz <- get bh
666 elems <- sequence (take sz (repeat (getFS bh)))
667 return (listArray (0,sz-1) elems)
668
669 ---------------------------------------------------------
670 -- The Symbol Table
671 ---------------------------------------------------------
672
673 -- On disk, the symbol table is an array of IfaceExtName, when
674 -- reading it in we turn it into a SymbolTable.
675
676 type SymbolTable = Array Int Name
677
678 ---------------------------------------------------------
679 -- Reading and writing FastStrings
680 ---------------------------------------------------------
681
682 putFS :: BinHandle -> FastString -> IO ()
683 putFS bh (FastString _ l _ buf _) = do
684 put_ bh l
685 withForeignPtr buf $ \ptr ->
686 let
687 go n | n == l = return ()
688 | otherwise = do
689 b <- peekElemOff ptr n
690 putByte bh b
691 go (n+1)
692 in
693 go 0
694
695 {- -- possible faster version, not quite there yet:
696 getFS bh@BinMem{} = do
697 (I# l) <- get bh
698 arr <- readIORef (arr_r bh)
699 off <- readFastMutInt (off_r bh)
700 return $! (mkFastSubStringBA# arr off l)
701 -}
702 getFS :: BinHandle -> IO FastString
703 getFS bh = do
704 l <- get bh
705 fp <- mallocForeignPtrBytes l
706 withForeignPtr fp $ \ptr -> do
707 let
708 go n | n == l = mkFastStringForeignPtr ptr fp 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 FastString where
717 put_ bh f =
718 case getUserData bh of
719 UserData { ud_put_fs = put_fs } -> put_fs bh f
720
721 get bh = do
722 j <- get bh
723 return $! (ud_dict (getUserData bh) ! j)
724
725 -- Here to avoid loop
726
727 instance Binary Fingerprint where
728 put_ h (Fingerprint w1 w2) = do put_ h w1; put_ h w2
729 get h = do w1 <- get h; w2 <- get h; return (Fingerprint w1 w2)
730
731 instance Binary FunctionOrData where
732 put_ bh IsFunction = putByte bh 0
733 put_ bh IsData = putByte bh 1
734 get bh = do
735 h <- getByte bh
736 case h of
737 0 -> return IsFunction
738 1 -> return IsData
739 _ -> panic "Binary FunctionOrData"
740