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