2 {-# OPTIONS_GHC -O -funbox-strict-fields #-}
3 -- We always optimise this, otherwise performance of a non-optimised
4 -- compiler is severely affected
7 -- (c) The University of Glasgow 2002-2006
9 -- Binary I/O library, with special tweaks for GHC
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/
22 openBinIO, openBinIO_,
39 -- for writing instances:
47 #ifdef __GLASGOW_HASKELL__
54 UserData(..), getUserData, setUserData,
55 newReadState, newWriteState,
56 putDictionary, getDictionary, putFS,
59 #include "HsVersions.h"
61 -- The *host* architecture version:
64 import {-# SOURCE #-} Name (Name)
78 import Data.Char ( ord, chr )
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(..) )
86 import GHC.Word ( Word8(..) )
87 import System.IO ( openBinaryFile )
89 #if __GLASGOW_HASKELL__ >= 611
90 import GHC.IO ( IO(..) )
92 import GHC.IOBase ( IO(..) )
95 type BinArray = ForeignPtr Word8
97 ---------------------------------------------------------------
99 ---------------------------------------------------------------
102 = BinMem { -- binary data stored in an unboxed array
103 bh_usr :: UserData, -- sigh, need parameterized modules :-)
104 _off_r :: !FastMutInt, -- the current offset
105 _sz_r :: !FastMutInt, -- size of the array (cached)
106 _arr_r :: !(IORef BinArray) -- the array (bounds: (0,size-1))
108 -- XXX: should really store a "high water mark" for dumping out
109 -- the binary data to a file.
111 | BinIO { -- binary data stored in a file
113 _off_r :: !FastMutInt, -- the current offset (cached)
114 _hdl :: !IO.Handle -- the file handle (must be seekable)
116 -- cache the file ptr in BinIO; using hTell is too expensive
117 -- to call repeatedly. If anyone else is modifying this Handle
118 -- at the same time, we'll be screwed.
120 getUserData :: BinHandle -> UserData
121 getUserData bh = bh_usr bh
123 setUserData :: BinHandle -> UserData -> BinHandle
124 setUserData bh us = bh { bh_usr = us }
127 ---------------------------------------------------------------
129 ---------------------------------------------------------------
131 newtype Bin a = BinPtr Int
132 deriving (Eq, Ord, Show, Bounded)
134 castBin :: Bin a -> Bin b
135 castBin (BinPtr i) = BinPtr i
137 ---------------------------------------------------------------
139 ---------------------------------------------------------------
142 put_ :: BinHandle -> a -> IO ()
143 put :: BinHandle -> a -> IO (Bin a)
144 get :: BinHandle -> IO a
146 -- define one of put_, put. Use of put_ is recommended because it
147 -- is more likely that tail-calls can kick in, and we rarely need the
148 -- position return value.
149 put_ bh a = do put bh a; return ()
150 put bh a = do p <- tellBin bh; put_ bh a; return p
152 putAt :: Binary a => BinHandle -> Bin a -> a -> IO ()
153 putAt bh p x = do seekBin bh p; put bh x; return ()
155 getAt :: Binary a => BinHandle -> Bin a -> IO a
156 getAt bh p = do seekBin bh p; get bh
158 openBinIO_ :: IO.Handle -> IO BinHandle
159 openBinIO_ h = openBinIO h
161 openBinIO :: IO.Handle -> IO BinHandle
165 return (BinIO noUserData r h)
167 openBinMem :: Int -> IO BinHandle
169 | size <= 0 = error "Data.Binary.openBinMem: size must be >= 0"
171 arr <- mallocForeignPtrBytes size
172 arr_r <- newIORef arr
173 ix_r <- newFastMutInt
174 writeFastMutInt ix_r 0
175 sz_r <- newFastMutInt
176 writeFastMutInt sz_r size
177 return (BinMem noUserData ix_r sz_r arr_r)
179 tellBin :: BinHandle -> IO (Bin a)
180 tellBin (BinIO _ r _) = do ix <- readFastMutInt r; return (BinPtr ix)
181 tellBin (BinMem _ r _ _) = do ix <- readFastMutInt r; return (BinPtr ix)
183 seekBin :: BinHandle -> Bin a -> IO ()
184 seekBin (BinIO _ ix_r h) (BinPtr p) = do
185 writeFastMutInt ix_r p
186 hSeek h AbsoluteSeek (fromIntegral p)
187 seekBin h@(BinMem _ ix_r sz_r _) (BinPtr p) = do
188 sz <- readFastMutInt sz_r
190 then do expandBin h p; writeFastMutInt ix_r p
191 else writeFastMutInt ix_r p
193 seekBy :: BinHandle -> Int -> IO ()
194 seekBy (BinIO _ ix_r h) off = do
195 ix <- readFastMutInt ix_r
197 writeFastMutInt ix_r ix'
198 hSeek h AbsoluteSeek (fromIntegral ix')
199 seekBy h@(BinMem _ ix_r sz_r _) off = do
200 sz <- readFastMutInt sz_r
201 ix <- readFastMutInt ix_r
204 then do expandBin h ix'; writeFastMutInt ix_r ix'
205 else writeFastMutInt ix_r ix'
207 isEOFBin :: BinHandle -> IO Bool
208 isEOFBin (BinMem _ ix_r sz_r _) = do
209 ix <- readFastMutInt ix_r
210 sz <- readFastMutInt sz_r
212 isEOFBin (BinIO _ _ h) = hIsEOF h
214 writeBinMem :: BinHandle -> FilePath -> IO ()
215 writeBinMem (BinIO _ _ _) _ = error "Data.Binary.writeBinMem: not a memory handle"
216 writeBinMem (BinMem _ ix_r _ arr_r) fn = do
217 h <- openBinaryFile fn WriteMode
218 arr <- readIORef arr_r
219 ix <- readFastMutInt ix_r
220 withForeignPtr arr $ \p -> hPutBuf h p ix
223 readBinMem :: FilePath -> IO BinHandle
224 -- Return a BinHandle with a totally undefined State
225 readBinMem filename = do
226 h <- openBinaryFile filename ReadMode
227 filesize' <- hFileSize h
228 let filesize = fromIntegral filesize'
229 arr <- mallocForeignPtrBytes (filesize*2)
230 count <- withForeignPtr arr $ \p -> hGetBuf h p filesize
231 when (count /= filesize) $
232 error ("Binary.readBinMem: only read " ++ show count ++ " bytes")
234 arr_r <- newIORef arr
235 ix_r <- newFastMutInt
236 writeFastMutInt ix_r 0
237 sz_r <- newFastMutInt
238 writeFastMutInt sz_r filesize
239 return (BinMem noUserData ix_r sz_r arr_r)
241 fingerprintBinMem :: BinHandle -> IO Fingerprint
242 fingerprintBinMem (BinIO _ _ _) = error "Binary.md5BinMem: not a memory handle"
243 fingerprintBinMem (BinMem _ ix_r _ arr_r) = do
244 arr <- readIORef arr_r
245 ix <- readFastMutInt ix_r
246 withForeignPtr arr $ \p -> fingerprintData p ix
248 -- expand the size of the array to include a specified offset
249 expandBin :: BinHandle -> Int -> IO ()
250 expandBin (BinMem _ _ sz_r arr_r) off = do
251 sz <- readFastMutInt sz_r
252 let sz' = head (dropWhile (<= off) (iterate (* 2) sz))
253 arr <- readIORef arr_r
254 arr' <- mallocForeignPtrBytes sz'
255 withForeignPtr arr $ \old ->
256 withForeignPtr arr' $ \new ->
258 writeFastMutInt sz_r sz'
259 writeIORef arr_r arr'
260 when False $ -- disabled
261 hPutStrLn stderr ("Binary: expanding to size: " ++ show sz')
263 expandBin (BinIO _ _ _) _ = return ()
264 -- no need to expand a file, we'll assume they expand by themselves.
266 -- -----------------------------------------------------------------------------
267 -- Low-level reading/writing of bytes
269 putWord8 :: BinHandle -> Word8 -> IO ()
270 putWord8 h@(BinMem _ ix_r sz_r arr_r) w = do
271 ix <- readFastMutInt ix_r
272 sz <- readFastMutInt sz_r
273 -- double the size of the array if it overflows
275 then do expandBin h ix
277 else do arr <- readIORef arr_r
278 withForeignPtr arr $ \p -> pokeByteOff p ix w
279 writeFastMutInt ix_r (ix+1)
281 putWord8 (BinIO _ ix_r h) w = do
282 ix <- readFastMutInt ix_r
283 hPutChar h (chr (fromIntegral w)) -- XXX not really correct
284 writeFastMutInt ix_r (ix+1)
287 getWord8 :: BinHandle -> IO Word8
288 getWord8 (BinMem _ ix_r sz_r arr_r) = do
289 ix <- readFastMutInt ix_r
290 sz <- readFastMutInt sz_r
292 ioError (mkIOError eofErrorType "Data.Binary.getWord8" Nothing Nothing)
293 arr <- readIORef arr_r
294 w <- withForeignPtr arr $ \p -> peekByteOff p ix
295 writeFastMutInt ix_r (ix+1)
297 getWord8 (BinIO _ ix_r h) = do
298 ix <- readFastMutInt ix_r
300 writeFastMutInt ix_r (ix+1)
301 return $! (fromIntegral (ord c)) -- XXX not really correct
303 putByte :: BinHandle -> Word8 -> IO ()
304 putByte bh w = put_ bh w
306 getByte :: BinHandle -> IO Word8
309 -- -----------------------------------------------------------------------------
310 -- Primitve Word writes
312 instance Binary Word8 where
316 instance Binary Word16 where
317 put_ h w = do -- XXX too slow.. inline putWord8?
318 putByte h (fromIntegral (w `shiftR` 8))
319 putByte h (fromIntegral (w .&. 0xff))
323 return $! ((fromIntegral w1 `shiftL` 8) .|. fromIntegral w2)
326 instance Binary Word32 where
328 putByte h (fromIntegral (w `shiftR` 24))
329 putByte h (fromIntegral ((w `shiftR` 16) .&. 0xff))
330 putByte h (fromIntegral ((w `shiftR` 8) .&. 0xff))
331 putByte h (fromIntegral (w .&. 0xff))
337 return $! ((fromIntegral w1 `shiftL` 24) .|.
338 (fromIntegral w2 `shiftL` 16) .|.
339 (fromIntegral w3 `shiftL` 8) .|.
342 instance Binary Word64 where
344 putByte h (fromIntegral (w `shiftR` 56))
345 putByte h (fromIntegral ((w `shiftR` 48) .&. 0xff))
346 putByte h (fromIntegral ((w `shiftR` 40) .&. 0xff))
347 putByte h (fromIntegral ((w `shiftR` 32) .&. 0xff))
348 putByte h (fromIntegral ((w `shiftR` 24) .&. 0xff))
349 putByte h (fromIntegral ((w `shiftR` 16) .&. 0xff))
350 putByte h (fromIntegral ((w `shiftR` 8) .&. 0xff))
351 putByte h (fromIntegral (w .&. 0xff))
361 return $! ((fromIntegral w1 `shiftL` 56) .|.
362 (fromIntegral w2 `shiftL` 48) .|.
363 (fromIntegral w3 `shiftL` 40) .|.
364 (fromIntegral w4 `shiftL` 32) .|.
365 (fromIntegral w5 `shiftL` 24) .|.
366 (fromIntegral w6 `shiftL` 16) .|.
367 (fromIntegral w7 `shiftL` 8) .|.
370 -- -----------------------------------------------------------------------------
371 -- Primitve Int writes
373 instance Binary Int8 where
374 put_ h w = put_ h (fromIntegral w :: Word8)
375 get h = do w <- get h; return $! (fromIntegral (w::Word8))
377 instance Binary Int16 where
378 put_ h w = put_ h (fromIntegral w :: Word16)
379 get h = do w <- get h; return $! (fromIntegral (w::Word16))
381 instance Binary Int32 where
382 put_ h w = put_ h (fromIntegral w :: Word32)
383 get h = do w <- get h; return $! (fromIntegral (w::Word32))
385 instance Binary Int64 where
386 put_ h w = put_ h (fromIntegral w :: Word64)
387 get h = do w <- get h; return $! (fromIntegral (w::Word64))
389 -- -----------------------------------------------------------------------------
390 -- Instances for standard types
392 instance Binary () where
393 put_ _ () = return ()
395 -- getF bh p = case getBitsF bh 0 p of (_,b) -> ((),b)
397 instance Binary Bool where
398 put_ bh b = putByte bh (fromIntegral (fromEnum b))
399 get bh = do x <- getWord8 bh; return $! (toEnum (fromIntegral x))
400 -- getF bh p = case getBitsF bh 1 p of (x,b) -> (toEnum x,b)
402 instance Binary Char where
403 put_ bh c = put_ bh (fromIntegral (ord c) :: Word32)
404 get bh = do x <- get bh; return $! (chr (fromIntegral (x :: Word32)))
405 -- getF bh p = case getBitsF bh 8 p of (x,b) -> (toEnum x,b)
407 instance Binary Int where
408 #if SIZEOF_HSINT == 4
409 put_ bh i = put_ bh (fromIntegral i :: Int32)
412 return $! (fromIntegral (x :: Int32))
413 #elif SIZEOF_HSINT == 8
414 put_ bh i = put_ bh (fromIntegral i :: Int64)
417 return $! (fromIntegral (x :: Int64))
419 #error "unsupported sizeof(HsInt)"
421 -- getF bh = getBitsF bh 32
423 instance Binary a => Binary [a] where
427 then putByte bh (fromIntegral len :: Word8)
428 else do putByte bh 0xff; put_ bh (fromIntegral len :: Word32)
434 else return (fromIntegral b :: Word32)
435 let loop 0 = return []
436 loop n = do a <- get bh; as <- loop (n-1); return (a:as)
439 instance (Binary a, Binary b) => Binary (a,b) where
440 put_ bh (a,b) = do put_ bh a; put_ bh b
441 get bh = do a <- get bh
445 instance (Binary a, Binary b, Binary c) => Binary (a,b,c) where
446 put_ bh (a,b,c) = do put_ bh a; put_ bh b; put_ bh c
447 get bh = do a <- get bh
452 instance (Binary a, Binary b, Binary c, Binary d) => Binary (a,b,c,d) where
453 put_ bh (a,b,c,d) = do put_ bh a; put_ bh b; put_ bh c; put_ bh d
454 get bh = do a <- get bh
460 instance Binary a => Binary (Maybe a) where
461 put_ bh Nothing = putByte bh 0
462 put_ bh (Just a) = do putByte bh 1; put_ bh a
463 get bh = do h <- getWord8 bh
466 _ -> do x <- get bh; return (Just x)
468 instance (Binary a, Binary b) => Binary (Either a b) where
469 put_ bh (Left a) = do putByte bh 0; put_ bh a
470 put_ bh (Right b) = do putByte bh 1; put_ bh b
471 get bh = do h <- getWord8 bh
473 0 -> do a <- get bh ; return (Left a)
474 _ -> do b <- get bh ; return (Right b)
476 #if defined(__GLASGOW_HASKELL__) || 1
477 --to quote binary-0.3 on this code idea,
479 -- TODO This instance is not architecture portable. GMP stores numbers as
480 -- arrays of machine sized words, so the byte format is not portable across
481 -- architectures with different endianess and word size.
483 -- This makes it hard (impossible) to make an equivalent instance
484 -- with code that is compilable with non-GHC. Do we need any instance
485 -- Binary Integer, and if so, does it have to be blazing fast? Or can
486 -- we just change this instance to be portable like the rest of the
487 -- instances? (binary package has code to steal for that)
489 -- yes, we need Binary Integer and Binary Rational in basicTypes/Literal.lhs
491 instance Binary Integer where
492 -- XXX This is hideous
493 put_ bh i = put_ bh (show i)
494 get bh = do str <- get bh
496 [(i, "")] -> return i
497 _ -> fail ("Binary Integer: got " ++ show str)
500 put_ bh (S# i#) = do putByte bh 0; put_ bh (I# i#)
501 put_ bh (J# s# a#) = do
504 let sz# = sizeofByteArray# a# -- in *bytes*
505 put_ bh (I# sz#) -- in *bytes*
506 putByteArray bh a# sz#
511 0 -> do (I# i#) <- get bh
513 _ -> do (I# s#) <- get bh
515 (BA a#) <- getByteArray bh sz
519 -- As for the rest of this code, even though this module
520 -- exports it, it doesn't seem to be used anywhere else
523 putByteArray :: BinHandle -> ByteArray# -> Int# -> IO ()
524 putByteArray bh a s# = loop 0#
526 | n# ==# s# = return ()
528 putByte bh (indexByteArray a n#)
531 getByteArray :: BinHandle -> Int -> IO ByteArray
532 getByteArray bh (I# sz) = do
533 (MBA arr) <- newByteArray sz
535 | n ==# sz = return ()
538 writeByteArray arr n w
544 data ByteArray = BA ByteArray#
545 data MBA = MBA (MutableByteArray# RealWorld)
547 newByteArray :: Int# -> IO MBA
548 newByteArray sz = IO $ \s ->
549 case newByteArray# sz s of { (# s, arr #) ->
552 freezeByteArray :: MutableByteArray# RealWorld -> IO ByteArray
553 freezeByteArray arr = IO $ \s ->
554 case unsafeFreezeByteArray# arr s of { (# s, arr #) ->
557 writeByteArray :: MutableByteArray# RealWorld -> Int# -> Word8 -> IO ()
558 writeByteArray arr i (W8# w) = IO $ \s ->
559 case writeWord8Array# arr i w s of { s ->
562 indexByteArray :: ByteArray# -> Int# -> Word8
563 indexByteArray a# n# = W8# (indexWord8Array# a# n#)
565 instance (Integral a, Binary a) => Binary (Ratio a) where
566 put_ bh (a :% b) = do put_ bh a; put_ bh b
567 get bh = do a <- get bh; b <- get bh; return (a :% b)
570 instance Binary (Bin a) where
571 put_ bh (BinPtr i) = put_ bh i
572 get bh = do i <- get bh; return (BinPtr i)
574 -- -----------------------------------------------------------------------------
575 -- Instances for Data.Typeable stuff
577 instance Binary TyCon where
579 let s = tyConString ty_con
585 instance Binary TypeRep where
586 put_ bh type_rep = do
587 let (ty_con, child_type_reps) = splitTyConApp type_rep
589 put_ bh child_type_reps
592 child_type_reps <- get bh
593 return (mkTyConApp ty_con child_type_reps)
595 -- -----------------------------------------------------------------------------
596 -- Lazy reading/writing
598 lazyPut :: Binary a => BinHandle -> a -> IO ()
600 -- output the obj with a ptr to skip over it:
602 put_ bh pre_a -- save a slot for the ptr
603 put_ bh a -- dump the object
604 q <- tellBin bh -- q = ptr to after object
605 putAt bh pre_a q -- fill in slot before a with ptr to q
606 seekBin bh q -- finally carry on writing at q
608 lazyGet :: Binary a => BinHandle -> IO a
610 p <- get bh -- a BinPtr
612 a <- unsafeInterleaveIO (getAt bh p_a)
613 seekBin bh p -- skip over the object for now
616 -- -----------------------------------------------------------------------------
618 -- -----------------------------------------------------------------------------
622 -- for *deserialising* only:
623 ud_dict :: Dictionary,
624 ud_symtab :: SymbolTable,
626 -- for *serialising* only:
627 ud_put_name :: BinHandle -> Name -> IO (),
628 ud_put_fs :: BinHandle -> FastString -> IO ()
631 newReadState :: Dictionary -> IO UserData
632 newReadState dict = do
633 return UserData { ud_dict = dict,
634 ud_symtab = undef "symtab",
635 ud_put_name = undef "put_name",
636 ud_put_fs = undef "put_fs"
639 newWriteState :: (BinHandle -> Name -> IO ())
640 -> (BinHandle -> FastString -> IO ())
642 newWriteState put_name put_fs = do
643 return UserData { ud_dict = undef "dict",
644 ud_symtab = undef "symtab",
645 ud_put_name = put_name,
650 noUserData = undef "UserData"
653 undef s = panic ("Binary.UserData: no " ++ s)
655 ---------------------------------------------------------
657 ---------------------------------------------------------
659 type Dictionary = Array Int FastString -- The dictionary
660 -- Should be 0-indexed
662 putDictionary :: BinHandle -> Int -> UniqFM (Int,FastString) -> IO ()
663 putDictionary bh sz dict = do
665 mapM_ (putFS bh) (elems (array (0,sz-1) (eltsUFM dict)))
667 getDictionary :: BinHandle -> IO Dictionary
668 getDictionary bh = do
670 elems <- sequence (take sz (repeat (getFS bh)))
671 return (listArray (0,sz-1) elems)
673 ---------------------------------------------------------
675 ---------------------------------------------------------
677 -- On disk, the symbol table is an array of IfaceExtName, when
678 -- reading it in we turn it into a SymbolTable.
680 type SymbolTable = Array Int Name
682 ---------------------------------------------------------
683 -- Reading and writing FastStrings
684 ---------------------------------------------------------
686 putFS :: BinHandle -> FastString -> IO ()
687 putFS bh (FastString _ l _ buf _) = do
689 withForeignPtr buf $ \ptr ->
691 go n | n == l = return ()
693 b <- peekElemOff ptr n
699 {- -- possible faster version, not quite there yet:
700 getFS bh@BinMem{} = do
702 arr <- readIORef (arr_r bh)
703 off <- readFastMutInt (off_r bh)
704 return $! (mkFastSubStringBA# arr off l)
706 getFS :: BinHandle -> IO FastString
709 fp <- mallocForeignPtrBytes l
710 withForeignPtr fp $ \ptr -> do
712 go n | n == l = mkFastStringForeignPtr ptr fp l
720 instance Binary FastString where
722 case getUserData bh of
723 UserData { ud_put_fs = put_fs } -> put_fs bh f
727 return $! (ud_dict (getUserData bh) ! j)
729 -- Here to avoid loop
731 instance Binary Fingerprint where
732 put_ h (Fingerprint w1 w2) = do put_ h w1; put_ h w2
733 get h = do w1 <- get h; w2 <- get h; return (Fingerprint w1 w2)
735 instance Binary FunctionOrData where
736 put_ bh IsFunction = putByte bh 0
737 put_ bh IsData = putByte bh 1
741 0 -> return IsFunction
743 _ -> panic "Binary FunctionOrData"