3 -- The above warning supression flag is a temporary kludge.
4 -- While working on this module you are encouraged to remove it and fix
5 -- any warnings in the module. See
6 -- http://hackage.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#Warnings
10 -- (c) The University of Glasgow 2002-2006
12 -- Binary I/O library, with special tweaks for GHC
14 -- Based on the nhc98 Binary library, which is copyright
15 -- (c) Malcolm Wallace and Colin Runciman, University of York, 1998.
16 -- Under the terms of the license for that software, we must tell you
17 -- where you can obtain the original version of the Binary library, namely
18 -- http://www.cs.york.ac.uk/fp/nhc98/
25 openBinIO, openBinIO_,
40 -- for writing instances:
48 #ifdef __GLASGOW_HASKELL__
55 UserData(..), getUserData, setUserData,
56 newReadState, newWriteState,
57 putDictionary, getDictionary,
60 #include "HsVersions.h"
62 -- The *host* architecture version:
65 import {-# SOURCE #-} Name (Name)
79 import Data.Char ( ord, chr )
80 import Data.Array.Base ( unsafeRead, unsafeWrite )
81 import Control.Monad ( when )
82 import System.IO as IO
83 import System.IO.Unsafe ( unsafeInterleaveIO )
84 import System.IO.Error ( mkIOError, eofErrorType )
85 import GHC.Real ( Ratio(..) )
87 import GHC.IOBase ( IO(..) )
88 import GHC.Word ( Word8(..) )
89 #if defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ < 601
90 -- openFileEx is available from the lang package, but we want to
91 -- be independent of hslibs libraries.
92 import GHC.Handle ( openFileEx, IOModeEx(..) )
94 import System.IO ( openBinaryFile )
97 #if defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ < 601
98 openBinaryFile f mode = openFileEx f (BinaryMode mode)
101 type BinArray = IOUArray Int Word8
103 ---------------------------------------------------------------
105 ---------------------------------------------------------------
108 = BinMem { -- binary data stored in an unboxed array
109 bh_usr :: UserData, -- sigh, need parameterized modules :-)
110 off_r :: !FastMutInt, -- the current offset
111 sz_r :: !FastMutInt, -- size of the array (cached)
112 arr_r :: !(IORef BinArray) -- the array (bounds: (0,size-1))
114 -- XXX: should really store a "high water mark" for dumping out
115 -- the binary data to a file.
117 | BinIO { -- binary data stored in a file
119 off_r :: !FastMutInt, -- the current offset (cached)
120 hdl :: !IO.Handle -- the file handle (must be seekable)
122 -- cache the file ptr in BinIO; using hTell is too expensive
123 -- to call repeatedly. If anyone else is modifying this Handle
124 -- at the same time, we'll be screwed.
126 getUserData :: BinHandle -> UserData
127 getUserData bh = bh_usr bh
129 setUserData :: BinHandle -> UserData -> BinHandle
130 setUserData bh us = bh { bh_usr = us }
133 ---------------------------------------------------------------
135 ---------------------------------------------------------------
137 newtype Bin a = BinPtr Int
138 deriving (Eq, Ord, Show, Bounded)
140 castBin :: Bin a -> Bin b
141 castBin (BinPtr i) = BinPtr i
143 ---------------------------------------------------------------
145 ---------------------------------------------------------------
148 put_ :: BinHandle -> a -> IO ()
149 put :: BinHandle -> a -> IO (Bin a)
150 get :: BinHandle -> IO a
152 -- define one of put_, put. Use of put_ is recommended because it
153 -- is more likely that tail-calls can kick in, and we rarely need the
154 -- position return value.
155 put_ bh a = do put bh a; return ()
156 put bh a = do p <- tellBin bh; put_ bh a; return p
158 putAt :: Binary a => BinHandle -> Bin a -> a -> IO ()
159 putAt bh p x = do seekBin bh p; put bh x; return ()
161 getAt :: Binary a => BinHandle -> Bin a -> IO a
162 getAt bh p = do seekBin bh p; get bh
164 openBinIO_ :: IO.Handle -> IO BinHandle
165 openBinIO_ h = openBinIO h
167 openBinIO :: IO.Handle -> IO BinHandle
171 return (BinIO noUserData r h)
173 openBinMem :: Int -> IO BinHandle
175 | size <= 0 = error "Data.Binary.openBinMem: size must be >= 0"
177 arr <- newArray_ (0,size-1)
178 arr_r <- newIORef arr
179 ix_r <- newFastMutInt
180 writeFastMutInt ix_r 0
181 sz_r <- newFastMutInt
182 writeFastMutInt sz_r size
183 return (BinMem noUserData ix_r sz_r arr_r)
185 tellBin :: BinHandle -> IO (Bin a)
186 tellBin (BinIO _ r _) = do ix <- readFastMutInt r; return (BinPtr ix)
187 tellBin (BinMem _ r _ _) = do ix <- readFastMutInt r; return (BinPtr ix)
189 seekBin :: BinHandle -> Bin a -> IO ()
190 seekBin (BinIO _ ix_r h) (BinPtr p) = do
191 writeFastMutInt ix_r p
192 hSeek h AbsoluteSeek (fromIntegral p)
193 seekBin h@(BinMem _ ix_r sz_r a) (BinPtr p) = do
194 sz <- readFastMutInt sz_r
196 then do expandBin h p; writeFastMutInt ix_r p
197 else writeFastMutInt ix_r p
199 isEOFBin :: BinHandle -> IO Bool
200 isEOFBin (BinMem _ ix_r sz_r a) = do
201 ix <- readFastMutInt ix_r
202 sz <- readFastMutInt sz_r
204 isEOFBin (BinIO _ ix_r h) = hIsEOF h
206 writeBinMem :: BinHandle -> FilePath -> IO ()
207 writeBinMem (BinIO _ _ _) _ = error "Data.Binary.writeBinMem: not a memory handle"
208 writeBinMem (BinMem _ ix_r sz_r arr_r) fn = do
209 h <- openBinaryFile fn WriteMode
210 arr <- readIORef arr_r
211 ix <- readFastMutInt ix_r
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 <- newArray_ (0,filesize-1)
222 count <- hGetArray h arr filesize
223 when (count /= filesize)
224 (error ("Binary.readBinMem: only read " ++ show count ++ " bytes"))
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)
233 -- expand the size of the array to include a specified offset
234 expandBin :: BinHandle -> Int -> IO ()
235 expandBin (BinMem _ ix_r sz_r arr_r) off = do
236 sz <- readFastMutInt sz_r
237 let sz' = head (dropWhile (<= off) (iterate (* 2) sz))
238 arr <- readIORef arr_r
239 arr' <- newArray_ (0,sz'-1)
240 sequence_ [ unsafeRead arr i >>= unsafeWrite arr' i
241 | i <- [ 0 .. sz-1 ] ]
242 writeFastMutInt sz_r sz'
243 writeIORef arr_r arr'
245 hPutStrLn stderr ("Binary: expanding to size: " ++ show sz')
248 expandBin (BinIO _ _ _) _ = return ()
249 -- no need to expand a file, we'll assume they expand by themselves.
251 -- -----------------------------------------------------------------------------
252 -- Low-level reading/writing of bytes
254 putWord8 :: BinHandle -> Word8 -> IO ()
255 putWord8 h@(BinMem _ ix_r sz_r arr_r) w = do
256 ix <- readFastMutInt ix_r
257 sz <- readFastMutInt sz_r
258 -- double the size of the array if it overflows
260 then do expandBin h ix
262 else do arr <- readIORef arr_r
264 writeFastMutInt ix_r (ix+1)
266 putWord8 (BinIO _ ix_r h) w = do
267 ix <- readFastMutInt ix_r
268 hPutChar h (chr (fromIntegral w)) -- XXX not really correct
269 writeFastMutInt ix_r (ix+1)
272 getWord8 :: BinHandle -> IO Word8
273 getWord8 (BinMem _ ix_r sz_r arr_r) = do
274 ix <- readFastMutInt ix_r
275 sz <- readFastMutInt sz_r
277 ioError (mkIOError eofErrorType "Data.Binary.getWord8" Nothing Nothing)
278 arr <- readIORef arr_r
279 w <- unsafeRead arr ix
280 writeFastMutInt ix_r (ix+1)
282 getWord8 (BinIO _ ix_r h) = do
283 ix <- readFastMutInt ix_r
285 writeFastMutInt ix_r (ix+1)
286 return $! (fromIntegral (ord c)) -- XXX not really correct
288 putByte :: BinHandle -> Word8 -> IO ()
289 putByte bh w = put_ bh w
291 getByte :: BinHandle -> IO Word8
294 -- -----------------------------------------------------------------------------
295 -- Primitve Word writes
297 instance Binary Word8 where
301 instance Binary Word16 where
302 put_ h w = do -- XXX too slow.. inline putWord8?
303 putByte h (fromIntegral (w `shiftR` 8))
304 putByte h (fromIntegral (w .&. 0xff))
308 return $! ((fromIntegral w1 `shiftL` 8) .|. fromIntegral w2)
311 instance Binary Word32 where
313 putByte h (fromIntegral (w `shiftR` 24))
314 putByte h (fromIntegral ((w `shiftR` 16) .&. 0xff))
315 putByte h (fromIntegral ((w `shiftR` 8) .&. 0xff))
316 putByte h (fromIntegral (w .&. 0xff))
322 return $! ((fromIntegral w1 `shiftL` 24) .|.
323 (fromIntegral w2 `shiftL` 16) .|.
324 (fromIntegral w3 `shiftL` 8) .|.
328 instance Binary Word64 where
330 putByte h (fromIntegral (w `shiftR` 56))
331 putByte h (fromIntegral ((w `shiftR` 48) .&. 0xff))
332 putByte h (fromIntegral ((w `shiftR` 40) .&. 0xff))
333 putByte h (fromIntegral ((w `shiftR` 32) .&. 0xff))
334 putByte h (fromIntegral ((w `shiftR` 24) .&. 0xff))
335 putByte h (fromIntegral ((w `shiftR` 16) .&. 0xff))
336 putByte h (fromIntegral ((w `shiftR` 8) .&. 0xff))
337 putByte h (fromIntegral (w .&. 0xff))
347 return $! ((fromIntegral w1 `shiftL` 56) .|.
348 (fromIntegral w2 `shiftL` 48) .|.
349 (fromIntegral w3 `shiftL` 40) .|.
350 (fromIntegral w4 `shiftL` 32) .|.
351 (fromIntegral w5 `shiftL` 24) .|.
352 (fromIntegral w6 `shiftL` 16) .|.
353 (fromIntegral w7 `shiftL` 8) .|.
356 -- -----------------------------------------------------------------------------
357 -- Primitve Int writes
359 instance Binary Int8 where
360 put_ h w = put_ h (fromIntegral w :: Word8)
361 get h = do w <- get h; return $! (fromIntegral (w::Word8))
363 instance Binary Int16 where
364 put_ h w = put_ h (fromIntegral w :: Word16)
365 get h = do w <- get h; return $! (fromIntegral (w::Word16))
367 instance Binary Int32 where
368 put_ h w = put_ h (fromIntegral w :: Word32)
369 get h = do w <- get h; return $! (fromIntegral (w::Word32))
371 instance Binary Int64 where
372 put_ h w = put_ h (fromIntegral w :: Word64)
373 get h = do w <- get h; return $! (fromIntegral (w::Word64))
375 -- -----------------------------------------------------------------------------
376 -- Instances for standard types
378 instance Binary () where
379 put_ bh () = return ()
381 -- getF bh p = case getBitsF bh 0 p of (_,b) -> ((),b)
383 instance Binary Bool where
384 put_ bh b = putByte bh (fromIntegral (fromEnum b))
385 get bh = do x <- getWord8 bh; return $! (toEnum (fromIntegral x))
386 -- getF bh p = case getBitsF bh 1 p of (x,b) -> (toEnum x,b)
388 instance Binary Char where
389 put_ bh c = put_ bh (fromIntegral (ord c) :: Word32)
390 get bh = do x <- get bh; return $! (chr (fromIntegral (x :: Word32)))
391 -- getF bh p = case getBitsF bh 8 p of (x,b) -> (toEnum x,b)
393 instance Binary Int where
394 #if SIZEOF_HSINT == 4
395 put_ bh i = put_ bh (fromIntegral i :: Int32)
398 return $! (fromIntegral (x :: Int32))
399 #elif SIZEOF_HSINT == 8
400 put_ bh i = put_ bh (fromIntegral i :: Int64)
403 return $! (fromIntegral (x :: Int64))
405 #error "unsupported sizeof(HsInt)"
407 -- getF bh = getBitsF bh 32
409 instance Binary a => Binary [a] where
413 then putByte bh (fromIntegral len :: Word8)
414 else do putByte bh 0xff; put_ bh (fromIntegral len :: Word32)
420 else return (fromIntegral b :: Word32)
421 let loop 0 = return []
422 loop n = do a <- get bh; as <- loop (n-1); return (a:as)
425 instance (Binary a, Binary b) => Binary (a,b) where
426 put_ bh (a,b) = do put_ bh a; put_ bh b
427 get bh = do a <- get bh
431 instance (Binary a, Binary b, Binary c) => Binary (a,b,c) where
432 put_ bh (a,b,c) = do put_ bh a; put_ bh b; put_ bh c
433 get bh = do a <- get bh
438 instance (Binary a, Binary b, Binary c, Binary d) => Binary (a,b,c,d) where
439 put_ bh (a,b,c,d) = do put_ bh a; put_ bh b; put_ bh c; put_ bh d
440 get bh = do a <- get bh
446 instance Binary a => Binary (Maybe a) where
447 put_ bh Nothing = putByte bh 0
448 put_ bh (Just a) = do putByte bh 1; put_ bh a
449 get bh = do h <- getWord8 bh
452 _ -> do x <- get bh; return (Just x)
454 instance (Binary a, Binary b) => Binary (Either a b) where
455 put_ bh (Left a) = do putByte bh 0; put_ bh a
456 put_ bh (Right b) = do putByte bh 1; put_ bh b
457 get bh = do h <- getWord8 bh
459 0 -> do a <- get bh ; return (Left a)
460 _ -> do b <- get bh ; return (Right b)
462 #if defined(__GLASGOW_HASKELL__) || 1
463 --to quote binary-0.3 on this code idea,
465 -- TODO This instance is not architecture portable. GMP stores numbers as
466 -- arrays of machine sized words, so the byte format is not portable across
467 -- architectures with different endianess and word size.
469 -- This makes it hard (impossible) to make an equivalent instance
470 -- with code that is compilable with non-GHC. Do we need any instance
471 -- Binary Integer, and if so, does it have to be blazing fast? Or can
472 -- we just change this instance to be portable like the rest of the
473 -- instances? (binary package has code to steal for that)
475 -- yes, we need Binary Integer and Binary Rational in basicTypes/Literal.lhs
477 instance Binary Integer where
478 put_ bh (S# i#) = do putByte bh 0; put_ bh (I# i#)
479 put_ bh (J# s# a#) = do
482 let sz# = sizeofByteArray# a# -- in *bytes*
483 put_ bh (I# sz#) -- in *bytes*
484 putByteArray bh a# sz#
489 0 -> do (I# i#) <- get bh
491 _ -> do (I# s#) <- get bh
493 (BA a#) <- getByteArray bh sz
496 -- As for the rest of this code, even though this module
497 -- exports it, it doesn't seem to be used anywhere else
500 putByteArray :: BinHandle -> ByteArray# -> Int# -> IO ()
501 putByteArray bh a s# = loop 0#
503 | n# ==# s# = return ()
505 putByte bh (indexByteArray a n#)
508 getByteArray :: BinHandle -> Int -> IO ByteArray
509 getByteArray bh (I# sz) = do
510 (MBA arr) <- newByteArray sz
512 | n ==# sz = return ()
515 writeByteArray arr n w
521 data ByteArray = BA ByteArray#
522 data MBA = MBA (MutableByteArray# RealWorld)
524 newByteArray :: Int# -> IO MBA
525 newByteArray sz = IO $ \s ->
526 case newByteArray# sz s of { (# s, arr #) ->
529 freezeByteArray :: MutableByteArray# RealWorld -> IO ByteArray
530 freezeByteArray arr = IO $ \s ->
531 case unsafeFreezeByteArray# arr s of { (# s, arr #) ->
534 writeByteArray :: MutableByteArray# RealWorld -> Int# -> Word8 -> IO ()
535 writeByteArray arr i (W8# w) = IO $ \s ->
536 case writeWord8Array# arr i w s of { s ->
539 indexByteArray :: ByteArray# -> Int# -> Word8
540 indexByteArray a# n# = W8# (indexWord8Array# a# n#)
542 instance (Integral a, Binary a) => Binary (Ratio a) where
543 put_ bh (a :% b) = do put_ bh a; put_ bh b
544 get bh = do a <- get bh; b <- get bh; return (a :% b)
547 instance Binary (Bin a) where
548 put_ bh (BinPtr i) = put_ bh i
549 get bh = do i <- get bh; return (BinPtr i)
551 -- -----------------------------------------------------------------------------
552 -- Lazy reading/writing
554 lazyPut :: Binary a => BinHandle -> a -> IO ()
556 -- output the obj with a ptr to skip over it:
558 put_ bh pre_a -- save a slot for the ptr
559 put_ bh a -- dump the object
560 q <- tellBin bh -- q = ptr to after object
561 putAt bh pre_a q -- fill in slot before a with ptr to q
562 seekBin bh q -- finally carry on writing at q
564 lazyGet :: Binary a => BinHandle -> IO a
566 p <- get bh -- a BinPtr
568 a <- unsafeInterleaveIO (getAt bh p_a)
569 seekBin bh p -- skip over the object for now
572 -- -----------------------------------------------------------------------------
574 -- -----------------------------------------------------------------------------
578 -- for *deserialising* only:
579 ud_dict :: Dictionary,
580 ud_symtab :: SymbolTable,
582 -- for *serialising* only:
583 ud_dict_next :: !FastMutInt, -- The next index to use
584 ud_dict_map :: !(IORef (UniqFM (Int,FastString))),
585 -- indexed by FastString
587 ud_symtab_next :: !FastMutInt, -- The next index to use
588 ud_symtab_map :: !(IORef (UniqFM (Int,Name)))
592 newReadState :: Dictionary -> IO UserData
593 newReadState dict = do
594 dict_next <- newFastMutInt
595 dict_map <- newIORef (undef "dict_map")
596 symtab_next <- newFastMutInt
597 symtab_map <- newIORef (undef "symtab_map")
598 return UserData { ud_dict = dict,
599 ud_symtab = undef "symtab",
600 ud_dict_next = dict_next,
601 ud_dict_map = dict_map,
602 ud_symtab_next = symtab_next,
603 ud_symtab_map = symtab_map
606 newWriteState :: IO UserData
608 dict_next <- newFastMutInt
609 writeFastMutInt dict_next 0
610 dict_map <- newIORef emptyUFM
611 symtab_next <- newFastMutInt
612 writeFastMutInt symtab_next 0
613 symtab_map <- newIORef emptyUFM
614 return UserData { ud_dict = undef "dict",
615 ud_symtab = undef "symtab",
616 ud_dict_next = dict_next,
617 ud_dict_map = dict_map,
618 ud_symtab_next = symtab_next,
619 ud_symtab_map = symtab_map
622 noUserData = undef "UserData"
624 undef s = panic ("Binary.UserData: no " ++ s)
626 ---------------------------------------------------------
628 ---------------------------------------------------------
630 type Dictionary = Array Int FastString -- The dictionary
631 -- Should be 0-indexed
633 putDictionary :: BinHandle -> Int -> UniqFM (Int,FastString) -> IO ()
634 putDictionary bh sz dict = do
636 mapM_ (putFS bh) (elems (array (0,sz-1) (eltsUFM dict)))
638 getDictionary :: BinHandle -> IO Dictionary
639 getDictionary bh = do
641 elems <- sequence (take sz (repeat (getFS bh)))
642 return (listArray (0,sz-1) elems)
644 ---------------------------------------------------------
646 ---------------------------------------------------------
648 -- On disk, the symbol table is an array of IfaceExtName, when
649 -- reading it in we turn it into a SymbolTable.
651 type SymbolTable = Array Int Name
653 ---------------------------------------------------------
654 -- Reading and writing FastStrings
655 ---------------------------------------------------------
657 putFS bh (FastString id l _ buf _) = do
659 withForeignPtr buf $ \ptr ->
661 go n | n == l = return ()
663 b <- peekElemOff ptr n
669 {- -- possible faster version, not quite there yet:
670 getFS bh@BinMem{} = do
672 arr <- readIORef (arr_r bh)
673 off <- readFastMutInt (off_r bh)
674 return $! (mkFastSubStringBA# arr off l)
678 fp <- mallocForeignPtrBytes l
679 withForeignPtr fp $ \ptr -> do
681 go n | n == l = mkFastStringForeignPtr ptr fp l
689 instance Binary FastString where
690 put_ bh f@(FastString id l _ fp _) =
691 case getUserData bh of {
692 UserData { ud_dict_next = j_r,
694 ud_dict = dict} -> do
695 out <- readIORef out_r
696 let uniq = getUnique f
697 case lookupUFM out uniq of
698 Just (j,f) -> put_ bh j
700 j <- readFastMutInt j_r
702 writeFastMutInt j_r (j+1)
703 writeIORef out_r $! addToUFM out uniq (j,f)
708 return $! (ud_dict (getUserData bh) ! j)