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