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