PageRenderTime 39ms CodeModel.GetById 11ms RepoModel.GetById 0ms app.codeStats 1ms

/compiler/utils/Binary.hs

https://bitbucket.org/carter/ghc
Haskell | 784 lines | 546 code | 123 blank | 115 comment | 14 complexity | 42c7e6ca0f09020b89b65818e22210fd MD5 | raw file
  1. {-# OPTIONS -cpp #-}
  2. {-# OPTIONS_GHC -O -funbox-strict-fields #-}
  3. -- We always optimise this, otherwise performance of a non-optimised
  4. -- compiler is severely affected
  5. --
  6. -- (c) The University of Glasgow 2002-2006
  7. --
  8. -- Binary I/O library, with special tweaks for GHC
  9. --
  10. -- Based on the nhc98 Binary library, which is copyright
  11. -- (c) Malcolm Wallace and Colin Runciman, University of York, 1998.
  12. -- Under the terms of the license for that software, we must tell you
  13. -- where you can obtain the original version of the Binary library, namely
  14. -- http://www.cs.york.ac.uk/fp/nhc98/
  15. module Binary
  16. ( {-type-} Bin,
  17. {-class-} Binary(..),
  18. {-type-} BinHandle,
  19. SymbolTable, Dictionary,
  20. openBinIO, openBinIO_,
  21. openBinMem,
  22. -- closeBin,
  23. seekBin,
  24. seekBy,
  25. tellBin,
  26. castBin,
  27. writeBinMem,
  28. readBinMem,
  29. fingerprintBinMem,
  30. computeFingerprint,
  31. isEOFBin,
  32. putAt, getAt,
  33. -- for writing instances:
  34. putByte,
  35. getByte,
  36. -- lazy Bin I/O
  37. lazyGet,
  38. lazyPut,
  39. #ifdef __GLASGOW_HASKELL__
  40. -- GHC only:
  41. ByteArray(..),
  42. getByteArray,
  43. putByteArray,
  44. #endif
  45. UserData(..), getUserData, setUserData,
  46. newReadState, newWriteState,
  47. putDictionary, getDictionary, putFS,
  48. ) where
  49. #include "HsVersions.h"
  50. -- The *host* architecture version:
  51. #include "../includes/MachDeps.h"
  52. import {-# SOURCE #-} Name (Name)
  53. import FastString
  54. import Panic
  55. import UniqFM
  56. import FastMutInt
  57. import Fingerprint
  58. import BasicTypes
  59. import Foreign
  60. import Data.Array
  61. import Data.IORef
  62. import Data.Char ( ord, chr )
  63. import Data.Time
  64. import Data.Typeable
  65. import Data.Typeable.Internal
  66. import Control.Monad ( when )
  67. import System.IO as IO
  68. import System.IO.Unsafe ( unsafeInterleaveIO )
  69. import System.IO.Error ( mkIOError, eofErrorType )
  70. import GHC.Real ( Ratio(..) )
  71. import GHC.Exts
  72. import GHC.Word ( Word8(..) )
  73. import GHC.IO ( IO(..) )
  74. type BinArray = ForeignPtr Word8
  75. ---------------------------------------------------------------
  76. -- BinHandle
  77. ---------------------------------------------------------------
  78. data BinHandle
  79. = BinMem { -- binary data stored in an unboxed array
  80. bh_usr :: UserData, -- sigh, need parameterized modules :-)
  81. _off_r :: !FastMutInt, -- the current offset
  82. _sz_r :: !FastMutInt, -- size of the array (cached)
  83. _arr_r :: !(IORef BinArray) -- the array (bounds: (0,size-1))
  84. }
  85. -- XXX: should really store a "high water mark" for dumping out
  86. -- the binary data to a file.
  87. | BinIO { -- binary data stored in a file
  88. bh_usr :: UserData,
  89. _off_r :: !FastMutInt, -- the current offset (cached)
  90. _hdl :: !IO.Handle -- the file handle (must be seekable)
  91. }
  92. -- cache the file ptr in BinIO; using hTell is too expensive
  93. -- to call repeatedly. If anyone else is modifying this Handle
  94. -- at the same time, we'll be screwed.
  95. getUserData :: BinHandle -> UserData
  96. getUserData bh = bh_usr bh
  97. setUserData :: BinHandle -> UserData -> BinHandle
  98. setUserData bh us = bh { bh_usr = us }
  99. ---------------------------------------------------------------
  100. -- Bin
  101. ---------------------------------------------------------------
  102. newtype Bin a = BinPtr Int
  103. deriving (Eq, Ord, Show, Bounded)
  104. castBin :: Bin a -> Bin b
  105. castBin (BinPtr i) = BinPtr i
  106. ---------------------------------------------------------------
  107. -- class Binary
  108. ---------------------------------------------------------------
  109. class Binary a where
  110. put_ :: BinHandle -> a -> IO ()
  111. put :: BinHandle -> a -> IO (Bin a)
  112. get :: BinHandle -> IO a
  113. -- define one of put_, put. Use of put_ is recommended because it
  114. -- is more likely that tail-calls can kick in, and we rarely need the
  115. -- position return value.
  116. put_ bh a = do _ <- put bh a; return ()
  117. put bh a = do p <- tellBin bh; put_ bh a; return p
  118. putAt :: Binary a => BinHandle -> Bin a -> a -> IO ()
  119. putAt bh p x = do seekBin bh p; put_ bh x; return ()
  120. getAt :: Binary a => BinHandle -> Bin a -> IO a
  121. getAt bh p = do seekBin bh p; get bh
  122. openBinIO_ :: IO.Handle -> IO BinHandle
  123. openBinIO_ h = openBinIO h
  124. openBinIO :: IO.Handle -> IO BinHandle
  125. openBinIO h = do
  126. r <- newFastMutInt
  127. writeFastMutInt r 0
  128. return (BinIO noUserData r h)
  129. openBinMem :: Int -> IO BinHandle
  130. openBinMem size
  131. | size <= 0 = error "Data.Binary.openBinMem: size must be >= 0"
  132. | otherwise = do
  133. arr <- mallocForeignPtrBytes size
  134. arr_r <- newIORef arr
  135. ix_r <- newFastMutInt
  136. writeFastMutInt ix_r 0
  137. sz_r <- newFastMutInt
  138. writeFastMutInt sz_r size
  139. return (BinMem noUserData ix_r sz_r arr_r)
  140. tellBin :: BinHandle -> IO (Bin a)
  141. tellBin (BinIO _ r _) = do ix <- readFastMutInt r; return (BinPtr ix)
  142. tellBin (BinMem _ r _ _) = do ix <- readFastMutInt r; return (BinPtr ix)
  143. seekBin :: BinHandle -> Bin a -> IO ()
  144. seekBin (BinIO _ ix_r h) (BinPtr p) = do
  145. writeFastMutInt ix_r p
  146. hSeek h AbsoluteSeek (fromIntegral p)
  147. seekBin h@(BinMem _ ix_r sz_r _) (BinPtr p) = do
  148. sz <- readFastMutInt sz_r
  149. if (p >= sz)
  150. then do expandBin h p; writeFastMutInt ix_r p
  151. else writeFastMutInt ix_r p
  152. seekBy :: BinHandle -> Int -> IO ()
  153. seekBy (BinIO _ ix_r h) off = do
  154. ix <- readFastMutInt ix_r
  155. let ix' = ix + off
  156. writeFastMutInt ix_r ix'
  157. hSeek h AbsoluteSeek (fromIntegral ix')
  158. seekBy h@(BinMem _ ix_r sz_r _) off = do
  159. sz <- readFastMutInt sz_r
  160. ix <- readFastMutInt ix_r
  161. let ix' = ix + off
  162. if (ix' >= sz)
  163. then do expandBin h ix'; writeFastMutInt ix_r ix'
  164. else writeFastMutInt ix_r ix'
  165. isEOFBin :: BinHandle -> IO Bool
  166. isEOFBin (BinMem _ ix_r sz_r _) = do
  167. ix <- readFastMutInt ix_r
  168. sz <- readFastMutInt sz_r
  169. return (ix >= sz)
  170. isEOFBin (BinIO _ _ h) = hIsEOF h
  171. writeBinMem :: BinHandle -> FilePath -> IO ()
  172. writeBinMem (BinIO _ _ _) _ = error "Data.Binary.writeBinMem: not a memory handle"
  173. writeBinMem (BinMem _ ix_r _ arr_r) fn = do
  174. h <- openBinaryFile fn WriteMode
  175. arr <- readIORef arr_r
  176. ix <- readFastMutInt ix_r
  177. withForeignPtr arr $ \p -> hPutBuf h p ix
  178. hClose h
  179. readBinMem :: FilePath -> IO BinHandle
  180. -- Return a BinHandle with a totally undefined State
  181. readBinMem filename = do
  182. h <- openBinaryFile filename ReadMode
  183. filesize' <- hFileSize h
  184. let filesize = fromIntegral filesize'
  185. arr <- mallocForeignPtrBytes (filesize*2)
  186. count <- withForeignPtr arr $ \p -> hGetBuf h p filesize
  187. when (count /= filesize) $
  188. error ("Binary.readBinMem: only read " ++ show count ++ " bytes")
  189. hClose h
  190. arr_r <- newIORef arr
  191. ix_r <- newFastMutInt
  192. writeFastMutInt ix_r 0
  193. sz_r <- newFastMutInt
  194. writeFastMutInt sz_r filesize
  195. return (BinMem noUserData ix_r sz_r arr_r)
  196. fingerprintBinMem :: BinHandle -> IO Fingerprint
  197. fingerprintBinMem (BinIO _ _ _) = error "Binary.md5BinMem: not a memory handle"
  198. fingerprintBinMem (BinMem _ ix_r _ arr_r) = do
  199. arr <- readIORef arr_r
  200. ix <- readFastMutInt ix_r
  201. withForeignPtr arr $ \p -> fingerprintData p ix
  202. computeFingerprint :: Binary a
  203. => (BinHandle -> Name -> IO ())
  204. -> a
  205. -> IO Fingerprint
  206. computeFingerprint put_name a = do
  207. bh <- openBinMem (3*1024) -- just less than a block
  208. bh <- return $ setUserData bh $ newWriteState put_name putFS
  209. put_ bh a
  210. fingerprintBinMem bh
  211. -- expand the size of the array to include a specified offset
  212. expandBin :: BinHandle -> Int -> IO ()
  213. expandBin (BinMem _ _ sz_r arr_r) off = do
  214. sz <- readFastMutInt sz_r
  215. let sz' = head (dropWhile (<= off) (iterate (* 2) sz))
  216. arr <- readIORef arr_r
  217. arr' <- mallocForeignPtrBytes sz'
  218. withForeignPtr arr $ \old ->
  219. withForeignPtr arr' $ \new ->
  220. copyBytes new old sz
  221. writeFastMutInt sz_r sz'
  222. writeIORef arr_r arr'
  223. expandBin (BinIO _ _ _) _ = return ()
  224. -- no need to expand a file, we'll assume they expand by themselves.
  225. -- -----------------------------------------------------------------------------
  226. -- Low-level reading/writing of bytes
  227. putWord8 :: BinHandle -> Word8 -> IO ()
  228. putWord8 h@(BinMem _ ix_r sz_r arr_r) w = do
  229. ix <- readFastMutInt ix_r
  230. sz <- readFastMutInt sz_r
  231. -- double the size of the array if it overflows
  232. if (ix >= sz)
  233. then do expandBin h ix
  234. putWord8 h w
  235. else do arr <- readIORef arr_r
  236. withForeignPtr arr $ \p -> pokeByteOff p ix w
  237. writeFastMutInt ix_r (ix+1)
  238. return ()
  239. putWord8 (BinIO _ ix_r h) w = do
  240. ix <- readFastMutInt ix_r
  241. hPutChar h (chr (fromIntegral w)) -- XXX not really correct
  242. writeFastMutInt ix_r (ix+1)
  243. return ()
  244. getWord8 :: BinHandle -> IO Word8
  245. getWord8 (BinMem _ ix_r sz_r arr_r) = do
  246. ix <- readFastMutInt ix_r
  247. sz <- readFastMutInt sz_r
  248. when (ix >= sz) $
  249. ioError (mkIOError eofErrorType "Data.Binary.getWord8" Nothing Nothing)
  250. arr <- readIORef arr_r
  251. w <- withForeignPtr arr $ \p -> peekByteOff p ix
  252. writeFastMutInt ix_r (ix+1)
  253. return w
  254. getWord8 (BinIO _ ix_r h) = do
  255. ix <- readFastMutInt ix_r
  256. c <- hGetChar h
  257. writeFastMutInt ix_r (ix+1)
  258. return $! (fromIntegral (ord c)) -- XXX not really correct
  259. putByte :: BinHandle -> Word8 -> IO ()
  260. putByte bh w = put_ bh w
  261. getByte :: BinHandle -> IO Word8
  262. getByte = getWord8
  263. -- -----------------------------------------------------------------------------
  264. -- Primitve Word writes
  265. instance Binary Word8 where
  266. put_ = putWord8
  267. get = getWord8
  268. instance Binary Word16 where
  269. put_ h w = do -- XXX too slow.. inline putWord8?
  270. putByte h (fromIntegral (w `shiftR` 8))
  271. putByte h (fromIntegral (w .&. 0xff))
  272. get h = do
  273. w1 <- getWord8 h
  274. w2 <- getWord8 h
  275. return $! ((fromIntegral w1 `shiftL` 8) .|. fromIntegral w2)
  276. instance Binary Word32 where
  277. put_ h w = do
  278. putByte h (fromIntegral (w `shiftR` 24))
  279. putByte h (fromIntegral ((w `shiftR` 16) .&. 0xff))
  280. putByte h (fromIntegral ((w `shiftR` 8) .&. 0xff))
  281. putByte h (fromIntegral (w .&. 0xff))
  282. get h = do
  283. w1 <- getWord8 h
  284. w2 <- getWord8 h
  285. w3 <- getWord8 h
  286. w4 <- getWord8 h
  287. return $! ((fromIntegral w1 `shiftL` 24) .|.
  288. (fromIntegral w2 `shiftL` 16) .|.
  289. (fromIntegral w3 `shiftL` 8) .|.
  290. (fromIntegral w4))
  291. instance Binary Word64 where
  292. put_ h w = do
  293. putByte h (fromIntegral (w `shiftR` 56))
  294. putByte h (fromIntegral ((w `shiftR` 48) .&. 0xff))
  295. putByte h (fromIntegral ((w `shiftR` 40) .&. 0xff))
  296. putByte h (fromIntegral ((w `shiftR` 32) .&. 0xff))
  297. putByte h (fromIntegral ((w `shiftR` 24) .&. 0xff))
  298. putByte h (fromIntegral ((w `shiftR` 16) .&. 0xff))
  299. putByte h (fromIntegral ((w `shiftR` 8) .&. 0xff))
  300. putByte h (fromIntegral (w .&. 0xff))
  301. get h = do
  302. w1 <- getWord8 h
  303. w2 <- getWord8 h
  304. w3 <- getWord8 h
  305. w4 <- getWord8 h
  306. w5 <- getWord8 h
  307. w6 <- getWord8 h
  308. w7 <- getWord8 h
  309. w8 <- getWord8 h
  310. return $! ((fromIntegral w1 `shiftL` 56) .|.
  311. (fromIntegral w2 `shiftL` 48) .|.
  312. (fromIntegral w3 `shiftL` 40) .|.
  313. (fromIntegral w4 `shiftL` 32) .|.
  314. (fromIntegral w5 `shiftL` 24) .|.
  315. (fromIntegral w6 `shiftL` 16) .|.
  316. (fromIntegral w7 `shiftL` 8) .|.
  317. (fromIntegral w8))
  318. -- -----------------------------------------------------------------------------
  319. -- Primitve Int writes
  320. instance Binary Int8 where
  321. put_ h w = put_ h (fromIntegral w :: Word8)
  322. get h = do w <- get h; return $! (fromIntegral (w::Word8))
  323. instance Binary Int16 where
  324. put_ h w = put_ h (fromIntegral w :: Word16)
  325. get h = do w <- get h; return $! (fromIntegral (w::Word16))
  326. instance Binary Int32 where
  327. put_ h w = put_ h (fromIntegral w :: Word32)
  328. get h = do w <- get h; return $! (fromIntegral (w::Word32))
  329. instance Binary Int64 where
  330. put_ h w = put_ h (fromIntegral w :: Word64)
  331. get h = do w <- get h; return $! (fromIntegral (w::Word64))
  332. -- -----------------------------------------------------------------------------
  333. -- Instances for standard types
  334. instance Binary () where
  335. put_ _ () = return ()
  336. get _ = return ()
  337. instance Binary Bool where
  338. put_ bh b = putByte bh (fromIntegral (fromEnum b))
  339. get bh = do x <- getWord8 bh; return $! (toEnum (fromIntegral x))
  340. instance Binary Char where
  341. put_ bh c = put_ bh (fromIntegral (ord c) :: Word32)
  342. get bh = do x <- get bh; return $! (chr (fromIntegral (x :: Word32)))
  343. instance Binary Int where
  344. put_ bh i = put_ bh (fromIntegral i :: Int64)
  345. get bh = do
  346. x <- get bh
  347. return $! (fromIntegral (x :: Int64))
  348. instance Binary a => Binary [a] where
  349. put_ bh l = do
  350. let len = length l
  351. if (len < 0xff)
  352. then putByte bh (fromIntegral len :: Word8)
  353. else do putByte bh 0xff; put_ bh (fromIntegral len :: Word32)
  354. mapM_ (put_ bh) l
  355. get bh = do
  356. b <- getByte bh
  357. len <- if b == 0xff
  358. then get bh
  359. else return (fromIntegral b :: Word32)
  360. let loop 0 = return []
  361. loop n = do a <- get bh; as <- loop (n-1); return (a:as)
  362. loop len
  363. instance (Binary a, Binary b) => Binary (a,b) where
  364. put_ bh (a,b) = do put_ bh a; put_ bh b
  365. get bh = do a <- get bh
  366. b <- get bh
  367. return (a,b)
  368. instance (Binary a, Binary b, Binary c) => Binary (a,b,c) where
  369. put_ bh (a,b,c) = do put_ bh a; put_ bh b; put_ bh c
  370. get bh = do a <- get bh
  371. b <- get bh
  372. c <- get bh
  373. return (a,b,c)
  374. instance (Binary a, Binary b, Binary c, Binary d) => Binary (a,b,c,d) where
  375. put_ bh (a,b,c,d) = do put_ bh a; put_ bh b; put_ bh c; put_ bh d
  376. get bh = do a <- get bh
  377. b <- get bh
  378. c <- get bh
  379. d <- get bh
  380. return (a,b,c,d)
  381. instance (Binary a, Binary b, Binary c, Binary d, Binary e) => Binary (a,b,c,d, e) where
  382. put_ bh (a,b,c,d, e) = do put_ bh a; put_ bh b; put_ bh c; put_ bh d; put_ bh e;
  383. get bh = do a <- get bh
  384. b <- get bh
  385. c <- get bh
  386. d <- get bh
  387. e <- get bh
  388. return (a,b,c,d,e)
  389. instance (Binary a, Binary b, Binary c, Binary d, Binary e, Binary f) => Binary (a,b,c,d, e, f) where
  390. put_ bh (a,b,c,d, e, f) = do put_ bh a; put_ bh b; put_ bh c; put_ bh d; put_ bh e; put_ bh f;
  391. get bh = do a <- get bh
  392. b <- get bh
  393. c <- get bh
  394. d <- get bh
  395. e <- get bh
  396. f <- get bh
  397. return (a,b,c,d,e,f)
  398. instance Binary a => Binary (Maybe a) where
  399. put_ bh Nothing = putByte bh 0
  400. put_ bh (Just a) = do putByte bh 1; put_ bh a
  401. get bh = do h <- getWord8 bh
  402. case h of
  403. 0 -> return Nothing
  404. _ -> do x <- get bh; return (Just x)
  405. instance (Binary a, Binary b) => Binary (Either a b) where
  406. put_ bh (Left a) = do putByte bh 0; put_ bh a
  407. put_ bh (Right b) = do putByte bh 1; put_ bh b
  408. get bh = do h <- getWord8 bh
  409. case h of
  410. 0 -> do a <- get bh ; return (Left a)
  411. _ -> do b <- get bh ; return (Right b)
  412. instance Binary UTCTime where
  413. put_ bh u = do put_ bh (utctDay u)
  414. put_ bh (utctDayTime u)
  415. get bh = do day <- get bh
  416. dayTime <- get bh
  417. return $ UTCTime { utctDay = day, utctDayTime = dayTime }
  418. instance Binary Day where
  419. put_ bh d = put_ bh (toModifiedJulianDay d)
  420. get bh = do i <- get bh
  421. return $ ModifiedJulianDay { toModifiedJulianDay = i }
  422. instance Binary DiffTime where
  423. put_ bh dt = put_ bh (toRational dt)
  424. get bh = do r <- get bh
  425. return $ fromRational r
  426. #if defined(__GLASGOW_HASKELL__) || 1
  427. --to quote binary-0.3 on this code idea,
  428. --
  429. -- TODO This instance is not architecture portable. GMP stores numbers as
  430. -- arrays of machine sized words, so the byte format is not portable across
  431. -- architectures with different endianess and word size.
  432. --
  433. -- This makes it hard (impossible) to make an equivalent instance
  434. -- with code that is compilable with non-GHC. Do we need any instance
  435. -- Binary Integer, and if so, does it have to be blazing fast? Or can
  436. -- we just change this instance to be portable like the rest of the
  437. -- instances? (binary package has code to steal for that)
  438. --
  439. -- yes, we need Binary Integer and Binary Rational in basicTypes/Literal.lhs
  440. instance Binary Integer where
  441. -- XXX This is hideous
  442. put_ bh i = put_ bh (show i)
  443. get bh = do str <- get bh
  444. case reads str of
  445. [(i, "")] -> return i
  446. _ -> fail ("Binary Integer: got " ++ show str)
  447. {-
  448. put_ bh (S# i#) = do putByte bh 0; put_ bh (I# i#)
  449. put_ bh (J# s# a#) = do
  450. putByte bh 1
  451. put_ bh (I# s#)
  452. let sz# = sizeofByteArray# a# -- in *bytes*
  453. put_ bh (I# sz#) -- in *bytes*
  454. putByteArray bh a# sz#
  455. get bh = do
  456. b <- getByte bh
  457. case b of
  458. 0 -> do (I# i#) <- get bh
  459. return (S# i#)
  460. _ -> do (I# s#) <- get bh
  461. sz <- get bh
  462. (BA a#) <- getByteArray bh sz
  463. return (J# s# a#)
  464. -}
  465. -- As for the rest of this code, even though this module
  466. -- exports it, it doesn't seem to be used anywhere else
  467. -- in GHC!
  468. putByteArray :: BinHandle -> ByteArray# -> Int# -> IO ()
  469. putByteArray bh a s# = loop 0#
  470. where loop n#
  471. | n# ==# s# = return ()
  472. | otherwise = do
  473. putByte bh (indexByteArray a n#)
  474. loop (n# +# 1#)
  475. getByteArray :: BinHandle -> Int -> IO ByteArray
  476. getByteArray bh (I# sz) = do
  477. (MBA arr) <- newByteArray sz
  478. let loop n
  479. | n ==# sz = return ()
  480. | otherwise = do
  481. w <- getByte bh
  482. writeByteArray arr n w
  483. loop (n +# 1#)
  484. loop 0#
  485. freezeByteArray arr
  486. data ByteArray = BA ByteArray#
  487. data MBA = MBA (MutableByteArray# RealWorld)
  488. newByteArray :: Int# -> IO MBA
  489. newByteArray sz = IO $ \s ->
  490. case newByteArray# sz s of { (# s, arr #) ->
  491. (# s, MBA arr #) }
  492. freezeByteArray :: MutableByteArray# RealWorld -> IO ByteArray
  493. freezeByteArray arr = IO $ \s ->
  494. case unsafeFreezeByteArray# arr s of { (# s, arr #) ->
  495. (# s, BA arr #) }
  496. writeByteArray :: MutableByteArray# RealWorld -> Int# -> Word8 -> IO ()
  497. writeByteArray arr i (W8# w) = IO $ \s ->
  498. case writeWord8Array# arr i w s of { s ->
  499. (# s, () #) }
  500. indexByteArray :: ByteArray# -> Int# -> Word8
  501. indexByteArray a# n# = W8# (indexWord8Array# a# n#)
  502. instance (Integral a, Binary a) => Binary (Ratio a) where
  503. put_ bh (a :% b) = do put_ bh a; put_ bh b
  504. get bh = do a <- get bh; b <- get bh; return (a :% b)
  505. #endif
  506. instance Binary (Bin a) where
  507. put_ bh (BinPtr i) = put_ bh (fromIntegral i :: Int32)
  508. get bh = do i <- get bh; return (BinPtr (fromIntegral (i :: Int32)))
  509. -- -----------------------------------------------------------------------------
  510. -- Instances for Data.Typeable stuff
  511. instance Binary TyCon where
  512. put_ bh (TyCon _ p m n) = do
  513. put_ bh (p,m,n)
  514. get bh = do
  515. (p,m,n) <- get bh
  516. return (mkTyCon3 p m n)
  517. instance Binary TypeRep where
  518. put_ bh type_rep = do
  519. let (ty_con, child_type_reps) = splitTyConApp type_rep
  520. put_ bh ty_con
  521. put_ bh child_type_reps
  522. get bh = do
  523. ty_con <- get bh
  524. child_type_reps <- get bh
  525. return (mkTyConApp ty_con child_type_reps)
  526. -- -----------------------------------------------------------------------------
  527. -- Lazy reading/writing
  528. lazyPut :: Binary a => BinHandle -> a -> IO ()
  529. lazyPut bh a = do
  530. -- output the obj with a ptr to skip over it:
  531. pre_a <- tellBin bh
  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
  537. lazyGet :: Binary a => BinHandle -> IO a
  538. lazyGet bh = do
  539. p <- get bh -- a BinPtr
  540. p_a <- tellBin bh
  541. a <- unsafeInterleaveIO (getAt bh p_a)
  542. seekBin bh p -- skip over the object for now
  543. return a
  544. -- -----------------------------------------------------------------------------
  545. -- UserData
  546. -- -----------------------------------------------------------------------------
  547. data UserData =
  548. UserData {
  549. -- for *deserialising* only:
  550. ud_get_name :: BinHandle -> IO Name,
  551. ud_get_fs :: BinHandle -> IO FastString,
  552. -- for *serialising* only:
  553. ud_put_name :: BinHandle -> Name -> IO (),
  554. ud_put_fs :: BinHandle -> FastString -> IO ()
  555. }
  556. newReadState :: (BinHandle -> IO Name)
  557. -> (BinHandle -> IO FastString)
  558. -> UserData
  559. newReadState get_name get_fs
  560. = UserData { ud_get_name = get_name,
  561. ud_get_fs = get_fs,
  562. ud_put_name = undef "put_name",
  563. ud_put_fs = undef "put_fs"
  564. }
  565. newWriteState :: (BinHandle -> Name -> IO ())
  566. -> (BinHandle -> FastString -> IO ())
  567. -> UserData
  568. newWriteState put_name put_fs
  569. = UserData { ud_get_name = undef "get_name",
  570. ud_get_fs = undef "get_fs",
  571. ud_put_name = put_name,
  572. ud_put_fs = put_fs
  573. }
  574. noUserData :: a
  575. noUserData = undef "UserData"
  576. undef :: String -> a
  577. undef s = panic ("Binary.UserData: no " ++ s)
  578. ---------------------------------------------------------
  579. -- The Dictionary
  580. ---------------------------------------------------------
  581. type Dictionary = Array Int FastString -- The dictionary
  582. -- Should be 0-indexed
  583. putDictionary :: BinHandle -> Int -> UniqFM (Int,FastString) -> IO ()
  584. putDictionary bh sz dict = do
  585. put_ bh sz
  586. mapM_ (putFS bh) (elems (array (0,sz-1) (eltsUFM dict)))
  587. getDictionary :: BinHandle -> IO Dictionary
  588. getDictionary bh = do
  589. sz <- get bh
  590. elems <- sequence (take sz (repeat (getFS bh)))
  591. return (listArray (0,sz-1) elems)
  592. ---------------------------------------------------------
  593. -- The Symbol Table
  594. ---------------------------------------------------------
  595. -- On disk, the symbol table is an array of IfaceExtName, when
  596. -- reading it in we turn it into a SymbolTable.
  597. type SymbolTable = Array Int Name
  598. ---------------------------------------------------------
  599. -- Reading and writing FastStrings
  600. ---------------------------------------------------------
  601. putFS :: BinHandle -> FastString -> IO ()
  602. putFS bh fs = putFB bh $ fastStringToFastBytes fs
  603. getFS :: BinHandle -> IO FastString
  604. getFS bh = do fb <- getFB bh
  605. mkFastStringFastBytes fb
  606. putFB :: BinHandle -> FastBytes -> IO ()
  607. putFB bh (FastBytes l buf) = do
  608. put_ bh l
  609. withForeignPtr buf $ \ptr ->
  610. let
  611. go n | n == l = return ()
  612. | otherwise = do
  613. b <- peekElemOff ptr n
  614. putByte bh b
  615. go (n+1)
  616. in
  617. go 0
  618. {- -- possible faster version, not quite there yet:
  619. getFB bh@BinMem{} = do
  620. (I# l) <- get bh
  621. arr <- readIORef (arr_r bh)
  622. off <- readFastMutInt (off_r bh)
  623. return $! (mkFastSubBytesBA# arr off l)
  624. -}
  625. getFB :: BinHandle -> IO FastBytes
  626. getFB bh = do
  627. l <- get bh
  628. fp <- mallocForeignPtrBytes l
  629. withForeignPtr fp $ \ptr -> do
  630. let
  631. go n | n == l = return $ foreignPtrToFastBytes fp l
  632. | otherwise = do
  633. b <- getByte bh
  634. pokeElemOff ptr n b
  635. go (n+1)
  636. --
  637. go 0
  638. instance Binary FastBytes where
  639. put_ bh f = putFB bh f
  640. get bh = getFB bh
  641. instance Binary FastString where
  642. put_ bh f =
  643. case getUserData bh of
  644. UserData { ud_put_fs = put_fs } -> put_fs bh f
  645. get bh =
  646. case getUserData bh of
  647. UserData { ud_get_fs = get_fs } -> get_fs bh
  648. -- Here to avoid loop
  649. instance Binary Fingerprint where
  650. put_ h (Fingerprint w1 w2) = do put_ h w1; put_ h w2
  651. get h = do w1 <- get h; w2 <- get h; return (Fingerprint w1 w2)
  652. instance Binary FunctionOrData where
  653. put_ bh IsFunction = putByte bh 0
  654. put_ bh IsData = putByte bh 1
  655. get bh = do
  656. h <- getByte bh
  657. case h of
  658. 0 -> return IsFunction
  659. 1 -> return IsData
  660. _ -> panic "Binary FunctionOrData"