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