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