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