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