Module header tidyup #2
[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 #if __GLASGOW_HASKELL__ <= 500
206 -- workaround a bug in old implementation of hPutBuf (it doesn't
207 -- set the FILEOBJ_RW_WRITTEN flag on the file object, so the file doens't
208 -- get flushed properly). Adding an extra '\0' doens't do any harm.
209 hPutChar h '\0'
210 #endif
211 hClose h
212
213 readBinMem :: FilePath -> IO BinHandle
214 -- Return a BinHandle with a totally undefined State
215 readBinMem filename = do
216 h <- openBinaryFile filename ReadMode
217 filesize' <- hFileSize h
218 let filesize = fromIntegral filesize'
219 arr <- newArray_ (0,filesize-1)
220 count <- hGetArray h arr filesize
221 when (count /= filesize)
222 (error ("Binary.readBinMem: only read " ++ show count ++ " bytes"))
223 hClose h
224 arr_r <- newIORef arr
225 ix_r <- newFastMutInt
226 writeFastMutInt ix_r 0
227 sz_r <- newFastMutInt
228 writeFastMutInt sz_r filesize
229 return (BinMem noUserData ix_r sz_r arr_r)
230
231 -- expand the size of the array to include a specified offset
232 expandBin :: BinHandle -> Int -> IO ()
233 expandBin (BinMem _ ix_r sz_r arr_r) off = do
234 sz <- readFastMutInt sz_r
235 let sz' = head (dropWhile (<= off) (iterate (* 2) sz))
236 arr <- readIORef arr_r
237 arr' <- newArray_ (0,sz'-1)
238 sequence_ [ unsafeRead arr i >>= unsafeWrite arr' i
239 | i <- [ 0 .. sz-1 ] ]
240 writeFastMutInt sz_r sz'
241 writeIORef arr_r arr'
242 #ifdef DEBUG
243 hPutStrLn stderr ("Binary: expanding to size: " ++ show sz')
244 #endif
245 return ()
246 expandBin (BinIO _ _ _) _ = return ()
247 -- no need to expand a file, we'll assume they expand by themselves.
248
249 -- -----------------------------------------------------------------------------
250 -- Low-level reading/writing of bytes
251
252 putWord8 :: BinHandle -> Word8 -> IO ()
253 putWord8 h@(BinMem _ ix_r sz_r arr_r) w = do
254 ix <- readFastMutInt ix_r
255 sz <- readFastMutInt sz_r
256 -- double the size of the array if it overflows
257 if (ix >= sz)
258 then do expandBin h ix
259 putWord8 h w
260 else do arr <- readIORef arr_r
261 unsafeWrite arr ix w
262 writeFastMutInt ix_r (ix+1)
263 return ()
264 putWord8 (BinIO _ ix_r h) w = do
265 ix <- readFastMutInt ix_r
266 hPutChar h (chr (fromIntegral w)) -- XXX not really correct
267 writeFastMutInt ix_r (ix+1)
268 return ()
269
270 getWord8 :: BinHandle -> IO Word8
271 getWord8 (BinMem _ ix_r sz_r arr_r) = do
272 ix <- readFastMutInt ix_r
273 sz <- readFastMutInt sz_r
274 when (ix >= sz) $
275 #if __GLASGOW_HASKELL__ <= 408
276 throw (mkIOError eofErrorType "Data.Binary.getWord8" Nothing Nothing)
277 #else
278 ioError (mkIOError eofErrorType "Data.Binary.getWord8" Nothing Nothing)
279 #endif
280 arr <- readIORef arr_r
281 w <- unsafeRead arr ix
282 writeFastMutInt ix_r (ix+1)
283 return w
284 getWord8 (BinIO _ ix_r h) = do
285 ix <- readFastMutInt ix_r
286 c <- hGetChar h
287 writeFastMutInt ix_r (ix+1)
288 return $! (fromIntegral (ord c)) -- XXX not really correct
289
290 putByte :: BinHandle -> Word8 -> IO ()
291 putByte bh w = put_ bh w
292
293 getByte :: BinHandle -> IO Word8
294 getByte = getWord8
295
296 -- -----------------------------------------------------------------------------
297 -- Primitve Word writes
298
299 instance Binary Word8 where
300 put_ = putWord8
301 get = getWord8
302
303 instance Binary Word16 where
304 put_ h w = do -- XXX too slow.. inline putWord8?
305 putByte h (fromIntegral (w `shiftR` 8))
306 putByte h (fromIntegral (w .&. 0xff))
307 get h = do
308 w1 <- getWord8 h
309 w2 <- getWord8 h
310 return $! ((fromIntegral w1 `shiftL` 8) .|. fromIntegral w2)
311
312
313 instance Binary Word32 where
314 put_ h w = do
315 putByte h (fromIntegral (w `shiftR` 24))
316 putByte h (fromIntegral ((w `shiftR` 16) .&. 0xff))
317 putByte h (fromIntegral ((w `shiftR` 8) .&. 0xff))
318 putByte h (fromIntegral (w .&. 0xff))
319 get h = do
320 w1 <- getWord8 h
321 w2 <- getWord8 h
322 w3 <- getWord8 h
323 w4 <- getWord8 h
324 return $! ((fromIntegral w1 `shiftL` 24) .|.
325 (fromIntegral w2 `shiftL` 16) .|.
326 (fromIntegral w3 `shiftL` 8) .|.
327 (fromIntegral w4))
328
329
330 instance Binary Word64 where
331 put_ h w = do
332 putByte h (fromIntegral (w `shiftR` 56))
333 putByte h (fromIntegral ((w `shiftR` 48) .&. 0xff))
334 putByte h (fromIntegral ((w `shiftR` 40) .&. 0xff))
335 putByte h (fromIntegral ((w `shiftR` 32) .&. 0xff))
336 putByte h (fromIntegral ((w `shiftR` 24) .&. 0xff))
337 putByte h (fromIntegral ((w `shiftR` 16) .&. 0xff))
338 putByte h (fromIntegral ((w `shiftR` 8) .&. 0xff))
339 putByte h (fromIntegral (w .&. 0xff))
340 get h = do
341 w1 <- getWord8 h
342 w2 <- getWord8 h
343 w3 <- getWord8 h
344 w4 <- getWord8 h
345 w5 <- getWord8 h
346 w6 <- getWord8 h
347 w7 <- getWord8 h
348 w8 <- getWord8 h
349 return $! ((fromIntegral w1 `shiftL` 56) .|.
350 (fromIntegral w2 `shiftL` 48) .|.
351 (fromIntegral w3 `shiftL` 40) .|.
352 (fromIntegral w4 `shiftL` 32) .|.
353 (fromIntegral w5 `shiftL` 24) .|.
354 (fromIntegral w6 `shiftL` 16) .|.
355 (fromIntegral w7 `shiftL` 8) .|.
356 (fromIntegral w8))
357
358 -- -----------------------------------------------------------------------------
359 -- Primitve Int writes
360
361 instance Binary Int8 where
362 put_ h w = put_ h (fromIntegral w :: Word8)
363 get h = do w <- get h; return $! (fromIntegral (w::Word8))
364
365 instance Binary Int16 where
366 put_ h w = put_ h (fromIntegral w :: Word16)
367 get h = do w <- get h; return $! (fromIntegral (w::Word16))
368
369 instance Binary Int32 where
370 put_ h w = put_ h (fromIntegral w :: Word32)
371 get h = do w <- get h; return $! (fromIntegral (w::Word32))
372
373 instance Binary Int64 where
374 put_ h w = put_ h (fromIntegral w :: Word64)
375 get h = do w <- get h; return $! (fromIntegral (w::Word64))
376
377 -- -----------------------------------------------------------------------------
378 -- Instances for standard types
379
380 instance Binary () where
381 put_ bh () = return ()
382 get _ = return ()
383 -- getF bh p = case getBitsF bh 0 p of (_,b) -> ((),b)
384
385 instance Binary Bool where
386 put_ bh b = putByte bh (fromIntegral (fromEnum b))
387 get bh = do x <- getWord8 bh; return $! (toEnum (fromIntegral x))
388 -- getF bh p = case getBitsF bh 1 p of (x,b) -> (toEnum x,b)
389
390 instance Binary Char where
391 put_ bh c = put_ bh (fromIntegral (ord c) :: Word32)
392 get bh = do x <- get bh; return $! (chr (fromIntegral (x :: Word32)))
393 -- getF bh p = case getBitsF bh 8 p of (x,b) -> (toEnum x,b)
394
395 instance Binary Int where
396 #if SIZEOF_HSINT == 4
397 put_ bh i = put_ bh (fromIntegral i :: Int32)
398 get bh = do
399 x <- get bh
400 return $! (fromIntegral (x :: Int32))
401 #elif SIZEOF_HSINT == 8
402 put_ bh i = put_ bh (fromIntegral i :: Int64)
403 get bh = do
404 x <- get bh
405 return $! (fromIntegral (x :: Int64))
406 #else
407 #error "unsupported sizeof(HsInt)"
408 #endif
409 -- getF bh = getBitsF bh 32
410
411 instance Binary a => Binary [a] where
412 put_ bh l = do
413 let len = length l
414 if (len < 0xff)
415 then putByte bh (fromIntegral len :: Word8)
416 else do putByte bh 0xff; put_ bh (fromIntegral len :: Word32)
417 mapM_ (put_ bh) l
418 get bh = do
419 b <- getByte bh
420 len <- if b == 0xff
421 then get bh
422 else return (fromIntegral b :: Word32)
423 let loop 0 = return []
424 loop n = do a <- get bh; as <- loop (n-1); return (a:as)
425 loop len
426
427 instance (Binary a, Binary b) => Binary (a,b) where
428 put_ bh (a,b) = do put_ bh a; put_ bh b
429 get bh = do a <- get bh
430 b <- get bh
431 return (a,b)
432
433 instance (Binary a, Binary b, Binary c) => Binary (a,b,c) where
434 put_ bh (a,b,c) = do put_ bh a; put_ bh b; put_ bh c
435 get bh = do a <- get bh
436 b <- get bh
437 c <- get bh
438 return (a,b,c)
439
440 instance (Binary a, Binary b, Binary c, Binary d) => Binary (a,b,c,d) where
441 put_ bh (a,b,c,d) = do put_ bh a; put_ bh b; put_ bh c; put_ bh d
442 get bh = do a <- get bh
443 b <- get bh
444 c <- get bh
445 d <- get bh
446 return (a,b,c,d)
447
448 instance Binary a => Binary (Maybe a) where
449 put_ bh Nothing = putByte bh 0
450 put_ bh (Just a) = do putByte bh 1; put_ bh a
451 get bh = do h <- getWord8 bh
452 case h of
453 0 -> return Nothing
454 _ -> do x <- get bh; return (Just x)
455
456 instance (Binary a, Binary b) => Binary (Either a b) where
457 put_ bh (Left a) = do putByte bh 0; put_ bh a
458 put_ bh (Right b) = do putByte bh 1; put_ bh b
459 get bh = do h <- getWord8 bh
460 case h of
461 0 -> do a <- get bh ; return (Left a)
462 _ -> do b <- get bh ; return (Right b)
463
464 #ifdef __GLASGOW_HASKELL__
465 instance Binary Integer where
466 put_ bh (S# i#) = do putByte bh 0; put_ bh (I# i#)
467 put_ bh (J# s# a#) = do
468 p <- putByte bh 1;
469 put_ bh (I# s#)
470 let sz# = sizeofByteArray# a# -- in *bytes*
471 put_ bh (I# sz#) -- in *bytes*
472 putByteArray bh a# sz#
473
474 get bh = do
475 b <- getByte bh
476 case b of
477 0 -> do (I# i#) <- get bh
478 return (S# i#)
479 _ -> do (I# s#) <- get bh
480 sz <- get bh
481 (BA a#) <- getByteArray bh sz
482 return (J# s# a#)
483
484 putByteArray :: BinHandle -> ByteArray# -> Int# -> IO ()
485 putByteArray bh a s# = loop 0#
486 where loop n#
487 | n# ==# s# = return ()
488 | otherwise = do
489 putByte bh (indexByteArray a n#)
490 loop (n# +# 1#)
491
492 getByteArray :: BinHandle -> Int -> IO ByteArray
493 getByteArray bh (I# sz) = do
494 (MBA arr) <- newByteArray sz
495 let loop n
496 | n ==# sz = return ()
497 | otherwise = do
498 w <- getByte bh
499 writeByteArray arr n w
500 loop (n +# 1#)
501 loop 0#
502 freezeByteArray arr
503
504
505 data ByteArray = BA ByteArray#
506 data MBA = MBA (MutableByteArray# RealWorld)
507
508 newByteArray :: Int# -> IO MBA
509 newByteArray sz = IO $ \s ->
510 case newByteArray# sz s of { (# s, arr #) ->
511 (# s, MBA arr #) }
512
513 freezeByteArray :: MutableByteArray# RealWorld -> IO ByteArray
514 freezeByteArray arr = IO $ \s ->
515 case unsafeFreezeByteArray# arr s of { (# s, arr #) ->
516 (# s, BA arr #) }
517
518 writeByteArray :: MutableByteArray# RealWorld -> Int# -> Word8 -> IO ()
519
520 #if __GLASGOW_HASKELL__ < 503
521 writeByteArray arr i w8 = IO $ \s ->
522 case word8ToWord w8 of { W# w# ->
523 case writeCharArray# arr i (chr# (word2Int# w#)) s of { s ->
524 (# s , () #) }}
525 #else
526 writeByteArray arr i (W8# w) = IO $ \s ->
527 case writeWord8Array# arr i w s of { s ->
528 (# s, () #) }
529 #endif
530
531 #if __GLASGOW_HASKELL__ < 503
532 indexByteArray a# n# = fromIntegral (I# (ord# (indexCharArray# a# n#)))
533 #else
534 indexByteArray a# n# = W8# (indexWord8Array# a# n#)
535 #endif
536
537 instance (Integral a, Binary a) => Binary (Ratio a) where
538 put_ bh (a :% b) = do put_ bh a; put_ bh b
539 get bh = do a <- get bh; b <- get bh; return (a :% b)
540 #endif
541
542 instance Binary (Bin a) where
543 put_ bh (BinPtr i) = put_ bh i
544 get bh = do i <- get bh; return (BinPtr i)
545
546 -- -----------------------------------------------------------------------------
547 -- Lazy reading/writing
548
549 lazyPut :: Binary a => BinHandle -> a -> IO ()
550 lazyPut bh a = do
551 -- output the obj with a ptr to skip over it:
552 pre_a <- tellBin bh
553 put_ bh pre_a -- save a slot for the ptr
554 put_ bh a -- dump the object
555 q <- tellBin bh -- q = ptr to after object
556 putAt bh pre_a q -- fill in slot before a with ptr to q
557 seekBin bh q -- finally carry on writing at q
558
559 lazyGet :: Binary a => BinHandle -> IO a
560 lazyGet bh = do
561 p <- get bh -- a BinPtr
562 p_a <- tellBin bh
563 a <- unsafeInterleaveIO (getAt bh p_a)
564 seekBin bh p -- skip over the object for now
565 return a
566
567 -- -----------------------------------------------------------------------------
568 -- UserData
569 -- -----------------------------------------------------------------------------
570
571 data UserData =
572 UserData {
573 -- for *deserialising* only:
574 ud_dict :: Dictionary,
575 ud_symtab :: SymbolTable,
576
577 -- for *serialising* only:
578 ud_dict_next :: !FastMutInt, -- The next index to use
579 ud_dict_map :: !(IORef (UniqFM (Int,FastString))),
580 -- indexed by FastString
581
582 ud_symtab_next :: !FastMutInt, -- The next index to use
583 ud_symtab_map :: !(IORef (UniqFM (Int,Name)))
584 -- indexed by Name
585 }
586
587 newReadState :: Dictionary -> IO UserData
588 newReadState dict = do
589 dict_next <- newFastMutInt
590 dict_map <- newIORef (undef "dict_map")
591 symtab_next <- newFastMutInt
592 symtab_map <- newIORef (undef "symtab_map")
593 return UserData { ud_dict = dict,
594 ud_symtab = undef "symtab",
595 ud_dict_next = dict_next,
596 ud_dict_map = dict_map,
597 ud_symtab_next = symtab_next,
598 ud_symtab_map = symtab_map
599 }
600
601 newWriteState :: IO UserData
602 newWriteState = do
603 dict_next <- newFastMutInt
604 writeFastMutInt dict_next 0
605 dict_map <- newIORef emptyUFM
606 symtab_next <- newFastMutInt
607 writeFastMutInt symtab_next 0
608 symtab_map <- newIORef emptyUFM
609 return UserData { ud_dict = undef "dict",
610 ud_symtab = undef "symtab",
611 ud_dict_next = dict_next,
612 ud_dict_map = dict_map,
613 ud_symtab_next = symtab_next,
614 ud_symtab_map = symtab_map
615 }
616
617 noUserData = undef "UserData"
618
619 undef s = panic ("Binary.UserData: no " ++ s)
620
621 ---------------------------------------------------------
622 -- The Dictionary
623 ---------------------------------------------------------
624
625 type Dictionary = Array Int FastString -- The dictionary
626 -- Should be 0-indexed
627
628 putDictionary :: BinHandle -> Int -> UniqFM (Int,FastString) -> IO ()
629 putDictionary bh sz dict = do
630 put_ bh sz
631 mapM_ (putFS bh) (elems (array (0,sz-1) (eltsUFM dict)))
632
633 getDictionary :: BinHandle -> IO Dictionary
634 getDictionary bh = do
635 sz <- get bh
636 elems <- sequence (take sz (repeat (getFS bh)))
637 return (listArray (0,sz-1) elems)
638
639 ---------------------------------------------------------
640 -- The Symbol Table
641 ---------------------------------------------------------
642
643 -- On disk, the symbol table is an array of IfaceExtName, when
644 -- reading it in we turn it into a SymbolTable.
645
646 type SymbolTable = Array Int Name
647
648 ---------------------------------------------------------
649 -- Reading and writing FastStrings
650 ---------------------------------------------------------
651
652 putFS bh (FastString id l _ buf _) = do
653 put_ bh l
654 withForeignPtr buf $ \ptr ->
655 let
656 go n | n == l = return ()
657 | otherwise = do
658 b <- peekElemOff ptr n
659 putByte bh b
660 go (n+1)
661 in
662 go 0
663
664 {- -- possible faster version, not quite there yet:
665 getFS bh@BinMem{} = do
666 (I# l) <- get bh
667 arr <- readIORef (arr_r bh)
668 off <- readFastMutInt (off_r bh)
669 return $! (mkFastSubStringBA# arr off l)
670 -}
671 getFS bh = do
672 l <- get bh
673 fp <- mallocForeignPtrBytes l
674 withForeignPtr fp $ \ptr -> do
675 let
676 go n | n == l = mkFastStringForeignPtr ptr fp l
677 | otherwise = do
678 b <- getByte bh
679 pokeElemOff ptr n b
680 go (n+1)
681 --
682 go 0
683
684 #if __GLASGOW_HASKELL__ < 600
685 mallocForeignPtrBytes :: Int -> IO (ForeignPtr a)
686 mallocForeignPtrBytes n = do
687 r <- mallocBytes n
688 newForeignPtr r (finalizerFree r)
689
690 foreign import ccall unsafe "stdlib.h free"
691 finalizerFree :: Ptr a -> IO ()
692 #endif
693
694 instance Binary PackageId where
695 put_ bh pid = put_ bh (packageIdFS pid)
696 get bh = do { fs <- get bh; return (fsToPackageId fs) }
697
698 instance Binary FastString where
699 put_ bh f@(FastString id l _ fp _) =
700 case getUserData bh of {
701 UserData { ud_dict_next = j_r,
702 ud_dict_map = out_r,
703 ud_dict = dict} -> do
704 out <- readIORef out_r
705 let uniq = getUnique f
706 case lookupUFM out uniq of
707 Just (j,f) -> put_ bh j
708 Nothing -> do
709 j <- readFastMutInt j_r
710 put_ bh j
711 writeFastMutInt j_r (j+1)
712 writeIORef out_r $! addToUFM out uniq (j,f)
713 }
714
715 get bh = do
716 j <- get bh
717 return $! (ud_dict (getUserData bh) ! j)