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:
53 UserData(..), getUserData, setUserData,
54 newReadState, newWriteState,
55 putDictionary, getDictionary,
58 #include "HsVersions.h"
60 -- The *host* architecture version:
63 import {-# SOURCE #-} Name (Name)
77 import Data.Char ( ord, chr )
78 import Data.Array.Base ( unsafeRead, unsafeWrite )
79 import Control.Monad ( when )
80 import System.IO as IO
81 import System.IO.Unsafe ( unsafeInterleaveIO )
82 import System.IO.Error ( mkIOError, eofErrorType )
83 import GHC.Real ( Ratio(..) )
85 import GHC.IOBase ( IO(..) )
86 import GHC.Word ( Word8(..) )
87 #if __GLASGOW_HASKELL__ < 601
88 -- openFileEx is available from the lang package, but we want to
89 -- be independent of hslibs libraries.
90 import GHC.Handle ( openFileEx, IOModeEx(..) )
92 import System.IO ( openBinaryFile )
95 #if __GLASGOW_HASKELL__ < 601
96 openBinaryFile f mode = openFileEx f (BinaryMode mode)
99 type BinArray = IOUArray Int Word8
101 ---------------------------------------------------------------
103 ---------------------------------------------------------------
106 = BinMem { -- binary data stored in an unboxed array
107 bh_usr :: UserData, -- sigh, need parameterized modules :-)
108 off_r :: !FastMutInt, -- the current offset
109 sz_r :: !FastMutInt, -- size of the array (cached)
110 arr_r :: !(IORef BinArray) -- the array (bounds: (0,size-1))
112 -- XXX: should really store a "high water mark" for dumping out
113 -- the binary data to a file.
115 | BinIO { -- binary data stored in a file
117 off_r :: !FastMutInt, -- the current offset (cached)
118 hdl :: !IO.Handle -- the file handle (must be seekable)
120 -- cache the file ptr in BinIO; using hTell is too expensive
121 -- to call repeatedly. If anyone else is modifying this Handle
122 -- at the same time, we'll be screwed.
124 getUserData :: BinHandle -> UserData
125 getUserData bh = bh_usr bh
127 setUserData :: BinHandle -> UserData -> BinHandle
128 setUserData bh us = bh { bh_usr = us }
131 ---------------------------------------------------------------
133 ---------------------------------------------------------------
135 newtype Bin a = BinPtr Int
136 deriving (Eq, Ord, Show, Bounded)
138 castBin :: Bin a -> Bin b
139 castBin (BinPtr i) = BinPtr i
141 ---------------------------------------------------------------
143 ---------------------------------------------------------------
146 put_ :: BinHandle -> a -> IO ()
147 put :: BinHandle -> a -> IO (Bin a)
148 get :: BinHandle -> IO a
150 -- define one of put_, put. Use of put_ is recommended because it
151 -- is more likely that tail-calls can kick in, and we rarely need the
152 -- position return value.
153 put_ bh a = do put bh a; return ()
154 put bh a = do p <- tellBin bh; put_ bh a; return p
156 putAt :: Binary a => BinHandle -> Bin a -> a -> IO ()
157 putAt bh p x = do seekBin bh p; put bh x; return ()
159 getAt :: Binary a => BinHandle -> Bin a -> IO a
160 getAt bh p = do seekBin bh p; get bh
162 openBinIO_ :: IO.Handle -> IO BinHandle
163 openBinIO_ h = openBinIO h
165 openBinIO :: IO.Handle -> IO BinHandle
169 return (BinIO noUserData r h)
171 openBinMem :: Int -> IO BinHandle
173 | size <= 0 = error "Data.Binary.openBinMem: size must be >= 0"
175 arr <- newArray_ (0,size-1)
176 arr_r <- newIORef arr
177 ix_r <- newFastMutInt
178 writeFastMutInt ix_r 0
179 sz_r <- newFastMutInt
180 writeFastMutInt sz_r size
181 return (BinMem noUserData ix_r sz_r arr_r)
183 tellBin :: BinHandle -> IO (Bin a)
184 tellBin (BinIO _ r _) = do ix <- readFastMutInt r; return (BinPtr ix)
185 tellBin (BinMem _ r _ _) = do ix <- readFastMutInt r; return (BinPtr ix)
187 seekBin :: BinHandle -> Bin a -> IO ()
188 seekBin (BinIO _ ix_r h) (BinPtr p) = do
189 writeFastMutInt ix_r p
190 hSeek h AbsoluteSeek (fromIntegral p)
191 seekBin h@(BinMem _ ix_r sz_r a) (BinPtr p) = do
192 sz <- readFastMutInt sz_r
194 then do expandBin h p; writeFastMutInt ix_r p
195 else writeFastMutInt ix_r p
197 isEOFBin :: BinHandle -> IO Bool
198 isEOFBin (BinMem _ ix_r sz_r a) = do
199 ix <- readFastMutInt ix_r
200 sz <- readFastMutInt sz_r
202 isEOFBin (BinIO _ ix_r h) = hIsEOF h
204 writeBinMem :: BinHandle -> FilePath -> IO ()
205 writeBinMem (BinIO _ _ _) _ = error "Data.Binary.writeBinMem: not a memory handle"
206 writeBinMem (BinMem _ ix_r sz_r arr_r) fn = do
207 h <- openBinaryFile fn WriteMode
208 arr <- readIORef arr_r
209 ix <- readFastMutInt ix_r
213 readBinMem :: FilePath -> IO BinHandle
214 -- Return a BinHandle with a totally undefined State
215 readBinMem filename = do
216 h <- openBinaryFile filename ReadMode
217 filesize' <- hFileSize h
218 let filesize = fromIntegral filesize'
219 arr <- newArray_ (0,filesize-1)
220 count <- hGetArray h arr filesize
221 when (count /= filesize)
222 (error ("Binary.readBinMem: only read " ++ show count ++ " bytes"))
224 arr_r <- newIORef arr
225 ix_r <- newFastMutInt
226 writeFastMutInt ix_r 0
227 sz_r <- newFastMutInt
228 writeFastMutInt sz_r filesize
229 return (BinMem noUserData ix_r sz_r arr_r)
231 -- expand the size of the array to include a specified offset
232 expandBin :: BinHandle -> Int -> IO ()
233 expandBin (BinMem _ ix_r sz_r arr_r) off = do
234 sz <- readFastMutInt sz_r
235 let sz' = head (dropWhile (<= off) (iterate (* 2) sz))
236 arr <- readIORef arr_r
237 arr' <- newArray_ (0,sz'-1)
238 sequence_ [ unsafeRead arr i >>= unsafeWrite arr' i
239 | i <- [ 0 .. sz-1 ] ]
240 writeFastMutInt sz_r sz'
241 writeIORef arr_r arr'
243 hPutStrLn stderr ("Binary: expanding to size: " ++ show sz')
246 expandBin (BinIO _ _ _) _ = return ()
247 -- no need to expand a file, we'll assume they expand by themselves.
249 -- -----------------------------------------------------------------------------
250 -- Low-level reading/writing of bytes
252 putWord8 :: BinHandle -> Word8 -> IO ()
253 putWord8 h@(BinMem _ ix_r sz_r arr_r) w = do
254 ix <- readFastMutInt ix_r
255 sz <- readFastMutInt sz_r
256 -- double the size of the array if it overflows
258 then do expandBin h ix
260 else do arr <- readIORef arr_r
262 writeFastMutInt ix_r (ix+1)
264 putWord8 (BinIO _ ix_r h) w = do
265 ix <- readFastMutInt ix_r
266 hPutChar h (chr (fromIntegral w)) -- XXX not really correct
267 writeFastMutInt ix_r (ix+1)
270 getWord8 :: BinHandle -> IO Word8
271 getWord8 (BinMem _ ix_r sz_r arr_r) = do
272 ix <- readFastMutInt ix_r
273 sz <- readFastMutInt sz_r
275 ioError (mkIOError eofErrorType "Data.Binary.getWord8" Nothing Nothing)
276 arr <- readIORef arr_r
277 w <- unsafeRead arr ix
278 writeFastMutInt ix_r (ix+1)
280 getWord8 (BinIO _ ix_r h) = do
281 ix <- readFastMutInt ix_r
283 writeFastMutInt ix_r (ix+1)
284 return $! (fromIntegral (ord c)) -- XXX not really correct
286 putByte :: BinHandle -> Word8 -> IO ()
287 putByte bh w = put_ bh w
289 getByte :: BinHandle -> IO Word8
292 -- -----------------------------------------------------------------------------
293 -- Primitve Word writes
295 instance Binary Word8 where
299 instance Binary Word16 where
300 put_ h w = do -- XXX too slow.. inline putWord8?
301 putByte h (fromIntegral (w `shiftR` 8))
302 putByte h (fromIntegral (w .&. 0xff))
306 return $! ((fromIntegral w1 `shiftL` 8) .|. fromIntegral w2)
309 instance Binary Word32 where
311 putByte h (fromIntegral (w `shiftR` 24))
312 putByte h (fromIntegral ((w `shiftR` 16) .&. 0xff))
313 putByte h (fromIntegral ((w `shiftR` 8) .&. 0xff))
314 putByte h (fromIntegral (w .&. 0xff))
320 return $! ((fromIntegral w1 `shiftL` 24) .|.
321 (fromIntegral w2 `shiftL` 16) .|.
322 (fromIntegral w3 `shiftL` 8) .|.
326 instance Binary Word64 where
328 putByte h (fromIntegral (w `shiftR` 56))
329 putByte h (fromIntegral ((w `shiftR` 48) .&. 0xff))
330 putByte h (fromIntegral ((w `shiftR` 40) .&. 0xff))
331 putByte h (fromIntegral ((w `shiftR` 32) .&. 0xff))
332 putByte h (fromIntegral ((w `shiftR` 24) .&. 0xff))
333 putByte h (fromIntegral ((w `shiftR` 16) .&. 0xff))
334 putByte h (fromIntegral ((w `shiftR` 8) .&. 0xff))
335 putByte h (fromIntegral (w .&. 0xff))
345 return $! ((fromIntegral w1 `shiftL` 56) .|.
346 (fromIntegral w2 `shiftL` 48) .|.
347 (fromIntegral w3 `shiftL` 40) .|.
348 (fromIntegral w4 `shiftL` 32) .|.
349 (fromIntegral w5 `shiftL` 24) .|.
350 (fromIntegral w6 `shiftL` 16) .|.
351 (fromIntegral w7 `shiftL` 8) .|.
354 -- -----------------------------------------------------------------------------
355 -- Primitve Int writes
357 instance Binary Int8 where
358 put_ h w = put_ h (fromIntegral w :: Word8)
359 get h = do w <- get h; return $! (fromIntegral (w::Word8))
361 instance Binary Int16 where
362 put_ h w = put_ h (fromIntegral w :: Word16)
363 get h = do w <- get h; return $! (fromIntegral (w::Word16))
365 instance Binary Int32 where
366 put_ h w = put_ h (fromIntegral w :: Word32)
367 get h = do w <- get h; return $! (fromIntegral (w::Word32))
369 instance Binary Int64 where
370 put_ h w = put_ h (fromIntegral w :: Word64)
371 get h = do w <- get h; return $! (fromIntegral (w::Word64))
373 -- -----------------------------------------------------------------------------
374 -- Instances for standard types
376 instance Binary () where
377 put_ bh () = return ()
379 -- getF bh p = case getBitsF bh 0 p of (_,b) -> ((),b)
381 instance Binary Bool where
382 put_ bh b = putByte bh (fromIntegral (fromEnum b))
383 get bh = do x <- getWord8 bh; return $! (toEnum (fromIntegral x))
384 -- getF bh p = case getBitsF bh 1 p of (x,b) -> (toEnum x,b)
386 instance Binary Char where
387 put_ bh c = put_ bh (fromIntegral (ord c) :: Word32)
388 get bh = do x <- get bh; return $! (chr (fromIntegral (x :: Word32)))
389 -- getF bh p = case getBitsF bh 8 p of (x,b) -> (toEnum x,b)
391 instance Binary Int where
392 #if SIZEOF_HSINT == 4
393 put_ bh i = put_ bh (fromIntegral i :: Int32)
396 return $! (fromIntegral (x :: Int32))
397 #elif SIZEOF_HSINT == 8
398 put_ bh i = put_ bh (fromIntegral i :: Int64)
401 return $! (fromIntegral (x :: Int64))
403 #error "unsupported sizeof(HsInt)"
405 -- getF bh = getBitsF bh 32
407 instance Binary a => Binary [a] where
411 then putByte bh (fromIntegral len :: Word8)
412 else do putByte bh 0xff; put_ bh (fromIntegral len :: Word32)
418 else return (fromIntegral b :: Word32)
419 let loop 0 = return []
420 loop n = do a <- get bh; as <- loop (n-1); return (a:as)
423 instance (Binary a, Binary b) => Binary (a,b) where
424 put_ bh (a,b) = do put_ bh a; put_ bh b
425 get bh = do a <- get bh
429 instance (Binary a, Binary b, Binary c) => Binary (a,b,c) where
430 put_ bh (a,b,c) = do put_ bh a; put_ bh b; put_ bh c
431 get bh = do a <- get bh
436 instance (Binary a, Binary b, Binary c, Binary d) => Binary (a,b,c,d) where
437 put_ bh (a,b,c,d) = do put_ bh a; put_ bh b; put_ bh c; put_ bh d
438 get bh = do a <- get bh
444 instance Binary a => Binary (Maybe a) where
445 put_ bh Nothing = putByte bh 0
446 put_ bh (Just a) = do putByte bh 1; put_ bh a
447 get bh = do h <- getWord8 bh
450 _ -> do x <- get bh; return (Just x)
452 instance (Binary a, Binary b) => Binary (Either a b) where
453 put_ bh (Left a) = do putByte bh 0; put_ bh a
454 put_ bh (Right b) = do putByte bh 1; put_ bh b
455 get bh = do h <- getWord8 bh
457 0 -> do a <- get bh ; return (Left a)
458 _ -> do b <- get bh ; return (Right b)
460 #ifdef __GLASGOW_HASKELL__
461 instance Binary Integer where
462 put_ bh (S# i#) = do putByte bh 0; put_ bh (I# i#)
463 put_ bh (J# s# a#) = do
466 let sz# = sizeofByteArray# a# -- in *bytes*
467 put_ bh (I# sz#) -- in *bytes*
468 putByteArray bh a# sz#
473 0 -> do (I# i#) <- get bh
475 _ -> do (I# s#) <- get bh
477 (BA a#) <- getByteArray bh sz
480 putByteArray :: BinHandle -> ByteArray# -> Int# -> IO ()
481 putByteArray bh a s# = loop 0#
483 | n# ==# s# = return ()
485 putByte bh (indexByteArray a n#)
488 getByteArray :: BinHandle -> Int -> IO ByteArray
489 getByteArray bh (I# sz) = do
490 (MBA arr) <- newByteArray sz
492 | n ==# sz = return ()
495 writeByteArray arr n w
501 data ByteArray = BA ByteArray#
502 data MBA = MBA (MutableByteArray# RealWorld)
504 newByteArray :: Int# -> IO MBA
505 newByteArray sz = IO $ \s ->
506 case newByteArray# sz s of { (# s, arr #) ->
509 freezeByteArray :: MutableByteArray# RealWorld -> IO ByteArray
510 freezeByteArray arr = IO $ \s ->
511 case unsafeFreezeByteArray# arr s of { (# s, arr #) ->
514 writeByteArray :: MutableByteArray# RealWorld -> Int# -> Word8 -> IO ()
515 writeByteArray arr i (W8# w) = IO $ \s ->
516 case writeWord8Array# arr i w s of { s ->
519 indexByteArray :: ByteArray# -> Int# -> Word8
520 indexByteArray a# n# = W8# (indexWord8Array# a# n#)
522 instance (Integral a, Binary a) => Binary (Ratio a) where
523 put_ bh (a :% b) = do put_ bh a; put_ bh b
524 get bh = do a <- get bh; b <- get bh; return (a :% b)
527 instance Binary (Bin a) where
528 put_ bh (BinPtr i) = put_ bh i
529 get bh = do i <- get bh; return (BinPtr i)
531 -- -----------------------------------------------------------------------------
532 -- Lazy reading/writing
534 lazyPut :: Binary a => BinHandle -> a -> IO ()
536 -- output the obj with a ptr to skip over it:
538 put_ bh pre_a -- save a slot for the ptr
539 put_ bh a -- dump the object
540 q <- tellBin bh -- q = ptr to after object
541 putAt bh pre_a q -- fill in slot before a with ptr to q
542 seekBin bh q -- finally carry on writing at q
544 lazyGet :: Binary a => BinHandle -> IO a
546 p <- get bh -- a BinPtr
548 a <- unsafeInterleaveIO (getAt bh p_a)
549 seekBin bh p -- skip over the object for now
552 -- -----------------------------------------------------------------------------
554 -- -----------------------------------------------------------------------------
558 -- for *deserialising* only:
559 ud_dict :: Dictionary,
560 ud_symtab :: SymbolTable,
562 -- for *serialising* only:
563 ud_dict_next :: !FastMutInt, -- The next index to use
564 ud_dict_map :: !(IORef (UniqFM (Int,FastString))),
565 -- indexed by FastString
567 ud_symtab_next :: !FastMutInt, -- The next index to use
568 ud_symtab_map :: !(IORef (UniqFM (Int,Name)))
572 newReadState :: Dictionary -> IO UserData
573 newReadState dict = do
574 dict_next <- newFastMutInt
575 dict_map <- newIORef (undef "dict_map")
576 symtab_next <- newFastMutInt
577 symtab_map <- newIORef (undef "symtab_map")
578 return UserData { ud_dict = dict,
579 ud_symtab = undef "symtab",
580 ud_dict_next = dict_next,
581 ud_dict_map = dict_map,
582 ud_symtab_next = symtab_next,
583 ud_symtab_map = symtab_map
586 newWriteState :: IO UserData
588 dict_next <- newFastMutInt
589 writeFastMutInt dict_next 0
590 dict_map <- newIORef emptyUFM
591 symtab_next <- newFastMutInt
592 writeFastMutInt symtab_next 0
593 symtab_map <- newIORef emptyUFM
594 return UserData { ud_dict = undef "dict",
595 ud_symtab = undef "symtab",
596 ud_dict_next = dict_next,
597 ud_dict_map = dict_map,
598 ud_symtab_next = symtab_next,
599 ud_symtab_map = symtab_map
602 noUserData = undef "UserData"
604 undef s = panic ("Binary.UserData: no " ++ s)
606 ---------------------------------------------------------
608 ---------------------------------------------------------
610 type Dictionary = Array Int FastString -- The dictionary
611 -- Should be 0-indexed
613 putDictionary :: BinHandle -> Int -> UniqFM (Int,FastString) -> IO ()
614 putDictionary bh sz dict = do
616 mapM_ (putFS bh) (elems (array (0,sz-1) (eltsUFM dict)))
618 getDictionary :: BinHandle -> IO Dictionary
619 getDictionary bh = do
621 elems <- sequence (take sz (repeat (getFS bh)))
622 return (listArray (0,sz-1) elems)
624 ---------------------------------------------------------
626 ---------------------------------------------------------
628 -- On disk, the symbol table is an array of IfaceExtName, when
629 -- reading it in we turn it into a SymbolTable.
631 type SymbolTable = Array Int Name
633 ---------------------------------------------------------
634 -- Reading and writing FastStrings
635 ---------------------------------------------------------
637 putFS bh (FastString id l _ buf _) = do
639 withForeignPtr buf $ \ptr ->
641 go n | n == l = return ()
643 b <- peekElemOff ptr n
649 {- -- possible faster version, not quite there yet:
650 getFS bh@BinMem{} = do
652 arr <- readIORef (arr_r bh)
653 off <- readFastMutInt (off_r bh)
654 return $! (mkFastSubStringBA# arr off l)
658 fp <- mallocForeignPtrBytes l
659 withForeignPtr fp $ \ptr -> do
661 go n | n == l = mkFastStringForeignPtr ptr fp l
669 instance Binary FastString where
670 put_ bh f@(FastString id l _ fp _) =
671 case getUserData bh of {
672 UserData { ud_dict_next = j_r,
674 ud_dict = dict} -> do
675 out <- readIORef out_r
676 let uniq = getUnique f
677 case lookupUFM out uniq of
678 Just (j,f) -> put_ bh j
680 j <- readFastMutInt j_r
682 writeFastMutInt j_r (j+1)
683 writeIORef out_r $! addToUFM out uniq (j,f)
688 return $! (ud_dict (getUserData bh) ! j)