Fix #481: use a safe recompilation check when Template Haskell is
[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 name) => Binary (GenAvailInfo name) 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 Boxity where
655 put_ bh Boxed = putByte bh 0
656 put_ bh Unboxed = putByte bh 1
657 get bh = do
658 h <- getByte bh
659 case h of
660 0 -> do return Boxed
661 _ -> do return Unboxed
662
663 instance Binary TupCon where
664 put_ bh (TupCon ab ac) = do
665 put_ bh ab
666 put_ bh ac
667 get bh = do
668 ab <- get bh
669 ac <- get bh
670 return (TupCon ab ac)
671
672 instance Binary RecFlag where
673 put_ bh Recursive = do
674 putByte bh 0
675 put_ bh NonRecursive = do
676 putByte bh 1
677 get bh = do
678 h <- getByte bh
679 case h of
680 0 -> do return Recursive
681 _ -> do return NonRecursive
682
683 instance Binary DefMethSpec where
684 put_ bh NoDM = putByte bh 0
685 put_ bh VanillaDM = putByte bh 1
686 put_ bh GenericDM = putByte bh 2
687 get bh = do
688 h <- getByte bh
689 case h of
690 0 -> return NoDM
691 1 -> return VanillaDM
692 _ -> return GenericDM
693
694 instance Binary FixityDirection where
695 put_ bh InfixL = do
696 putByte bh 0
697 put_ bh InfixR = do
698 putByte bh 1
699 put_ bh InfixN = do
700 putByte bh 2
701 get bh = do
702 h <- getByte bh
703 case h of
704 0 -> do return InfixL
705 1 -> do return InfixR
706 _ -> do return InfixN
707
708 instance Binary Fixity where
709 put_ bh (Fixity aa ab) = do
710 put_ bh aa
711 put_ bh ab
712 get bh = do
713 aa <- get bh
714 ab <- get bh
715 return (Fixity aa ab)
716
717 instance (Binary name) => Binary (IPName name) where
718 put_ bh (IPName aa) = put_ bh aa
719 get bh = do aa <- get bh
720 return (IPName aa)
721
722 -------------------------------------------------------------------------
723 -- Types from: Demand
724 -------------------------------------------------------------------------
725
726 instance Binary DmdType where
727 -- Ignore DmdEnv when spitting out the DmdType
728 put bh (DmdType _ ds dr) = do p <- put bh ds; put_ bh dr; return (castBin p)
729 get bh = do ds <- get bh; dr <- get bh; return (DmdType emptyVarEnv ds dr)
730
731 instance Binary Demand where
732 put_ bh Top = do
733 putByte bh 0
734 put_ bh Abs = do
735 putByte bh 1
736 put_ bh (Call aa) = do
737 putByte bh 2
738 put_ bh aa
739 put_ bh (Eval ab) = do
740 putByte bh 3
741 put_ bh ab
742 put_ bh (Defer ac) = do
743 putByte bh 4
744 put_ bh ac
745 put_ bh (Box ad) = do
746 putByte bh 5
747 put_ bh ad
748 put_ bh Bot = do
749 putByte bh 6
750 get bh = do
751 h <- getByte bh
752 case h of
753 0 -> do return Top
754 1 -> do return Abs
755 2 -> do aa <- get bh
756 return (Call aa)
757 3 -> do ab <- get bh
758 return (Eval ab)
759 4 -> do ac <- get bh
760 return (Defer ac)
761 5 -> do ad <- get bh
762 return (Box ad)
763 _ -> do return Bot
764
765 instance Binary Demands where
766 put_ bh (Poly aa) = do
767 putByte bh 0
768 put_ bh aa
769 put_ bh (Prod ab) = do
770 putByte bh 1
771 put_ bh ab
772 get bh = do
773 h <- getByte bh
774 case h of
775 0 -> do aa <- get bh
776 return (Poly aa)
777 _ -> do ab <- get bh
778 return (Prod ab)
779
780 instance Binary DmdResult where
781 put_ bh TopRes = do
782 putByte bh 0
783 put_ bh RetCPR = do
784 putByte bh 1
785 put_ bh BotRes = do
786 putByte bh 2
787 get bh = do
788 h <- getByte bh
789 case h of
790 0 -> do return TopRes
791 1 -> do return RetCPR -- Really use RetCPR even if -fcpr-off
792 -- The wrapper was generated for CPR in
793 -- the imported module!
794 _ -> do return BotRes
795
796 instance Binary StrictSig where
797 put_ bh (StrictSig aa) = do
798 put_ bh aa
799 get bh = do
800 aa <- get bh
801 return (StrictSig aa)
802
803
804 -------------------------------------------------------------------------
805 -- Types from: CostCentre
806 -------------------------------------------------------------------------
807
808 instance Binary IsCafCC where
809 put_ bh CafCC = do
810 putByte bh 0
811 put_ bh NotCafCC = do
812 putByte bh 1
813 get bh = do
814 h <- getByte bh
815 case h of
816 0 -> do return CafCC
817 _ -> do return NotCafCC
818
819 instance Binary IsDupdCC where
820 put_ bh OriginalCC = do
821 putByte bh 0
822 put_ bh DupdCC = do
823 putByte bh 1
824 get bh = do
825 h <- getByte bh
826 case h of
827 0 -> do return OriginalCC
828 _ -> do return DupdCC
829
830 instance Binary CostCentre where
831 put_ bh NoCostCentre = do
832 putByte bh 0
833 put_ bh (NormalCC aa ab ac ad) = do
834 putByte bh 1
835 put_ bh aa
836 put_ bh ab
837 put_ bh ac
838 put_ bh ad
839 put_ bh (AllCafsCC ae) = do
840 putByte bh 2
841 put_ bh ae
842 get bh = do
843 h <- getByte bh
844 case h of
845 0 -> do return NoCostCentre
846 1 -> do aa <- get bh
847 ab <- get bh
848 ac <- get bh
849 ad <- get bh
850 return (NormalCC aa ab ac ad)
851 _ -> do ae <- get bh
852 return (AllCafsCC ae)
853
854 -------------------------------------------------------------------------
855 -- IfaceTypes and friends
856 -------------------------------------------------------------------------
857
858 instance Binary IfaceBndr where
859 put_ bh (IfaceIdBndr aa) = do
860 putByte bh 0
861 put_ bh aa
862 put_ bh (IfaceTvBndr ab) = do
863 putByte bh 1
864 put_ bh ab
865 get bh = do
866 h <- getByte bh
867 case h of
868 0 -> do aa <- get bh
869 return (IfaceIdBndr aa)
870 _ -> do ab <- get bh
871 return (IfaceTvBndr ab)
872
873 instance Binary IfaceLetBndr where
874 put_ bh (IfLetBndr a b c) = do
875 put_ bh a
876 put_ bh b
877 put_ bh c
878 get bh = do a <- get bh
879 b <- get bh
880 c <- get bh
881 return (IfLetBndr a b c)
882
883 instance Binary IfaceType where
884 put_ bh (IfaceForAllTy aa ab) = do
885 putByte bh 0
886 put_ bh aa
887 put_ bh ab
888 put_ bh (IfaceTyVar ad) = do
889 putByte bh 1
890 put_ bh ad
891 put_ bh (IfaceAppTy ae af) = do
892 putByte bh 2
893 put_ bh ae
894 put_ bh af
895 put_ bh (IfaceFunTy ag ah) = do
896 putByte bh 3
897 put_ bh ag
898 put_ bh ah
899 put_ bh (IfacePredTy aq) = do
900 putByte bh 5
901 put_ bh aq
902
903 -- Simple compression for common cases of TyConApp
904 put_ bh (IfaceTyConApp IfaceIntTc []) = putByte bh 6
905 put_ bh (IfaceTyConApp IfaceCharTc []) = putByte bh 7
906 put_ bh (IfaceTyConApp IfaceBoolTc []) = putByte bh 8
907 put_ bh (IfaceTyConApp IfaceListTc [ty]) = do { putByte bh 9; put_ bh ty }
908 -- Unit tuple and pairs
909 put_ bh (IfaceTyConApp (IfaceTupTc Boxed 0) []) = putByte bh 10
910 put_ bh (IfaceTyConApp (IfaceTupTc Boxed 2) [t1,t2]) = do { putByte bh 11; put_ bh t1; put_ bh t2 }
911 -- Kind cases
912 put_ bh (IfaceTyConApp IfaceLiftedTypeKindTc []) = putByte bh 12
913 put_ bh (IfaceTyConApp IfaceOpenTypeKindTc []) = putByte bh 13
914 put_ bh (IfaceTyConApp IfaceUnliftedTypeKindTc []) = putByte bh 14
915 put_ bh (IfaceTyConApp IfaceUbxTupleKindTc []) = putByte bh 15
916 put_ bh (IfaceTyConApp IfaceArgTypeKindTc []) = putByte bh 16
917 put_ bh (IfaceTyConApp (IfaceAnyTc k) []) = do { putByte bh 17; put_ bh k }
918
919 -- Generic cases
920 put_ bh (IfaceTyConApp (IfaceTc tc) tys) = do { putByte bh 18; put_ bh tc; put_ bh tys }
921 put_ bh (IfaceTyConApp tc tys) = do { putByte bh 19; put_ bh tc; put_ bh tys }
922
923 put_ bh (IfaceCoConApp cc tys) = do { putByte bh 20; put_ bh cc; put_ bh tys }
924
925 get bh = do
926 h <- getByte bh
927 case h of
928 0 -> do aa <- get bh
929 ab <- get bh
930 return (IfaceForAllTy aa ab)
931 1 -> do ad <- get bh
932 return (IfaceTyVar ad)
933 2 -> do ae <- get bh
934 af <- get bh
935 return (IfaceAppTy ae af)
936 3 -> do ag <- get bh
937 ah <- get bh
938 return (IfaceFunTy ag ah)
939 5 -> do ap <- get bh
940 return (IfacePredTy ap)
941
942 -- Now the special cases for TyConApp
943 6 -> return (IfaceTyConApp IfaceIntTc [])
944 7 -> return (IfaceTyConApp IfaceCharTc [])
945 8 -> return (IfaceTyConApp IfaceBoolTc [])
946 9 -> do { ty <- get bh; return (IfaceTyConApp IfaceListTc [ty]) }
947 10 -> return (IfaceTyConApp (IfaceTupTc Boxed 0) [])
948 11 -> do { t1 <- get bh; t2 <- get bh; return (IfaceTyConApp (IfaceTupTc Boxed 2) [t1,t2]) }
949 12 -> return (IfaceTyConApp IfaceLiftedTypeKindTc [])
950 13 -> return (IfaceTyConApp IfaceOpenTypeKindTc [])
951 14 -> return (IfaceTyConApp IfaceUnliftedTypeKindTc [])
952 15 -> return (IfaceTyConApp IfaceUbxTupleKindTc [])
953 16 -> return (IfaceTyConApp IfaceArgTypeKindTc [])
954 17 -> do { k <- get bh; return (IfaceTyConApp (IfaceAnyTc k) []) }
955
956 18 -> do { tc <- get bh; tys <- get bh; return (IfaceTyConApp (IfaceTc tc) tys) }
957 19 -> do { tc <- get bh; tys <- get bh; return (IfaceTyConApp tc tys) }
958 _ -> do { cc <- get bh; tys <- get bh; return (IfaceCoConApp cc tys) }
959
960 instance Binary IfaceTyCon where
961 -- Int,Char,Bool can't show up here because they can't not be saturated
962 put_ bh IfaceIntTc = putByte bh 1
963 put_ bh IfaceBoolTc = putByte bh 2
964 put_ bh IfaceCharTc = putByte bh 3
965 put_ bh IfaceListTc = putByte bh 4
966 put_ bh IfacePArrTc = putByte bh 5
967 put_ bh IfaceLiftedTypeKindTc = putByte bh 6
968 put_ bh IfaceOpenTypeKindTc = putByte bh 7
969 put_ bh IfaceUnliftedTypeKindTc = putByte bh 8
970 put_ bh IfaceUbxTupleKindTc = putByte bh 9
971 put_ bh IfaceArgTypeKindTc = putByte bh 10
972 put_ bh (IfaceTupTc bx ar) = do { putByte bh 11; put_ bh bx; put_ bh ar }
973 put_ bh (IfaceTc ext) = do { putByte bh 12; put_ bh ext }
974 put_ bh (IfaceAnyTc k) = do { putByte bh 13; put_ bh k }
975
976 get bh = do
977 h <- getByte bh
978 case h of
979 1 -> return IfaceIntTc
980 2 -> return IfaceBoolTc
981 3 -> return IfaceCharTc
982 4 -> return IfaceListTc
983 5 -> return IfacePArrTc
984 6 -> return IfaceLiftedTypeKindTc
985 7 -> return IfaceOpenTypeKindTc
986 8 -> return IfaceUnliftedTypeKindTc
987 9 -> return IfaceUbxTupleKindTc
988 10 -> return IfaceArgTypeKindTc
989 11 -> do { bx <- get bh; ar <- get bh; return (IfaceTupTc bx ar) }
990 12 -> do { ext <- get bh; return (IfaceTc ext) }
991 _ -> do { k <- get bh; return (IfaceAnyTc k) }
992
993 instance Binary IfaceCoCon where
994 put_ bh (IfaceCoAx n) = do { putByte bh 0; put_ bh n }
995 put_ bh IfaceReflCo = putByte bh 1
996 put_ bh IfaceUnsafeCo = putByte bh 2
997 put_ bh IfaceSymCo = putByte bh 3
998 put_ bh IfaceTransCo = putByte bh 4
999 put_ bh IfaceInstCo = putByte bh 5
1000 put_ bh (IfaceNthCo d) = do { putByte bh 6; put_ bh d }
1001
1002 get bh = do
1003 h <- getByte bh
1004 case h of
1005 0 -> do { n <- get bh; return (IfaceCoAx n) }
1006 1 -> return IfaceReflCo
1007 2 -> return IfaceUnsafeCo
1008 3 -> return IfaceSymCo
1009 4 -> return IfaceTransCo
1010 5 -> return IfaceInstCo
1011 _ -> do { d <- get bh; return (IfaceNthCo d) }
1012
1013 instance Binary IfacePredType where
1014 put_ bh (IfaceClassP aa ab) = do
1015 putByte bh 0
1016 put_ bh aa
1017 put_ bh ab
1018 put_ bh (IfaceIParam ac ad) = do
1019 putByte bh 1
1020 put_ bh ac
1021 put_ bh ad
1022 put_ bh (IfaceEqPred ac ad) = do
1023 putByte bh 2
1024 put_ bh ac
1025 put_ bh ad
1026 get bh = do
1027 h <- getByte bh
1028 case h of
1029 0 -> do aa <- get bh
1030 ab <- get bh
1031 return (IfaceClassP aa ab)
1032 1 -> do ac <- get bh
1033 ad <- get bh
1034 return (IfaceIParam ac ad)
1035 2 -> do ac <- get bh
1036 ad <- get bh
1037 return (IfaceEqPred ac ad)
1038 _ -> panic ("get IfacePredType " ++ show h)
1039
1040 -------------------------------------------------------------------------
1041 -- IfaceExpr and friends
1042 -------------------------------------------------------------------------
1043
1044 instance Binary IfaceExpr where
1045 put_ bh (IfaceLcl aa) = do
1046 putByte bh 0
1047 put_ bh aa
1048 put_ bh (IfaceType ab) = do
1049 putByte bh 1
1050 put_ bh ab
1051 put_ bh (IfaceCo ab) = do
1052 putByte bh 2
1053 put_ bh ab
1054 put_ bh (IfaceTuple ac ad) = do
1055 putByte bh 3
1056 put_ bh ac
1057 put_ bh ad
1058 put_ bh (IfaceLam ae af) = do
1059 putByte bh 4
1060 put_ bh ae
1061 put_ bh af
1062 put_ bh (IfaceApp ag ah) = do
1063 putByte bh 5
1064 put_ bh ag
1065 put_ bh ah
1066 put_ bh (IfaceCase ai aj ak) = do
1067 putByte bh 6
1068 put_ bh ai
1069 put_ bh aj
1070 put_ bh ak
1071 put_ bh (IfaceLet al am) = do
1072 putByte bh 7
1073 put_ bh al
1074 put_ bh am
1075 put_ bh (IfaceNote an ao) = do
1076 putByte bh 8
1077 put_ bh an
1078 put_ bh ao
1079 put_ bh (IfaceLit ap) = do
1080 putByte bh 9
1081 put_ bh ap
1082 put_ bh (IfaceFCall as at) = do
1083 putByte bh 10
1084 put_ bh as
1085 put_ bh at
1086 put_ bh (IfaceExt aa) = do
1087 putByte bh 11
1088 put_ bh aa
1089 put_ bh (IfaceCast ie ico) = do
1090 putByte bh 12
1091 put_ bh ie
1092 put_ bh ico
1093 put_ bh (IfaceTick m ix) = do
1094 putByte bh 13
1095 put_ bh m
1096 put_ bh ix
1097 get bh = do
1098 h <- getByte bh
1099 case h of
1100 0 -> do aa <- get bh
1101 return (IfaceLcl aa)
1102 1 -> do ab <- get bh
1103 return (IfaceType ab)
1104 2 -> do ab <- get bh
1105 return (IfaceCo ab)
1106 3 -> do ac <- get bh
1107 ad <- get bh
1108 return (IfaceTuple ac ad)
1109 4 -> do ae <- get bh
1110 af <- get bh
1111 return (IfaceLam ae af)
1112 5 -> do ag <- get bh
1113 ah <- get bh
1114 return (IfaceApp ag ah)
1115 6 -> do ai <- get bh
1116 aj <- get bh
1117 ak <- get bh
1118 return (IfaceCase ai aj ak)
1119 7 -> do al <- get bh
1120 am <- get bh
1121 return (IfaceLet al am)
1122 8 -> do an <- get bh
1123 ao <- get bh
1124 return (IfaceNote an ao)
1125 9 -> do ap <- get bh
1126 return (IfaceLit ap)
1127 10 -> do as <- get bh
1128 at <- get bh
1129 return (IfaceFCall as at)
1130 11 -> do aa <- get bh
1131 return (IfaceExt aa)
1132 12 -> do ie <- get bh
1133 ico <- get bh
1134 return (IfaceCast ie ico)
1135 13 -> do m <- get bh
1136 ix <- get bh
1137 return (IfaceTick m ix)
1138 _ -> panic ("get IfaceExpr " ++ show h)
1139
1140 instance Binary IfaceConAlt where
1141 put_ bh IfaceDefault = do
1142 putByte bh 0
1143 put_ bh (IfaceDataAlt aa) = do
1144 putByte bh 1
1145 put_ bh aa
1146 put_ bh (IfaceTupleAlt ab) = do
1147 putByte bh 2
1148 put_ bh ab
1149 put_ bh (IfaceLitAlt ac) = do
1150 putByte bh 3
1151 put_ bh ac
1152 get bh = do
1153 h <- getByte bh
1154 case h of
1155 0 -> do return IfaceDefault
1156 1 -> do aa <- get bh
1157 return (IfaceDataAlt aa)
1158 2 -> do ab <- get bh
1159 return (IfaceTupleAlt ab)
1160 _ -> do ac <- get bh
1161 return (IfaceLitAlt ac)
1162
1163 instance Binary IfaceBinding where
1164 put_ bh (IfaceNonRec aa ab) = do
1165 putByte bh 0
1166 put_ bh aa
1167 put_ bh ab
1168 put_ bh (IfaceRec ac) = do
1169 putByte bh 1
1170 put_ bh ac
1171 get bh = do
1172 h <- getByte bh
1173 case h of
1174 0 -> do aa <- get bh
1175 ab <- get bh
1176 return (IfaceNonRec aa ab)
1177 _ -> do ac <- get bh
1178 return (IfaceRec ac)
1179
1180 instance Binary IfaceIdDetails where
1181 put_ bh IfVanillaId = putByte bh 0
1182 put_ bh (IfRecSelId a b) = do { putByte bh 1; put_ bh a; put_ bh b }
1183 put_ bh IfDFunId = putByte bh 2
1184 get bh = do
1185 h <- getByte bh
1186 case h of
1187 0 -> return IfVanillaId
1188 1 -> do a <- get bh
1189 b <- get bh
1190 return (IfRecSelId a b)
1191 _ -> return IfDFunId
1192
1193 instance Binary IfaceIdInfo where
1194 put_ bh NoInfo = putByte bh 0
1195 put_ bh (HasInfo i) = do
1196 putByte bh 1
1197 lazyPut bh i -- NB lazyPut
1198
1199 get bh = do
1200 h <- getByte bh
1201 case h of
1202 0 -> return NoInfo
1203 _ -> do info <- lazyGet bh -- NB lazyGet
1204 return (HasInfo info)
1205
1206 instance Binary IfaceInfoItem where
1207 put_ bh (HsArity aa) = do
1208 putByte bh 0
1209 put_ bh aa
1210 put_ bh (HsStrictness ab) = do
1211 putByte bh 1
1212 put_ bh ab
1213 put_ bh (HsUnfold lb ad) = do
1214 putByte bh 2
1215 put_ bh lb
1216 put_ bh ad
1217 put_ bh (HsInline ad) = do
1218 putByte bh 3
1219 put_ bh ad
1220 put_ bh HsNoCafRefs = do
1221 putByte bh 4
1222 get bh = do
1223 h <- getByte bh
1224 case h of
1225 0 -> do aa <- get bh
1226 return (HsArity aa)
1227 1 -> do ab <- get bh
1228 return (HsStrictness ab)
1229 2 -> do lb <- get bh
1230 ad <- get bh
1231 return (HsUnfold lb ad)
1232 3 -> do ad <- get bh
1233 return (HsInline ad)
1234 _ -> do return HsNoCafRefs
1235
1236 instance Binary IfaceUnfolding where
1237 put_ bh (IfCoreUnfold s e) = do
1238 putByte bh 0
1239 put_ bh s
1240 put_ bh e
1241 put_ bh (IfInlineRule a b c d) = do
1242 putByte bh 1
1243 put_ bh a
1244 put_ bh b
1245 put_ bh c
1246 put_ bh d
1247 put_ bh (IfLclWrapper a n) = do
1248 putByte bh 2
1249 put_ bh a
1250 put_ bh n
1251 put_ bh (IfExtWrapper a n) = do
1252 putByte bh 3
1253 put_ bh a
1254 put_ bh n
1255 put_ bh (IfDFunUnfold as) = do
1256 putByte bh 4
1257 put_ bh as
1258 put_ bh (IfCompulsory e) = do
1259 putByte bh 5
1260 put_ bh e
1261 get bh = do
1262 h <- getByte bh
1263 case h of
1264 0 -> do s <- get bh
1265 e <- get bh
1266 return (IfCoreUnfold s e)
1267 1 -> do a <- get bh
1268 b <- get bh
1269 c <- get bh
1270 d <- get bh
1271 return (IfInlineRule a b c d)
1272 2 -> do a <- get bh
1273 n <- get bh
1274 return (IfLclWrapper a n)
1275 3 -> do a <- get bh
1276 n <- get bh
1277 return (IfExtWrapper a n)
1278 4 -> do as <- get bh
1279 return (IfDFunUnfold as)
1280 _ -> do e <- get bh
1281 return (IfCompulsory e)
1282
1283 instance Binary IfaceNote where
1284 put_ bh (IfaceSCC aa) = do
1285 putByte bh 0
1286 put_ bh aa
1287 put_ bh (IfaceCoreNote s) = do
1288 putByte bh 4
1289 put_ bh s
1290 get bh = do
1291 h <- getByte bh
1292 case h of
1293 0 -> do aa <- get bh
1294 return (IfaceSCC aa)
1295 4 -> do ac <- get bh
1296 return (IfaceCoreNote ac)
1297 _ -> panic ("get IfaceNote " ++ show h)
1298
1299 -------------------------------------------------------------------------
1300 -- IfaceDecl and friends
1301 -------------------------------------------------------------------------
1302
1303 -- A bit of magic going on here: there's no need to store the OccName
1304 -- for a decl on the disk, since we can infer the namespace from the
1305 -- context; however it is useful to have the OccName in the IfaceDecl
1306 -- to avoid re-building it in various places. So we build the OccName
1307 -- when de-serialising.
1308
1309 instance Binary IfaceDecl where
1310 put_ bh (IfaceId name ty details idinfo) = do
1311 putByte bh 0
1312 put_ bh (occNameFS name)
1313 put_ bh ty
1314 put_ bh details
1315 put_ bh idinfo
1316 put_ _ (IfaceForeign _ _) =
1317 error "Binary.put_(IfaceDecl): IfaceForeign"
1318 put_ bh (IfaceData a1 a2 a3 a4 a5 a6 a7) = do
1319 putByte bh 2
1320 put_ bh (occNameFS a1)
1321 put_ bh a2
1322 put_ bh a3
1323 put_ bh a4
1324 put_ bh a5
1325 put_ bh a6
1326 put_ bh a7
1327 put_ bh (IfaceSyn a1 a2 a3 a4 a5) = do
1328 putByte bh 3
1329 put_ bh (occNameFS a1)
1330 put_ bh a2
1331 put_ bh a3
1332 put_ bh a4
1333 put_ bh a5
1334 put_ bh (IfaceClass a1 a2 a3 a4 a5 a6 a7) = do
1335 putByte bh 4
1336 put_ bh a1
1337 put_ bh (occNameFS a2)
1338 put_ bh a3
1339 put_ bh a4
1340 put_ bh a5
1341 put_ bh a6
1342 put_ bh a7
1343 get bh = do
1344 h <- getByte bh
1345 case h of
1346 0 -> do name <- get bh
1347 ty <- get bh
1348 details <- get bh
1349 idinfo <- get bh
1350 occ <- return $! mkOccNameFS varName name
1351 return (IfaceId occ ty details idinfo)
1352 1 -> error "Binary.get(TyClDecl): ForeignType"
1353 2 -> do
1354 a1 <- get bh
1355 a2 <- get bh
1356 a3 <- get bh
1357 a4 <- get bh
1358 a5 <- get bh
1359 a6 <- get bh
1360 a7 <- get bh
1361 occ <- return $! mkOccNameFS tcName a1
1362 return (IfaceData occ a2 a3 a4 a5 a6 a7)
1363 3 -> do
1364 a1 <- get bh
1365 a2 <- get bh
1366 a3 <- get bh
1367 a4 <- get bh
1368 a5 <- get bh
1369 occ <- return $! mkOccNameFS tcName a1
1370 return (IfaceSyn occ a2 a3 a4 a5)
1371 _ -> do
1372 a1 <- get bh
1373 a2 <- get bh
1374 a3 <- get bh
1375 a4 <- get bh
1376 a5 <- get bh
1377 a6 <- get bh
1378 a7 <- get bh
1379 occ <- return $! mkOccNameFS clsName a2
1380 return (IfaceClass a1 occ a3 a4 a5 a6 a7)
1381
1382 instance Binary IfaceInst where
1383 put_ bh (IfaceInst cls tys dfun flag orph) = do
1384 put_ bh cls
1385 put_ bh tys
1386 put_ bh dfun
1387 put_ bh flag
1388 put_ bh orph
1389 get bh = do cls <- get bh
1390 tys <- get bh
1391 dfun <- get bh
1392 flag <- get bh
1393 orph <- get bh
1394 return (IfaceInst cls tys dfun flag orph)
1395
1396 instance Binary IfaceFamInst where
1397 put_ bh (IfaceFamInst fam tys tycon) = do
1398 put_ bh fam
1399 put_ bh tys
1400 put_ bh tycon
1401 get bh = do fam <- get bh
1402 tys <- get bh
1403 tycon <- get bh
1404 return (IfaceFamInst fam tys tycon)
1405
1406 instance Binary OverlapFlag where
1407 put_ bh (NoOverlap b) = putByte bh 0 >> put_ bh b
1408 put_ bh (OverlapOk b) = putByte bh 1 >> put_ bh b
1409 put_ bh (Incoherent b) = putByte bh 2 >> put_ bh b
1410 get bh = do h <- getByte bh
1411 b <- get bh
1412 case h of
1413 0 -> return $ NoOverlap b
1414 1 -> return $ OverlapOk b
1415 2 -> return $ Incoherent b
1416 _ -> panic ("get OverlapFlag " ++ show h)
1417
1418 instance Binary IfaceConDecls where
1419 put_ bh IfAbstractTyCon = putByte bh 0
1420 put_ bh IfOpenDataTyCon = putByte bh 1
1421 put_ bh (IfDataTyCon cs) = do { putByte bh 2
1422 ; put_ bh cs }
1423 put_ bh (IfNewTyCon c) = do { putByte bh 3
1424 ; put_ bh c }
1425 get bh = do
1426 h <- getByte bh
1427 case h of
1428 0 -> return IfAbstractTyCon
1429 1 -> return IfOpenDataTyCon
1430 2 -> do cs <- get bh
1431 return (IfDataTyCon cs)
1432 _ -> do aa <- get bh
1433 return (IfNewTyCon aa)
1434
1435 instance Binary IfaceConDecl where
1436 put_ bh (IfCon a1 a2 a3 a4 a5 a6 a7 a8 a9 a10) = do
1437 put_ bh a1
1438 put_ bh a2
1439 put_ bh a3
1440 put_ bh a4
1441 put_ bh a5
1442 put_ bh a6
1443 put_ bh a7
1444 put_ bh a8
1445 put_ bh a9
1446 put_ bh a10
1447 get bh = do a1 <- get bh
1448 a2 <- get bh
1449 a3 <- get bh
1450 a4 <- get bh
1451 a5 <- get bh
1452 a6 <- get bh
1453 a7 <- get bh
1454 a8 <- get bh
1455 a9 <- get bh
1456 a10 <- get bh
1457 return (IfCon a1 a2 a3 a4 a5 a6 a7 a8 a9 a10)
1458
1459 instance Binary IfaceClassOp where
1460 put_ bh (IfaceClassOp n def ty) = do
1461 put_ bh (occNameFS n)
1462 put_ bh def
1463 put_ bh ty
1464 get bh = do
1465 n <- get bh
1466 def <- get bh
1467 ty <- get bh
1468 occ <- return $! mkOccNameFS varName n
1469 return (IfaceClassOp occ def ty)
1470
1471 instance Binary IfaceRule where
1472 put_ bh (IfaceRule a1 a2 a3 a4 a5 a6 a7 a8) = do
1473 put_ bh a1
1474 put_ bh a2
1475 put_ bh a3
1476 put_ bh a4
1477 put_ bh a5
1478 put_ bh a6
1479 put_ bh a7
1480 put_ bh a8
1481 get bh = do
1482 a1 <- get bh
1483 a2 <- get bh
1484 a3 <- get bh
1485 a4 <- get bh
1486 a5 <- get bh
1487 a6 <- get bh
1488 a7 <- get bh
1489 a8 <- get bh
1490 return (IfaceRule a1 a2 a3 a4 a5 a6 a7 a8)
1491
1492 instance Binary IfaceAnnotation where
1493 put_ bh (IfaceAnnotation a1 a2) = do
1494 put_ bh a1
1495 put_ bh a2
1496 get bh = do
1497 a1 <- get bh
1498 a2 <- get bh
1499 return (IfaceAnnotation a1 a2)
1500
1501 instance Binary name => Binary (AnnTarget name) where
1502 put_ bh (NamedTarget a) = do
1503 putByte bh 0
1504 put_ bh a
1505 put_ bh (ModuleTarget a) = do
1506 putByte bh 1
1507 put_ bh a
1508 get bh = do
1509 h <- getByte bh
1510 case h of
1511 0 -> do a <- get bh
1512 return (NamedTarget a)
1513 _ -> do a <- get bh
1514 return (ModuleTarget a)
1515
1516 instance Binary IfaceVectInfo where
1517 put_ bh (IfaceVectInfo a1 a2 a3 a4 a5) = do
1518 put_ bh a1
1519 put_ bh a2
1520 put_ bh a3
1521 put_ bh a4
1522 put_ bh a5
1523 get bh = do
1524 a1 <- get bh
1525 a2 <- get bh
1526 a3 <- get bh
1527 a4 <- get bh
1528 a5 <- get bh
1529 return (IfaceVectInfo a1 a2 a3 a4 a5)
1530
1531 instance Binary IfaceTrustInfo where
1532 put_ bh iftrust = putByte bh $ trustInfoToNum iftrust
1533 get bh = getByte bh >>= (return . numToTrustInfo)
1534