3 -- (c) The University of Glasgow 2002-2006
5 -- Binary I/O library, with special tweaks for GHC
7 -- Based on the nhc98 Binary library, which is copyright
8 -- (c) Malcolm Wallace and Colin Runciman, University of York, 1998.
9 -- Under the terms of the license for that software, we must tell you
10 -- where you can obtain the original version of the Binary library, namely
11 -- http://www.cs.york.ac.uk/fp/nhc98/
18 openBinIO, openBinIO_,
33 -- for writing instances:
46 UserData(..), getUserData, setUserData,
47 newReadState, newWriteState,
48 putDictionary, getDictionary,
51 #include "HsVersions.h"
53 -- The *host* architecture version:
56 import {-# SOURCE #-} Name (Name)
71 import Data.Char ( ord, chr )
72 import Data.Array.Base ( unsafeRead, unsafeWrite )
73 import Control.Monad ( when )
74 import System.IO as IO
75 import System.IO.Unsafe ( unsafeInterleaveIO )
76 import System.IO.Error ( mkIOError, eofErrorType )
77 import GHC.Real ( Ratio(..) )
79 import GHC.IOBase ( IO(..) )
80 import GHC.Word ( Word8(..) )
81 #if __GLASGOW_HASKELL__ < 601
82 -- openFileEx is available from the lang package, but we want to
83 -- be independent of hslibs libraries.
84 import GHC.Handle ( openFileEx, IOModeEx(..) )
86 import System.IO ( openBinaryFile )
89 #if __GLASGOW_HASKELL__ < 601
90 openBinaryFile f mode = openFileEx f (BinaryMode mode)
93 type BinArray = IOUArray Int Word8
95 ---------------------------------------------------------------
97 ---------------------------------------------------------------
100 = BinMem { -- binary data stored in an unboxed array
101 bh_usr :: UserData, -- sigh, need parameterized modules :-)
102 off_r :: !FastMutInt, -- the current offset
103 sz_r :: !FastMutInt, -- size of the array (cached)
104 arr_r :: !(IORef BinArray) -- the array (bounds: (0,size-1))
106 -- XXX: should really store a "high water mark" for dumping out
107 -- the binary data to a file.
109 | BinIO { -- binary data stored in a file
111 off_r :: !FastMutInt, -- the current offset (cached)
112 hdl :: !IO.Handle -- the file handle (must be seekable)
114 -- cache the file ptr in BinIO; using hTell is too expensive
115 -- to call repeatedly. If anyone else is modifying this Handle
116 -- at the same time, we'll be screwed.
118 getUserData :: BinHandle -> UserData
119 getUserData bh = bh_usr bh
121 setUserData :: BinHandle -> UserData -> BinHandle
122 setUserData bh us = bh { bh_usr = us }
125 ---------------------------------------------------------------
127 ---------------------------------------------------------------
129 newtype Bin a = BinPtr Int
130 deriving (Eq, Ord, Show, Bounded)
132 castBin :: Bin a -> Bin b
133 castBin (BinPtr i) = BinPtr i
135 ---------------------------------------------------------------
137 ---------------------------------------------------------------
140 put_ :: BinHandle -> a -> IO ()
141 put :: BinHandle -> a -> IO (Bin a)
142 get :: BinHandle -> IO a
144 -- define one of put_, put. Use of put_ is recommended because it
145 -- is more likely that tail-calls can kick in, and we rarely need the
146 -- position return value.
147 put_ bh a = do put bh a; return ()
148 put bh a = do p <- tellBin bh; put_ bh a; return p
150 putAt :: Binary a => BinHandle -> Bin a -> a -> IO ()
151 putAt bh p x = do seekBin bh p; put bh x; return ()
153 getAt :: Binary a => BinHandle -> Bin a -> IO a
154 getAt bh p = do seekBin bh p; get bh
156 openBinIO_ :: IO.Handle -> IO BinHandle
157 openBinIO_ h = openBinIO h
159 openBinIO :: IO.Handle -> IO BinHandle
163 return (BinIO noUserData r h)
165 openBinMem :: Int -> IO BinHandle
167 | size <= 0 = error "Data.Binary.openBinMem: size must be >= 0"
169 arr <- newArray_ (0,size-1)
170 arr_r <- newIORef arr
171 ix_r <- newFastMutInt
172 writeFastMutInt ix_r 0
173 sz_r <- newFastMutInt
174 writeFastMutInt sz_r size
175 return (BinMem noUserData ix_r sz_r arr_r)
177 tellBin :: BinHandle -> IO (Bin a)
178 tellBin (BinIO _ r _) = do ix <- readFastMutInt r; return (BinPtr ix)
179 tellBin (BinMem _ r _ _) = do ix <- readFastMutInt r; return (BinPtr ix)
181 seekBin :: BinHandle -> Bin a -> IO ()
182 seekBin (BinIO _ ix_r h) (BinPtr p) = do
183 writeFastMutInt ix_r p
184 hSeek h AbsoluteSeek (fromIntegral p)
185 seekBin h@(BinMem _ ix_r sz_r a) (BinPtr p) = do
186 sz <- readFastMutInt sz_r
188 then do expandBin h p; writeFastMutInt ix_r p
189 else writeFastMutInt ix_r p
191 isEOFBin :: BinHandle -> IO Bool
192 isEOFBin (BinMem _ ix_r sz_r a) = do
193 ix <- readFastMutInt ix_r
194 sz <- readFastMutInt sz_r
196 isEOFBin (BinIO _ ix_r h) = hIsEOF h
198 writeBinMem :: BinHandle -> FilePath -> IO ()
199 writeBinMem (BinIO _ _ _) _ = error "Data.Binary.writeBinMem: not a memory handle"
200 writeBinMem (BinMem _ ix_r sz_r arr_r) fn = do
201 h <- openBinaryFile fn WriteMode
202 arr <- readIORef arr_r
203 ix <- readFastMutInt ix_r
207 readBinMem :: FilePath -> IO BinHandle
208 -- Return a BinHandle with a totally undefined State
209 readBinMem filename = do
210 h <- openBinaryFile filename ReadMode
211 filesize' <- hFileSize h
212 let filesize = fromIntegral filesize'
213 arr <- newArray_ (0,filesize-1)
214 count <- hGetArray h arr filesize
215 when (count /= filesize)
216 (error ("Binary.readBinMem: only read " ++ show count ++ " bytes"))
218 arr_r <- newIORef arr
219 ix_r <- newFastMutInt
220 writeFastMutInt ix_r 0
221 sz_r <- newFastMutInt
222 writeFastMutInt sz_r filesize
223 return (BinMem noUserData ix_r sz_r arr_r)
225 -- expand the size of the array to include a specified offset
226 expandBin :: BinHandle -> Int -> IO ()
227 expandBin (BinMem _ ix_r sz_r arr_r) off = do
228 sz <- readFastMutInt sz_r
229 let sz' = head (dropWhile (<= off) (iterate (* 2) sz))
230 arr <- readIORef arr_r
231 arr' <- newArray_ (0,sz'-1)
232 sequence_ [ unsafeRead arr i >>= unsafeWrite arr' i
233 | i <- [ 0 .. sz-1 ] ]
234 writeFastMutInt sz_r sz'
235 writeIORef arr_r arr'
237 hPutStrLn stderr ("Binary: expanding to size: " ++ show sz')
240 expandBin (BinIO _ _ _) _ = return ()
241 -- no need to expand a file, we'll assume they expand by themselves.
243 -- -----------------------------------------------------------------------------
244 -- Low-level reading/writing of bytes
246 putWord8 :: BinHandle -> Word8 -> IO ()
247 putWord8 h@(BinMem _ ix_r sz_r arr_r) w = do
248 ix <- readFastMutInt ix_r
249 sz <- readFastMutInt sz_r
250 -- double the size of the array if it overflows
252 then do expandBin h ix
254 else do arr <- readIORef arr_r
256 writeFastMutInt ix_r (ix+1)
258 putWord8 (BinIO _ ix_r h) w = do
259 ix <- readFastMutInt ix_r
260 hPutChar h (chr (fromIntegral w)) -- XXX not really correct
261 writeFastMutInt ix_r (ix+1)
264 getWord8 :: BinHandle -> IO Word8
265 getWord8 (BinMem _ ix_r sz_r arr_r) = do
266 ix <- readFastMutInt ix_r
267 sz <- readFastMutInt sz_r
269 ioError (mkIOError eofErrorType "Data.Binary.getWord8" Nothing Nothing)
270 arr <- readIORef arr_r
271 w <- unsafeRead arr ix
272 writeFastMutInt ix_r (ix+1)
274 getWord8 (BinIO _ ix_r h) = do
275 ix <- readFastMutInt ix_r
277 writeFastMutInt ix_r (ix+1)
278 return $! (fromIntegral (ord c)) -- XXX not really correct
280 putByte :: BinHandle -> Word8 -> IO ()
281 putByte bh w = put_ bh w
283 getByte :: BinHandle -> IO Word8
286 -- -----------------------------------------------------------------------------
287 -- Primitve Word writes
289 instance Binary Word8 where
293 instance Binary Word16 where
294 put_ h w = do -- XXX too slow.. inline putWord8?
295 putByte h (fromIntegral (w `shiftR` 8))
296 putByte h (fromIntegral (w .&. 0xff))
300 return $! ((fromIntegral w1 `shiftL` 8) .|. fromIntegral w2)
303 instance Binary Word32 where
305 putByte h (fromIntegral (w `shiftR` 24))
306 putByte h (fromIntegral ((w `shiftR` 16) .&. 0xff))
307 putByte h (fromIntegral ((w `shiftR` 8) .&. 0xff))
308 putByte h (fromIntegral (w .&. 0xff))
314 return $! ((fromIntegral w1 `shiftL` 24) .|.
315 (fromIntegral w2 `shiftL` 16) .|.
316 (fromIntegral w3 `shiftL` 8) .|.
320 instance Binary Word64 where
322 putByte h (fromIntegral (w `shiftR` 56))
323 putByte h (fromIntegral ((w `shiftR` 48) .&. 0xff))
324 putByte h (fromIntegral ((w `shiftR` 40) .&. 0xff))
325 putByte h (fromIntegral ((w `shiftR` 32) .&. 0xff))
326 putByte h (fromIntegral ((w `shiftR` 24) .&. 0xff))
327 putByte h (fromIntegral ((w `shiftR` 16) .&. 0xff))
328 putByte h (fromIntegral ((w `shiftR` 8) .&. 0xff))
329 putByte h (fromIntegral (w .&. 0xff))
339 return $! ((fromIntegral w1 `shiftL` 56) .|.
340 (fromIntegral w2 `shiftL` 48) .|.
341 (fromIntegral w3 `shiftL` 40) .|.
342 (fromIntegral w4 `shiftL` 32) .|.
343 (fromIntegral w5 `shiftL` 24) .|.
344 (fromIntegral w6 `shiftL` 16) .|.
345 (fromIntegral w7 `shiftL` 8) .|.
348 -- -----------------------------------------------------------------------------
349 -- Primitve Int writes
351 instance Binary Int8 where
352 put_ h w = put_ h (fromIntegral w :: Word8)
353 get h = do w <- get h; return $! (fromIntegral (w::Word8))
355 instance Binary Int16 where
356 put_ h w = put_ h (fromIntegral w :: Word16)
357 get h = do w <- get h; return $! (fromIntegral (w::Word16))
359 instance Binary Int32 where
360 put_ h w = put_ h (fromIntegral w :: Word32)
361 get h = do w <- get h; return $! (fromIntegral (w::Word32))
363 instance Binary Int64 where
364 put_ h w = put_ h (fromIntegral w :: Word64)
365 get h = do w <- get h; return $! (fromIntegral (w::Word64))
367 -- -----------------------------------------------------------------------------
368 -- Instances for standard types
370 instance Binary () where
371 put_ bh () = return ()
373 -- getF bh p = case getBitsF bh 0 p of (_,b) -> ((),b)
375 instance Binary Bool where
376 put_ bh b = putByte bh (fromIntegral (fromEnum b))
377 get bh = do x <- getWord8 bh; return $! (toEnum (fromIntegral x))
378 -- getF bh p = case getBitsF bh 1 p of (x,b) -> (toEnum x,b)
380 instance Binary Char where
381 put_ bh c = put_ bh (fromIntegral (ord c) :: Word32)
382 get bh = do x <- get bh; return $! (chr (fromIntegral (x :: Word32)))
383 -- getF bh p = case getBitsF bh 8 p of (x,b) -> (toEnum x,b)
385 instance Binary Int where
386 #if SIZEOF_HSINT == 4
387 put_ bh i = put_ bh (fromIntegral i :: Int32)
390 return $! (fromIntegral (x :: Int32))
391 #elif SIZEOF_HSINT == 8
392 put_ bh i = put_ bh (fromIntegral i :: Int64)
395 return $! (fromIntegral (x :: Int64))
397 #error "unsupported sizeof(HsInt)"
399 -- getF bh = getBitsF bh 32
401 instance Binary a => Binary [a] where
405 then putByte bh (fromIntegral len :: Word8)
406 else do putByte bh 0xff; put_ bh (fromIntegral len :: Word32)
412 else return (fromIntegral b :: Word32)
413 let loop 0 = return []
414 loop n = do a <- get bh; as <- loop (n-1); return (a:as)
417 instance (Binary a, Binary b) => Binary (a,b) where
418 put_ bh (a,b) = do put_ bh a; put_ bh b
419 get bh = do a <- get bh
423 instance (Binary a, Binary b, Binary c) => Binary (a,b,c) where
424 put_ bh (a,b,c) = do put_ bh a; put_ bh b; put_ bh c
425 get bh = do a <- get bh
430 instance (Binary a, Binary b, Binary c, Binary d) => Binary (a,b,c,d) where
431 put_ bh (a,b,c,d) = do put_ bh a; put_ bh b; put_ bh c; put_ bh d
432 get bh = do a <- get bh
438 instance Binary a => Binary (Maybe a) where
439 put_ bh Nothing = putByte bh 0
440 put_ bh (Just a) = do putByte bh 1; put_ bh a
441 get bh = do h <- getWord8 bh
444 _ -> do x <- get bh; return (Just x)
446 instance (Binary a, Binary b) => Binary (Either a b) where
447 put_ bh (Left a) = do putByte bh 0; put_ bh a
448 put_ bh (Right b) = do putByte bh 1; put_ bh b
449 get bh = do h <- getWord8 bh
451 0 -> do a <- get bh ; return (Left a)
452 _ -> do b <- get bh ; return (Right b)
454 #ifdef __GLASGOW_HASKELL__
455 instance Binary Integer where
456 put_ bh (S# i#) = do putByte bh 0; put_ bh (I# i#)
457 put_ bh (J# s# a#) = do
460 let sz# = sizeofByteArray# a# -- in *bytes*
461 put_ bh (I# sz#) -- in *bytes*
462 putByteArray bh a# sz#
467 0 -> do (I# i#) <- get bh
469 _ -> do (I# s#) <- get bh
471 (BA a#) <- getByteArray bh sz
474 putByteArray :: BinHandle -> ByteArray# -> Int# -> IO ()
475 putByteArray bh a s# = loop 0#
477 | n# ==# s# = return ()
479 putByte bh (indexByteArray a n#)
482 getByteArray :: BinHandle -> Int -> IO ByteArray
483 getByteArray bh (I# sz) = do
484 (MBA arr) <- newByteArray sz
486 | n ==# sz = return ()
489 writeByteArray arr n w
495 data ByteArray = BA ByteArray#
496 data MBA = MBA (MutableByteArray# RealWorld)
498 newByteArray :: Int# -> IO MBA
499 newByteArray sz = IO $ \s ->
500 case newByteArray# sz s of { (# s, arr #) ->
503 freezeByteArray :: MutableByteArray# RealWorld -> IO ByteArray
504 freezeByteArray arr = IO $ \s ->
505 case unsafeFreezeByteArray# arr s of { (# s, arr #) ->
508 writeByteArray :: MutableByteArray# RealWorld -> Int# -> Word8 -> IO ()
509 writeByteArray arr i (W8# w) = IO $ \s ->
510 case writeWord8Array# arr i w s of { s ->
513 indexByteArray :: ByteArray# -> Int# -> Word8
514 indexByteArray a# n# = W8# (indexWord8Array# a# n#)
516 instance (Integral a, Binary a) => Binary (Ratio a) where
517 put_ bh (a :% b) = do put_ bh a; put_ bh b
518 get bh = do a <- get bh; b <- get bh; return (a :% b)
521 instance Binary (Bin a) where
522 put_ bh (BinPtr i) = put_ bh i
523 get bh = do i <- get bh; return (BinPtr i)
525 -- -----------------------------------------------------------------------------
526 -- Lazy reading/writing
528 lazyPut :: Binary a => BinHandle -> a -> IO ()
530 -- output the obj with a ptr to skip over it:
532 put_ bh pre_a -- save a slot for the ptr
533 put_ bh a -- dump the object
534 q <- tellBin bh -- q = ptr to after object
535 putAt bh pre_a q -- fill in slot before a with ptr to q
536 seekBin bh q -- finally carry on writing at q
538 lazyGet :: Binary a => BinHandle -> IO a
540 p <- get bh -- a BinPtr
542 a <- unsafeInterleaveIO (getAt bh p_a)
543 seekBin bh p -- skip over the object for now
546 -- -----------------------------------------------------------------------------
548 -- -----------------------------------------------------------------------------
552 -- for *deserialising* only:
553 ud_dict :: Dictionary,
554 ud_symtab :: SymbolTable,
556 -- for *serialising* only:
557 ud_dict_next :: !FastMutInt, -- The next index to use
558 ud_dict_map :: !(IORef (UniqFM (Int,FastString))),
559 -- indexed by FastString
561 ud_symtab_next :: !FastMutInt, -- The next index to use
562 ud_symtab_map :: !(IORef (UniqFM (Int,Name)))
566 newReadState :: Dictionary -> IO UserData
567 newReadState dict = do
568 dict_next <- newFastMutInt
569 dict_map <- newIORef (undef "dict_map")
570 symtab_next <- newFastMutInt
571 symtab_map <- newIORef (undef "symtab_map")
572 return UserData { ud_dict = dict,
573 ud_symtab = undef "symtab",
574 ud_dict_next = dict_next,
575 ud_dict_map = dict_map,
576 ud_symtab_next = symtab_next,
577 ud_symtab_map = symtab_map
580 newWriteState :: IO UserData
582 dict_next <- newFastMutInt
583 writeFastMutInt dict_next 0
584 dict_map <- newIORef emptyUFM
585 symtab_next <- newFastMutInt
586 writeFastMutInt symtab_next 0
587 symtab_map <- newIORef emptyUFM
588 return UserData { ud_dict = undef "dict",
589 ud_symtab = undef "symtab",
590 ud_dict_next = dict_next,
591 ud_dict_map = dict_map,
592 ud_symtab_next = symtab_next,
593 ud_symtab_map = symtab_map
596 noUserData = undef "UserData"
598 undef s = panic ("Binary.UserData: no " ++ s)
600 ---------------------------------------------------------
602 ---------------------------------------------------------
604 type Dictionary = Array Int FastString -- The dictionary
605 -- Should be 0-indexed
607 putDictionary :: BinHandle -> Int -> UniqFM (Int,FastString) -> IO ()
608 putDictionary bh sz dict = do
610 mapM_ (putFS bh) (elems (array (0,sz-1) (eltsUFM dict)))
612 getDictionary :: BinHandle -> IO Dictionary
613 getDictionary bh = do
615 elems <- sequence (take sz (repeat (getFS bh)))
616 return (listArray (0,sz-1) elems)
618 ---------------------------------------------------------
620 ---------------------------------------------------------
622 -- On disk, the symbol table is an array of IfaceExtName, when
623 -- reading it in we turn it into a SymbolTable.
625 type SymbolTable = Array Int Name
627 ---------------------------------------------------------
628 -- Reading and writing FastStrings
629 ---------------------------------------------------------
631 putFS bh (FastString id l _ buf _) = do
633 withForeignPtr buf $ \ptr ->
635 go n | n == l = return ()
637 b <- peekElemOff ptr n
643 {- -- possible faster version, not quite there yet:
644 getFS bh@BinMem{} = do
646 arr <- readIORef (arr_r bh)
647 off <- readFastMutInt (off_r bh)
648 return $! (mkFastSubStringBA# arr off l)
652 fp <- mallocForeignPtrBytes l
653 withForeignPtr fp $ \ptr -> do
655 go n | n == l = mkFastStringForeignPtr ptr fp l
663 #if __GLASGOW_HASKELL__ < 600
664 mallocForeignPtrBytes :: Int -> IO (ForeignPtr a)
665 mallocForeignPtrBytes n = do
667 newForeignPtr r (finalizerFree r)
669 foreign import ccall unsafe "stdlib.h free"
670 finalizerFree :: Ptr a -> IO ()
673 instance Binary PackageId where
674 put_ bh pid = put_ bh (packageIdFS pid)
675 get bh = do { fs <- get bh; return (fsToPackageId fs) }
677 instance Binary FastString where
678 put_ bh f@(FastString id l _ fp _) =
679 case getUserData bh of {
680 UserData { ud_dict_next = j_r,
682 ud_dict = dict} -> do
683 out <- readIORef out_r
684 let uniq = getUnique f
685 case lookupUFM out uniq of
686 Just (j,f) -> put_ bh j
688 j <- readFastMutInt j_r
690 writeFastMutInt j_r (j+1)
691 writeIORef out_r $! addToUFM out uniq (j,f)
696 return $! (ud_dict (getUserData bh) ! j)