PageRenderTime 54ms CodeModel.GetById 12ms RepoModel.GetById 0ms app.codeStats 1ms

/compiler/iface/BinIface.hs

https://bitbucket.org/khibino/ghc-hack
Haskell | 1614 lines | 1299 code | 158 blank | 157 comment | 11 complexity | 94e393225be002d58e44f1c98a985d2d MD5 | raw file
Possible License(s): BSD-3-Clause, BSD-2-Clause, LGPL-3.0

Large files files are truncated, but you can click here to view the full file

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

Large files files are truncated, but you can click here to view the full file