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