remove the "expanding to size" messages
[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 #if defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ < 601
83 -- openFileEx is available from the lang package, but we want to
84 -- be independent of hslibs libraries.
85 import GHC.Handle ( openFileEx, IOModeEx(..) )
86 #else
87 import System.IO ( openBinaryFile )
88 #endif
89
90 #if defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ < 601
91 openBinaryFile f mode = openFileEx f (BinaryMode mode)
92 #endif
93
94 type BinArray = ForeignPtr Word8
95
96 ---------------------------------------------------------------
97 -- BinHandle
98 ---------------------------------------------------------------
99
100 data BinHandle
101 = BinMem { -- binary data stored in an unboxed array
102 bh_usr :: UserData, -- sigh, need parameterized modules :-)
103 _off_r :: !FastMutInt, -- the current offset
104 _sz_r :: !FastMutInt, -- size of the array (cached)
105 _arr_r :: !(IORef BinArray) -- the array (bounds: (0,size-1))
106 }
107 -- XXX: should really store a "high water mark" for dumping out
108 -- the binary data to a file.
109
110 | BinIO { -- binary data stored in a file
111 bh_usr :: UserData,
112 _off_r :: !FastMutInt, -- the current offset (cached)
113 _hdl :: !IO.Handle -- the file handle (must be seekable)
114 }
115 -- cache the file ptr in BinIO; using hTell is too expensive
116 -- to call repeatedly. If anyone else is modifying this Handle
117 -- at the same time, we'll be screwed.
118
119 getUserData :: BinHandle -> UserData
120 getUserData bh = bh_usr bh
121
122 setUserData :: BinHandle -> UserData -> BinHandle
123 setUserData bh us = bh { bh_usr = us }
124
125
126 ---------------------------------------------------------------
127 -- Bin
128 ---------------------------------------------------------------
129
130 newtype Bin a = BinPtr Int
131 deriving (Eq, Ord, Show, Bounded)
132
133 castBin :: Bin a -> Bin b
134 castBin (BinPtr i) = BinPtr i
135
136 ---------------------------------------------------------------
137 -- class Binary
138 ---------------------------------------------------------------
139
140 class Binary a where
141 put_ :: BinHandle -> a -> IO ()
142 put :: BinHandle -> a -> IO (Bin a)
143 get :: BinHandle -> IO a
144
145 -- define one of put_, put. Use of put_ is recommended because it
146 -- is more likely that tail-calls can kick in, and we rarely need the
147 -- position return value.
148 put_ bh a = do put bh a; return ()
149 put bh a = do p <- tellBin bh; put_ bh a; return p
150
151 putAt :: Binary a => BinHandle -> Bin a -> a -> IO ()
152 putAt bh p x = do seekBin bh p; put bh x; return ()
153
154 getAt :: Binary a => BinHandle -> Bin a -> IO a
155 getAt bh p = do seekBin bh p; get bh
156
157 openBinIO_ :: IO.Handle -> IO BinHandle
158 openBinIO_ h = openBinIO h
159
160 openBinIO :: IO.Handle -> IO BinHandle
161 openBinIO h = do
162 r <- newFastMutInt
163 writeFastMutInt r 0
164 return (BinIO noUserData r h)
165
166 openBinMem :: Int -> IO BinHandle
167 openBinMem size
168 | size <= 0 = error "Data.Binary.openBinMem: size must be >= 0"
169 | otherwise = do
170 arr <- mallocForeignPtrBytes size
171 arr_r <- newIORef arr
172 ix_r <- newFastMutInt
173 writeFastMutInt ix_r 0
174 sz_r <- newFastMutInt
175 writeFastMutInt sz_r size
176 return (BinMem noUserData ix_r sz_r arr_r)
177
178 tellBin :: BinHandle -> IO (Bin a)
179 tellBin (BinIO _ r _) = do ix <- readFastMutInt r; return (BinPtr ix)
180 tellBin (BinMem _ r _ _) = do ix <- readFastMutInt r; return (BinPtr ix)
181
182 seekBin :: BinHandle -> Bin a -> IO ()
183 seekBin (BinIO _ ix_r h) (BinPtr p) = do
184 writeFastMutInt ix_r p
185 hSeek h AbsoluteSeek (fromIntegral p)
186 seekBin h@(BinMem _ ix_r sz_r _) (BinPtr p) = do
187 sz <- readFastMutInt sz_r
188 if (p >= sz)
189 then do expandBin h p; writeFastMutInt ix_r p
190 else writeFastMutInt ix_r p
191
192 seekBy :: BinHandle -> Int -> IO ()
193 seekBy (BinIO _ ix_r h) off = do
194 ix <- readFastMutInt ix_r
195 let ix' = ix + off
196 writeFastMutInt ix_r ix'
197 hSeek h AbsoluteSeek (fromIntegral ix')
198 seekBy h@(BinMem _ ix_r sz_r _) off = do
199 sz <- readFastMutInt sz_r
200 ix <- readFastMutInt ix_r
201 let ix' = ix + off
202 if (ix' >= sz)
203 then do expandBin h ix'; writeFastMutInt ix_r ix'
204 else writeFastMutInt ix_r ix'
205
206 isEOFBin :: BinHandle -> IO Bool
207 isEOFBin (BinMem _ ix_r sz_r _) = do
208 ix <- readFastMutInt ix_r
209 sz <- readFastMutInt sz_r
210 return (ix >= sz)
211 isEOFBin (BinIO _ _ h) = hIsEOF h
212
213 writeBinMem :: BinHandle -> FilePath -> IO ()
214 writeBinMem (BinIO _ _ _) _ = error "Data.Binary.writeBinMem: not a memory handle"
215 writeBinMem (BinMem _ ix_r _ arr_r) fn = do
216 h <- openBinaryFile fn WriteMode
217 arr <- readIORef arr_r
218 ix <- readFastMutInt ix_r
219 withForeignPtr arr $ \p -> hPutBuf h p ix
220 hClose h
221
222 readBinMem :: FilePath -> IO BinHandle
223 -- Return a BinHandle with a totally undefined State
224 readBinMem filename = do
225 h <- openBinaryFile filename ReadMode
226 filesize' <- hFileSize h
227 let filesize = fromIntegral filesize'
228 arr <- mallocForeignPtrBytes (filesize*2)
229 count <- withForeignPtr arr $ \p -> hGetBuf h p filesize
230 when (count /= filesize) $
231 error ("Binary.readBinMem: only read " ++ show count ++ " bytes")
232 hClose h
233 arr_r <- newIORef arr
234 ix_r <- newFastMutInt
235 writeFastMutInt ix_r 0
236 sz_r <- newFastMutInt
237 writeFastMutInt sz_r filesize
238 return (BinMem noUserData ix_r sz_r arr_r)
239
240 fingerprintBinMem :: BinHandle -> IO Fingerprint
241 fingerprintBinMem (BinIO _ _ _) = error "Binary.md5BinMem: not a memory handle"
242 fingerprintBinMem (BinMem _ ix_r _ arr_r) = do
243 arr <- readIORef arr_r
244 ix <- readFastMutInt ix_r
245 withForeignPtr arr $ \p -> fingerprintData p ix
246
247 -- expand the size of the array to include a specified offset
248 expandBin :: BinHandle -> Int -> IO ()
249 expandBin (BinMem _ _ sz_r arr_r) off = do
250 sz <- readFastMutInt sz_r
251 let sz' = head (dropWhile (<= off) (iterate (* 2) sz))
252 arr <- readIORef arr_r
253 arr' <- mallocForeignPtrBytes sz'
254 withForeignPtr arr $ \old ->
255 withForeignPtr arr' $ \new ->
256 copyBytes new old sz
257 writeFastMutInt sz_r sz'
258 writeIORef arr_r arr'
259 when False $ -- disabled
260 hPutStrLn stderr ("Binary: expanding to size: " ++ show sz')
261 return ()
262 expandBin (BinIO _ _ _) _ = return ()
263 -- no need to expand a file, we'll assume they expand by themselves.
264
265 -- -----------------------------------------------------------------------------
266 -- Low-level reading/writing of bytes
267
268 putWord8 :: BinHandle -> Word8 -> IO ()
269 putWord8 h@(BinMem _ ix_r sz_r arr_r) w = do
270 ix <- readFastMutInt ix_r
271 sz <- readFastMutInt sz_r
272 -- double the size of the array if it overflows
273 if (ix >= sz)
274 then do expandBin h ix
275 putWord8 h w
276 else do arr <- readIORef arr_r
277 withForeignPtr arr $ \p -> pokeByteOff p ix w
278 writeFastMutInt ix_r (ix+1)
279 return ()
280 putWord8 (BinIO _ ix_r h) w = do
281 ix <- readFastMutInt ix_r
282 hPutChar h (chr (fromIntegral w)) -- XXX not really correct
283 writeFastMutInt ix_r (ix+1)
284 return ()
285
286 getWord8 :: BinHandle -> IO Word8
287 getWord8 (BinMem _ ix_r sz_r arr_r) = do
288 ix <- readFastMutInt ix_r
289 sz <- readFastMutInt sz_r
290 when (ix >= sz) $
291 ioError (mkIOError eofErrorType "Data.Binary.getWord8" Nothing Nothing)
292 arr <- readIORef arr_r
293 w <- withForeignPtr arr $ \p -> peekByteOff p ix
294 writeFastMutInt ix_r (ix+1)
295 return w
296 getWord8 (BinIO _ ix_r h) = do
297 ix <- readFastMutInt ix_r
298 c <- hGetChar h
299 writeFastMutInt ix_r (ix+1)
300 return $! (fromIntegral (ord c)) -- XXX not really correct
301
302 putByte :: BinHandle -> Word8 -> IO ()
303 putByte bh w = put_ bh w
304
305 getByte :: BinHandle -> IO Word8
306 getByte = getWord8
307
308 -- -----------------------------------------------------------------------------
309 -- Primitve Word writes
310
311 instance Binary Word8 where
312 put_ = putWord8
313 get = getWord8
314
315 instance Binary Word16 where
316 put_ h w = do -- XXX too slow.. inline putWord8?
317 putByte h (fromIntegral (w `shiftR` 8))
318 putByte h (fromIntegral (w .&. 0xff))
319 get h = do
320 w1 <- getWord8 h
321 w2 <- getWord8 h
322 return $! ((fromIntegral w1 `shiftL` 8) .|. fromIntegral w2)
323
324
325 instance Binary Word32 where
326 put_ h w = do
327 putByte h (fromIntegral (w `shiftR` 24))
328 putByte h (fromIntegral ((w `shiftR` 16) .&. 0xff))
329 putByte h (fromIntegral ((w `shiftR` 8) .&. 0xff))
330 putByte h (fromIntegral (w .&. 0xff))
331 get h = do
332 w1 <- getWord8 h
333 w2 <- getWord8 h
334 w3 <- getWord8 h
335 w4 <- getWord8 h
336 return $! ((fromIntegral w1 `shiftL` 24) .|.
337 (fromIntegral w2 `shiftL` 16) .|.
338 (fromIntegral w3 `shiftL` 8) .|.
339 (fromIntegral w4))
340
341 instance Binary Word64 where
342 put_ h w = do
343 putByte h (fromIntegral (w `shiftR` 56))
344 putByte h (fromIntegral ((w `shiftR` 48) .&. 0xff))
345 putByte h (fromIntegral ((w `shiftR` 40) .&. 0xff))
346 putByte h (fromIntegral ((w `shiftR` 32) .&. 0xff))
347 putByte h (fromIntegral ((w `shiftR` 24) .&. 0xff))
348 putByte h (fromIntegral ((w `shiftR` 16) .&. 0xff))
349 putByte h (fromIntegral ((w `shiftR` 8) .&. 0xff))
350 putByte h (fromIntegral (w .&. 0xff))
351 get h = do
352 w1 <- getWord8 h
353 w2 <- getWord8 h
354 w3 <- getWord8 h
355 w4 <- getWord8 h
356 w5 <- getWord8 h
357 w6 <- getWord8 h
358 w7 <- getWord8 h
359 w8 <- getWord8 h
360 return $! ((fromIntegral w1 `shiftL` 56) .|.
361 (fromIntegral w2 `shiftL` 48) .|.
362 (fromIntegral w3 `shiftL` 40) .|.
363 (fromIntegral w4 `shiftL` 32) .|.
364 (fromIntegral w5 `shiftL` 24) .|.
365 (fromIntegral w6 `shiftL` 16) .|.
366 (fromIntegral w7 `shiftL` 8) .|.
367 (fromIntegral w8))
368
369 -- -----------------------------------------------------------------------------
370 -- Primitve Int writes
371
372 instance Binary Int8 where
373 put_ h w = put_ h (fromIntegral w :: Word8)
374 get h = do w <- get h; return $! (fromIntegral (w::Word8))
375
376 instance Binary Int16 where
377 put_ h w = put_ h (fromIntegral w :: Word16)
378 get h = do w <- get h; return $! (fromIntegral (w::Word16))
379
380 instance Binary Int32 where
381 put_ h w = put_ h (fromIntegral w :: Word32)
382 get h = do w <- get h; return $! (fromIntegral (w::Word32))
383
384 instance Binary Int64 where
385 put_ h w = put_ h (fromIntegral w :: Word64)
386 get h = do w <- get h; return $! (fromIntegral (w::Word64))
387
388 -- -----------------------------------------------------------------------------
389 -- Instances for standard types
390
391 instance Binary () where
392 put_ _ () = return ()
393 get _ = return ()
394 -- getF bh p = case getBitsF bh 0 p of (_,b) -> ((),b)
395
396 instance Binary Bool where
397 put_ bh b = putByte bh (fromIntegral (fromEnum b))
398 get bh = do x <- getWord8 bh; return $! (toEnum (fromIntegral x))
399 -- getF bh p = case getBitsF bh 1 p of (x,b) -> (toEnum x,b)
400
401 instance Binary Char where
402 put_ bh c = put_ bh (fromIntegral (ord c) :: Word32)
403 get bh = do x <- get bh; return $! (chr (fromIntegral (x :: Word32)))
404 -- getF bh p = case getBitsF bh 8 p of (x,b) -> (toEnum x,b)
405
406 instance Binary Int where
407 #if SIZEOF_HSINT == 4
408 put_ bh i = put_ bh (fromIntegral i :: Int32)
409 get bh = do
410 x <- get bh
411 return $! (fromIntegral (x :: Int32))
412 #elif SIZEOF_HSINT == 8
413 put_ bh i = put_ bh (fromIntegral i :: Int64)
414 get bh = do
415 x <- get bh
416 return $! (fromIntegral (x :: Int64))
417 #else
418 #error "unsupported sizeof(HsInt)"
419 #endif
420 -- getF bh = getBitsF bh 32
421
422 instance Binary a => Binary [a] where
423 put_ bh l = do
424 let len = length l
425 if (len < 0xff)
426 then putByte bh (fromIntegral len :: Word8)
427 else do putByte bh 0xff; put_ bh (fromIntegral len :: Word32)
428 mapM_ (put_ bh) l
429 get bh = do
430 b <- getByte bh
431 len <- if b == 0xff
432 then get bh
433 else return (fromIntegral b :: Word32)
434 let loop 0 = return []
435 loop n = do a <- get bh; as <- loop (n-1); return (a:as)
436 loop len
437
438 instance (Binary a, Binary b) => Binary (a,b) where
439 put_ bh (a,b) = do put_ bh a; put_ bh b
440 get bh = do a <- get bh
441 b <- get bh
442 return (a,b)
443
444 instance (Binary a, Binary b, Binary c) => Binary (a,b,c) where
445 put_ bh (a,b,c) = do put_ bh a; put_ bh b; put_ bh c
446 get bh = do a <- get bh
447 b <- get bh
448 c <- get bh
449 return (a,b,c)
450
451 instance (Binary a, Binary b, Binary c, Binary d) => Binary (a,b,c,d) where
452 put_ bh (a,b,c,d) = do put_ bh a; put_ bh b; put_ bh c; put_ bh d
453 get bh = do a <- get bh
454 b <- get bh
455 c <- get bh
456 d <- get bh
457 return (a,b,c,d)
458
459 instance Binary a => Binary (Maybe a) where
460 put_ bh Nothing = putByte bh 0
461 put_ bh (Just a) = do putByte bh 1; put_ bh a
462 get bh = do h <- getWord8 bh
463 case h of
464 0 -> return Nothing
465 _ -> do x <- get bh; return (Just x)
466
467 instance (Binary a, Binary b) => Binary (Either a b) where
468 put_ bh (Left a) = do putByte bh 0; put_ bh a
469 put_ bh (Right b) = do putByte bh 1; put_ bh b
470 get bh = do h <- getWord8 bh
471 case h of
472 0 -> do a <- get bh ; return (Left a)
473 _ -> do b <- get bh ; return (Right b)
474
475 #if defined(__GLASGOW_HASKELL__) || 1
476 --to quote binary-0.3 on this code idea,
477 --
478 -- TODO This instance is not architecture portable. GMP stores numbers as
479 -- arrays of machine sized words, so the byte format is not portable across
480 -- architectures with different endianess and word size.
481 --
482 -- This makes it hard (impossible) to make an equivalent instance
483 -- with code that is compilable with non-GHC. Do we need any instance
484 -- Binary Integer, and if so, does it have to be blazing fast? Or can
485 -- we just change this instance to be portable like the rest of the
486 -- instances? (binary package has code to steal for that)
487 --
488 -- yes, we need Binary Integer and Binary Rational in basicTypes/Literal.lhs
489
490 instance Binary Integer where
491 -- XXX This is hideous
492 put_ bh i = put_ bh (show i)
493 get bh = do str <- get bh
494 case reads str of
495 [(i, "")] -> return i
496 _ -> fail ("Binary Integer: got " ++ show str)
497
498 {-
499 put_ bh (S# i#) = do putByte bh 0; put_ bh (I# i#)
500 put_ bh (J# s# a#) = do
501 putByte bh 1
502 put_ bh (I# s#)
503 let sz# = sizeofByteArray# a# -- in *bytes*
504 put_ bh (I# sz#) -- in *bytes*
505 putByteArray bh a# sz#
506
507 get bh = do
508 b <- getByte bh
509 case b of
510 0 -> do (I# i#) <- get bh
511 return (S# i#)
512 _ -> do (I# s#) <- get bh
513 sz <- get bh
514 (BA a#) <- getByteArray bh sz
515 return (J# s# a#)
516 -}
517
518 -- As for the rest of this code, even though this module
519 -- exports it, it doesn't seem to be used anywhere else
520 -- in GHC!
521
522 putByteArray :: BinHandle -> ByteArray# -> Int# -> IO ()
523 putByteArray bh a s# = loop 0#
524 where loop n#
525 | n# ==# s# = return ()
526 | otherwise = do
527 putByte bh (indexByteArray a n#)
528 loop (n# +# 1#)
529
530 getByteArray :: BinHandle -> Int -> IO ByteArray
531 getByteArray bh (I# sz) = do
532 (MBA arr) <- newByteArray sz
533 let loop n
534 | n ==# sz = return ()
535 | otherwise = do
536 w <- getByte bh
537 writeByteArray arr n w
538 loop (n +# 1#)
539 loop 0#
540 freezeByteArray arr
541
542
543 data ByteArray = BA ByteArray#
544 data MBA = MBA (MutableByteArray# RealWorld)
545
546 newByteArray :: Int# -> IO MBA
547 newByteArray sz = IO $ \s ->
548 case newByteArray# sz s of { (# s, arr #) ->
549 (# s, MBA arr #) }
550
551 freezeByteArray :: MutableByteArray# RealWorld -> IO ByteArray
552 freezeByteArray arr = IO $ \s ->
553 case unsafeFreezeByteArray# arr s of { (# s, arr #) ->
554 (# s, BA arr #) }
555
556 writeByteArray :: MutableByteArray# RealWorld -> Int# -> Word8 -> IO ()
557 writeByteArray arr i (W8# w) = IO $ \s ->
558 case writeWord8Array# arr i w s of { s ->
559 (# s, () #) }
560
561 indexByteArray :: ByteArray# -> Int# -> Word8
562 indexByteArray a# n# = W8# (indexWord8Array# a# n#)
563
564 instance (Integral a, Binary a) => Binary (Ratio a) where
565 put_ bh (a :% b) = do put_ bh a; put_ bh b
566 get bh = do a <- get bh; b <- get bh; return (a :% b)
567 #endif
568
569 instance Binary (Bin a) where
570 put_ bh (BinPtr i) = put_ bh i
571 get bh = do i <- get bh; return (BinPtr i)
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) ! j)
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