PageRenderTime 64ms CodeModel.GetById 27ms RepoModel.GetById 0ms app.codeStats 1ms

/ghc-7.0.4/compiler/iface/BinIface.hs

http://picorec.googlecode.com/
Haskell | 1506 lines | 1240 code | 140 blank | 126 comment | 13 complexity | a2858c87f7e8b3c30977bedc134a27c5 MD5 | raw file
Possible License(s): BSD-3-Clause, BSD-2-Clause
  1. {-# OPTIONS_GHC -O #-}
  2. -- We always optimise this, otherwise performance of a non-optimised
  3. -- compiler is severely affected
  4. --
  5. -- (c) The University of Glasgow 2002-2006
  6. --
  7. -- Binary interface file support.
  8. module BinIface ( writeBinIface, readBinIface,
  9. CheckHiWay(..), TraceBinIFaceReading(..) ) where
  10. #include "HsVersions.h"
  11. import TcRnMonad
  12. import IfaceEnv
  13. import HscTypes
  14. import BasicTypes
  15. import Demand
  16. import Annotations
  17. import CoreSyn
  18. import IfaceSyn
  19. import Module
  20. import Name
  21. import VarEnv
  22. import DynFlags
  23. import UniqFM
  24. import UniqSupply
  25. import CostCentre
  26. import StaticFlags
  27. import Panic
  28. import Binary
  29. import SrcLoc
  30. import ErrUtils
  31. import Config
  32. import FastMutInt
  33. import Unique
  34. import Outputable
  35. import FastString
  36. import Constants
  37. import Data.List
  38. import Data.Word
  39. import Data.Array
  40. import Data.IORef
  41. import Control.Monad
  42. data CheckHiWay = CheckHiWay | IgnoreHiWay
  43. deriving Eq
  44. data TraceBinIFaceReading = TraceBinIFaceReading | QuietBinIFaceReading
  45. deriving Eq
  46. -- ---------------------------------------------------------------------------
  47. -- Reading and writing binary interface files
  48. readBinIface :: CheckHiWay -> TraceBinIFaceReading -> FilePath
  49. -> TcRnIf a b ModIface
  50. readBinIface checkHiWay traceBinIFaceReading hi_path = do
  51. update_nc <- mkNameCacheUpdater
  52. dflags <- getDOpts
  53. liftIO $ readBinIface_ dflags checkHiWay traceBinIFaceReading hi_path update_nc
  54. readBinIface_ :: DynFlags -> CheckHiWay -> TraceBinIFaceReading -> FilePath
  55. -> NameCacheUpdater (Array Int Name)
  56. -> IO ModIface
  57. readBinIface_ dflags checkHiWay traceBinIFaceReading hi_path update_nc = do
  58. let printer :: SDoc -> IO ()
  59. printer = case traceBinIFaceReading of
  60. TraceBinIFaceReading -> \sd -> printSDoc sd defaultDumpStyle
  61. QuietBinIFaceReading -> \_ -> return ()
  62. wantedGot :: Outputable a => String -> a -> a -> IO ()
  63. wantedGot what wanted got
  64. = printer (text what <> text ": " <>
  65. vcat [text "Wanted " <> ppr wanted <> text ",",
  66. text "got " <> ppr got])
  67. errorOnMismatch :: (Eq a, Show a) => String -> a -> a -> IO ()
  68. errorOnMismatch what wanted got
  69. -- This will be caught by readIface which will emit an error
  70. -- msg containing the iface module name.
  71. = when (wanted /= got) $ ghcError $ ProgramError
  72. (what ++ " (wanted " ++ show wanted
  73. ++ ", got " ++ show got ++ ")")
  74. bh <- Binary.readBinMem hi_path
  75. -- Read the magic number to check that this really is a GHC .hi file
  76. -- (This magic number does not change when we change
  77. -- GHC interface file format)
  78. magic <- get bh
  79. wantedGot "Magic" binaryInterfaceMagic magic
  80. errorOnMismatch "magic number mismatch: old/corrupt interface file?"
  81. binaryInterfaceMagic magic
  82. -- Note [dummy iface field]
  83. -- read a dummy 32/64 bit value. This field used to hold the
  84. -- dictionary pointer in old interface file formats, but now
  85. -- the dictionary pointer is after the version (where it
  86. -- should be). Also, the serialisation of value of type "Bin
  87. -- a" used to depend on the word size of the machine, now they
  88. -- are always 32 bits.
  89. --
  90. if wORD_SIZE == 4
  91. then do _ <- Binary.get bh :: IO Word32; return ()
  92. else do _ <- Binary.get bh :: IO Word64; return ()
  93. -- Check the interface file version and ways.
  94. check_ver <- get bh
  95. let our_ver = show opt_HiVersion
  96. wantedGot "Version" our_ver check_ver
  97. errorOnMismatch "mismatched interface file versions" our_ver check_ver
  98. check_way <- get bh
  99. let way_descr = getWayDescr dflags
  100. wantedGot "Way" way_descr check_way
  101. when (checkHiWay == CheckHiWay) $
  102. errorOnMismatch "mismatched interface file ways" way_descr check_way
  103. -- Read the dictionary
  104. -- The next word in the file is a pointer to where the dictionary is
  105. -- (probably at the end of the file)
  106. dict_p <- Binary.get bh
  107. data_p <- tellBin bh -- Remember where we are now
  108. seekBin bh dict_p
  109. dict <- getDictionary bh
  110. seekBin bh data_p -- Back to where we were before
  111. -- Initialise the user-data field of bh
  112. ud <- newReadState dict
  113. bh <- return (setUserData bh ud)
  114. symtab_p <- Binary.get bh -- Get the symtab ptr
  115. data_p <- tellBin bh -- Remember where we are now
  116. seekBin bh symtab_p
  117. symtab <- getSymbolTable bh update_nc
  118. seekBin bh data_p -- Back to where we were before
  119. let ud = getUserData bh
  120. bh <- return $! setUserData bh ud{ud_symtab = symtab}
  121. iface <- get bh
  122. return iface
  123. writeBinIface :: DynFlags -> FilePath -> ModIface -> IO ()
  124. writeBinIface dflags hi_path mod_iface = do
  125. bh <- openBinMem initBinMemSize
  126. put_ bh binaryInterfaceMagic
  127. -- dummy 32/64-bit field before the version/way for
  128. -- compatibility with older interface file formats.
  129. -- See Note [dummy iface field] above.
  130. if wORD_SIZE == 4
  131. then Binary.put_ bh (0 :: Word32)
  132. else Binary.put_ bh (0 :: Word64)
  133. -- The version and way descriptor go next
  134. put_ bh (show opt_HiVersion)
  135. let way_descr = getWayDescr dflags
  136. put_ bh way_descr
  137. -- Remember where the dictionary pointer will go
  138. dict_p_p <- tellBin bh
  139. put_ bh dict_p_p -- Placeholder for ptr to dictionary
  140. -- Remember where the symbol table pointer will go
  141. symtab_p_p <- tellBin bh
  142. put_ bh symtab_p_p
  143. -- Make some intial state
  144. symtab_next <- newFastMutInt
  145. writeFastMutInt symtab_next 0
  146. symtab_map <- newIORef emptyUFM
  147. let bin_symtab = BinSymbolTable {
  148. bin_symtab_next = symtab_next,
  149. bin_symtab_map = symtab_map }
  150. dict_next_ref <- newFastMutInt
  151. writeFastMutInt dict_next_ref 0
  152. dict_map_ref <- newIORef emptyUFM
  153. let bin_dict = BinDictionary {
  154. bin_dict_next = dict_next_ref,
  155. bin_dict_map = dict_map_ref }
  156. ud <- newWriteState (putName bin_symtab) (putFastString bin_dict)
  157. -- Put the main thing,
  158. bh <- return $ setUserData bh ud
  159. put_ bh mod_iface
  160. -- Write the symtab pointer at the fornt of the file
  161. symtab_p <- tellBin bh -- This is where the symtab will start
  162. putAt bh symtab_p_p symtab_p -- Fill in the placeholder
  163. seekBin bh symtab_p -- Seek back to the end of the file
  164. -- Write the symbol table itself
  165. symtab_next <- readFastMutInt symtab_next
  166. symtab_map <- readIORef symtab_map
  167. putSymbolTable bh symtab_next symtab_map
  168. debugTraceMsg dflags 3 (text "writeBinIface:" <+> int symtab_next
  169. <+> text "Names")
  170. -- NB. write the dictionary after the symbol table, because
  171. -- writing the symbol table may create more dictionary entries.
  172. -- Write the dictionary pointer at the fornt of the file
  173. dict_p <- tellBin bh -- This is where the dictionary will start
  174. putAt bh dict_p_p dict_p -- Fill in the placeholder
  175. seekBin bh dict_p -- Seek back to the end of the file
  176. -- Write the dictionary itself
  177. dict_next <- readFastMutInt dict_next_ref
  178. dict_map <- readIORef dict_map_ref
  179. putDictionary bh dict_next dict_map
  180. debugTraceMsg dflags 3 (text "writeBinIface:" <+> int dict_next
  181. <+> text "dict entries")
  182. -- And send the result to the file
  183. writeBinMem bh hi_path
  184. initBinMemSize :: Int
  185. initBinMemSize = 1024 * 1024
  186. -- The *host* architecture version:
  187. #include "../includes/MachDeps.h"
  188. binaryInterfaceMagic :: Word32
  189. #if WORD_SIZE_IN_BITS == 32
  190. binaryInterfaceMagic = 0x1face
  191. #elif WORD_SIZE_IN_BITS == 64
  192. binaryInterfaceMagic = 0x1face64
  193. #endif
  194. -- -----------------------------------------------------------------------------
  195. -- The symbol table
  196. putSymbolTable :: BinHandle -> Int -> UniqFM (Int,Name) -> IO ()
  197. putSymbolTable bh next_off symtab = do
  198. put_ bh next_off
  199. let names = elems (array (0,next_off-1) (eltsUFM symtab))
  200. mapM_ (\n -> serialiseName bh n symtab) names
  201. getSymbolTable :: BinHandle -> NameCacheUpdater (Array Int Name)
  202. -> IO (Array Int Name)
  203. getSymbolTable bh update_namecache = do
  204. sz <- get bh
  205. od_names <- sequence (replicate sz (get bh))
  206. update_namecache $ \namecache ->
  207. let
  208. arr = listArray (0,sz-1) names
  209. (namecache', names) =
  210. mapAccumR (fromOnDiskName arr) namecache od_names
  211. in (namecache', arr)
  212. type OnDiskName = (PackageId, ModuleName, OccName)
  213. fromOnDiskName
  214. :: Array Int Name
  215. -> NameCache
  216. -> OnDiskName
  217. -> (NameCache, Name)
  218. fromOnDiskName _ nc (pid, mod_name, occ) =
  219. let
  220. mod = mkModule pid mod_name
  221. cache = nsNames nc
  222. in
  223. case lookupOrigNameCache cache mod occ of
  224. Just name -> (nc, name)
  225. Nothing ->
  226. let
  227. us = nsUniqs nc
  228. uniq = uniqFromSupply us
  229. name = mkExternalName uniq mod occ noSrcSpan
  230. new_cache = extendNameCache cache mod occ name
  231. in
  232. case splitUniqSupply us of { (us',_) ->
  233. ( nc{ nsUniqs = us', nsNames = new_cache }, name )
  234. }
  235. serialiseName :: BinHandle -> Name -> UniqFM (Int,Name) -> IO ()
  236. serialiseName bh name _ = do
  237. let mod = ASSERT2( isExternalName name, ppr name ) nameModule name
  238. put_ bh (modulePackageId mod, moduleName mod, nameOccName name)
  239. putName :: BinSymbolTable -> BinHandle -> Name -> IO ()
  240. putName BinSymbolTable{
  241. bin_symtab_map = symtab_map_ref,
  242. bin_symtab_next = symtab_next } bh name
  243. = do
  244. symtab_map <- readIORef symtab_map_ref
  245. case lookupUFM symtab_map name of
  246. Just (off,_) -> put_ bh (fromIntegral off :: Word32)
  247. Nothing -> do
  248. off <- readFastMutInt symtab_next
  249. writeFastMutInt symtab_next (off+1)
  250. writeIORef symtab_map_ref
  251. $! addToUFM symtab_map name (off,name)
  252. put_ bh (fromIntegral off :: Word32)
  253. data BinSymbolTable = BinSymbolTable {
  254. bin_symtab_next :: !FastMutInt, -- The next index to use
  255. bin_symtab_map :: !(IORef (UniqFM (Int,Name)))
  256. -- indexed by Name
  257. }
  258. putFastString :: BinDictionary -> BinHandle -> FastString -> IO ()
  259. putFastString BinDictionary { bin_dict_next = j_r,
  260. bin_dict_map = out_r} bh f
  261. = do
  262. out <- readIORef out_r
  263. let uniq = getUnique f
  264. case lookupUFM out uniq of
  265. Just (j, _) -> put_ bh (fromIntegral j :: Word32)
  266. Nothing -> do
  267. j <- readFastMutInt j_r
  268. put_ bh (fromIntegral j :: Word32)
  269. writeFastMutInt j_r (j + 1)
  270. writeIORef out_r $! addToUFM out uniq (j, f)
  271. data BinDictionary = BinDictionary {
  272. bin_dict_next :: !FastMutInt, -- The next index to use
  273. bin_dict_map :: !(IORef (UniqFM (Int,FastString)))
  274. -- indexed by FastString
  275. }
  276. -- -----------------------------------------------------------------------------
  277. -- All the binary instances
  278. -- BasicTypes
  279. {-! for IPName derive: Binary !-}
  280. {-! for Fixity derive: Binary !-}
  281. {-! for FixityDirection derive: Binary !-}
  282. {-! for Boxity derive: Binary !-}
  283. {-! for StrictnessMark derive: Binary !-}
  284. {-! for Activation derive: Binary !-}
  285. -- Demand
  286. {-! for Demand derive: Binary !-}
  287. {-! for Demands derive: Binary !-}
  288. {-! for DmdResult derive: Binary !-}
  289. {-! for StrictSig derive: Binary !-}
  290. -- Class
  291. {-! for DefMeth derive: Binary !-}
  292. -- HsTypes
  293. {-! for HsPred derive: Binary !-}
  294. {-! for HsType derive: Binary !-}
  295. {-! for TupCon derive: Binary !-}
  296. {-! for HsTyVarBndr derive: Binary !-}
  297. -- HsCore
  298. {-! for UfExpr derive: Binary !-}
  299. {-! for UfConAlt derive: Binary !-}
  300. {-! for UfBinding derive: Binary !-}
  301. {-! for UfBinder derive: Binary !-}
  302. {-! for HsIdInfo derive: Binary !-}
  303. {-! for UfNote derive: Binary !-}
  304. -- HsDecls
  305. {-! for ConDetails derive: Binary !-}
  306. {-! for BangType derive: Binary !-}
  307. -- CostCentre
  308. {-! for IsCafCC derive: Binary !-}
  309. {-! for IsDupdCC derive: Binary !-}
  310. {-! for CostCentre derive: Binary !-}
  311. -- ---------------------------------------------------------------------------
  312. -- Reading a binary interface into ParsedIface
  313. instance Binary ModIface where
  314. put_ bh (ModIface {
  315. mi_module = mod,
  316. mi_boot = is_boot,
  317. mi_iface_hash= iface_hash,
  318. mi_mod_hash = mod_hash,
  319. mi_orphan = orphan,
  320. mi_finsts = hasFamInsts,
  321. mi_deps = deps,
  322. mi_usages = usages,
  323. mi_exports = exports,
  324. mi_exp_hash = exp_hash,
  325. mi_fixities = fixities,
  326. mi_warns = warns,
  327. mi_anns = anns,
  328. mi_decls = decls,
  329. mi_insts = insts,
  330. mi_fam_insts = fam_insts,
  331. mi_rules = rules,
  332. mi_orphan_hash = orphan_hash,
  333. mi_vect_info = vect_info,
  334. mi_hpc = hpc_info }) = do
  335. put_ bh mod
  336. put_ bh is_boot
  337. put_ bh iface_hash
  338. put_ bh mod_hash
  339. put_ bh orphan
  340. put_ bh hasFamInsts
  341. lazyPut bh deps
  342. lazyPut bh usages
  343. put_ bh exports
  344. put_ bh exp_hash
  345. put_ bh fixities
  346. lazyPut bh warns
  347. lazyPut bh anns
  348. put_ bh decls
  349. put_ bh insts
  350. put_ bh fam_insts
  351. lazyPut bh rules
  352. put_ bh orphan_hash
  353. put_ bh vect_info
  354. put_ bh hpc_info
  355. get bh = do
  356. mod_name <- get bh
  357. is_boot <- get bh
  358. iface_hash <- get bh
  359. mod_hash <- get bh
  360. orphan <- get bh
  361. hasFamInsts <- get bh
  362. deps <- lazyGet bh
  363. usages <- {-# SCC "bin_usages" #-} lazyGet bh
  364. exports <- {-# SCC "bin_exports" #-} get bh
  365. exp_hash <- get bh
  366. fixities <- {-# SCC "bin_fixities" #-} get bh
  367. warns <- {-# SCC "bin_warns" #-} lazyGet bh
  368. anns <- {-# SCC "bin_anns" #-} lazyGet bh
  369. decls <- {-# SCC "bin_tycldecls" #-} get bh
  370. insts <- {-# SCC "bin_insts" #-} get bh
  371. fam_insts <- {-# SCC "bin_fam_insts" #-} get bh
  372. rules <- {-# SCC "bin_rules" #-} lazyGet bh
  373. orphan_hash <- get bh
  374. vect_info <- get bh
  375. hpc_info <- get bh
  376. return (ModIface {
  377. mi_module = mod_name,
  378. mi_boot = is_boot,
  379. mi_iface_hash = iface_hash,
  380. mi_mod_hash = mod_hash,
  381. mi_orphan = orphan,
  382. mi_finsts = hasFamInsts,
  383. mi_deps = deps,
  384. mi_usages = usages,
  385. mi_exports = exports,
  386. mi_exp_hash = exp_hash,
  387. mi_anns = anns,
  388. mi_fixities = fixities,
  389. mi_warns = warns,
  390. mi_decls = decls,
  391. mi_globals = Nothing,
  392. mi_insts = insts,
  393. mi_fam_insts = fam_insts,
  394. mi_rules = rules,
  395. mi_orphan_hash = orphan_hash,
  396. mi_vect_info = vect_info,
  397. mi_hpc = hpc_info,
  398. -- And build the cached values
  399. mi_warn_fn = mkIfaceWarnCache warns,
  400. mi_fix_fn = mkIfaceFixCache fixities,
  401. mi_hash_fn = mkIfaceHashCache decls })
  402. getWayDescr :: DynFlags -> String
  403. getWayDescr dflags
  404. | cGhcUnregisterised == "YES" = 'u':tag
  405. | otherwise = tag
  406. where tag = buildTag dflags
  407. -- if this is an unregisterised build, make sure our interfaces
  408. -- can't be used by a registerised build.
  409. -------------------------------------------------------------------------
  410. -- Types from: HscTypes
  411. -------------------------------------------------------------------------
  412. instance Binary Dependencies where
  413. put_ bh deps = do put_ bh (dep_mods deps)
  414. put_ bh (dep_pkgs deps)
  415. put_ bh (dep_orphs deps)
  416. put_ bh (dep_finsts deps)
  417. get bh = do ms <- get bh
  418. ps <- get bh
  419. os <- get bh
  420. fis <- get bh
  421. return (Deps { dep_mods = ms, dep_pkgs = ps, dep_orphs = os,
  422. dep_finsts = fis })
  423. instance (Binary name) => Binary (GenAvailInfo name) where
  424. put_ bh (Avail aa) = do
  425. putByte bh 0
  426. put_ bh aa
  427. put_ bh (AvailTC ab ac) = do
  428. putByte bh 1
  429. put_ bh ab
  430. put_ bh ac
  431. get bh = do
  432. h <- getByte bh
  433. case h of
  434. 0 -> do aa <- get bh
  435. return (Avail aa)
  436. _ -> do ab <- get bh
  437. ac <- get bh
  438. return (AvailTC ab ac)
  439. instance Binary Usage where
  440. put_ bh usg@UsagePackageModule{} = do
  441. putByte bh 0
  442. put_ bh (usg_mod usg)
  443. put_ bh (usg_mod_hash usg)
  444. put_ bh usg@UsageHomeModule{} = do
  445. putByte bh 1
  446. put_ bh (usg_mod_name usg)
  447. put_ bh (usg_mod_hash usg)
  448. put_ bh (usg_exports usg)
  449. put_ bh (usg_entities usg)
  450. get bh = do
  451. h <- getByte bh
  452. case h of
  453. 0 -> do
  454. nm <- get bh
  455. mod <- get bh
  456. return UsagePackageModule { usg_mod = nm, usg_mod_hash = mod }
  457. _ -> do
  458. nm <- get bh
  459. mod <- get bh
  460. exps <- get bh
  461. ents <- get bh
  462. return UsageHomeModule { usg_mod_name = nm, usg_mod_hash = mod,
  463. usg_exports = exps, usg_entities = ents }
  464. instance Binary Warnings where
  465. put_ bh NoWarnings = putByte bh 0
  466. put_ bh (WarnAll t) = do
  467. putByte bh 1
  468. put_ bh t
  469. put_ bh (WarnSome ts) = do
  470. putByte bh 2
  471. put_ bh ts
  472. get bh = do
  473. h <- getByte bh
  474. case h of
  475. 0 -> return NoWarnings
  476. 1 -> do aa <- get bh
  477. return (WarnAll aa)
  478. _ -> do aa <- get bh
  479. return (WarnSome aa)
  480. instance Binary WarningTxt where
  481. put_ bh (WarningTxt w) = do
  482. putByte bh 0
  483. put_ bh w
  484. put_ bh (DeprecatedTxt d) = do
  485. putByte bh 1
  486. put_ bh d
  487. get bh = do
  488. h <- getByte bh
  489. case h of
  490. 0 -> do w <- get bh
  491. return (WarningTxt w)
  492. _ -> do d <- get bh
  493. return (DeprecatedTxt d)
  494. -------------------------------------------------------------------------
  495. -- Types from: BasicTypes
  496. -------------------------------------------------------------------------
  497. instance Binary Activation where
  498. put_ bh NeverActive = do
  499. putByte bh 0
  500. put_ bh AlwaysActive = do
  501. putByte bh 1
  502. put_ bh (ActiveBefore aa) = do
  503. putByte bh 2
  504. put_ bh aa
  505. put_ bh (ActiveAfter ab) = do
  506. putByte bh 3
  507. put_ bh ab
  508. get bh = do
  509. h <- getByte bh
  510. case h of
  511. 0 -> do return NeverActive
  512. 1 -> do return AlwaysActive
  513. 2 -> do aa <- get bh
  514. return (ActiveBefore aa)
  515. _ -> do ab <- get bh
  516. return (ActiveAfter ab)
  517. instance Binary RuleMatchInfo where
  518. put_ bh FunLike = putByte bh 0
  519. put_ bh ConLike = putByte bh 1
  520. get bh = do
  521. h <- getByte bh
  522. if h == 1 then return ConLike
  523. else return FunLike
  524. instance Binary InlinePragma where
  525. put_ bh (InlinePragma a b c d) = do
  526. put_ bh a
  527. put_ bh b
  528. put_ bh c
  529. put_ bh d
  530. get bh = do
  531. a <- get bh
  532. b <- get bh
  533. c <- get bh
  534. d <- get bh
  535. return (InlinePragma a b c d)
  536. instance Binary InlineSpec where
  537. put_ bh EmptyInlineSpec = putByte bh 0
  538. put_ bh Inline = putByte bh 1
  539. put_ bh Inlinable = putByte bh 2
  540. put_ bh NoInline = putByte bh 3
  541. get bh = do h <- getByte bh
  542. case h of
  543. 0 -> return EmptyInlineSpec
  544. 1 -> return Inline
  545. 2 -> return Inlinable
  546. _ -> return NoInline
  547. instance Binary HsBang where
  548. put_ bh HsNoBang = putByte bh 0
  549. put_ bh HsStrict = putByte bh 1
  550. put_ bh HsUnpack = putByte bh 2
  551. put_ bh HsUnpackFailed = putByte bh 3
  552. get bh = do
  553. h <- getByte bh
  554. case h of
  555. 0 -> do return HsNoBang
  556. 1 -> do return HsStrict
  557. 2 -> do return HsUnpack
  558. _ -> do return HsUnpackFailed
  559. instance Binary Boxity where
  560. put_ bh Boxed = putByte bh 0
  561. put_ bh Unboxed = putByte bh 1
  562. get bh = do
  563. h <- getByte bh
  564. case h of
  565. 0 -> do return Boxed
  566. _ -> do return Unboxed
  567. instance Binary TupCon where
  568. put_ bh (TupCon ab ac) = do
  569. put_ bh ab
  570. put_ bh ac
  571. get bh = do
  572. ab <- get bh
  573. ac <- get bh
  574. return (TupCon ab ac)
  575. instance Binary RecFlag where
  576. put_ bh Recursive = do
  577. putByte bh 0
  578. put_ bh NonRecursive = do
  579. putByte bh 1
  580. get bh = do
  581. h <- getByte bh
  582. case h of
  583. 0 -> do return Recursive
  584. _ -> do return NonRecursive
  585. instance Binary DefMethSpec where
  586. put_ bh NoDM = putByte bh 0
  587. put_ bh VanillaDM = putByte bh 1
  588. put_ bh GenericDM = putByte bh 2
  589. get bh = do
  590. h <- getByte bh
  591. case h of
  592. 0 -> return NoDM
  593. 1 -> return VanillaDM
  594. _ -> return GenericDM
  595. instance Binary FixityDirection where
  596. put_ bh InfixL = do
  597. putByte bh 0
  598. put_ bh InfixR = do
  599. putByte bh 1
  600. put_ bh InfixN = do
  601. putByte bh 2
  602. get bh = do
  603. h <- getByte bh
  604. case h of
  605. 0 -> do return InfixL
  606. 1 -> do return InfixR
  607. _ -> do return InfixN
  608. instance Binary Fixity where
  609. put_ bh (Fixity aa ab) = do
  610. put_ bh aa
  611. put_ bh ab
  612. get bh = do
  613. aa <- get bh
  614. ab <- get bh
  615. return (Fixity aa ab)
  616. instance (Binary name) => Binary (IPName name) where
  617. put_ bh (IPName aa) = put_ bh aa
  618. get bh = do aa <- get bh
  619. return (IPName aa)
  620. -------------------------------------------------------------------------
  621. -- Types from: Demand
  622. -------------------------------------------------------------------------
  623. instance Binary DmdType where
  624. -- Ignore DmdEnv when spitting out the DmdType
  625. put bh (DmdType _ ds dr) = do p <- put bh ds; put_ bh dr; return (castBin p)
  626. get bh = do ds <- get bh; dr <- get bh; return (DmdType emptyVarEnv ds dr)
  627. instance Binary Demand where
  628. put_ bh Top = do
  629. putByte bh 0
  630. put_ bh Abs = do
  631. putByte bh 1
  632. put_ bh (Call aa) = do
  633. putByte bh 2
  634. put_ bh aa
  635. put_ bh (Eval ab) = do
  636. putByte bh 3
  637. put_ bh ab
  638. put_ bh (Defer ac) = do
  639. putByte bh 4
  640. put_ bh ac
  641. put_ bh (Box ad) = do
  642. putByte bh 5
  643. put_ bh ad
  644. put_ bh Bot = do
  645. putByte bh 6
  646. get bh = do
  647. h <- getByte bh
  648. case h of
  649. 0 -> do return Top
  650. 1 -> do return Abs
  651. 2 -> do aa <- get bh
  652. return (Call aa)
  653. 3 -> do ab <- get bh
  654. return (Eval ab)
  655. 4 -> do ac <- get bh
  656. return (Defer ac)
  657. 5 -> do ad <- get bh
  658. return (Box ad)
  659. _ -> do return Bot
  660. instance Binary Demands where
  661. put_ bh (Poly aa) = do
  662. putByte bh 0
  663. put_ bh aa
  664. put_ bh (Prod ab) = do
  665. putByte bh 1
  666. put_ bh ab
  667. get bh = do
  668. h <- getByte bh
  669. case h of
  670. 0 -> do aa <- get bh
  671. return (Poly aa)
  672. _ -> do ab <- get bh
  673. return (Prod ab)
  674. instance Binary DmdResult where
  675. put_ bh TopRes = do
  676. putByte bh 0
  677. put_ bh RetCPR = do
  678. putByte bh 1
  679. put_ bh BotRes = do
  680. putByte bh 2
  681. get bh = do
  682. h <- getByte bh
  683. case h of
  684. 0 -> do return TopRes
  685. 1 -> do return RetCPR -- Really use RetCPR even if -fcpr-off
  686. -- The wrapper was generated for CPR in
  687. -- the imported module!
  688. _ -> do return BotRes
  689. instance Binary StrictSig where
  690. put_ bh (StrictSig aa) = do
  691. put_ bh aa
  692. get bh = do
  693. aa <- get bh
  694. return (StrictSig aa)
  695. -------------------------------------------------------------------------
  696. -- Types from: CostCentre
  697. -------------------------------------------------------------------------
  698. instance Binary IsCafCC where
  699. put_ bh CafCC = do
  700. putByte bh 0
  701. put_ bh NotCafCC = do
  702. putByte bh 1
  703. get bh = do
  704. h <- getByte bh
  705. case h of
  706. 0 -> do return CafCC
  707. _ -> do return NotCafCC
  708. instance Binary IsDupdCC where
  709. put_ bh OriginalCC = do
  710. putByte bh 0
  711. put_ bh DupdCC = do
  712. putByte bh 1
  713. get bh = do
  714. h <- getByte bh
  715. case h of
  716. 0 -> do return OriginalCC
  717. _ -> do return DupdCC
  718. instance Binary CostCentre where
  719. put_ bh NoCostCentre = do
  720. putByte bh 0
  721. put_ bh (NormalCC aa ab ac ad) = do
  722. putByte bh 1
  723. put_ bh aa
  724. put_ bh ab
  725. put_ bh ac
  726. put_ bh ad
  727. put_ bh (AllCafsCC ae) = do
  728. putByte bh 2
  729. put_ bh ae
  730. get bh = do
  731. h <- getByte bh
  732. case h of
  733. 0 -> do return NoCostCentre
  734. 1 -> do aa <- get bh
  735. ab <- get bh
  736. ac <- get bh
  737. ad <- get bh
  738. return (NormalCC aa ab ac ad)
  739. _ -> do ae <- get bh
  740. return (AllCafsCC ae)
  741. -------------------------------------------------------------------------
  742. -- IfaceTypes and friends
  743. -------------------------------------------------------------------------
  744. instance Binary IfaceBndr where
  745. put_ bh (IfaceIdBndr aa) = do
  746. putByte bh 0
  747. put_ bh aa
  748. put_ bh (IfaceTvBndr ab) = do
  749. putByte bh 1
  750. put_ bh ab
  751. get bh = do
  752. h <- getByte bh
  753. case h of
  754. 0 -> do aa <- get bh
  755. return (IfaceIdBndr aa)
  756. _ -> do ab <- get bh
  757. return (IfaceTvBndr ab)
  758. instance Binary IfaceLetBndr where
  759. put_ bh (IfLetBndr a b c) = do
  760. put_ bh a
  761. put_ bh b
  762. put_ bh c
  763. get bh = do a <- get bh
  764. b <- get bh
  765. c <- get bh
  766. return (IfLetBndr a b c)
  767. instance Binary IfaceType where
  768. put_ bh (IfaceForAllTy aa ab) = do
  769. putByte bh 0
  770. put_ bh aa
  771. put_ bh ab
  772. put_ bh (IfaceTyVar ad) = do
  773. putByte bh 1
  774. put_ bh ad
  775. put_ bh (IfaceAppTy ae af) = do
  776. putByte bh 2
  777. put_ bh ae
  778. put_ bh af
  779. put_ bh (IfaceFunTy ag ah) = do
  780. putByte bh 3
  781. put_ bh ag
  782. put_ bh ah
  783. put_ bh (IfacePredTy aq) = do
  784. putByte bh 5
  785. put_ bh aq
  786. -- Simple compression for common cases of TyConApp
  787. put_ bh (IfaceTyConApp IfaceIntTc []) = putByte bh 6
  788. put_ bh (IfaceTyConApp IfaceCharTc []) = putByte bh 7
  789. put_ bh (IfaceTyConApp IfaceBoolTc []) = putByte bh 8
  790. put_ bh (IfaceTyConApp IfaceListTc [ty]) = do { putByte bh 9; put_ bh ty }
  791. -- Unit tuple and pairs
  792. put_ bh (IfaceTyConApp (IfaceTupTc Boxed 0) []) = putByte bh 10
  793. put_ bh (IfaceTyConApp (IfaceTupTc Boxed 2) [t1,t2]) = do { putByte bh 11; put_ bh t1; put_ bh t2 }
  794. -- Kind cases
  795. put_ bh (IfaceTyConApp IfaceLiftedTypeKindTc []) = putByte bh 12
  796. put_ bh (IfaceTyConApp IfaceOpenTypeKindTc []) = putByte bh 13
  797. put_ bh (IfaceTyConApp IfaceUnliftedTypeKindTc []) = putByte bh 14
  798. put_ bh (IfaceTyConApp IfaceUbxTupleKindTc []) = putByte bh 15
  799. put_ bh (IfaceTyConApp IfaceArgTypeKindTc []) = putByte bh 16
  800. put_ bh (IfaceTyConApp (IfaceAnyTc k) []) = do { putByte bh 17; put_ bh k }
  801. -- Generic cases
  802. put_ bh (IfaceTyConApp (IfaceTc tc) tys) = do { putByte bh 18; put_ bh tc; put_ bh tys }
  803. put_ bh (IfaceTyConApp tc tys) = do { putByte bh 19; put_ bh tc; put_ bh tys }
  804. get bh = do
  805. h <- getByte bh
  806. case h of
  807. 0 -> do aa <- get bh
  808. ab <- get bh
  809. return (IfaceForAllTy aa ab)
  810. 1 -> do ad <- get bh
  811. return (IfaceTyVar ad)
  812. 2 -> do ae <- get bh
  813. af <- get bh
  814. return (IfaceAppTy ae af)
  815. 3 -> do ag <- get bh
  816. ah <- get bh
  817. return (IfaceFunTy ag ah)
  818. 5 -> do ap <- get bh
  819. return (IfacePredTy ap)
  820. -- Now the special cases for TyConApp
  821. 6 -> return (IfaceTyConApp IfaceIntTc [])
  822. 7 -> return (IfaceTyConApp IfaceCharTc [])
  823. 8 -> return (IfaceTyConApp IfaceBoolTc [])
  824. 9 -> do { ty <- get bh; return (IfaceTyConApp IfaceListTc [ty]) }
  825. 10 -> return (IfaceTyConApp (IfaceTupTc Boxed 0) [])
  826. 11 -> do { t1 <- get bh; t2 <- get bh; return (IfaceTyConApp (IfaceTupTc Boxed 2) [t1,t2]) }
  827. 12 -> return (IfaceTyConApp IfaceLiftedTypeKindTc [])
  828. 13 -> return (IfaceTyConApp IfaceOpenTypeKindTc [])
  829. 14 -> return (IfaceTyConApp IfaceUnliftedTypeKindTc [])
  830. 15 -> return (IfaceTyConApp IfaceUbxTupleKindTc [])
  831. 16 -> return (IfaceTyConApp IfaceArgTypeKindTc [])
  832. 17 -> do { k <- get bh; return (IfaceTyConApp (IfaceAnyTc k) []) }
  833. 18 -> do { tc <- get bh; tys <- get bh; return (IfaceTyConApp (IfaceTc tc) tys) }
  834. _ -> do { tc <- get bh; tys <- get bh; return (IfaceTyConApp tc tys) }
  835. instance Binary IfaceTyCon where
  836. -- Int,Char,Bool can't show up here because they can't not be saturated
  837. put_ bh IfaceIntTc = putByte bh 1
  838. put_ bh IfaceBoolTc = putByte bh 2
  839. put_ bh IfaceCharTc = putByte bh 3
  840. put_ bh IfaceListTc = putByte bh 4
  841. put_ bh IfacePArrTc = putByte bh 5
  842. put_ bh IfaceLiftedTypeKindTc = putByte bh 6
  843. put_ bh IfaceOpenTypeKindTc = putByte bh 7
  844. put_ bh IfaceUnliftedTypeKindTc = putByte bh 8
  845. put_ bh IfaceUbxTupleKindTc = putByte bh 9
  846. put_ bh IfaceArgTypeKindTc = putByte bh 10
  847. put_ bh (IfaceTupTc bx ar) = do { putByte bh 11; put_ bh bx; put_ bh ar }
  848. put_ bh (IfaceTc ext) = do { putByte bh 12; put_ bh ext }
  849. put_ bh (IfaceAnyTc k) = do { putByte bh 13; put_ bh k }
  850. get bh = do
  851. h <- getByte bh
  852. case h of
  853. 1 -> return IfaceIntTc
  854. 2 -> return IfaceBoolTc
  855. 3 -> return IfaceCharTc
  856. 4 -> return IfaceListTc
  857. 5 -> return IfacePArrTc
  858. 6 -> return IfaceLiftedTypeKindTc
  859. 7 -> return IfaceOpenTypeKindTc
  860. 8 -> return IfaceUnliftedTypeKindTc
  861. 9 -> return IfaceUbxTupleKindTc
  862. 10 -> return IfaceArgTypeKindTc
  863. 11 -> do { bx <- get bh; ar <- get bh; return (IfaceTupTc bx ar) }
  864. 12 -> do { ext <- get bh; return (IfaceTc ext) }
  865. _ -> do { k <- get bh; return (IfaceAnyTc k) }
  866. instance Binary IfacePredType where
  867. put_ bh (IfaceClassP aa ab) = do
  868. putByte bh 0
  869. put_ bh aa
  870. put_ bh ab
  871. put_ bh (IfaceIParam ac ad) = do
  872. putByte bh 1
  873. put_ bh ac
  874. put_ bh ad
  875. put_ bh (IfaceEqPred ac ad) = do
  876. putByte bh 2
  877. put_ bh ac
  878. put_ bh ad
  879. get bh = do
  880. h <- getByte bh
  881. case h of
  882. 0 -> do aa <- get bh
  883. ab <- get bh
  884. return (IfaceClassP aa ab)
  885. 1 -> do ac <- get bh
  886. ad <- get bh
  887. return (IfaceIParam ac ad)
  888. 2 -> do ac <- get bh
  889. ad <- get bh
  890. return (IfaceEqPred ac ad)
  891. _ -> panic ("get IfacePredType " ++ show h)
  892. -------------------------------------------------------------------------
  893. -- IfaceExpr and friends
  894. -------------------------------------------------------------------------
  895. instance Binary IfaceExpr where
  896. put_ bh (IfaceLcl aa) = do
  897. putByte bh 0
  898. put_ bh aa
  899. put_ bh (IfaceType ab) = do
  900. putByte bh 1
  901. put_ bh ab
  902. put_ bh (IfaceTuple ac ad) = do
  903. putByte bh 2
  904. put_ bh ac
  905. put_ bh ad
  906. put_ bh (IfaceLam ae af) = do
  907. putByte bh 3
  908. put_ bh ae
  909. put_ bh af
  910. put_ bh (IfaceApp ag ah) = do
  911. putByte bh 4
  912. put_ bh ag
  913. put_ bh ah
  914. -- gaw 2004
  915. put_ bh (IfaceCase ai aj al ak) = do
  916. putByte bh 5
  917. put_ bh ai
  918. put_ bh aj
  919. -- gaw 2004
  920. put_ bh al
  921. put_ bh ak
  922. put_ bh (IfaceLet al am) = do
  923. putByte bh 6
  924. put_ bh al
  925. put_ bh am
  926. put_ bh (IfaceNote an ao) = do
  927. putByte bh 7
  928. put_ bh an
  929. put_ bh ao
  930. put_ bh (IfaceLit ap) = do
  931. putByte bh 8
  932. put_ bh ap
  933. put_ bh (IfaceFCall as at) = do
  934. putByte bh 9
  935. put_ bh as
  936. put_ bh at
  937. put_ bh (IfaceExt aa) = do
  938. putByte bh 10
  939. put_ bh aa
  940. put_ bh (IfaceCast ie ico) = do
  941. putByte bh 11
  942. put_ bh ie
  943. put_ bh ico
  944. put_ bh (IfaceTick m ix) = do
  945. putByte bh 12
  946. put_ bh m
  947. put_ bh ix
  948. get bh = do
  949. h <- getByte bh
  950. case h of
  951. 0 -> do aa <- get bh
  952. return (IfaceLcl aa)
  953. 1 -> do ab <- get bh
  954. return (IfaceType ab)
  955. 2 -> do ac <- get bh
  956. ad <- get bh
  957. return (IfaceTuple ac ad)
  958. 3 -> do ae <- get bh
  959. af <- get bh
  960. return (IfaceLam ae af)
  961. 4 -> do ag <- get bh
  962. ah <- get bh
  963. return (IfaceApp ag ah)
  964. 5 -> do ai <- get bh
  965. aj <- get bh
  966. -- gaw 2004
  967. al <- get bh
  968. ak <- get bh
  969. -- gaw 2004
  970. return (IfaceCase ai aj al ak)
  971. 6 -> do al <- get bh
  972. am <- get bh
  973. return (IfaceLet al am)
  974. 7 -> do an <- get bh
  975. ao <- get bh
  976. return (IfaceNote an ao)
  977. 8 -> do ap <- get bh
  978. return (IfaceLit ap)
  979. 9 -> do as <- get bh
  980. at <- get bh
  981. return (IfaceFCall as at)
  982. 10 -> do aa <- get bh
  983. return (IfaceExt aa)
  984. 11 -> do ie <- get bh
  985. ico <- get bh
  986. return (IfaceCast ie ico)
  987. 12 -> do m <- get bh
  988. ix <- get bh
  989. return (IfaceTick m ix)
  990. _ -> panic ("get IfaceExpr " ++ show h)
  991. instance Binary IfaceConAlt where
  992. put_ bh IfaceDefault = do
  993. putByte bh 0
  994. put_ bh (IfaceDataAlt aa) = do
  995. putByte bh 1
  996. put_ bh aa
  997. put_ bh (IfaceTupleAlt ab) = do
  998. putByte bh 2
  999. put_ bh ab
  1000. put_ bh (IfaceLitAlt ac) = do
  1001. putByte bh 3
  1002. put_ bh ac
  1003. get bh = do
  1004. h <- getByte bh
  1005. case h of
  1006. 0 -> do return IfaceDefault
  1007. 1 -> do aa <- get bh
  1008. return (IfaceDataAlt aa)
  1009. 2 -> do ab <- get bh
  1010. return (IfaceTupleAlt ab)
  1011. _ -> do ac <- get bh
  1012. return (IfaceLitAlt ac)
  1013. instance Binary IfaceBinding where
  1014. put_ bh (IfaceNonRec aa ab) = do
  1015. putByte bh 0
  1016. put_ bh aa
  1017. put_ bh ab
  1018. put_ bh (IfaceRec ac) = do
  1019. putByte bh 1
  1020. put_ bh ac
  1021. get bh = do
  1022. h <- getByte bh
  1023. case h of
  1024. 0 -> do aa <- get bh
  1025. ab <- get bh
  1026. return (IfaceNonRec aa ab)
  1027. _ -> do ac <- get bh
  1028. return (IfaceRec ac)
  1029. instance Binary IfaceIdDetails where
  1030. put_ bh IfVanillaId = putByte bh 0
  1031. put_ bh (IfRecSelId a b) = do { putByte bh 1; put_ bh a; put_ bh b }
  1032. put_ bh (IfDFunId n) = do { putByte bh 2; put_ bh n }
  1033. get bh = do
  1034. h <- getByte bh
  1035. case h of
  1036. 0 -> return IfVanillaId
  1037. 1 -> do a <- get bh
  1038. b <- get bh
  1039. return (IfRecSelId a b)
  1040. _ -> do { n <- get bh; return (IfDFunId n) }
  1041. instance Binary IfaceIdInfo where
  1042. put_ bh NoInfo = putByte bh 0
  1043. put_ bh (HasInfo i) = do
  1044. putByte bh 1
  1045. lazyPut bh i -- NB lazyPut
  1046. get bh = do
  1047. h <- getByte bh
  1048. case h of
  1049. 0 -> return NoInfo
  1050. _ -> do info <- lazyGet bh -- NB lazyGet
  1051. return (HasInfo info)
  1052. instance Binary IfaceInfoItem where
  1053. put_ bh (HsArity aa) = do
  1054. putByte bh 0
  1055. put_ bh aa
  1056. put_ bh (HsStrictness ab) = do
  1057. putByte bh 1
  1058. put_ bh ab
  1059. put_ bh (HsUnfold lb ad) = do
  1060. putByte bh 2
  1061. put_ bh lb
  1062. put_ bh ad
  1063. put_ bh (HsInline ad) = do
  1064. putByte bh 3
  1065. put_ bh ad
  1066. put_ bh HsNoCafRefs = do
  1067. putByte bh 4
  1068. get bh = do
  1069. h <- getByte bh
  1070. case h of
  1071. 0 -> do aa <- get bh
  1072. return (HsArity aa)
  1073. 1 -> do ab <- get bh
  1074. return (HsStrictness ab)
  1075. 2 -> do lb <- get bh
  1076. ad <- get bh
  1077. return (HsUnfold lb ad)
  1078. 3 -> do ad <- get bh
  1079. return (HsInline ad)
  1080. _ -> do return HsNoCafRefs
  1081. instance Binary IfaceUnfolding where
  1082. put_ bh (IfCoreUnfold s e) = do
  1083. putByte bh 0
  1084. put_ bh s
  1085. put_ bh e
  1086. put_ bh (IfInlineRule a b c d) = do
  1087. putByte bh 1
  1088. put_ bh a
  1089. put_ bh b
  1090. put_ bh c
  1091. put_ bh d
  1092. put_ bh (IfLclWrapper a n) = do
  1093. putByte bh 2
  1094. put_ bh a
  1095. put_ bh n
  1096. put_ bh (IfExtWrapper a n) = do
  1097. putByte bh 3
  1098. put_ bh a
  1099. put_ bh n
  1100. put_ bh (IfDFunUnfold as) = do
  1101. putByte bh 4
  1102. put_ bh as
  1103. put_ bh (IfCompulsory e) = do
  1104. putByte bh 5
  1105. put_ bh e
  1106. get bh = do
  1107. h <- getByte bh
  1108. case h of
  1109. 0 -> do s <- get bh
  1110. e <- get bh
  1111. return (IfCoreUnfold s e)
  1112. 1 -> do a <- get bh
  1113. b <- get bh
  1114. c <- get bh
  1115. d <- get bh
  1116. return (IfInlineRule a b c d)
  1117. 2 -> do a <- get bh
  1118. n <- get bh
  1119. return (IfLclWrapper a n)
  1120. 3 -> do a <- get bh
  1121. n <- get bh
  1122. return (IfExtWrapper a n)
  1123. 4 -> do as <- get bh
  1124. return (IfDFunUnfold as)
  1125. _ -> do e <- get bh
  1126. return (IfCompulsory e)
  1127. instance Binary (DFunArg IfaceExpr) where
  1128. put_ bh (DFunPolyArg e) = putByte bh 0 >> put_ bh e
  1129. put_ bh (DFunConstArg e) = putByte bh 1 >> put_ bh e
  1130. put_ bh (DFunLamArg i) = putByte bh 2 >> put_ bh i
  1131. get bh = do { h <- getByte bh
  1132. ; case h of
  1133. 0 -> do { a <- get bh; return (DFunPolyArg a) }
  1134. 1 -> do { a <- get bh; return (DFunConstArg a) }
  1135. _ -> do { a <- get bh; return (DFunLamArg a) } }
  1136. instance Binary IfaceNote where
  1137. put_ bh (IfaceSCC aa) = do
  1138. putByte bh 0
  1139. put_ bh aa
  1140. put_ bh (IfaceCoreNote s) = do
  1141. putByte bh 4
  1142. put_ bh s
  1143. get bh = do
  1144. h <- getByte bh
  1145. case h of
  1146. 0 -> do aa <- get bh
  1147. return (IfaceSCC aa)
  1148. 4 -> do ac <- get bh
  1149. return (IfaceCoreNote ac)
  1150. _ -> panic ("get IfaceNote " ++ show h)
  1151. -------------------------------------------------------------------------
  1152. -- IfaceDecl and friends
  1153. -------------------------------------------------------------------------
  1154. -- A bit of magic going on here: there's no need to store the OccName
  1155. -- for a decl on the disk, since we can infer the namespace from the
  1156. -- context; however it is useful to have the OccName in the IfaceDecl
  1157. -- to avoid re-building it in various places. So we build the OccName
  1158. -- when de-serialising.
  1159. instance Binary IfaceDecl where
  1160. put_ bh (IfaceId name ty details idinfo) = do
  1161. putByte bh 0
  1162. put_ bh (occNameFS name)
  1163. put_ bh ty
  1164. put_ bh details
  1165. put_ bh idinfo
  1166. put_ _ (IfaceForeign _ _) =
  1167. error "Binary.put_(IfaceDecl): IfaceForeign"
  1168. put_ bh (IfaceData a1 a2 a3 a4 a5 a6 a7 a8) = do
  1169. putByte bh 2
  1170. put_ bh (occNameFS a1)
  1171. put_ bh a2
  1172. put_ bh a3
  1173. put_ bh a4
  1174. put_ bh a5
  1175. put_ bh a6
  1176. put_ bh a7
  1177. put_ bh a8
  1178. put_ bh (IfaceSyn a1 a2 a3 a4 a5) = do
  1179. putByte bh 3
  1180. put_ bh (occNameFS a1)
  1181. put_ bh a2
  1182. put_ bh a3
  1183. put_ bh a4
  1184. put_ bh a5
  1185. put_ bh (IfaceClass a1 a2 a3 a4 a5 a6 a7) = do
  1186. putByte bh 4
  1187. put_ bh a1
  1188. put_ bh (occNameFS a2)
  1189. put_ bh a3
  1190. put_ bh a4
  1191. put_ bh a5
  1192. put_ bh a6
  1193. put_ bh a7
  1194. get bh = do
  1195. h <- getByte bh
  1196. case h of
  1197. 0 -> do name <- get bh
  1198. ty <- get bh
  1199. details <- get bh
  1200. idinfo <- get bh
  1201. occ <- return $! mkOccNameFS varName name
  1202. return (IfaceId occ ty details idinfo)
  1203. 1 -> error "Binary.get(TyClDecl): ForeignType"
  1204. 2 -> do
  1205. a1 <- get bh
  1206. a2 <- get bh
  1207. a3 <- get bh
  1208. a4 <- get bh
  1209. a5 <- get bh
  1210. a6 <- get bh
  1211. a7 <- get bh
  1212. a8 <- get bh
  1213. occ <- return $! mkOccNameFS tcName a1
  1214. return (IfaceData occ a2 a3 a4 a5 a6 a7 a8)
  1215. 3 -> do
  1216. a1 <- get bh
  1217. a2 <- get bh
  1218. a3 <- get bh
  1219. a4 <- get bh
  1220. a5 <- get bh
  1221. occ <- return $! mkOccNameFS tcName a1
  1222. return (IfaceSyn occ a2 a3 a4 a5)
  1223. _ -> do
  1224. a1 <- get bh
  1225. a2 <- get bh
  1226. a3 <- get bh
  1227. a4 <- get bh
  1228. a5 <- get bh
  1229. a6 <- get bh
  1230. a7 <- get bh
  1231. occ <- return $! mkOccNameFS clsName a2
  1232. return (IfaceClass a1 occ a3 a4 a5 a6 a7)
  1233. instance Binary IfaceInst where
  1234. put_ bh (IfaceInst cls tys dfun flag orph) = do
  1235. put_ bh cls
  1236. put_ bh tys
  1237. put_ bh dfun
  1238. put_ bh flag
  1239. put_ bh orph
  1240. get bh = do cls <- get bh
  1241. tys <- get bh
  1242. dfun <- get bh
  1243. flag <- get bh
  1244. orph <- get bh
  1245. return (IfaceInst cls tys dfun flag orph)
  1246. instance Binary IfaceFamInst where
  1247. put_ bh (IfaceFamInst fam tys tycon) = do
  1248. put_ bh fam
  1249. put_ bh tys
  1250. put_ bh tycon
  1251. get bh = do fam <- get bh
  1252. tys <- get bh
  1253. tycon <- get bh
  1254. return (IfaceFamInst fam tys tycon)
  1255. instance Binary OverlapFlag where
  1256. put_ bh NoOverlap = putByte bh 0
  1257. put_ bh OverlapOk = putByte bh 1
  1258. put_ bh Incoherent = putByte bh 2
  1259. get bh = do h <- getByte bh
  1260. case h of
  1261. 0 -> return NoOverlap
  1262. 1 -> return OverlapOk
  1263. 2 -> return Incoherent
  1264. _ -> panic ("get OverlapFlag " ++ show h)
  1265. instance Binary IfaceConDecls where
  1266. put_ bh IfAbstractTyCon = putByte bh 0
  1267. put_ bh IfOpenDataTyCon = putByte bh 1
  1268. put_ bh (IfDataTyCon cs) = do { putByte bh 2
  1269. ; put_ bh cs }
  1270. put_ bh (IfNewTyCon c) = do { putByte bh 3
  1271. ; put_ bh c }
  1272. get bh = do
  1273. h <- getByte bh
  1274. case h of
  1275. 0 -> return IfAbstractTyCon
  1276. 1 -> return IfOpenDataTyCon
  1277. 2 -> do cs <- get bh
  1278. return (IfDataTyCon cs)
  1279. _ -> do aa <- get bh
  1280. return (IfNewTyCon aa)
  1281. instance Binary IfaceConDecl where
  1282. put_ bh (IfCon a1 a2 a3 a4 a5 a6 a7 a8 a9 a10) = do
  1283. put_ bh a1
  1284. put_ bh a2
  1285. put_ bh a3
  1286. put_ bh a4
  1287. put_ bh a5
  1288. put_ bh a6
  1289. put_ bh a7
  1290. put_ bh a8
  1291. put_ bh a9
  1292. put_ bh a10
  1293. get bh = do a1 <- get bh
  1294. a2 <- get bh
  1295. a3 <- get bh
  1296. a4 <- get bh
  1297. a5 <- get bh
  1298. a6 <- get bh
  1299. a7 <- get bh
  1300. a8 <- get bh
  1301. a9 <- get bh
  1302. a10 <- get bh
  1303. return (IfCon a1 a2 a3 a4 a5 a6 a7 a8 a9 a10)
  1304. instance Binary IfaceClassOp where
  1305. put_ bh (IfaceClassOp n def ty) = do
  1306. put_ bh (occNameFS n)
  1307. put_ bh def
  1308. put_ bh ty
  1309. get bh = do
  1310. n <- get bh
  1311. def <- get bh
  1312. ty <- get bh
  1313. occ <- return $! mkOccNameFS varName n
  1314. return (IfaceClassOp occ def ty)
  1315. instance Binary IfaceRule where
  1316. put_ bh (IfaceRule a1 a2 a3 a4 a5 a6 a7 a8) = do
  1317. put_ bh a1
  1318. put_ bh a2
  1319. put_ bh a3
  1320. put_ bh a4
  1321. put_ bh a5
  1322. put_ bh a6
  1323. put_ bh a7
  1324. put_ bh a8
  1325. get bh = do
  1326. a1 <- get bh
  1327. a2 <- get bh
  1328. a3 <- get bh
  1329. a4 <- get bh
  1330. a5 <- get bh
  1331. a6 <- get bh
  1332. a7 <- get bh
  1333. a8 <- get bh
  1334. return (IfaceRule a1 a2 a3 a4 a5 a6 a7 a8)
  1335. instance Binary IfaceAnnotation where
  1336. put_ bh (IfaceAnnotation a1 a2) = do
  1337. put_ bh a1
  1338. put_ bh a2
  1339. get bh = do
  1340. a1 <- get bh
  1341. a2 <- get bh
  1342. return (IfaceAnnotation a1 a2)
  1343. instance Binary name => Binary (AnnTarget name) where
  1344. put_ bh (NamedTarget a) = do
  1345. putByte bh 0
  1346. put_ bh a
  1347. put_ bh (ModuleTarget a) = do
  1348. putByte bh 1
  1349. put_ bh a
  1350. get bh = do
  1351. h <- getByte bh
  1352. case h of
  1353. 0 -> do a <- get bh
  1354. return (NamedTarget a)
  1355. _ -> do a <- get bh
  1356. return (ModuleTarget a)
  1357. instance Binary IfaceVectInfo where
  1358. put_ bh (IfaceVectInfo a1 a2 a3) = do
  1359. put_ bh a1
  1360. put_ bh a2
  1361. put_ bh a3
  1362. get bh = do
  1363. a1 <- get bh
  1364. a2 <- get bh
  1365. a3 <- get bh
  1366. return (IfaceVectInfo a1 a2 a3)