PageRenderTime 56ms CodeModel.GetById 21ms RepoModel.GetById 1ms app.codeStats 0ms

/compiler/iface/BinIface.hs

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