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