42507d99015f5a4cac47b5eb53f7446e6919b463
[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_fixities = fixities,
384 mi_warns = warns,
385 mi_anns = anns,
386 mi_decls = decls,
387 mi_insts = insts,
388 mi_fam_insts = fam_insts,
389 mi_rules = rules,
390 mi_orphan_hash = orphan_hash,
391 mi_vect_info = vect_info,
392 mi_hpc = hpc_info,
393 mi_trust = trust,
394 mi_trust_pkg = trust_pkg }) = 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 put_ bh trust
416 put_ bh trust_pkg
417
418 get bh = do
419 mod_name <- get bh
420 is_boot <- get bh
421 iface_hash <- get bh
422 mod_hash <- get bh
423 orphan <- get bh
424 hasFamInsts <- get bh
425 deps <- lazyGet bh
426 usages <- {-# SCC "bin_usages" #-} lazyGet bh
427 exports <- {-# SCC "bin_exports" #-} get bh
428 exp_hash <- get bh
429 fixities <- {-# SCC "bin_fixities" #-} get bh
430 warns <- {-# SCC "bin_warns" #-} lazyGet bh
431 anns <- {-# SCC "bin_anns" #-} lazyGet bh
432 decls <- {-# SCC "bin_tycldecls" #-} get bh
433 insts <- {-# SCC "bin_insts" #-} get bh
434 fam_insts <- {-# SCC "bin_fam_insts" #-} get bh
435 rules <- {-# SCC "bin_rules" #-} lazyGet bh
436 orphan_hash <- get bh
437 vect_info <- get bh
438 hpc_info <- get bh
439 trust <- get bh
440 trust_pkg <- get bh
441 return (ModIface {
442 mi_module = mod_name,
443 mi_boot = is_boot,
444 mi_iface_hash = iface_hash,
445 mi_mod_hash = mod_hash,
446 mi_orphan = orphan,
447 mi_finsts = hasFamInsts,
448 mi_deps = deps,
449 mi_usages = usages,
450 mi_exports = exports,
451 mi_exp_hash = exp_hash,
452 mi_anns = anns,
453 mi_fixities = fixities,
454 mi_warns = warns,
455 mi_decls = decls,
456 mi_globals = Nothing,
457 mi_insts = insts,
458 mi_fam_insts = fam_insts,
459 mi_rules = rules,
460 mi_orphan_hash = orphan_hash,
461 mi_vect_info = vect_info,
462 mi_hpc = hpc_info,
463 mi_trust = trust,
464 mi_trust_pkg = trust_pkg,
465 -- And build the cached values
466 mi_warn_fn = mkIfaceWarnCache warns,
467 mi_fix_fn = mkIfaceFixCache fixities,
468 mi_hash_fn = mkIfaceHashCache decls })
469
470 getWayDescr :: DynFlags -> String
471 getWayDescr dflags
472 | cGhcUnregisterised == "YES" = 'u':tag
473 | otherwise = tag
474 where tag = buildTag dflags
475 -- if this is an unregisterised build, make sure our interfaces
476 -- can't be used by a registerised build.
477
478 -------------------------------------------------------------------------
479 -- Types from: HscTypes
480 -------------------------------------------------------------------------
481
482 instance Binary Dependencies where
483 put_ bh deps = do put_ bh (dep_mods deps)
484 put_ bh (dep_pkgs deps)
485 put_ bh (dep_orphs deps)
486 put_ bh (dep_finsts deps)
487
488 get bh = do ms <- get bh
489 ps <- get bh
490 os <- get bh
491 fis <- get bh
492 return (Deps { dep_mods = ms, dep_pkgs = ps, dep_orphs = os,
493 dep_finsts = fis })
494
495 instance (Binary name) => Binary (GenAvailInfo name) where
496 put_ bh (Avail aa) = do
497 putByte bh 0
498 put_ bh aa
499 put_ bh (AvailTC ab ac) = do
500 putByte bh 1
501 put_ bh ab
502 put_ bh ac
503 get bh = do
504 h <- getByte bh
505 case h of
506 0 -> do aa <- get bh
507 return (Avail aa)
508 _ -> do ab <- get bh
509 ac <- get bh
510 return (AvailTC ab ac)
511
512 instance Binary Usage where
513 put_ bh usg@UsagePackageModule{} = do
514 putByte bh 0
515 put_ bh (usg_mod usg)
516 put_ bh (usg_mod_hash usg)
517 put_ bh (usg_safe usg)
518 put_ bh usg@UsageHomeModule{} = do
519 putByte bh 1
520 put_ bh (usg_mod_name usg)
521 put_ bh (usg_mod_hash usg)
522 put_ bh (usg_exports usg)
523 put_ bh (usg_entities usg)
524 put_ bh (usg_safe usg)
525
526 get bh = do
527 h <- getByte bh
528 case h of
529 0 -> do
530 nm <- get bh
531 mod <- get bh
532 safe <- get bh
533 return UsagePackageModule { usg_mod = nm, usg_mod_hash = mod, usg_safe = safe }
534 _ -> do
535 nm <- get bh
536 mod <- get bh
537 exps <- get bh
538 ents <- get bh
539 safe <- get bh
540 return UsageHomeModule { usg_mod_name = nm, usg_mod_hash = mod,
541 usg_exports = exps, usg_entities = ents, usg_safe = safe }
542
543 instance Binary Warnings where
544 put_ bh NoWarnings = putByte bh 0
545 put_ bh (WarnAll t) = do
546 putByte bh 1
547 put_ bh t
548 put_ bh (WarnSome ts) = do
549 putByte bh 2
550 put_ bh ts
551
552 get bh = do
553 h <- getByte bh
554 case h of
555 0 -> return NoWarnings
556 1 -> do aa <- get bh
557 return (WarnAll aa)
558 _ -> do aa <- get bh
559 return (WarnSome aa)
560
561 instance Binary WarningTxt where
562 put_ bh (WarningTxt w) = do
563 putByte bh 0
564 put_ bh w
565 put_ bh (DeprecatedTxt d) = do
566 putByte bh 1
567 put_ bh d
568
569 get bh = do
570 h <- getByte bh
571 case h of
572 0 -> do w <- get bh
573 return (WarningTxt w)
574 _ -> do d <- get bh
575 return (DeprecatedTxt d)
576
577 -------------------------------------------------------------------------
578 -- Types from: BasicTypes
579 -------------------------------------------------------------------------
580
581 instance Binary Activation where
582 put_ bh NeverActive = do
583 putByte bh 0
584 put_ bh AlwaysActive = do
585 putByte bh 1
586 put_ bh (ActiveBefore aa) = do
587 putByte bh 2
588 put_ bh aa
589 put_ bh (ActiveAfter ab) = do
590 putByte bh 3
591 put_ bh ab
592 get bh = do
593 h <- getByte bh
594 case h of
595 0 -> do return NeverActive
596 1 -> do return AlwaysActive
597 2 -> do aa <- get bh
598 return (ActiveBefore aa)
599 _ -> do ab <- get bh
600 return (ActiveAfter ab)
601
602 instance Binary RuleMatchInfo where
603 put_ bh FunLike = putByte bh 0
604 put_ bh ConLike = putByte bh 1
605 get bh = do
606 h <- getByte bh
607 if h == 1 then return ConLike
608 else return FunLike
609
610 instance Binary InlinePragma where
611 put_ bh (InlinePragma a b c d) = do
612 put_ bh a
613 put_ bh b
614 put_ bh c
615 put_ bh d
616
617 get bh = do
618 a <- get bh
619 b <- get bh
620 c <- get bh
621 d <- get bh
622 return (InlinePragma a b c d)
623
624 instance Binary InlineSpec where
625 put_ bh EmptyInlineSpec = putByte bh 0
626 put_ bh Inline = putByte bh 1
627 put_ bh Inlinable = putByte bh 2
628 put_ bh NoInline = putByte bh 3
629
630 get bh = do h <- getByte bh
631 case h of
632 0 -> return EmptyInlineSpec
633 1 -> return Inline
634 2 -> return Inlinable
635 _ -> return NoInline
636
637 instance Binary HsBang where
638 put_ bh HsNoBang = putByte bh 0
639 put_ bh HsStrict = putByte bh 1
640 put_ bh HsUnpack = putByte bh 2
641 put_ bh HsUnpackFailed = putByte bh 3
642 get bh = do
643 h <- getByte bh
644 case h of
645 0 -> do return HsNoBang
646 1 -> do return HsStrict
647 2 -> do return HsUnpack
648 _ -> do return HsUnpackFailed
649
650 instance Binary Boxity where
651 put_ bh Boxed = putByte bh 0
652 put_ bh Unboxed = putByte bh 1
653 get bh = do
654 h <- getByte bh
655 case h of
656 0 -> do return Boxed
657 _ -> do return Unboxed
658
659 instance Binary TupCon where
660 put_ bh (TupCon ab ac) = do
661 put_ bh ab
662 put_ bh ac
663 get bh = do
664 ab <- get bh
665 ac <- get bh
666 return (TupCon ab ac)
667
668 instance Binary RecFlag where
669 put_ bh Recursive = do
670 putByte bh 0
671 put_ bh NonRecursive = do
672 putByte bh 1
673 get bh = do
674 h <- getByte bh
675 case h of
676 0 -> do return Recursive
677 _ -> do return NonRecursive
678
679 instance Binary DefMethSpec where
680 put_ bh NoDM = putByte bh 0
681 put_ bh VanillaDM = putByte bh 1
682 put_ bh GenericDM = putByte bh 2
683 get bh = do
684 h <- getByte bh
685 case h of
686 0 -> return NoDM
687 1 -> return VanillaDM
688 _ -> return GenericDM
689
690 instance Binary FixityDirection where
691 put_ bh InfixL = do
692 putByte bh 0
693 put_ bh InfixR = do
694 putByte bh 1
695 put_ bh InfixN = do
696 putByte bh 2
697 get bh = do
698 h <- getByte bh
699 case h of
700 0 -> do return InfixL
701 1 -> do return InfixR
702 _ -> do return InfixN
703
704 instance Binary Fixity where
705 put_ bh (Fixity aa ab) = do
706 put_ bh aa
707 put_ bh ab
708 get bh = do
709 aa <- get bh
710 ab <- get bh
711 return (Fixity aa ab)
712
713 instance (Binary name) => Binary (IPName name) where
714 put_ bh (IPName aa) = put_ bh aa
715 get bh = do aa <- get bh
716 return (IPName aa)
717
718 -------------------------------------------------------------------------
719 -- Types from: Demand
720 -------------------------------------------------------------------------
721
722 instance Binary DmdType where
723 -- Ignore DmdEnv when spitting out the DmdType
724 put bh (DmdType _ ds dr) = do p <- put bh ds; put_ bh dr; return (castBin p)
725 get bh = do ds <- get bh; dr <- get bh; return (DmdType emptyVarEnv ds dr)
726
727 instance Binary Demand where
728 put_ bh Top = do
729 putByte bh 0
730 put_ bh Abs = do
731 putByte bh 1
732 put_ bh (Call aa) = do
733 putByte bh 2
734 put_ bh aa
735 put_ bh (Eval ab) = do
736 putByte bh 3
737 put_ bh ab
738 put_ bh (Defer ac) = do
739 putByte bh 4
740 put_ bh ac
741 put_ bh (Box ad) = do
742 putByte bh 5
743 put_ bh ad
744 put_ bh Bot = do
745 putByte bh 6
746 get bh = do
747 h <- getByte bh
748 case h of
749 0 -> do return Top
750 1 -> do return Abs
751 2 -> do aa <- get bh
752 return (Call aa)
753 3 -> do ab <- get bh
754 return (Eval ab)
755 4 -> do ac <- get bh
756 return (Defer ac)
757 5 -> do ad <- get bh
758 return (Box ad)
759 _ -> do return Bot
760
761 instance Binary Demands where
762 put_ bh (Poly aa) = do
763 putByte bh 0
764 put_ bh aa
765 put_ bh (Prod ab) = do
766 putByte bh 1
767 put_ bh ab
768 get bh = do
769 h <- getByte bh
770 case h of
771 0 -> do aa <- get bh
772 return (Poly aa)
773 _ -> do ab <- get bh
774 return (Prod ab)
775
776 instance Binary DmdResult where
777 put_ bh TopRes = do
778 putByte bh 0
779 put_ bh RetCPR = do
780 putByte bh 1
781 put_ bh BotRes = do
782 putByte bh 2
783 get bh = do
784 h <- getByte bh
785 case h of
786 0 -> do return TopRes
787 1 -> do return RetCPR -- Really use RetCPR even if -fcpr-off
788 -- The wrapper was generated for CPR in
789 -- the imported module!
790 _ -> do return BotRes
791
792 instance Binary StrictSig where
793 put_ bh (StrictSig aa) = do
794 put_ bh aa
795 get bh = do
796 aa <- get bh
797 return (StrictSig aa)
798
799
800 -------------------------------------------------------------------------
801 -- Types from: CostCentre
802 -------------------------------------------------------------------------
803
804 instance Binary IsCafCC where
805 put_ bh CafCC = do
806 putByte bh 0
807 put_ bh NotCafCC = do
808 putByte bh 1
809 get bh = do
810 h <- getByte bh
811 case h of
812 0 -> do return CafCC
813 _ -> do return NotCafCC
814
815 instance Binary IsDupdCC where
816 put_ bh OriginalCC = do
817 putByte bh 0
818 put_ bh DupdCC = do
819 putByte bh 1
820 get bh = do
821 h <- getByte bh
822 case h of
823 0 -> do return OriginalCC
824 _ -> do return DupdCC
825
826 instance Binary CostCentre where
827 put_ bh NoCostCentre = do
828 putByte bh 0
829 put_ bh (NormalCC aa ab ac ad) = do
830 putByte bh 1
831 put_ bh aa
832 put_ bh ab
833 put_ bh ac
834 put_ bh ad
835 put_ bh (AllCafsCC ae) = do
836 putByte bh 2
837 put_ bh ae
838 get bh = do
839 h <- getByte bh
840 case h of
841 0 -> do return NoCostCentre
842 1 -> do aa <- get bh
843 ab <- get bh
844 ac <- get bh
845 ad <- get bh
846 return (NormalCC aa ab ac ad)
847 _ -> do ae <- get bh
848 return (AllCafsCC ae)
849
850 -------------------------------------------------------------------------
851 -- IfaceTypes and friends
852 -------------------------------------------------------------------------
853
854 instance Binary IfaceBndr where
855 put_ bh (IfaceIdBndr aa) = do
856 putByte bh 0
857 put_ bh aa
858 put_ bh (IfaceTvBndr ab) = do
859 putByte bh 1
860 put_ bh ab
861 get bh = do
862 h <- getByte bh
863 case h of
864 0 -> do aa <- get bh
865 return (IfaceIdBndr aa)
866 _ -> do ab <- get bh
867 return (IfaceTvBndr ab)
868
869 instance Binary IfaceLetBndr where
870 put_ bh (IfLetBndr a b c) = do
871 put_ bh a
872 put_ bh b
873 put_ bh c
874 get bh = do a <- get bh
875 b <- get bh
876 c <- get bh
877 return (IfLetBndr a b c)
878
879 instance Binary IfaceType where
880 put_ bh (IfaceForAllTy aa ab) = do
881 putByte bh 0
882 put_ bh aa
883 put_ bh ab
884 put_ bh (IfaceTyVar ad) = do
885 putByte bh 1
886 put_ bh ad
887 put_ bh (IfaceAppTy ae af) = do
888 putByte bh 2
889 put_ bh ae
890 put_ bh af
891 put_ bh (IfaceFunTy ag ah) = do
892 putByte bh 3
893 put_ bh ag
894 put_ bh ah
895 put_ bh (IfacePredTy aq) = do
896 putByte bh 5
897 put_ bh aq
898
899 -- Simple compression for common cases of TyConApp
900 put_ bh (IfaceTyConApp IfaceIntTc []) = putByte bh 6
901 put_ bh (IfaceTyConApp IfaceCharTc []) = putByte bh 7
902 put_ bh (IfaceTyConApp IfaceBoolTc []) = putByte bh 8
903 put_ bh (IfaceTyConApp IfaceListTc [ty]) = do { putByte bh 9; put_ bh ty }
904 -- Unit tuple and pairs
905 put_ bh (IfaceTyConApp (IfaceTupTc Boxed 0) []) = putByte bh 10
906 put_ bh (IfaceTyConApp (IfaceTupTc Boxed 2) [t1,t2]) = do { putByte bh 11; put_ bh t1; put_ bh t2 }
907 -- Kind cases
908 put_ bh (IfaceTyConApp IfaceLiftedTypeKindTc []) = putByte bh 12
909 put_ bh (IfaceTyConApp IfaceOpenTypeKindTc []) = putByte bh 13
910 put_ bh (IfaceTyConApp IfaceUnliftedTypeKindTc []) = putByte bh 14
911 put_ bh (IfaceTyConApp IfaceUbxTupleKindTc []) = putByte bh 15
912 put_ bh (IfaceTyConApp IfaceArgTypeKindTc []) = putByte bh 16
913 put_ bh (IfaceTyConApp (IfaceAnyTc k) []) = do { putByte bh 17; put_ bh k }
914
915 -- Generic cases
916 put_ bh (IfaceTyConApp (IfaceTc tc) tys) = do { putByte bh 18; put_ bh tc; put_ bh tys }
917 put_ bh (IfaceTyConApp tc tys) = do { putByte bh 19; put_ bh tc; put_ bh tys }
918
919 put_ bh (IfaceCoConApp cc tys) = do { putByte bh 20; put_ bh cc; put_ bh tys }
920
921 get bh = do
922 h <- getByte bh
923 case h of
924 0 -> do aa <- get bh
925 ab <- get bh
926 return (IfaceForAllTy aa ab)
927 1 -> do ad <- get bh
928 return (IfaceTyVar ad)
929 2 -> do ae <- get bh
930 af <- get bh
931 return (IfaceAppTy ae af)
932 3 -> do ag <- get bh
933 ah <- get bh
934 return (IfaceFunTy ag ah)
935 5 -> do ap <- get bh
936 return (IfacePredTy ap)
937
938 -- Now the special cases for TyConApp
939 6 -> return (IfaceTyConApp IfaceIntTc [])
940 7 -> return (IfaceTyConApp IfaceCharTc [])
941 8 -> return (IfaceTyConApp IfaceBoolTc [])
942 9 -> do { ty <- get bh; return (IfaceTyConApp IfaceListTc [ty]) }
943 10 -> return (IfaceTyConApp (IfaceTupTc Boxed 0) [])
944 11 -> do { t1 <- get bh; t2 <- get bh; return (IfaceTyConApp (IfaceTupTc Boxed 2) [t1,t2]) }
945 12 -> return (IfaceTyConApp IfaceLiftedTypeKindTc [])
946 13 -> return (IfaceTyConApp IfaceOpenTypeKindTc [])
947 14 -> return (IfaceTyConApp IfaceUnliftedTypeKindTc [])
948 15 -> return (IfaceTyConApp IfaceUbxTupleKindTc [])
949 16 -> return (IfaceTyConApp IfaceArgTypeKindTc [])
950 17 -> do { k <- get bh; return (IfaceTyConApp (IfaceAnyTc k) []) }
951
952 18 -> do { tc <- get bh; tys <- get bh; return (IfaceTyConApp (IfaceTc tc) tys) }
953 19 -> do { tc <- get bh; tys <- get bh; return (IfaceTyConApp tc tys) }
954 _ -> do { cc <- get bh; tys <- get bh; return (IfaceCoConApp cc tys) }
955
956 instance Binary IfaceTyCon where
957 -- Int,Char,Bool can't show up here because they can't not be saturated
958 put_ bh IfaceIntTc = putByte bh 1
959 put_ bh IfaceBoolTc = putByte bh 2
960 put_ bh IfaceCharTc = putByte bh 3
961 put_ bh IfaceListTc = putByte bh 4
962 put_ bh IfacePArrTc = putByte bh 5
963 put_ bh IfaceLiftedTypeKindTc = putByte bh 6
964 put_ bh IfaceOpenTypeKindTc = putByte bh 7
965 put_ bh IfaceUnliftedTypeKindTc = putByte bh 8
966 put_ bh IfaceUbxTupleKindTc = putByte bh 9
967 put_ bh IfaceArgTypeKindTc = putByte bh 10
968 put_ bh (IfaceTupTc bx ar) = do { putByte bh 11; put_ bh bx; put_ bh ar }
969 put_ bh (IfaceTc ext) = do { putByte bh 12; put_ bh ext }
970 put_ bh (IfaceAnyTc k) = do { putByte bh 13; put_ bh k }
971
972 get bh = do
973 h <- getByte bh
974 case h of
975 1 -> return IfaceIntTc
976 2 -> return IfaceBoolTc
977 3 -> return IfaceCharTc
978 4 -> return IfaceListTc
979 5 -> return IfacePArrTc
980 6 -> return IfaceLiftedTypeKindTc
981 7 -> return IfaceOpenTypeKindTc
982 8 -> return IfaceUnliftedTypeKindTc
983 9 -> return IfaceUbxTupleKindTc
984 10 -> return IfaceArgTypeKindTc
985 11 -> do { bx <- get bh; ar <- get bh; return (IfaceTupTc bx ar) }
986 12 -> do { ext <- get bh; return (IfaceTc ext) }
987 _ -> do { k <- get bh; return (IfaceAnyTc k) }
988
989 instance Binary IfaceCoCon where
990 put_ bh (IfaceCoAx n) = do { putByte bh 0; put_ bh n }
991 put_ bh IfaceReflCo = putByte bh 1
992 put_ bh IfaceUnsafeCo = putByte bh 2
993 put_ bh IfaceSymCo = putByte bh 3
994 put_ bh IfaceTransCo = putByte bh 4
995 put_ bh IfaceInstCo = putByte bh 5
996 put_ bh (IfaceNthCo d) = do { putByte bh 6; put_ bh d }
997
998 get bh = do
999 h <- getByte bh
1000 case h of
1001 0 -> do { n <- get bh; return (IfaceCoAx n) }
1002 1 -> return IfaceReflCo
1003 2 -> return IfaceUnsafeCo
1004 3 -> return IfaceSymCo
1005 4 -> return IfaceTransCo
1006 5 -> return IfaceInstCo
1007 _ -> do { d <- get bh; return (IfaceNthCo d) }
1008
1009 instance Binary IfacePredType where
1010 put_ bh (IfaceClassP aa ab) = do
1011 putByte bh 0
1012 put_ bh aa
1013 put_ bh ab
1014 put_ bh (IfaceIParam ac ad) = do
1015 putByte bh 1
1016 put_ bh ac
1017 put_ bh ad
1018 put_ bh (IfaceEqPred ac ad) = do
1019 putByte bh 2
1020 put_ bh ac
1021 put_ bh ad
1022 get bh = do
1023 h <- getByte bh
1024 case h of
1025 0 -> do aa <- get bh
1026 ab <- get bh
1027 return (IfaceClassP aa ab)
1028 1 -> do ac <- get bh
1029 ad <- get bh
1030 return (IfaceIParam ac ad)
1031 2 -> do ac <- get bh
1032 ad <- get bh
1033 return (IfaceEqPred ac ad)
1034 _ -> panic ("get IfacePredType " ++ show h)
1035
1036 -------------------------------------------------------------------------
1037 -- IfaceExpr and friends
1038 -------------------------------------------------------------------------
1039
1040 instance Binary IfaceExpr where
1041 put_ bh (IfaceLcl aa) = do
1042 putByte bh 0
1043 put_ bh aa
1044 put_ bh (IfaceType ab) = do
1045 putByte bh 1
1046 put_ bh ab
1047 put_ bh (IfaceCo ab) = do
1048 putByte bh 2
1049 put_ bh ab
1050 put_ bh (IfaceTuple ac ad) = do
1051 putByte bh 3
1052 put_ bh ac
1053 put_ bh ad
1054 put_ bh (IfaceLam ae af) = do
1055 putByte bh 4
1056 put_ bh ae
1057 put_ bh af
1058 put_ bh (IfaceApp ag ah) = do
1059 putByte bh 5
1060 put_ bh ag
1061 put_ bh ah
1062 put_ bh (IfaceCase ai aj ak) = do
1063 putByte bh 6
1064 put_ bh ai
1065 put_ bh aj
1066 put_ bh ak
1067 put_ bh (IfaceLet al am) = do
1068 putByte bh 7
1069 put_ bh al
1070 put_ bh am
1071 put_ bh (IfaceNote an ao) = do
1072 putByte bh 8
1073 put_ bh an
1074 put_ bh ao
1075 put_ bh (IfaceLit ap) = do
1076 putByte bh 9
1077 put_ bh ap
1078 put_ bh (IfaceFCall as at) = do
1079 putByte bh 10
1080 put_ bh as
1081 put_ bh at
1082 put_ bh (IfaceExt aa) = do
1083 putByte bh 11
1084 put_ bh aa
1085 put_ bh (IfaceCast ie ico) = do
1086 putByte bh 12
1087 put_ bh ie
1088 put_ bh ico
1089 put_ bh (IfaceTick m ix) = do
1090 putByte bh 13
1091 put_ bh m
1092 put_ bh ix
1093 get bh = do
1094 h <- getByte bh
1095 case h of
1096 0 -> do aa <- get bh
1097 return (IfaceLcl aa)
1098 1 -> do ab <- get bh
1099 return (IfaceType ab)
1100 2 -> do ab <- get bh
1101 return (IfaceCo ab)
1102 3 -> do ac <- get bh
1103 ad <- get bh
1104 return (IfaceTuple ac ad)
1105 4 -> do ae <- get bh
1106 af <- get bh
1107 return (IfaceLam ae af)
1108 5 -> do ag <- get bh
1109 ah <- get bh
1110 return (IfaceApp ag ah)
1111 6 -> do ai <- get bh
1112 aj <- get bh
1113 ak <- get bh
1114 return (IfaceCase ai aj ak)
1115 7 -> do al <- get bh
1116 am <- get bh
1117 return (IfaceLet al am)
1118 8 -> do an <- get bh
1119 ao <- get bh
1120 return (IfaceNote an ao)
1121 9 -> do ap <- get bh
1122 return (IfaceLit ap)
1123 10 -> do as <- get bh
1124 at <- get bh
1125 return (IfaceFCall as at)
1126 11 -> do aa <- get bh
1127 return (IfaceExt aa)
1128 12 -> do ie <- get bh
1129 ico <- get bh
1130 return (IfaceCast ie ico)
1131 13 -> do m <- get bh
1132 ix <- get bh
1133 return (IfaceTick m ix)
1134 _ -> panic ("get IfaceExpr " ++ show h)
1135
1136 instance Binary IfaceConAlt where
1137 put_ bh IfaceDefault = do
1138 putByte bh 0
1139 put_ bh (IfaceDataAlt aa) = do
1140 putByte bh 1
1141 put_ bh aa
1142 put_ bh (IfaceTupleAlt ab) = do
1143 putByte bh 2
1144 put_ bh ab
1145 put_ bh (IfaceLitAlt ac) = do
1146 putByte bh 3
1147 put_ bh ac
1148 get bh = do
1149 h <- getByte bh
1150 case h of
1151 0 -> do return IfaceDefault
1152 1 -> do aa <- get bh
1153 return (IfaceDataAlt aa)
1154 2 -> do ab <- get bh
1155 return (IfaceTupleAlt ab)
1156 _ -> do ac <- get bh
1157 return (IfaceLitAlt ac)
1158
1159 instance Binary IfaceBinding where
1160 put_ bh (IfaceNonRec aa ab) = do
1161 putByte bh 0
1162 put_ bh aa
1163 put_ bh ab
1164 put_ bh (IfaceRec ac) = do
1165 putByte bh 1
1166 put_ bh ac
1167 get bh = do
1168 h <- getByte bh
1169 case h of
1170 0 -> do aa <- get bh
1171 ab <- get bh
1172 return (IfaceNonRec aa ab)
1173 _ -> do ac <- get bh
1174 return (IfaceRec ac)
1175
1176 instance Binary IfaceIdDetails where
1177 put_ bh IfVanillaId = putByte bh 0
1178 put_ bh (IfRecSelId a b) = do { putByte bh 1; put_ bh a; put_ bh b }
1179 put_ bh IfDFunId = putByte bh 2
1180 get bh = do
1181 h <- getByte bh
1182 case h of
1183 0 -> return IfVanillaId
1184 1 -> do a <- get bh
1185 b <- get bh
1186 return (IfRecSelId a b)
1187 _ -> return IfDFunId
1188
1189 instance Binary IfaceIdInfo where
1190 put_ bh NoInfo = putByte bh 0
1191 put_ bh (HasInfo i) = do
1192 putByte bh 1
1193 lazyPut bh i -- NB lazyPut
1194
1195 get bh = do
1196 h <- getByte bh
1197 case h of
1198 0 -> return NoInfo
1199 _ -> do info <- lazyGet bh -- NB lazyGet
1200 return (HasInfo info)
1201
1202 instance Binary IfaceInfoItem where
1203 put_ bh (HsArity aa) = do
1204 putByte bh 0
1205 put_ bh aa
1206 put_ bh (HsStrictness ab) = do
1207 putByte bh 1
1208 put_ bh ab
1209 put_ bh (HsUnfold lb ad) = do
1210 putByte bh 2
1211 put_ bh lb
1212 put_ bh ad
1213 put_ bh (HsInline ad) = do
1214 putByte bh 3
1215 put_ bh ad
1216 put_ bh HsNoCafRefs = do
1217 putByte bh 4
1218 get bh = do
1219 h <- getByte bh
1220 case h of
1221 0 -> do aa <- get bh
1222 return (HsArity aa)
1223 1 -> do ab <- get bh
1224 return (HsStrictness ab)
1225 2 -> do lb <- get bh
1226 ad <- get bh
1227 return (HsUnfold lb ad)
1228 3 -> do ad <- get bh
1229 return (HsInline ad)
1230 _ -> do return HsNoCafRefs
1231
1232 instance Binary IfaceUnfolding where
1233 put_ bh (IfCoreUnfold s e) = do
1234 putByte bh 0
1235 put_ bh s
1236 put_ bh e
1237 put_ bh (IfInlineRule a b c d) = do
1238 putByte bh 1
1239 put_ bh a
1240 put_ bh b
1241 put_ bh c
1242 put_ bh d
1243 put_ bh (IfLclWrapper a n) = do
1244 putByte bh 2
1245 put_ bh a
1246 put_ bh n
1247 put_ bh (IfExtWrapper a n) = do
1248 putByte bh 3
1249 put_ bh a
1250 put_ bh n
1251 put_ bh (IfDFunUnfold as) = do
1252 putByte bh 4
1253 put_ bh as
1254 put_ bh (IfCompulsory e) = do
1255 putByte bh 5
1256 put_ bh e
1257 get bh = do
1258 h <- getByte bh
1259 case h of
1260 0 -> do s <- get bh
1261 e <- get bh
1262 return (IfCoreUnfold s e)
1263 1 -> do a <- get bh
1264 b <- get bh
1265 c <- get bh
1266 d <- get bh
1267 return (IfInlineRule a b c d)
1268 2 -> do a <- get bh
1269 n <- get bh
1270 return (IfLclWrapper a n)
1271 3 -> do a <- get bh
1272 n <- get bh
1273 return (IfExtWrapper a n)
1274 4 -> do as <- get bh
1275 return (IfDFunUnfold as)
1276 _ -> do e <- get bh
1277 return (IfCompulsory e)
1278
1279 instance Binary IfaceNote where
1280 put_ bh (IfaceSCC aa) = do
1281 putByte bh 0
1282 put_ bh aa
1283 put_ bh (IfaceCoreNote s) = do
1284 putByte bh 4
1285 put_ bh s
1286 get bh = do
1287 h <- getByte bh
1288 case h of
1289 0 -> do aa <- get bh
1290 return (IfaceSCC aa)
1291 4 -> do ac <- get bh
1292 return (IfaceCoreNote ac)
1293 _ -> panic ("get IfaceNote " ++ show h)
1294
1295 -------------------------------------------------------------------------
1296 -- IfaceDecl and friends
1297 -------------------------------------------------------------------------
1298
1299 -- A bit of magic going on here: there's no need to store the OccName
1300 -- for a decl on the disk, since we can infer the namespace from the
1301 -- context; however it is useful to have the OccName in the IfaceDecl
1302 -- to avoid re-building it in various places. So we build the OccName
1303 -- when de-serialising.
1304
1305 instance Binary IfaceDecl where
1306 put_ bh (IfaceId name ty details idinfo) = do
1307 putByte bh 0
1308 put_ bh (occNameFS name)
1309 put_ bh ty
1310 put_ bh details
1311 put_ bh idinfo
1312 put_ _ (IfaceForeign _ _) =
1313 error "Binary.put_(IfaceDecl): IfaceForeign"
1314 put_ bh (IfaceData a1 a2 a3 a4 a5 a6 a7) = do
1315 putByte bh 2
1316 put_ bh (occNameFS a1)
1317 put_ bh a2
1318 put_ bh a3
1319 put_ bh a4
1320 put_ bh a5
1321 put_ bh a6
1322 put_ bh a7
1323 put_ bh (IfaceSyn a1 a2 a3 a4 a5) = do
1324 putByte bh 3
1325 put_ bh (occNameFS a1)
1326 put_ bh a2
1327 put_ bh a3
1328 put_ bh a4
1329 put_ bh a5
1330 put_ bh (IfaceClass a1 a2 a3 a4 a5 a6 a7) = do
1331 putByte bh 4
1332 put_ bh a1
1333 put_ bh (occNameFS a2)
1334 put_ bh a3
1335 put_ bh a4
1336 put_ bh a5
1337 put_ bh a6
1338 put_ bh a7
1339 get bh = do
1340 h <- getByte bh
1341 case h of
1342 0 -> do name <- get bh
1343 ty <- get bh
1344 details <- get bh
1345 idinfo <- get bh
1346 occ <- return $! mkOccNameFS varName name
1347 return (IfaceId occ ty details idinfo)
1348 1 -> error "Binary.get(TyClDecl): ForeignType"
1349 2 -> 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 tcName a1
1358 return (IfaceData occ a2 a3 a4 a5 a6 a7)
1359 3 -> do
1360 a1 <- get bh
1361 a2 <- get bh
1362 a3 <- get bh
1363 a4 <- get bh
1364 a5 <- get bh
1365 occ <- return $! mkOccNameFS tcName a1
1366 return (IfaceSyn occ a2 a3 a4 a5)
1367 _ -> do
1368 a1 <- get bh
1369 a2 <- get bh
1370 a3 <- get bh
1371 a4 <- get bh
1372 a5 <- get bh
1373 a6 <- get bh
1374 a7 <- get bh
1375 occ <- return $! mkOccNameFS clsName a2
1376 return (IfaceClass a1 occ a3 a4 a5 a6 a7)
1377
1378 instance Binary IfaceInst where
1379 put_ bh (IfaceInst cls tys dfun flag orph) = do
1380 put_ bh cls
1381 put_ bh tys
1382 put_ bh dfun
1383 put_ bh flag
1384 put_ bh orph
1385 get bh = do cls <- get bh
1386 tys <- get bh
1387 dfun <- get bh
1388 flag <- get bh
1389 orph <- get bh
1390 return (IfaceInst cls tys dfun flag orph)
1391
1392 instance Binary IfaceFamInst where
1393 put_ bh (IfaceFamInst fam tys tycon) = do
1394 put_ bh fam
1395 put_ bh tys
1396 put_ bh tycon
1397 get bh = do fam <- get bh
1398 tys <- get bh
1399 tycon <- get bh
1400 return (IfaceFamInst fam tys tycon)
1401
1402 instance Binary OverlapFlag where
1403 put_ bh (NoOverlap b) = putByte bh 0 >> put_ bh b
1404 put_ bh (OverlapOk b) = putByte bh 1 >> put_ bh b
1405 put_ bh (Incoherent b) = putByte bh 2 >> put_ bh b
1406 get bh = do h <- getByte bh
1407 b <- get bh
1408 case h of
1409 0 -> return $ NoOverlap b
1410 1 -> return $ OverlapOk b
1411 2 -> return $ Incoherent b
1412 _ -> panic ("get OverlapFlag " ++ show h)
1413
1414 instance Binary IfaceConDecls where
1415 put_ bh IfAbstractTyCon = putByte bh 0
1416 put_ bh IfOpenDataTyCon = putByte bh 1
1417 put_ bh (IfDataTyCon cs) = do { putByte bh 2
1418 ; put_ bh cs }
1419 put_ bh (IfNewTyCon c) = do { putByte bh 3
1420 ; put_ bh c }
1421 get bh = do
1422 h <- getByte bh
1423 case h of
1424 0 -> return IfAbstractTyCon
1425 1 -> return IfOpenDataTyCon
1426 2 -> do cs <- get bh
1427 return (IfDataTyCon cs)
1428 _ -> do aa <- get bh
1429 return (IfNewTyCon aa)
1430
1431 instance Binary IfaceConDecl where
1432 put_ bh (IfCon a1 a2 a3 a4 a5 a6 a7 a8 a9 a10) = do
1433 put_ bh a1
1434 put_ bh a2
1435 put_ bh a3
1436 put_ bh a4
1437 put_ bh a5
1438 put_ bh a6
1439 put_ bh a7
1440 put_ bh a8
1441 put_ bh a9
1442 put_ bh a10
1443 get bh = 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 a8 <- get bh
1451 a9 <- get bh
1452 a10 <- get bh
1453 return (IfCon a1 a2 a3 a4 a5 a6 a7 a8 a9 a10)
1454
1455 instance Binary IfaceClassOp where
1456 put_ bh (IfaceClassOp n def ty) = do
1457 put_ bh (occNameFS n)
1458 put_ bh def
1459 put_ bh ty
1460 get bh = do
1461 n <- get bh
1462 def <- get bh
1463 ty <- get bh
1464 occ <- return $! mkOccNameFS varName n
1465 return (IfaceClassOp occ def ty)
1466
1467 instance Binary IfaceRule where
1468 put_ bh (IfaceRule a1 a2 a3 a4 a5 a6 a7 a8) = do
1469 put_ bh a1
1470 put_ bh a2
1471 put_ bh a3
1472 put_ bh a4
1473 put_ bh a5
1474 put_ bh a6
1475 put_ bh a7
1476 put_ bh a8
1477 get bh = do
1478 a1 <- get bh
1479 a2 <- get bh
1480 a3 <- get bh
1481 a4 <- get bh
1482 a5 <- get bh
1483 a6 <- get bh
1484 a7 <- get bh
1485 a8 <- get bh
1486 return (IfaceRule a1 a2 a3 a4 a5 a6 a7 a8)
1487
1488 instance Binary IfaceAnnotation where
1489 put_ bh (IfaceAnnotation a1 a2) = do
1490 put_ bh a1
1491 put_ bh a2
1492 get bh = do
1493 a1 <- get bh
1494 a2 <- get bh
1495 return (IfaceAnnotation a1 a2)
1496
1497 instance Binary name => Binary (AnnTarget name) where
1498 put_ bh (NamedTarget a) = do
1499 putByte bh 0
1500 put_ bh a
1501 put_ bh (ModuleTarget a) = do
1502 putByte bh 1
1503 put_ bh a
1504 get bh = do
1505 h <- getByte bh
1506 case h of
1507 0 -> do a <- get bh
1508 return (NamedTarget a)
1509 _ -> do a <- get bh
1510 return (ModuleTarget a)
1511
1512 instance Binary IfaceVectInfo where
1513 put_ bh (IfaceVectInfo a1 a2 a3 a4 a5) = do
1514 put_ bh a1
1515 put_ bh a2
1516 put_ bh a3
1517 put_ bh a4
1518 put_ bh a5
1519 get bh = do
1520 a1 <- get bh
1521 a2 <- get bh
1522 a3 <- get bh
1523 a4 <- get bh
1524 a5 <- get bh
1525 return (IfaceVectInfo a1 a2 a3 a4 a5)
1526
1527 instance Binary IfaceTrustInfo where
1528 put_ bh iftrust = putByte bh $ trustInfoToNum iftrust
1529 get bh = getByte bh >>= (return . numToTrustInfo)
1530