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