Remove code that is dead now that we need >= 6.12 to build
[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 (Maybe a) where
439 put_ bh Nothing = putByte bh 0
440 put_ bh (Just a) = do putByte bh 1; put_ bh a
441 get bh = do h <- getWord8 bh
442 case h of
443 0 -> return Nothing
444 _ -> do x <- get bh; return (Just x)
445
446 instance (Binary a, Binary b) => Binary (Either a b) where
447 put_ bh (Left a) = do putByte bh 0; put_ bh a
448 put_ bh (Right b) = do putByte bh 1; put_ bh b
449 get bh = do h <- getWord8 bh
450 case h of
451 0 -> do a <- get bh ; return (Left a)
452 _ -> do b <- get bh ; return (Right b)
453
454 #if defined(__GLASGOW_HASKELL__) || 1
455 --to quote binary-0.3 on this code idea,
456 --
457 -- TODO This instance is not architecture portable. GMP stores numbers as
458 -- arrays of machine sized words, so the byte format is not portable across
459 -- architectures with different endianess and word size.
460 --
461 -- This makes it hard (impossible) to make an equivalent instance
462 -- with code that is compilable with non-GHC. Do we need any instance
463 -- Binary Integer, and if so, does it have to be blazing fast? Or can
464 -- we just change this instance to be portable like the rest of the
465 -- instances? (binary package has code to steal for that)
466 --
467 -- yes, we need Binary Integer and Binary Rational in basicTypes/Literal.lhs
468
469 instance Binary Integer where
470 -- XXX This is hideous
471 put_ bh i = put_ bh (show i)
472 get bh = do str <- get bh
473 case reads str of
474 [(i, "")] -> return i
475 _ -> fail ("Binary Integer: got " ++ show str)
476
477 {-
478 put_ bh (S# i#) = do putByte bh 0; put_ bh (I# i#)
479 put_ bh (J# s# a#) = do
480 putByte bh 1
481 put_ bh (I# s#)
482 let sz# = sizeofByteArray# a# -- in *bytes*
483 put_ bh (I# sz#) -- in *bytes*
484 putByteArray bh a# sz#
485
486 get bh = do
487 b <- getByte bh
488 case b of
489 0 -> do (I# i#) <- get bh
490 return (S# i#)
491 _ -> do (I# s#) <- get bh
492 sz <- get bh
493 (BA a#) <- getByteArray bh sz
494 return (J# s# a#)
495 -}
496
497 -- As for the rest of this code, even though this module
498 -- exports it, it doesn't seem to be used anywhere else
499 -- in GHC!
500
501 putByteArray :: BinHandle -> ByteArray# -> Int# -> IO ()
502 putByteArray bh a s# = loop 0#
503 where loop n#
504 | n# ==# s# = return ()
505 | otherwise = do
506 putByte bh (indexByteArray a n#)
507 loop (n# +# 1#)
508
509 getByteArray :: BinHandle -> Int -> IO ByteArray
510 getByteArray bh (I# sz) = do
511 (MBA arr) <- newByteArray sz
512 let loop n
513 | n ==# sz = return ()
514 | otherwise = do
515 w <- getByte bh
516 writeByteArray arr n w
517 loop (n +# 1#)
518 loop 0#
519 freezeByteArray arr
520
521
522 data ByteArray = BA ByteArray#
523 data MBA = MBA (MutableByteArray# RealWorld)
524
525 newByteArray :: Int# -> IO MBA
526 newByteArray sz = IO $ \s ->
527 case newByteArray# sz s of { (# s, arr #) ->
528 (# s, MBA arr #) }
529
530 freezeByteArray :: MutableByteArray# RealWorld -> IO ByteArray
531 freezeByteArray arr = IO $ \s ->
532 case unsafeFreezeByteArray# arr s of { (# s, arr #) ->
533 (# s, BA arr #) }
534
535 writeByteArray :: MutableByteArray# RealWorld -> Int# -> Word8 -> IO ()
536 writeByteArray arr i (W8# w) = IO $ \s ->
537 case writeWord8Array# arr i w s of { s ->
538 (# s, () #) }
539
540 indexByteArray :: ByteArray# -> Int# -> Word8
541 indexByteArray a# n# = W8# (indexWord8Array# a# n#)
542
543 instance (Integral a, Binary a) => Binary (Ratio a) where
544 put_ bh (a :% b) = do put_ bh a; put_ bh b
545 get bh = do a <- get bh; b <- get bh; return (a :% b)
546 #endif
547
548 instance Binary (Bin a) where
549 put_ bh (BinPtr i) = put_ bh (fromIntegral i :: Int32)
550 get bh = do i <- get bh; return (BinPtr (fromIntegral (i :: Int32)))
551
552 -- -----------------------------------------------------------------------------
553 -- Instances for Data.Typeable stuff
554
555 instance Binary TyCon where
556 put_ bh ty_con = do
557 let s = tyConString ty_con
558 put_ bh s
559 get bh = do
560 s <- get bh
561 return (mkTyCon s)
562
563 instance Binary TypeRep where
564 put_ bh type_rep = do
565 let (ty_con, child_type_reps) = splitTyConApp type_rep
566 put_ bh ty_con
567 put_ bh child_type_reps
568 get bh = do
569 ty_con <- get bh
570 child_type_reps <- get bh
571 return (mkTyConApp ty_con child_type_reps)
572
573 -- -----------------------------------------------------------------------------
574 -- Lazy reading/writing
575
576 lazyPut :: Binary a => BinHandle -> a -> IO ()
577 lazyPut bh a = do
578 -- output the obj with a ptr to skip over it:
579 pre_a <- tellBin bh
580 put_ bh pre_a -- save a slot for the ptr
581 put_ bh a -- dump the object
582 q <- tellBin bh -- q = ptr to after object
583 putAt bh pre_a q -- fill in slot before a with ptr to q
584 seekBin bh q -- finally carry on writing at q
585
586 lazyGet :: Binary a => BinHandle -> IO a
587 lazyGet bh = do
588 p <- get bh -- a BinPtr
589 p_a <- tellBin bh
590 a <- unsafeInterleaveIO (getAt bh p_a)
591 seekBin bh p -- skip over the object for now
592 return a
593
594 -- -----------------------------------------------------------------------------
595 -- UserData
596 -- -----------------------------------------------------------------------------
597
598 data UserData =
599 UserData {
600 -- for *deserialising* only:
601 ud_dict :: Dictionary,
602 ud_symtab :: SymbolTable,
603
604 -- for *serialising* only:
605 ud_put_name :: BinHandle -> Name -> IO (),
606 ud_put_fs :: BinHandle -> FastString -> IO ()
607 }
608
609 newReadState :: Dictionary -> IO UserData
610 newReadState dict = do
611 return UserData { ud_dict = dict,
612 ud_symtab = undef "symtab",
613 ud_put_name = undef "put_name",
614 ud_put_fs = undef "put_fs"
615 }
616
617 newWriteState :: (BinHandle -> Name -> IO ())
618 -> (BinHandle -> FastString -> IO ())
619 -> IO UserData
620 newWriteState put_name put_fs = do
621 return UserData { ud_dict = undef "dict",
622 ud_symtab = undef "symtab",
623 ud_put_name = put_name,
624 ud_put_fs = put_fs
625 }
626
627 noUserData :: a
628 noUserData = undef "UserData"
629
630 undef :: String -> a
631 undef s = panic ("Binary.UserData: no " ++ s)
632
633 ---------------------------------------------------------
634 -- The Dictionary
635 ---------------------------------------------------------
636
637 type Dictionary = Array Int FastString -- The dictionary
638 -- Should be 0-indexed
639
640 putDictionary :: BinHandle -> Int -> UniqFM (Int,FastString) -> IO ()
641 putDictionary bh sz dict = do
642 put_ bh sz
643 mapM_ (putFS bh) (elems (array (0,sz-1) (eltsUFM dict)))
644
645 getDictionary :: BinHandle -> IO Dictionary
646 getDictionary bh = do
647 sz <- get bh
648 elems <- sequence (take sz (repeat (getFS bh)))
649 return (listArray (0,sz-1) elems)
650
651 ---------------------------------------------------------
652 -- The Symbol Table
653 ---------------------------------------------------------
654
655 -- On disk, the symbol table is an array of IfaceExtName, when
656 -- reading it in we turn it into a SymbolTable.
657
658 type SymbolTable = Array Int Name
659
660 ---------------------------------------------------------
661 -- Reading and writing FastStrings
662 ---------------------------------------------------------
663
664 putFS :: BinHandle -> FastString -> IO ()
665 putFS bh (FastString _ l _ buf _) = do
666 put_ bh l
667 withForeignPtr buf $ \ptr ->
668 let
669 go n | n == l = return ()
670 | otherwise = do
671 b <- peekElemOff ptr n
672 putByte bh b
673 go (n+1)
674 in
675 go 0
676
677 {- -- possible faster version, not quite there yet:
678 getFS bh@BinMem{} = do
679 (I# l) <- get bh
680 arr <- readIORef (arr_r bh)
681 off <- readFastMutInt (off_r bh)
682 return $! (mkFastSubStringBA# arr off l)
683 -}
684 getFS :: BinHandle -> IO FastString
685 getFS bh = do
686 l <- get bh
687 fp <- mallocForeignPtrBytes l
688 withForeignPtr fp $ \ptr -> do
689 let
690 go n | n == l = mkFastStringForeignPtr ptr fp l
691 | otherwise = do
692 b <- getByte bh
693 pokeElemOff ptr n b
694 go (n+1)
695 --
696 go 0
697
698 instance Binary FastString where
699 put_ bh f =
700 case getUserData bh of
701 UserData { ud_put_fs = put_fs } -> put_fs bh f
702
703 get bh = do
704 j <- get bh
705 return $! (ud_dict (getUserData bh) ! (fromIntegral (j :: Word32)))
706
707 -- Here to avoid loop
708
709 instance Binary Fingerprint where
710 put_ h (Fingerprint w1 w2) = do put_ h w1; put_ h w2
711 get h = do w1 <- get h; w2 <- get h; return (Fingerprint w1 w2)
712
713 instance Binary FunctionOrData where
714 put_ bh IsFunction = putByte bh 0
715 put_ bh IsData = putByte bh 1
716 get bh = do
717 h <- getByte bh
718 case h of
719 0 -> return IsFunction
720 1 -> return IsData
721 _ -> panic "Binary FunctionOrData"
722