3 -- (c) The University of Glasgow 2002
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 getBinFileWithDict, -- :: Binary a => FilePath -> IO a
47 putBinFileWithDict, -- :: Binary a => FilePath -> Module -> a -> IO ()
51 #include "HsVersions.h"
53 -- The *host* architecture version:
56 import {-# SOURCE #-} Module
63 #if __GLASGOW_HASKELL__ < 503
71 import GlaExts hiding (ByteArray, newByteArray, freezeByteArray)
74 import PrelIOBase ( IOError(..), IOErrorType(..)
75 #if __GLASGOW_HASKELL__ > 411
79 import PrelReal ( Ratio(..) )
80 import PrelIOBase ( IO(..) )
81 import IOExts ( openFileEx, IOModeEx(..) )
89 import Data.Char ( ord, chr )
90 import Data.Array.Base ( unsafeRead, unsafeWrite )
91 import Control.Monad ( when )
92 import Control.Exception ( throwDyn )
93 import System.IO as IO
94 import System.IO.Unsafe ( unsafeInterleaveIO )
95 import System.IO.Error ( mkIOError, eofErrorType )
96 import GHC.Real ( Ratio(..) )
98 import GHC.IOBase ( IO(..) )
99 import GHC.Word ( Word8(..) )
100 #if __GLASGOW_HASKELL__ < 601
101 -- openFileEx is available from the lang package, but we want to
102 -- be independent of hslibs libraries.
103 import GHC.Handle ( openFileEx, IOModeEx(..) )
105 import System.IO ( openBinaryFile )
109 #if __GLASGOW_HASKELL__ < 601
110 openBinaryFile f mode = openFileEx f (BinaryMode mode)
113 #if __GLASGOW_HASKELL__ < 503
114 type BinArray = MutableByteArray RealWorld Int
115 newArray_ bounds = stToIO (newCharArray bounds)
116 unsafeWrite arr ix e = stToIO (writeWord8Array arr ix e)
117 unsafeRead arr ix = stToIO (readWord8Array arr ix)
118 #if __GLASGOW_HASKELL__ < 411
119 newByteArray# = newCharArray#
121 hPutArray h arr sz = hPutBufBAFull h arr sz
122 hGetArray h sz = hGetBufBAFull h sz
124 mkIOError :: IOErrorType -> String -> Maybe Handle -> Maybe FilePath -> Exception
125 mkIOError t location maybe_hdl maybe_filename
126 = IOException (IOError maybe_hdl t location ""
127 #if __GLASGOW_HASKELL__ > 411
135 #define SIZEOF_HSINT INT_SIZE_IN_BYTES
138 #ifndef SIZEOF_HSWORD
139 #define SIZEOF_HSWORD WORD_SIZE_IN_BYTES
143 type BinArray = IOUArray Int Word8
147 = BinMem { -- binary data stored in an unboxed array
148 state :: BinHandleState, -- sigh, need parameterized modules :-)
149 off_r :: !FastMutInt, -- the current offset
150 sz_r :: !FastMutInt, -- size of the array (cached)
151 arr_r :: !(IORef BinArray) -- the array (bounds: (0,size-1))
153 -- XXX: should really store a "high water mark" for dumping out
154 -- the binary data to a file.
156 | BinIO { -- binary data stored in a file
157 state :: BinHandleState,
158 off_r :: !FastMutInt, -- the current offset (cached)
159 hdl :: !IO.Handle -- the file handle (must be seekable)
161 -- cache the file ptr in BinIO; using hTell is too expensive
162 -- to call repeatedly. If anyone else is modifying this Handle
163 -- at the same time, we'll be screwed.
165 newtype Bin a = BinPtr Int
166 deriving (Eq, Ord, Show, Bounded)
168 castBin :: Bin a -> Bin b
169 castBin (BinPtr i) = BinPtr i
172 put_ :: BinHandle -> a -> IO ()
173 put :: BinHandle -> a -> IO (Bin a)
174 get :: BinHandle -> IO a
176 -- define one of put_, put. Use of put_ is recommended because it
177 -- is more likely that tail-calls can kick in, and we rarely need the
178 -- position return value.
179 put_ bh a = do put bh a; return ()
180 put bh a = do p <- tellBin bh; put_ bh a; return p
182 putAt :: Binary a => BinHandle -> Bin a -> a -> IO ()
183 putAt bh p x = do seekBin bh p; put bh x; return ()
185 getAt :: Binary a => BinHandle -> Bin a -> IO a
186 getAt bh p = do seekBin bh p; get bh
188 openBinIO_ :: IO.Handle -> IO BinHandle
189 openBinIO_ h = openBinIO h noBinHandleUserData
191 openBinIO :: IO.Handle -> Module -> IO BinHandle
195 state <- newWriteState mod
196 return (BinIO state r h)
198 openBinMem :: Int -> Module -> IO BinHandle
200 | size <= 0 = error "Data.Binary.openBinMem: size must be >= 0"
202 arr <- newArray_ (0,size-1)
203 arr_r <- newIORef arr
204 ix_r <- newFastMutInt
205 writeFastMutInt ix_r 0
206 sz_r <- newFastMutInt
207 writeFastMutInt sz_r size
208 state <- newWriteState mod
209 return (BinMem state ix_r sz_r arr_r)
211 noBinHandleUserData = error "Binary.BinHandle: no user data"
213 getUserData :: BinHandle -> BinHandleState
214 getUserData bh = state bh
216 tellBin :: BinHandle -> IO (Bin a)
217 tellBin (BinIO _ r _) = do ix <- readFastMutInt r; return (BinPtr ix)
218 tellBin (BinMem _ r _ _) = do ix <- readFastMutInt r; return (BinPtr ix)
220 seekBin :: BinHandle -> Bin a -> IO ()
221 seekBin (BinIO _ ix_r h) (BinPtr p) = do
222 writeFastMutInt ix_r p
223 hSeek h AbsoluteSeek (fromIntegral p)
224 seekBin h@(BinMem _ ix_r sz_r a) (BinPtr p) = do
225 sz <- readFastMutInt sz_r
227 then do expandBin h p; writeFastMutInt ix_r p
228 else writeFastMutInt ix_r p
230 isEOFBin :: BinHandle -> IO Bool
231 isEOFBin (BinMem _ ix_r sz_r a) = do
232 ix <- readFastMutInt ix_r
233 sz <- readFastMutInt sz_r
235 isEOFBin (BinIO _ ix_r h) = hIsEOF h
237 writeBinMem :: BinHandle -> FilePath -> IO ()
238 writeBinMem (BinIO _ _ _) _ = error "Data.Binary.writeBinMem: not a memory handle"
239 writeBinMem (BinMem _ ix_r sz_r arr_r) fn = do
240 h <- openBinaryFile fn WriteMode
241 arr <- readIORef arr_r
242 ix <- readFastMutInt ix_r
244 #if __GLASGOW_HASKELL__ <= 500
245 -- workaround a bug in old implementation of hPutBuf (it doesn't
246 -- set the FILEOBJ_RW_WRITTEN flag on the file object, so the file doens't
247 -- get flushed properly). Adding an extra '\0' doens't do any harm.
252 readBinMem :: FilePath -> IO BinHandle
253 readBinMem filename = do
254 h <- openBinaryFile filename ReadMode
255 filesize' <- hFileSize h
256 let filesize = fromIntegral filesize'
257 arr <- newArray_ (0,filesize-1)
258 count <- hGetArray h arr filesize
259 when (count /= filesize)
260 (error ("Binary.readBinMem: only read " ++ show count ++ " bytes"))
262 arr_r <- newIORef arr
263 ix_r <- newFastMutInt
264 writeFastMutInt ix_r 0
265 sz_r <- newFastMutInt
266 writeFastMutInt sz_r filesize
267 return (BinMem initReadState ix_r sz_r arr_r)
269 -- expand the size of the array to include a specified offset
270 expandBin :: BinHandle -> Int -> IO ()
271 expandBin (BinMem _ ix_r sz_r arr_r) off = do
272 sz <- readFastMutInt sz_r
273 let sz' = head (dropWhile (<= off) (iterate (* 2) sz))
274 arr <- readIORef arr_r
275 arr' <- newArray_ (0,sz'-1)
276 sequence_ [ unsafeRead arr i >>= unsafeWrite arr' i
277 | i <- [ 0 .. sz-1 ] ]
278 writeFastMutInt sz_r sz'
279 writeIORef arr_r arr'
281 hPutStrLn stderr ("Binary: expanding to size: " ++ show sz')
284 expandBin (BinIO _ _ _) _ = return ()
285 -- no need to expand a file, we'll assume they expand by themselves.
287 -- -----------------------------------------------------------------------------
288 -- Low-level reading/writing of bytes
290 putWord8 :: BinHandle -> Word8 -> IO ()
291 putWord8 h@(BinMem _ ix_r sz_r arr_r) w = do
292 ix <- readFastMutInt ix_r
293 sz <- readFastMutInt sz_r
294 -- double the size of the array if it overflows
296 then do expandBin h ix
298 else do arr <- readIORef arr_r
300 writeFastMutInt ix_r (ix+1)
302 putWord8 (BinIO _ ix_r h) w = do
303 ix <- readFastMutInt ix_r
304 hPutChar h (chr (fromIntegral w)) -- XXX not really correct
305 writeFastMutInt ix_r (ix+1)
308 getWord8 :: BinHandle -> IO Word8
309 getWord8 (BinMem _ ix_r sz_r arr_r) = do
310 ix <- readFastMutInt ix_r
311 sz <- readFastMutInt sz_r
313 #if __GLASGOW_HASKELL__ <= 408
314 throw (mkIOError eofErrorType "Data.Binary.getWord8" Nothing Nothing)
316 ioError (mkIOError eofErrorType "Data.Binary.getWord8" Nothing Nothing)
318 arr <- readIORef arr_r
319 w <- unsafeRead arr ix
320 writeFastMutInt ix_r (ix+1)
322 getWord8 (BinIO _ ix_r h) = do
323 ix <- readFastMutInt ix_r
325 writeFastMutInt ix_r (ix+1)
326 return $! (fromIntegral (ord c)) -- XXX not really correct
328 putByte :: BinHandle -> Word8 -> IO ()
329 putByte bh w = put_ bh w
331 getByte :: BinHandle -> IO Word8
334 -- -----------------------------------------------------------------------------
335 -- Primitve Word writes
337 instance Binary Word8 where
341 instance Binary Word16 where
342 put_ h w = do -- XXX too slow.. inline putWord8?
343 putByte h (fromIntegral (w `shiftR` 8))
344 putByte h (fromIntegral (w .&. 0xff))
348 return $! ((fromIntegral w1 `shiftL` 8) .|. fromIntegral w2)
351 instance Binary Word32 where
353 putByte h (fromIntegral (w `shiftR` 24))
354 putByte h (fromIntegral ((w `shiftR` 16) .&. 0xff))
355 putByte h (fromIntegral ((w `shiftR` 8) .&. 0xff))
356 putByte h (fromIntegral (w .&. 0xff))
362 return $! ((fromIntegral w1 `shiftL` 24) .|.
363 (fromIntegral w2 `shiftL` 16) .|.
364 (fromIntegral w3 `shiftL` 8) .|.
368 instance Binary Word64 where
370 putByte h (fromIntegral (w `shiftR` 56))
371 putByte h (fromIntegral ((w `shiftR` 48) .&. 0xff))
372 putByte h (fromIntegral ((w `shiftR` 40) .&. 0xff))
373 putByte h (fromIntegral ((w `shiftR` 32) .&. 0xff))
374 putByte h (fromIntegral ((w `shiftR` 24) .&. 0xff))
375 putByte h (fromIntegral ((w `shiftR` 16) .&. 0xff))
376 putByte h (fromIntegral ((w `shiftR` 8) .&. 0xff))
377 putByte h (fromIntegral (w .&. 0xff))
387 return $! ((fromIntegral w1 `shiftL` 56) .|.
388 (fromIntegral w2 `shiftL` 48) .|.
389 (fromIntegral w3 `shiftL` 40) .|.
390 (fromIntegral w4 `shiftL` 32) .|.
391 (fromIntegral w5 `shiftL` 24) .|.
392 (fromIntegral w6 `shiftL` 16) .|.
393 (fromIntegral w7 `shiftL` 8) .|.
396 -- -----------------------------------------------------------------------------
397 -- Primitve Int writes
399 instance Binary Int8 where
400 put_ h w = put_ h (fromIntegral w :: Word8)
401 get h = do w <- get h; return $! (fromIntegral (w::Word8))
403 instance Binary Int16 where
404 put_ h w = put_ h (fromIntegral w :: Word16)
405 get h = do w <- get h; return $! (fromIntegral (w::Word16))
407 instance Binary Int32 where
408 put_ h w = put_ h (fromIntegral w :: Word32)
409 get h = do w <- get h; return $! (fromIntegral (w::Word32))
411 instance Binary Int64 where
412 put_ h w = put_ h (fromIntegral w :: Word64)
413 get h = do w <- get h; return $! (fromIntegral (w::Word64))
415 -- -----------------------------------------------------------------------------
416 -- Instances for standard types
418 instance Binary () where
419 put_ bh () = return ()
421 -- getF bh p = case getBitsF bh 0 p of (_,b) -> ((),b)
423 instance Binary Bool where
424 put_ bh b = putByte bh (fromIntegral (fromEnum b))
425 get bh = do x <- getWord8 bh; return $! (toEnum (fromIntegral x))
426 -- getF bh p = case getBitsF bh 1 p of (x,b) -> (toEnum x,b)
428 instance Binary Char where
429 put_ bh c = put_ bh (fromIntegral (ord c) :: Word32)
430 get bh = do x <- get bh; return $! (chr (fromIntegral (x :: Word32)))
431 -- getF bh p = case getBitsF bh 8 p of (x,b) -> (toEnum x,b)
433 instance Binary Int where
434 #if SIZEOF_HSINT == 4
435 put_ bh i = put_ bh (fromIntegral i :: Int32)
438 return $! (fromIntegral (x :: Int32))
439 #elif SIZEOF_HSINT == 8
440 put_ bh i = put_ bh (fromIntegral i :: Int64)
443 return $! (fromIntegral (x :: Int64))
445 #error "unsupported sizeof(HsInt)"
447 -- getF bh = getBitsF bh 32
449 instance Binary a => Binary [a] where
450 put_ bh [] = putByte bh 0
451 put_ bh (x:xs) = do putByte bh 1; put_ bh x; put_ bh xs
452 get bh = do h <- getWord8 bh
459 instance (Binary a, Binary b) => Binary (a,b) where
460 put_ bh (a,b) = do put_ bh a; put_ bh b
461 get bh = do a <- get bh
465 instance (Binary a, Binary b, Binary c) => Binary (a,b,c) where
466 put_ bh (a,b,c) = do put_ bh a; put_ bh b; put_ bh c
467 get bh = do a <- get bh
472 instance (Binary a, Binary b, Binary c, Binary d) => Binary (a,b,c,d) where
473 put_ bh (a,b,c,d) = do put_ bh a; put_ bh b; put_ bh c; put_ bh d
474 get bh = do a <- get bh
480 instance Binary a => Binary (Maybe a) where
481 put_ bh Nothing = putByte bh 0
482 put_ bh (Just a) = do putByte bh 1; put_ bh a
483 get bh = do h <- getWord8 bh
486 _ -> do x <- get bh; return (Just x)
488 instance (Binary a, Binary b) => Binary (Either a b) where
489 put_ bh (Left a) = do putByte bh 0; put_ bh a
490 put_ bh (Right b) = do putByte bh 1; put_ bh b
491 get bh = do h <- getWord8 bh
493 0 -> do a <- get bh ; return (Left a)
494 _ -> do b <- get bh ; return (Right b)
496 #ifdef __GLASGOW_HASKELL__
497 instance Binary Integer where
498 put_ bh (S# i#) = do putByte bh 0; put_ bh (I# i#)
499 put_ bh (J# s# a#) = do
502 let sz# = sizeofByteArray# a# -- in *bytes*
503 put_ bh (I# sz#) -- in *bytes*
504 putByteArray bh a# sz#
509 0 -> do (I# i#) <- get bh
511 _ -> do (I# s#) <- get bh
513 (BA a#) <- getByteArray bh sz
516 putByteArray :: BinHandle -> ByteArray# -> Int# -> IO ()
517 putByteArray bh a s# = loop 0#
519 | n# ==# s# = return ()
521 putByte bh (indexByteArray a n#)
524 getByteArray :: BinHandle -> Int -> IO ByteArray
525 getByteArray bh (I# sz) = do
526 (MBA arr) <- newByteArray sz
528 | n ==# sz = return ()
531 writeByteArray arr n w
537 data ByteArray = BA ByteArray#
538 data MBA = MBA (MutableByteArray# RealWorld)
540 newByteArray :: Int# -> IO MBA
541 newByteArray sz = IO $ \s ->
542 case newByteArray# sz s of { (# s, arr #) ->
545 freezeByteArray :: MutableByteArray# RealWorld -> IO ByteArray
546 freezeByteArray arr = IO $ \s ->
547 case unsafeFreezeByteArray# arr s of { (# s, arr #) ->
550 writeByteArray :: MutableByteArray# RealWorld -> Int# -> Word8 -> IO ()
552 #if __GLASGOW_HASKELL__ < 503
553 writeByteArray arr i w8 = IO $ \s ->
554 case word8ToWord w8 of { W# w# ->
555 case writeCharArray# arr i (chr# (word2Int# w#)) s of { s ->
558 writeByteArray arr i (W8# w) = IO $ \s ->
559 case writeWord8Array# arr i w s of { s ->
563 #if __GLASGOW_HASKELL__ < 503
564 indexByteArray a# n# = fromIntegral (I# (ord# (indexCharArray# a# n#)))
566 indexByteArray a# n# = W8# (indexWord8Array# a# n#)
569 instance (Integral a, Binary a) => Binary (Ratio a) where
570 put_ bh (a :% b) = do put_ bh a; put_ bh b
571 get bh = do a <- get bh; b <- get bh; return (a :% b)
574 instance Binary (Bin a) where
575 put_ bh (BinPtr i) = put_ bh i
576 get bh = do i <- get bh; return (BinPtr i)
578 -- -----------------------------------------------------------------------------
579 -- Lazy reading/writing
581 lazyPut :: Binary a => BinHandle -> a -> IO ()
583 -- output the obj with a ptr to skip over it:
585 put_ bh pre_a -- save a slot for the ptr
586 put_ bh a -- dump the object
587 q <- tellBin bh -- q = ptr to after object
588 putAt bh pre_a q -- fill in slot before a with ptr to q
589 seekBin bh q -- finally carry on writing at q
591 lazyGet :: Binary a => BinHandle -> IO a
593 p <- get bh -- a BinPtr
595 a <- unsafeInterleaveIO (getAt bh p_a)
596 seekBin bh p -- skip over the object for now
599 -- -----------------------------------------------------------------------------
602 type BinHandleState =
605 IORef (UniqFM (Int,FastString)),
606 Array Int FastString)
608 initReadState :: BinHandleState
609 initReadState = (undef, undef, undef, undef)
611 newWriteState :: Module -> IO BinHandleState
614 out_r <- newIORef emptyUFM
615 return (m,j_r,out_r,undef)
617 undef = error "Binary.BinHandleState"
619 -- -----------------------------------------------------------------------------
620 -- FastString binary interface
622 getBinFileWithDict :: Binary a => FilePath -> IO a
623 getBinFileWithDict file_path = do
624 bh <- Binary.readBinMem file_path
626 when (magic /= binaryInterfaceMagic) $
627 throwDyn (ProgramError (
628 "magic number mismatch: old/corrupt interface file?"))
629 dict_p <- Binary.get bh -- get the dictionary ptr
632 dict <- getDictionary bh
634 let (mod, j_r, out_r, _) = state bh
635 get bh{ state = (mod,j_r,out_r,dict) }
637 initBinMemSize = (1024*1024) :: Int
639 binaryInterfaceMagic = 0x1face :: Word32
641 putBinFileWithDict :: Binary a => FilePath -> Module -> a -> IO ()
642 putBinFileWithDict file_path mod a = do
643 bh <- openBinMem initBinMemSize mod
644 put_ bh binaryInterfaceMagic
646 put_ bh p -- placeholder for ptr to dictionary
648 let (_, j_r, fm_r, _) = state bh
652 putAt bh p dict_p -- fill in the placeholder
653 seekBin bh dict_p -- seek back to the end of the file
654 putDictionary bh j (constructDictionary j fm)
655 writeBinMem bh file_path
657 type Dictionary = Array Int FastString
658 -- should be 0-indexed
660 putDictionary :: BinHandle -> Int -> Dictionary -> IO ()
661 putDictionary bh sz dict = do
663 mapM_ (putFS bh) (elems dict)
665 getDictionary :: BinHandle -> IO Dictionary
666 getDictionary bh = do
668 elems <- sequence (take sz (repeat (getFS bh)))
669 return (listArray (0,sz-1) elems)
671 constructDictionary :: Int -> UniqFM (Int,FastString) -> Dictionary
672 constructDictionary j fm = array (0,j-1) (eltsUFM fm)
674 putFS bh (FastString id l ba) = do
677 putFS bh s = error ("Binary.put_(FastString): " ++ unpackFS s)
678 -- Note: the length of the FastString is *not* the same as
679 -- the size of the ByteArray: the latter is rounded up to a
680 -- multiple of the word size.
682 {- -- possible faster version, not quite there yet:
683 getFS bh@BinMem{} = do
685 arr <- readIORef (arr_r bh)
686 off <- readFastMutInt (off_r bh)
687 return $! (mkFastSubStringBA# arr off l)
691 (BA ba) <- getByteArray bh (I# l)
692 return $! (mkFastSubStringBA# ba 0# l)
694 instance Binary FastString where
695 put_ bh f@(FastString id l ba) =
696 case getUserData bh of { (_, j_r, out_r, dict) -> do
697 out <- readIORef out_r
698 let uniq = getUnique f
699 case lookupUFM out uniq of
700 Just (j,f) -> put_ bh j
705 writeIORef out_r (addToUFM out uniq (j,f))
707 put_ bh s = error ("Binary.put_(FastString): " ++ show (unpackFS s))
711 case getUserData bh of (_, _, _, arr) -> return $! (arr ! j)