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