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 ()
53 import {-# SOURCE #-} Module
58 #if __GLASGOW_HASKELL__ < 503
66 import GlaExts hiding (ByteArray, newByteArray, freezeByteArray)
69 import PrelIOBase ( IOError(..), IOErrorType(..)
70 #if __GLASGOW_HASKELL__ > 411
74 import PrelReal ( Ratio(..) )
75 import PrelIOBase ( IO(..) )
83 import Data.Char ( ord, chr )
84 import Data.Array.Base ( unsafeRead, unsafeWrite )
85 import Control.Monad ( when )
86 import Control.Exception ( throw )
87 import System.IO as IO
88 import System.IO.Unsafe ( unsafeInterleaveIO )
89 import System.IO.Error ( mkIOError, eofErrorType )
90 import GHC.Real ( Ratio(..) )
92 import GHC.IOBase ( IO(..) )
93 import GHC.Word ( Word8(..) )
96 #if __GLASGOW_HASKELL__ < 503
97 type BinArray = MutableByteArray RealWorld Int
98 newArray_ bounds = stToIO (newCharArray bounds)
99 unsafeWrite arr ix e = stToIO (writeWord8Array arr ix e)
100 unsafeRead arr ix = stToIO (readWord8Array arr ix)
101 #if __GLASGOW_HASKELL__ < 411
102 newByteArray# = newCharArray#
104 hPutArray h arr sz = hPutBufBAFull h arr sz
105 hGetArray h sz = hGetBufBAFull h sz
107 mkIOError :: IOErrorType -> String -> Maybe Handle -> Maybe FilePath -> Exception
108 mkIOError t location maybe_hdl maybe_filename
109 = IOException (IOError maybe_hdl t location ""
110 #if __GLASGOW_HASKELL__ > 411
118 #define SIZEOF_HSINT INT_SIZE_IN_BYTES
121 #ifndef SIZEOF_HSWORD
122 #define SIZEOF_HSWORD WORD_SIZE_IN_BYTES
126 type BinArray = IOUArray Int Word8
130 = BinMem { -- binary data stored in an unboxed array
131 state :: BinHandleState, -- sigh, need parameterized modules :-)
132 off_r :: !FastMutInt, -- the current offset
133 sz_r :: !FastMutInt, -- size of the array (cached)
134 arr_r :: !(IORef BinArray) -- the array (bounds: (0,size-1))
136 -- XXX: should really store a "high water mark" for dumping out
137 -- the binary data to a file.
139 | BinIO { -- binary data stored in a file
140 state :: BinHandleState,
141 off_r :: !FastMutInt, -- the current offset (cached)
142 hdl :: !IO.Handle -- the file handle (must be seekable)
144 -- cache the file ptr in BinIO; using hTell is too expensive
145 -- to call repeatedly. If anyone else is modifying this Handle
146 -- at the same time, we'll be screwed.
148 newtype Bin a = BinPtr Int
149 deriving (Eq, Ord, Show, Bounded)
151 castBin :: Bin a -> Bin b
152 castBin (BinPtr i) = BinPtr i
155 put_ :: BinHandle -> a -> IO ()
156 put :: BinHandle -> a -> IO (Bin a)
157 get :: BinHandle -> IO a
159 -- define one of put_, put. Use of put_ is recommended because it
160 -- is more likely that tail-calls can kick in, and we rarely need the
161 -- position return value.
162 put_ bh a = do put bh a; return ()
163 put bh a = do p <- tellBin bh; put_ bh a; return p
165 putAt :: Binary a => BinHandle -> Bin a -> a -> IO ()
166 putAt bh p x = do seekBin bh p; put bh x; return ()
168 getAt :: Binary a => BinHandle -> Bin a -> IO a
169 getAt bh p = do seekBin bh p; get bh
171 openBinIO_ :: IO.Handle -> IO BinHandle
172 openBinIO_ h = openBinIO h noBinHandleUserData
174 openBinIO :: IO.Handle -> Module -> IO BinHandle
178 state <- newWriteState mod
179 return (BinIO state r h)
181 openBinMem :: Int -> Module -> IO BinHandle
183 | size <= 0 = error "Data.Binary.openBinMem: size must be >= 0"
185 arr <- newArray_ (0,size-1)
186 arr_r <- newIORef arr
187 ix_r <- newFastMutInt
188 writeFastMutInt ix_r 0
189 sz_r <- newFastMutInt
190 writeFastMutInt sz_r size
191 state <- newWriteState mod
192 return (BinMem state ix_r sz_r arr_r)
194 noBinHandleUserData = error "Binary.BinHandle: no user data"
196 getUserData :: BinHandle -> BinHandleState
197 getUserData bh = state bh
199 tellBin :: BinHandle -> IO (Bin a)
200 tellBin (BinIO _ r _) = do ix <- readFastMutInt r; return (BinPtr ix)
201 tellBin (BinMem _ r _ _) = do ix <- readFastMutInt r; return (BinPtr ix)
203 seekBin :: BinHandle -> Bin a -> IO ()
204 seekBin (BinIO _ ix_r h) (BinPtr p) = do
205 writeFastMutInt ix_r p
206 hSeek h AbsoluteSeek (fromIntegral p)
207 seekBin h@(BinMem _ ix_r sz_r a) (BinPtr p) = do
208 sz <- readFastMutInt sz_r
210 then do expandBin h p; writeFastMutInt ix_r p
211 else writeFastMutInt ix_r p
213 isEOFBin :: BinHandle -> IO Bool
214 isEOFBin (BinMem _ ix_r sz_r a) = do
215 ix <- readFastMutInt ix_r
216 sz <- readFastMutInt sz_r
218 isEOFBin (BinIO _ ix_r h) = hIsEOF h
220 writeBinMem :: BinHandle -> FilePath -> IO ()
221 writeBinMem (BinIO _ _ _) _ = error "Data.Binary.writeBinMem: not a memory handle"
222 writeBinMem (BinMem _ ix_r sz_r arr_r) fn = do
223 h <- openFileEx fn (BinaryMode WriteMode)
224 arr <- readIORef arr_r
225 ix <- readFastMutInt ix_r
227 #if __GLASGOW_HASKELL__ < 500
228 -- workaround a bug in ghc 4.08's implementation of hPutBuf (it doesn't
229 -- set the FILEOBJ_RW_WRITTEN flag on the file object, so the file doens't
230 -- get flushed properly). Adding an extra '\0' doens't do any harm.
235 readBinMem :: FilePath -> IO BinHandle
236 readBinMem filename = do
237 h <- openFileEx filename (BinaryMode ReadMode)
238 filesize' <- hFileSize h
239 let filesize = fromIntegral filesize'
240 arr <- newArray_ (0,filesize-1)
241 count <- hGetArray h arr filesize
242 when (count /= filesize)
243 (error ("Binary.readBinMem: only read " ++ show count ++ " bytes"))
245 arr_r <- newIORef arr
246 ix_r <- newFastMutInt
247 writeFastMutInt ix_r 0
248 sz_r <- newFastMutInt
249 writeFastMutInt sz_r filesize
250 return (BinMem initReadState ix_r sz_r arr_r)
252 -- expand the size of the array to include a specified offset
253 expandBin :: BinHandle -> Int -> IO ()
254 expandBin (BinMem _ ix_r sz_r arr_r) off = do
255 sz <- readFastMutInt sz_r
256 let sz' = head (dropWhile (<= off) (iterate (* 2) sz))
257 arr <- readIORef arr_r
258 arr' <- newArray_ (0,sz'-1)
259 sequence_ [ unsafeRead arr i >>= unsafeWrite arr' i
260 | i <- [ 0 .. sz-1 ] ]
261 writeFastMutInt sz_r sz'
262 writeIORef arr_r arr'
263 hPutStrLn stderr ("expanding to size: " ++ show sz')
265 expandBin (BinIO _ _ _) _ = return ()
266 -- no need to expand a file, we'll assume they expand by themselves.
268 -- -----------------------------------------------------------------------------
269 -- Low-level reading/writing of bytes
271 putWord8 :: BinHandle -> Word8 -> IO ()
272 putWord8 h@(BinMem _ ix_r sz_r arr_r) w = do
273 ix <- readFastMutInt ix_r
274 sz <- readFastMutInt sz_r
275 -- double the size of the array if it overflows
277 then do expandBin h ix
279 else do arr <- readIORef arr_r
281 writeFastMutInt ix_r (ix+1)
283 putWord8 (BinIO _ ix_r h) w = do
284 ix <- readFastMutInt ix_r
285 hPutChar h (chr (fromIntegral w)) -- XXX not really correct
286 writeFastMutInt ix_r (ix+1)
289 getWord8 :: BinHandle -> IO Word8
290 getWord8 (BinMem _ ix_r sz_r arr_r) = do
291 ix <- readFastMutInt ix_r
292 sz <- readFastMutInt sz_r
294 throw (mkIOError eofErrorType "Data.Binary.getWord8" Nothing Nothing)
295 arr <- readIORef arr_r
296 w <- unsafeRead arr ix
297 writeFastMutInt ix_r (ix+1)
299 getWord8 (BinIO _ ix_r h) = do
300 ix <- readFastMutInt ix_r
302 writeFastMutInt ix_r (ix+1)
303 return (fromIntegral (ord c)) -- XXX not really correct
305 putByte :: BinHandle -> Word8 -> IO ()
306 putByte bh w = put_ bh w
308 getByte :: BinHandle -> IO Word8
311 -- -----------------------------------------------------------------------------
312 -- Primitve Word writes
314 instance Binary Word8 where
318 instance Binary Word16 where
319 put_ h w = do -- XXX too slow.. inline putWord8?
320 putByte h (fromIntegral (w `shiftR` 8))
321 putByte h (fromIntegral (w .&. 0xff))
325 return ((fromIntegral w1 `shiftL` 8) .|. fromIntegral w2)
328 instance Binary Word32 where
330 putByte h (fromIntegral (w `shiftR` 24))
331 putByte h (fromIntegral ((w `shiftR` 16) .&. 0xff))
332 putByte h (fromIntegral ((w `shiftR` 8) .&. 0xff))
333 putByte h (fromIntegral (w .&. 0xff))
339 return ((fromIntegral w1 `shiftL` 24) .|.
340 (fromIntegral w2 `shiftL` 16) .|.
341 (fromIntegral w3 `shiftL` 8) .|.
345 instance Binary Word64 where
347 putByte h (fromIntegral (w `shiftR` 56))
348 putByte h (fromIntegral ((w `shiftR` 48) .&. 0xff))
349 putByte h (fromIntegral ((w `shiftR` 40) .&. 0xff))
350 putByte h (fromIntegral ((w `shiftR` 32) .&. 0xff))
351 putByte h (fromIntegral ((w `shiftR` 24) .&. 0xff))
352 putByte h (fromIntegral ((w `shiftR` 16) .&. 0xff))
353 putByte h (fromIntegral ((w `shiftR` 8) .&. 0xff))
354 putByte h (fromIntegral (w .&. 0xff))
364 return ((fromIntegral w1 `shiftL` 56) .|.
365 (fromIntegral w2 `shiftL` 48) .|.
366 (fromIntegral w3 `shiftL` 40) .|.
367 (fromIntegral w4 `shiftL` 32) .|.
368 (fromIntegral w5 `shiftL` 24) .|.
369 (fromIntegral w6 `shiftL` 16) .|.
370 (fromIntegral w7 `shiftL` 8) .|.
373 -- -----------------------------------------------------------------------------
374 -- Primitve Int writes
376 instance Binary Int8 where
377 put_ h w = put_ h (fromIntegral w :: Word8)
378 get h = do w <- get h; return (fromIntegral (w::Word8))
380 instance Binary Int16 where
381 put_ h w = put_ h (fromIntegral w :: Word16)
382 get h = do w <- get h; return (fromIntegral (w::Word16))
384 instance Binary Int32 where
385 put_ h w = put_ h (fromIntegral w :: Word32)
386 get h = do w <- get h; return (fromIntegral (w::Word32))
388 instance Binary Int64 where
389 put_ h w = put_ h (fromIntegral w :: Word64)
390 get h = do w <- get h; return (fromIntegral (w::Word64))
392 -- -----------------------------------------------------------------------------
393 -- Instances for standard types
395 instance Binary () where
396 put_ bh () = return ()
398 -- getF bh p = case getBitsF bh 0 p of (_,b) -> ((),b)
400 instance Binary Bool where
401 put_ bh b = putByte bh (fromIntegral (fromEnum b))
402 get bh = do x <- getWord8 bh; return (toEnum (fromIntegral x))
403 -- getF bh p = case getBitsF bh 1 p of (x,b) -> (toEnum x,b)
405 instance Binary Char where
406 put_ bh c = put_ bh (fromIntegral (ord c) :: Word32)
407 get bh = do x <- get bh; return (chr (fromIntegral (x :: Word32)))
408 -- getF bh p = case getBitsF bh 8 p of (x,b) -> (toEnum x,b)
410 instance Binary Int where
411 #if SIZEOF_HSINT == 4
412 put_ bh i = put_ bh (fromIntegral i :: Int32)
415 return (fromIntegral (x :: Int32))
416 #elif SIZEOF_HSINT == 8
417 put_ bh i = put_ bh (fromIntegral i :: Int64)
420 return (fromIntegral (x :: Int64))
422 #error "unsupported sizeof(HsInt)"
424 -- getF bh = getBitsF bh 32
426 instance Binary a => Binary [a] where
427 put_ bh [] = putByte bh 0
428 put_ bh (x:xs) = do putByte bh 1; put_ bh x; put_ bh xs
429 get bh = do h <- getWord8 bh
436 instance (Binary a, Binary b) => Binary (a,b) where
437 put_ bh (a,b) = do put_ bh a; put_ bh b
438 get bh = do a <- get bh
442 instance (Binary a, Binary b, Binary c) => Binary (a,b,c) where
443 put_ bh (a,b,c) = do put_ bh a; put_ bh b; put_ bh c
444 get bh = do a <- get bh
449 instance (Binary a, Binary b, Binary c, Binary d) => Binary (a,b,c,d) where
450 put_ bh (a,b,c,d) = do put_ bh a; put_ bh b; put_ bh c; put_ bh d
451 get bh = do a <- get bh
457 instance Binary a => Binary (Maybe a) where
458 put_ bh Nothing = putByte bh 0
459 put_ bh (Just a) = do putByte bh 1; put_ bh a
460 get bh = do h <- getWord8 bh
463 _ -> do x <- get bh; return (Just x)
465 instance (Binary a, Binary b) => Binary (Either a b) where
466 put_ bh (Left a) = do putByte bh 0; put_ bh a
467 put_ bh (Right b) = do putByte bh 1; put_ bh b
468 get bh = do h <- getWord8 bh
470 0 -> do a <- get bh ; return (Left a)
471 _ -> do b <- get bh ; return (Right b)
473 #ifdef __GLASGOW_HASKELL__
474 instance Binary Integer where
475 put_ bh (S# i#) = do putByte bh 0; put_ bh (I# i#)
476 put_ bh (J# s# a#) = do
479 let sz# = sizeofByteArray# a# -- in *bytes*
480 put_ bh (I# sz#) -- in *bytes*
481 putByteArray bh a# sz#
486 0 -> do (I# i#) <- get bh
488 _ -> do (I# s#) <- get bh
490 (BA a#) <- getByteArray bh sz
493 putByteArray :: BinHandle -> ByteArray# -> Int# -> IO ()
494 putByteArray bh a s# = loop 0#
496 | n# ==# s# = return ()
498 putByte bh (indexByteArray a n#)
501 getByteArray :: BinHandle -> Int -> IO ByteArray
502 getByteArray bh (I# sz) = do
503 (MBA arr) <- newByteArray sz
505 | n ==# sz = return ()
508 writeByteArray arr n w
514 data ByteArray = BA ByteArray#
515 data MBA = MBA (MutableByteArray# RealWorld)
517 newByteArray :: Int# -> IO MBA
518 newByteArray sz = IO $ \s ->
519 case newByteArray# sz s of { (# s, arr #) ->
522 freezeByteArray :: MutableByteArray# RealWorld -> IO ByteArray
523 freezeByteArray arr = IO $ \s ->
524 case unsafeFreezeByteArray# arr s of { (# s, arr #) ->
527 writeByteArray :: MutableByteArray# RealWorld -> Int# -> Word8 -> IO ()
529 #if __GLASGOW_HASKELL__ < 503
530 writeByteArray arr i w8 = IO $ \s ->
531 case word8ToWord w8 of { W# w# ->
532 case writeCharArray# arr i (chr# (word2Int# w#)) s of { s ->
535 writeByteArray arr i (W8# w) = IO $ \s ->
536 case writeWord8Array# arr i w s of { s ->
540 #if __GLASGOW_HASKELL__ < 503
541 indexByteArray a# n# = fromIntegral (I# (ord# (indexCharArray# a# n#)))
543 indexByteArray a# n# = W8# (indexWord8Array# a# n#)
546 instance (Integral a, Binary a) => Binary (Ratio a) where
547 put_ bh (a :% b) = do put_ bh a; put_ bh b
548 get bh = do a <- get bh; b <- get bh; return (a :% b)
551 instance Binary (Bin a) where
552 put_ bh (BinPtr i) = put_ bh i
553 get bh = do i <- get bh; return (BinPtr i)
555 -- -----------------------------------------------------------------------------
556 -- unboxed mutable Ints
558 #ifdef __GLASGOW_HASKELL__
559 data FastMutInt = FastMutInt (MutableByteArray# RealWorld)
561 newFastMutInt = IO $ \s ->
562 case newByteArray# size s of { (# s, arr #) ->
563 (# s, FastMutInt arr #) }
564 where I# size = SIZEOF_HSWORD
566 readFastMutInt (FastMutInt arr) = IO $ \s ->
567 case readIntArray# arr 0# s of { (# s, i #) ->
570 writeFastMutInt (FastMutInt arr) (I# i) = IO $ \s ->
571 case writeIntArray# arr 0# i s of { s ->
575 -- -----------------------------------------------------------------------------
576 -- Lazy reading/writing
578 lazyPut :: Binary a => BinHandle -> a -> IO ()
580 -- output the obj with a ptr to skip over it:
582 put_ bh pre_a -- save a slot for the ptr
583 put_ bh a -- dump the object
584 q <- tellBin bh -- q = ptr to after object
585 putAt bh pre_a q -- fill in slot before a with ptr to q
586 seekBin bh q -- finally carry on writing at q
588 lazyGet :: Binary a => BinHandle -> IO a
590 p <- get bh -- a BinPtr
592 a <- unsafeInterleaveIO (getAt bh p_a)
593 seekBin bh p -- skip over the object for now
596 -- -----------------------------------------------------------------------------
599 type BinHandleState =
602 IORef (UniqFM (Int,FastString)),
603 Array Int FastString)
605 initReadState :: BinHandleState
606 initReadState = (undef, undef, undef, undef)
608 newWriteState :: Module -> IO BinHandleState
611 out_r <- newIORef emptyUFM
612 return (m,j_r,out_r,undef)
614 undef = error "Binary.BinHandleState"
616 -- -----------------------------------------------------------------------------
617 -- FastString binary interface
619 getBinFileWithDict :: Binary a => FilePath -> IO a
620 getBinFileWithDict file_path = do
621 bh <- Binary.readBinMem file_path
622 dict_p <- Binary.get bh -- get the dictionary ptr
625 dict <- getDictionary bh
627 let (mod, j_r, out_r, _) = state bh
628 get bh{ state = (mod,j_r,out_r,dict) }
630 initBinMemSize = (1024*1024) :: Int
632 putBinFileWithDict :: Binary a => FilePath -> Module -> a -> IO ()
633 putBinFileWithDict file_path mod a = do
634 bh <- openBinMem initBinMemSize mod
636 put_ bh p -- placeholder for ptr to dictionary
638 let (_, j_r, fm_r, _) = state bh
642 putAt bh p dict_p -- fill in the placeholder
643 seekBin bh dict_p -- seek back to the end of the file
644 putDictionary bh j (constructDictionary j fm)
645 writeBinMem bh file_path
647 type Dictionary = Array Int FastString
648 -- should be 0-indexed
650 putDictionary :: BinHandle -> Int -> Dictionary -> IO ()
651 putDictionary bh sz dict = do
653 mapM_ (putFS bh) (elems dict)
655 getDictionary :: BinHandle -> IO Dictionary
656 getDictionary bh = do
658 elems <- sequence (take sz (repeat (getFS bh)))
659 return (listArray (0,sz-1) elems)
661 constructDictionary :: Int -> UniqFM (Int,FastString) -> Dictionary
662 constructDictionary j fm = array (0,j-1) (eltsUFM fm)
664 putFS bh (FastString id l ba) = do
667 putFS bh s = error ("Binary.put_(FastString): " ++ unpackFS s)
668 -- Note: the length of the FastString is *not* the same as
669 -- the size of the ByteArray: the latter is rounded up to a
670 -- multiple of the word size.
674 (BA ba) <- getByteArray bh (I# l)
675 return (mkFastSubStringBA# ba 0# l)
676 -- XXX ToDo: one too many copies here
678 instance Binary FastString where
679 put_ bh f@(FastString id l ba) =
680 case getUserData bh of { (_, j_r, out_r, dict) -> do
681 out <- readIORef out_r
682 let uniq = getUnique f
683 case lookupUFM out uniq of
684 Just (j,f) -> put_ bh j
689 writeIORef out_r (addToUFM out uniq (j,f))
691 put_ bh s = error ("Binary.put_(FastString): " ++ show (unpackFS s))
695 case getUserData bh of (_, _, _, arr) -> return (arr ! j)