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