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