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