remove #if branches for pre-ghc-6.0
[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 tellBin,
24 castBin,
25
26 writeBinMem,
27 readBinMem,
28
29 isEOFBin,
30
31 putAt, getAt,
32
33 -- for writing instances:
34 putByte,
35 getByte,
36
37 -- lazy Bin I/O
38 lazyGet,
39 lazyPut,
40
41 -- GHC only:
42 ByteArray(..),
43 getByteArray,
44 putByteArray,
45
46 UserData(..), getUserData, setUserData,
47 newReadState, newWriteState,
48 putDictionary, getDictionary,
49 ) where
50
51 #include "HsVersions.h"
52
53 -- The *host* architecture version:
54 #include "MachDeps.h"
55
56 import {-# SOURCE #-} Name (Name)
57 import FastString
58 import Unique
59 import Panic
60 import UniqFM
61 import FastMutInt
62 import PackageConfig
63
64 import Foreign
65 import Data.Array.IO
66 import Data.Array
67 import Data.Bits
68 import Data.Int
69 import Data.Word
70 import Data.IORef
71 import Data.Char ( ord, chr )
72 import Data.Array.Base ( unsafeRead, unsafeWrite )
73 import Control.Monad ( when )
74 import System.IO as IO
75 import System.IO.Unsafe ( unsafeInterleaveIO )
76 import System.IO.Error ( mkIOError, eofErrorType )
77 import GHC.Real ( Ratio(..) )
78 import GHC.Exts
79 import GHC.IOBase ( IO(..) )
80 import GHC.Word ( Word8(..) )
81 #if __GLASGOW_HASKELL__ < 601
82 -- openFileEx is available from the lang package, but we want to
83 -- be independent of hslibs libraries.
84 import GHC.Handle ( openFileEx, IOModeEx(..) )
85 #else
86 import System.IO ( openBinaryFile )
87 #endif
88
89 #if __GLASGOW_HASKELL__ < 601
90 openBinaryFile f mode = openFileEx f (BinaryMode mode)
91 #endif
92
93 type BinArray = IOUArray Int Word8
94
95 ---------------------------------------------------------------
96 -- BinHandle
97 ---------------------------------------------------------------
98
99 data BinHandle
100 = BinMem { -- binary data stored in an unboxed array
101 bh_usr :: UserData, -- sigh, need parameterized modules :-)
102 off_r :: !FastMutInt, -- the current offset
103 sz_r :: !FastMutInt, -- size of the array (cached)
104 arr_r :: !(IORef BinArray) -- the array (bounds: (0,size-1))
105 }
106 -- XXX: should really store a "high water mark" for dumping out
107 -- the binary data to a file.
108
109 | BinIO { -- binary data stored in a file
110 bh_usr :: UserData,
111 off_r :: !FastMutInt, -- the current offset (cached)
112 hdl :: !IO.Handle -- the file handle (must be seekable)
113 }
114 -- cache the file ptr in BinIO; using hTell is too expensive
115 -- to call repeatedly. If anyone else is modifying this Handle
116 -- at the same time, we'll be screwed.
117
118 getUserData :: BinHandle -> UserData
119 getUserData bh = bh_usr bh
120
121 setUserData :: BinHandle -> UserData -> BinHandle
122 setUserData bh us = bh { bh_usr = us }
123
124
125 ---------------------------------------------------------------
126 -- Bin
127 ---------------------------------------------------------------
128
129 newtype Bin a = BinPtr Int
130 deriving (Eq, Ord, Show, Bounded)
131
132 castBin :: Bin a -> Bin b
133 castBin (BinPtr i) = BinPtr i
134
135 ---------------------------------------------------------------
136 -- class Binary
137 ---------------------------------------------------------------
138
139 class Binary a where
140 put_ :: BinHandle -> a -> IO ()
141 put :: BinHandle -> a -> IO (Bin a)
142 get :: BinHandle -> IO a
143
144 -- define one of put_, put. Use of put_ is recommended because it
145 -- is more likely that tail-calls can kick in, and we rarely need the
146 -- position return value.
147 put_ bh a = do put bh a; return ()
148 put bh a = do p <- tellBin bh; put_ bh a; return p
149
150 putAt :: Binary a => BinHandle -> Bin a -> a -> IO ()
151 putAt bh p x = do seekBin bh p; put bh x; return ()
152
153 getAt :: Binary a => BinHandle -> Bin a -> IO a
154 getAt bh p = do seekBin bh p; get bh
155
156 openBinIO_ :: IO.Handle -> IO BinHandle
157 openBinIO_ h = openBinIO h
158
159 openBinIO :: IO.Handle -> IO BinHandle
160 openBinIO h = do
161 r <- newFastMutInt
162 writeFastMutInt r 0
163 return (BinIO noUserData r h)
164
165 openBinMem :: Int -> IO BinHandle
166 openBinMem size
167 | size <= 0 = error "Data.Binary.openBinMem: size must be >= 0"
168 | otherwise = do
169 arr <- newArray_ (0,size-1)
170 arr_r <- newIORef arr
171 ix_r <- newFastMutInt
172 writeFastMutInt ix_r 0
173 sz_r <- newFastMutInt
174 writeFastMutInt sz_r size
175 return (BinMem noUserData ix_r sz_r arr_r)
176
177 tellBin :: BinHandle -> IO (Bin a)
178 tellBin (BinIO _ r _) = do ix <- readFastMutInt r; return (BinPtr ix)
179 tellBin (BinMem _ r _ _) = do ix <- readFastMutInt r; return (BinPtr ix)
180
181 seekBin :: BinHandle -> Bin a -> IO ()
182 seekBin (BinIO _ ix_r h) (BinPtr p) = do
183 writeFastMutInt ix_r p
184 hSeek h AbsoluteSeek (fromIntegral p)
185 seekBin h@(BinMem _ ix_r sz_r a) (BinPtr p) = do
186 sz <- readFastMutInt sz_r
187 if (p >= sz)
188 then do expandBin h p; writeFastMutInt ix_r p
189 else writeFastMutInt ix_r p
190
191 isEOFBin :: BinHandle -> IO Bool
192 isEOFBin (BinMem _ ix_r sz_r a) = do
193 ix <- readFastMutInt ix_r
194 sz <- readFastMutInt sz_r
195 return (ix >= sz)
196 isEOFBin (BinIO _ ix_r h) = hIsEOF h
197
198 writeBinMem :: BinHandle -> FilePath -> IO ()
199 writeBinMem (BinIO _ _ _) _ = error "Data.Binary.writeBinMem: not a memory handle"
200 writeBinMem (BinMem _ ix_r sz_r arr_r) fn = do
201 h <- openBinaryFile fn WriteMode
202 arr <- readIORef arr_r
203 ix <- readFastMutInt ix_r
204 hPutArray h arr ix
205 hClose h
206
207 readBinMem :: FilePath -> IO BinHandle
208 -- Return a BinHandle with a totally undefined State
209 readBinMem filename = do
210 h <- openBinaryFile filename ReadMode
211 filesize' <- hFileSize h
212 let filesize = fromIntegral filesize'
213 arr <- newArray_ (0,filesize-1)
214 count <- hGetArray h arr filesize
215 when (count /= filesize)
216 (error ("Binary.readBinMem: only read " ++ show count ++ " bytes"))
217 hClose h
218 arr_r <- newIORef arr
219 ix_r <- newFastMutInt
220 writeFastMutInt ix_r 0
221 sz_r <- newFastMutInt
222 writeFastMutInt sz_r filesize
223 return (BinMem noUserData ix_r sz_r arr_r)
224
225 -- expand the size of the array to include a specified offset
226 expandBin :: BinHandle -> Int -> IO ()
227 expandBin (BinMem _ ix_r sz_r arr_r) off = do
228 sz <- readFastMutInt sz_r
229 let sz' = head (dropWhile (<= off) (iterate (* 2) sz))
230 arr <- readIORef arr_r
231 arr' <- newArray_ (0,sz'-1)
232 sequence_ [ unsafeRead arr i >>= unsafeWrite arr' i
233 | i <- [ 0 .. sz-1 ] ]
234 writeFastMutInt sz_r sz'
235 writeIORef arr_r arr'
236 #ifdef DEBUG
237 hPutStrLn stderr ("Binary: expanding to size: " ++ show sz')
238 #endif
239 return ()
240 expandBin (BinIO _ _ _) _ = return ()
241 -- no need to expand a file, we'll assume they expand by themselves.
242
243 -- -----------------------------------------------------------------------------
244 -- Low-level reading/writing of bytes
245
246 putWord8 :: BinHandle -> Word8 -> IO ()
247 putWord8 h@(BinMem _ ix_r sz_r arr_r) w = do
248 ix <- readFastMutInt ix_r
249 sz <- readFastMutInt sz_r
250 -- double the size of the array if it overflows
251 if (ix >= sz)
252 then do expandBin h ix
253 putWord8 h w
254 else do arr <- readIORef arr_r
255 unsafeWrite arr ix w
256 writeFastMutInt ix_r (ix+1)
257 return ()
258 putWord8 (BinIO _ ix_r h) w = do
259 ix <- readFastMutInt ix_r
260 hPutChar h (chr (fromIntegral w)) -- XXX not really correct
261 writeFastMutInt ix_r (ix+1)
262 return ()
263
264 getWord8 :: BinHandle -> IO Word8
265 getWord8 (BinMem _ ix_r sz_r arr_r) = do
266 ix <- readFastMutInt ix_r
267 sz <- readFastMutInt sz_r
268 when (ix >= sz) $
269 ioError (mkIOError eofErrorType "Data.Binary.getWord8" Nothing Nothing)
270 arr <- readIORef arr_r
271 w <- unsafeRead arr ix
272 writeFastMutInt ix_r (ix+1)
273 return w
274 getWord8 (BinIO _ ix_r h) = do
275 ix <- readFastMutInt ix_r
276 c <- hGetChar h
277 writeFastMutInt ix_r (ix+1)
278 return $! (fromIntegral (ord c)) -- XXX not really correct
279
280 putByte :: BinHandle -> Word8 -> IO ()
281 putByte bh w = put_ bh w
282
283 getByte :: BinHandle -> IO Word8
284 getByte = getWord8
285
286 -- -----------------------------------------------------------------------------
287 -- Primitve Word writes
288
289 instance Binary Word8 where
290 put_ = putWord8
291 get = getWord8
292
293 instance Binary Word16 where
294 put_ h w = do -- XXX too slow.. inline putWord8?
295 putByte h (fromIntegral (w `shiftR` 8))
296 putByte h (fromIntegral (w .&. 0xff))
297 get h = do
298 w1 <- getWord8 h
299 w2 <- getWord8 h
300 return $! ((fromIntegral w1 `shiftL` 8) .|. fromIntegral w2)
301
302
303 instance Binary Word32 where
304 put_ h w = do
305 putByte h (fromIntegral (w `shiftR` 24))
306 putByte h (fromIntegral ((w `shiftR` 16) .&. 0xff))
307 putByte h (fromIntegral ((w `shiftR` 8) .&. 0xff))
308 putByte h (fromIntegral (w .&. 0xff))
309 get h = do
310 w1 <- getWord8 h
311 w2 <- getWord8 h
312 w3 <- getWord8 h
313 w4 <- getWord8 h
314 return $! ((fromIntegral w1 `shiftL` 24) .|.
315 (fromIntegral w2 `shiftL` 16) .|.
316 (fromIntegral w3 `shiftL` 8) .|.
317 (fromIntegral w4))
318
319
320 instance Binary Word64 where
321 put_ h w = do
322 putByte h (fromIntegral (w `shiftR` 56))
323 putByte h (fromIntegral ((w `shiftR` 48) .&. 0xff))
324 putByte h (fromIntegral ((w `shiftR` 40) .&. 0xff))
325 putByte h (fromIntegral ((w `shiftR` 32) .&. 0xff))
326 putByte h (fromIntegral ((w `shiftR` 24) .&. 0xff))
327 putByte h (fromIntegral ((w `shiftR` 16) .&. 0xff))
328 putByte h (fromIntegral ((w `shiftR` 8) .&. 0xff))
329 putByte h (fromIntegral (w .&. 0xff))
330 get h = do
331 w1 <- getWord8 h
332 w2 <- getWord8 h
333 w3 <- getWord8 h
334 w4 <- getWord8 h
335 w5 <- getWord8 h
336 w6 <- getWord8 h
337 w7 <- getWord8 h
338 w8 <- getWord8 h
339 return $! ((fromIntegral w1 `shiftL` 56) .|.
340 (fromIntegral w2 `shiftL` 48) .|.
341 (fromIntegral w3 `shiftL` 40) .|.
342 (fromIntegral w4 `shiftL` 32) .|.
343 (fromIntegral w5 `shiftL` 24) .|.
344 (fromIntegral w6 `shiftL` 16) .|.
345 (fromIntegral w7 `shiftL` 8) .|.
346 (fromIntegral w8))
347
348 -- -----------------------------------------------------------------------------
349 -- Primitve Int writes
350
351 instance Binary Int8 where
352 put_ h w = put_ h (fromIntegral w :: Word8)
353 get h = do w <- get h; return $! (fromIntegral (w::Word8))
354
355 instance Binary Int16 where
356 put_ h w = put_ h (fromIntegral w :: Word16)
357 get h = do w <- get h; return $! (fromIntegral (w::Word16))
358
359 instance Binary Int32 where
360 put_ h w = put_ h (fromIntegral w :: Word32)
361 get h = do w <- get h; return $! (fromIntegral (w::Word32))
362
363 instance Binary Int64 where
364 put_ h w = put_ h (fromIntegral w :: Word64)
365 get h = do w <- get h; return $! (fromIntegral (w::Word64))
366
367 -- -----------------------------------------------------------------------------
368 -- Instances for standard types
369
370 instance Binary () where
371 put_ bh () = return ()
372 get _ = return ()
373 -- getF bh p = case getBitsF bh 0 p of (_,b) -> ((),b)
374
375 instance Binary Bool where
376 put_ bh b = putByte bh (fromIntegral (fromEnum b))
377 get bh = do x <- getWord8 bh; return $! (toEnum (fromIntegral x))
378 -- getF bh p = case getBitsF bh 1 p of (x,b) -> (toEnum x,b)
379
380 instance Binary Char where
381 put_ bh c = put_ bh (fromIntegral (ord c) :: Word32)
382 get bh = do x <- get bh; return $! (chr (fromIntegral (x :: Word32)))
383 -- getF bh p = case getBitsF bh 8 p of (x,b) -> (toEnum x,b)
384
385 instance Binary Int where
386 #if SIZEOF_HSINT == 4
387 put_ bh i = put_ bh (fromIntegral i :: Int32)
388 get bh = do
389 x <- get bh
390 return $! (fromIntegral (x :: Int32))
391 #elif SIZEOF_HSINT == 8
392 put_ bh i = put_ bh (fromIntegral i :: Int64)
393 get bh = do
394 x <- get bh
395 return $! (fromIntegral (x :: Int64))
396 #else
397 #error "unsupported sizeof(HsInt)"
398 #endif
399 -- getF bh = getBitsF bh 32
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 #ifdef __GLASGOW_HASKELL__
455 instance Binary Integer where
456 put_ bh (S# i#) = do putByte bh 0; put_ bh (I# i#)
457 put_ bh (J# s# a#) = do
458 p <- putByte bh 1;
459 put_ bh (I# s#)
460 let sz# = sizeofByteArray# a# -- in *bytes*
461 put_ bh (I# sz#) -- in *bytes*
462 putByteArray bh a# sz#
463
464 get bh = do
465 b <- getByte bh
466 case b of
467 0 -> do (I# i#) <- get bh
468 return (S# i#)
469 _ -> do (I# s#) <- get bh
470 sz <- get bh
471 (BA a#) <- getByteArray bh sz
472 return (J# s# a#)
473
474 putByteArray :: BinHandle -> ByteArray# -> Int# -> IO ()
475 putByteArray bh a s# = loop 0#
476 where loop n#
477 | n# ==# s# = return ()
478 | otherwise = do
479 putByte bh (indexByteArray a n#)
480 loop (n# +# 1#)
481
482 getByteArray :: BinHandle -> Int -> IO ByteArray
483 getByteArray bh (I# sz) = do
484 (MBA arr) <- newByteArray sz
485 let loop n
486 | n ==# sz = return ()
487 | otherwise = do
488 w <- getByte bh
489 writeByteArray arr n w
490 loop (n +# 1#)
491 loop 0#
492 freezeByteArray arr
493
494
495 data ByteArray = BA ByteArray#
496 data MBA = MBA (MutableByteArray# RealWorld)
497
498 newByteArray :: Int# -> IO MBA
499 newByteArray sz = IO $ \s ->
500 case newByteArray# sz s of { (# s, arr #) ->
501 (# s, MBA arr #) }
502
503 freezeByteArray :: MutableByteArray# RealWorld -> IO ByteArray
504 freezeByteArray arr = IO $ \s ->
505 case unsafeFreezeByteArray# arr s of { (# s, arr #) ->
506 (# s, BA arr #) }
507
508 writeByteArray :: MutableByteArray# RealWorld -> Int# -> Word8 -> IO ()
509 writeByteArray arr i (W8# w) = IO $ \s ->
510 case writeWord8Array# arr i w s of { s ->
511 (# s, () #) }
512
513 indexByteArray :: ByteArray# -> Int# -> Word8
514 indexByteArray a# n# = W8# (indexWord8Array# a# n#)
515
516 instance (Integral a, Binary a) => Binary (Ratio a) where
517 put_ bh (a :% b) = do put_ bh a; put_ bh b
518 get bh = do a <- get bh; b <- get bh; return (a :% b)
519 #endif
520
521 instance Binary (Bin a) where
522 put_ bh (BinPtr i) = put_ bh i
523 get bh = do i <- get bh; return (BinPtr i)
524
525 -- -----------------------------------------------------------------------------
526 -- Lazy reading/writing
527
528 lazyPut :: Binary a => BinHandle -> a -> IO ()
529 lazyPut bh a = do
530 -- output the obj with a ptr to skip over it:
531 pre_a <- tellBin bh
532 put_ bh pre_a -- save a slot for the ptr
533 put_ bh a -- dump the object
534 q <- tellBin bh -- q = ptr to after object
535 putAt bh pre_a q -- fill in slot before a with ptr to q
536 seekBin bh q -- finally carry on writing at q
537
538 lazyGet :: Binary a => BinHandle -> IO a
539 lazyGet bh = do
540 p <- get bh -- a BinPtr
541 p_a <- tellBin bh
542 a <- unsafeInterleaveIO (getAt bh p_a)
543 seekBin bh p -- skip over the object for now
544 return a
545
546 -- -----------------------------------------------------------------------------
547 -- UserData
548 -- -----------------------------------------------------------------------------
549
550 data UserData =
551 UserData {
552 -- for *deserialising* only:
553 ud_dict :: Dictionary,
554 ud_symtab :: SymbolTable,
555
556 -- for *serialising* only:
557 ud_dict_next :: !FastMutInt, -- The next index to use
558 ud_dict_map :: !(IORef (UniqFM (Int,FastString))),
559 -- indexed by FastString
560
561 ud_symtab_next :: !FastMutInt, -- The next index to use
562 ud_symtab_map :: !(IORef (UniqFM (Int,Name)))
563 -- indexed by Name
564 }
565
566 newReadState :: Dictionary -> IO UserData
567 newReadState dict = do
568 dict_next <- newFastMutInt
569 dict_map <- newIORef (undef "dict_map")
570 symtab_next <- newFastMutInt
571 symtab_map <- newIORef (undef "symtab_map")
572 return UserData { ud_dict = dict,
573 ud_symtab = undef "symtab",
574 ud_dict_next = dict_next,
575 ud_dict_map = dict_map,
576 ud_symtab_next = symtab_next,
577 ud_symtab_map = symtab_map
578 }
579
580 newWriteState :: IO UserData
581 newWriteState = do
582 dict_next <- newFastMutInt
583 writeFastMutInt dict_next 0
584 dict_map <- newIORef emptyUFM
585 symtab_next <- newFastMutInt
586 writeFastMutInt symtab_next 0
587 symtab_map <- newIORef emptyUFM
588 return UserData { ud_dict = undef "dict",
589 ud_symtab = undef "symtab",
590 ud_dict_next = dict_next,
591 ud_dict_map = dict_map,
592 ud_symtab_next = symtab_next,
593 ud_symtab_map = symtab_map
594 }
595
596 noUserData = undef "UserData"
597
598 undef s = panic ("Binary.UserData: no " ++ s)
599
600 ---------------------------------------------------------
601 -- The Dictionary
602 ---------------------------------------------------------
603
604 type Dictionary = Array Int FastString -- The dictionary
605 -- Should be 0-indexed
606
607 putDictionary :: BinHandle -> Int -> UniqFM (Int,FastString) -> IO ()
608 putDictionary bh sz dict = do
609 put_ bh sz
610 mapM_ (putFS bh) (elems (array (0,sz-1) (eltsUFM dict)))
611
612 getDictionary :: BinHandle -> IO Dictionary
613 getDictionary bh = do
614 sz <- get bh
615 elems <- sequence (take sz (repeat (getFS bh)))
616 return (listArray (0,sz-1) elems)
617
618 ---------------------------------------------------------
619 -- The Symbol Table
620 ---------------------------------------------------------
621
622 -- On disk, the symbol table is an array of IfaceExtName, when
623 -- reading it in we turn it into a SymbolTable.
624
625 type SymbolTable = Array Int Name
626
627 ---------------------------------------------------------
628 -- Reading and writing FastStrings
629 ---------------------------------------------------------
630
631 putFS bh (FastString id l _ buf _) = do
632 put_ bh l
633 withForeignPtr buf $ \ptr ->
634 let
635 go n | n == l = return ()
636 | otherwise = do
637 b <- peekElemOff ptr n
638 putByte bh b
639 go (n+1)
640 in
641 go 0
642
643 {- -- possible faster version, not quite there yet:
644 getFS bh@BinMem{} = do
645 (I# l) <- get bh
646 arr <- readIORef (arr_r bh)
647 off <- readFastMutInt (off_r bh)
648 return $! (mkFastSubStringBA# arr off l)
649 -}
650 getFS bh = do
651 l <- get bh
652 fp <- mallocForeignPtrBytes l
653 withForeignPtr fp $ \ptr -> do
654 let
655 go n | n == l = mkFastStringForeignPtr ptr fp l
656 | otherwise = do
657 b <- getByte bh
658 pokeElemOff ptr n b
659 go (n+1)
660 --
661 go 0
662
663 instance Binary PackageId where
664 put_ bh pid = put_ bh (packageIdFS pid)
665 get bh = do { fs <- get bh; return (fsToPackageId fs) }
666
667 instance Binary FastString where
668 put_ bh f@(FastString id l _ fp _) =
669 case getUserData bh of {
670 UserData { ud_dict_next = j_r,
671 ud_dict_map = out_r,
672 ud_dict = dict} -> do
673 out <- readIORef out_r
674 let uniq = getUnique f
675 case lookupUFM out uniq of
676 Just (j,f) -> put_ bh j
677 Nothing -> do
678 j <- readFastMutInt j_r
679 put_ bh j
680 writeFastMutInt j_r (j+1)
681 writeIORef out_r $! addToUFM out uniq (j,f)
682 }
683
684 get bh = do
685 j <- get bh
686 return $! (ud_dict (getUserData bh) ! j)