Use MD5 checksums for recompilation checking (fixes #1372, #1959)
[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 Util
66 import Fingerprint
67
68 import Foreign
69 import Data.Array
70 import Data.Bits
71 import Data.Int
72 import Data.Word
73 import Data.IORef
74 import Data.Char ( ord, chr )
75 import Control.Monad ( when )
76 import System.IO as IO
77 import System.IO.Unsafe ( unsafeInterleaveIO )
78 import System.IO.Error ( mkIOError, eofErrorType )
79 import GHC.Real ( Ratio(..) )
80 import GHC.Exts
81 import GHC.IOBase ( IO(..) )
82 import GHC.Word ( Word8(..) )
83 #if defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ < 601
84 -- openFileEx is available from the lang package, but we want to
85 -- be independent of hslibs libraries.
86 import GHC.Handle ( openFileEx, IOModeEx(..) )
87 #else
88 import System.IO ( openBinaryFile )
89 #endif
90
91 #if defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ < 601
92 openBinaryFile f mode = openFileEx f (BinaryMode mode)
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 debugIsOn $
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 -- Lazy reading/writing
576
577 lazyPut :: Binary a => BinHandle -> a -> IO ()
578 lazyPut bh a = do
579 -- output the obj with a ptr to skip over it:
580 pre_a <- tellBin bh
581 put_ bh pre_a -- save a slot for the ptr
582 put_ bh a -- dump the object
583 q <- tellBin bh -- q = ptr to after object
584 putAt bh pre_a q -- fill in slot before a with ptr to q
585 seekBin bh q -- finally carry on writing at q
586
587 lazyGet :: Binary a => BinHandle -> IO a
588 lazyGet bh = do
589 p <- get bh -- a BinPtr
590 p_a <- tellBin bh
591 a <- unsafeInterleaveIO (getAt bh p_a)
592 seekBin bh p -- skip over the object for now
593 return a
594
595 -- -----------------------------------------------------------------------------
596 -- UserData
597 -- -----------------------------------------------------------------------------
598
599 data UserData =
600 UserData {
601 -- for *deserialising* only:
602 ud_dict :: Dictionary,
603 ud_symtab :: SymbolTable,
604
605 -- for *serialising* only:
606 ud_put_name :: BinHandle -> Name -> IO (),
607 ud_put_fs :: BinHandle -> FastString -> IO ()
608 }
609
610 newReadState :: Dictionary -> IO UserData
611 newReadState dict = do
612 return UserData { ud_dict = dict,
613 ud_symtab = undef "symtab",
614 ud_put_name = undef "put_name",
615 ud_put_fs = undef "put_fs"
616 }
617
618 newWriteState :: (BinHandle -> Name -> IO ())
619 -> (BinHandle -> FastString -> IO ())
620 -> IO UserData
621 newWriteState put_name put_fs = do
622 return UserData { ud_dict = undef "dict",
623 ud_symtab = undef "symtab",
624 ud_put_name = put_name,
625 ud_put_fs = put_fs
626 }
627
628 noUserData :: a
629 noUserData = undef "UserData"
630
631 undef :: String -> a
632 undef s = panic ("Binary.UserData: no " ++ s)
633
634 ---------------------------------------------------------
635 -- The Dictionary
636 ---------------------------------------------------------
637
638 type Dictionary = Array Int FastString -- The dictionary
639 -- Should be 0-indexed
640
641 putDictionary :: BinHandle -> Int -> UniqFM (Int,FastString) -> IO ()
642 putDictionary bh sz dict = do
643 put_ bh sz
644 mapM_ (putFS bh) (elems (array (0,sz-1) (eltsUFM dict)))
645
646 getDictionary :: BinHandle -> IO Dictionary
647 getDictionary bh = do
648 sz <- get bh
649 elems <- sequence (take sz (repeat (getFS bh)))
650 return (listArray (0,sz-1) elems)
651
652 ---------------------------------------------------------
653 -- The Symbol Table
654 ---------------------------------------------------------
655
656 -- On disk, the symbol table is an array of IfaceExtName, when
657 -- reading it in we turn it into a SymbolTable.
658
659 type SymbolTable = Array Int Name
660
661 ---------------------------------------------------------
662 -- Reading and writing FastStrings
663 ---------------------------------------------------------
664
665 putFS :: BinHandle -> FastString -> IO ()
666 putFS bh (FastString _ l _ buf _) = do
667 put_ bh l
668 withForeignPtr buf $ \ptr ->
669 let
670 go n | n == l = return ()
671 | otherwise = do
672 b <- peekElemOff ptr n
673 putByte bh b
674 go (n+1)
675 in
676 go 0
677
678 {- -- possible faster version, not quite there yet:
679 getFS bh@BinMem{} = do
680 (I# l) <- get bh
681 arr <- readIORef (arr_r bh)
682 off <- readFastMutInt (off_r bh)
683 return $! (mkFastSubStringBA# arr off l)
684 -}
685 getFS :: BinHandle -> IO FastString
686 getFS bh = do
687 l <- get bh
688 fp <- mallocForeignPtrBytes l
689 withForeignPtr fp $ \ptr -> do
690 let
691 go n | n == l = mkFastStringForeignPtr ptr fp l
692 | otherwise = do
693 b <- getByte bh
694 pokeElemOff ptr n b
695 go (n+1)
696 --
697 go 0
698
699 instance Binary FastString where
700 put_ bh f =
701 case getUserData bh of
702 UserData { ud_put_fs = put_fs } -> put_fs bh f
703
704 get bh = do
705 j <- get bh
706 return $! (ud_dict (getUserData bh) ! j)
707
708 -- Here to avoid loop
709
710 instance Binary Fingerprint where
711 put_ h (Fingerprint w1 w2) = do put_ h w1; put_ h w2
712 get h = do w1 <- get h; w2 <- get h; return (Fingerprint w1 w2)
713