3 -- (c) The University of Glasgow 2002-2006
5 -- Binary interface file support.
7 module BinIface ( writeBinIface, readBinIface,
8 CheckHiWay(..), TraceBinIFaceReading(..) ) where
10 #include "HsVersions.h"
41 import Control.Exception
44 data CheckHiWay = CheckHiWay | IgnoreHiWay
47 data TraceBinIFaceReading = TraceBinIFaceReading | QuietBinIFaceReading
50 -- ---------------------------------------------------------------------------
51 -- Reading and writing binary interface files
53 readBinIface :: CheckHiWay -> TraceBinIFaceReading -> FilePath
54 -> TcRnIf a b ModIface
55 readBinIface checkHiWay traceBinIFaceReading hi_path = do
57 (new_nc, iface) <- liftIO $
58 readBinIface_ checkHiWay traceBinIFaceReading hi_path nc
62 readBinIface_ :: CheckHiWay -> TraceBinIFaceReading -> FilePath -> NameCache
63 -> IO (NameCache, ModIface)
64 readBinIface_ checkHiWay traceBinIFaceReading hi_path nc = do
65 let printer :: SDoc -> IO ()
66 printer = case traceBinIFaceReading of
67 TraceBinIFaceReading -> \sd -> printSDoc sd defaultDumpStyle
68 QuietBinIFaceReading -> \_ -> return ()
69 wantedGot :: Outputable a => String -> a -> a -> IO ()
70 wantedGot what wanted got
71 = printer (text what <> text ": " <>
72 vcat [text "Wanted " <> ppr wanted <> text ",",
73 text "got " <> ppr got])
74 errorOnMismatch :: (Eq a, Show a) => String -> a -> a -> IO ()
75 errorOnMismatch what wanted got
76 -- This will be caught by readIface which will emit an error
77 -- msg containing the iface module name.
78 = when (wanted /= got) $ throwDyn $ ProgramError
79 (what ++ " (wanted " ++ show wanted
80 ++ ", got " ++ show got ++ ")")
81 bh <- Binary.readBinMem hi_path
83 -- Read the magic number to check that this really is a GHC .hi file
84 -- (This magic number does not change when we change
85 -- GHC interface file format)
87 wantedGot "Magic" binaryInterfaceMagic magic
88 errorOnMismatch "magic number mismatch: old/corrupt interface file?"
89 binaryInterfaceMagic magic
91 -- Get the dictionary pointer. We won't attempt to actually
92 -- read the dictionary until we've done the version checks below,
93 -- just in case this isn't a valid interface. In retrospect the
94 -- version should have come before the dictionary pointer, but this
95 -- is the way it was done originally, and we can't change it now.
96 dict_p <- Binary.get bh -- Get the dictionary ptr
98 -- Check the interface file version and ways.
100 let our_ver = show opt_HiVersion
101 wantedGot "Version" our_ver check_ver
102 errorOnMismatch "mismatched interface file versions" our_ver check_ver
105 way_descr <- getWayDescr
106 wantedGot "Way" way_descr check_way
107 when (checkHiWay == CheckHiWay) $
108 errorOnMismatch "mismatched interface file ways" way_descr check_way
110 -- Read the dictionary
111 -- The next word in the file is a pointer to where the dictionary is
112 -- (probably at the end of the file)
113 data_p <- tellBin bh -- Remember where we are now
115 dict <- getDictionary bh
116 seekBin bh data_p -- Back to where we were before
118 -- Initialise the user-data field of bh
119 ud <- newReadState dict
120 bh <- return (setUserData bh ud)
122 symtab_p <- Binary.get bh -- Get the symtab ptr
123 data_p <- tellBin bh -- Remember where we are now
125 (nc', symtab) <- getSymbolTable bh nc
126 seekBin bh data_p -- Back to where we were before
127 let ud = getUserData bh
128 bh <- return $! setUserData bh ud{ud_symtab = symtab}
133 writeBinIface :: DynFlags -> FilePath -> ModIface -> IO ()
134 writeBinIface dflags hi_path mod_iface = do
135 bh <- openBinMem initBinMemSize
136 put_ bh binaryInterfaceMagic
138 -- Remember where the dictionary pointer will go
139 dict_p_p <- tellBin bh
140 put_ bh dict_p_p -- Placeholder for ptr to dictionary
142 -- The version and way descriptor go next
143 put_ bh (show opt_HiVersion)
144 way_descr <- getWayDescr
147 -- Remember where the symbol table pointer will go
148 symtab_p_p <- tellBin bh
151 -- Make some intial state
154 -- Put the main thing,
155 bh <- return $ setUserData bh ud
158 -- Write the symtab pointer at the fornt of the file
159 symtab_p <- tellBin bh -- This is where the symtab will start
160 putAt bh symtab_p_p symtab_p -- Fill in the placeholder
161 seekBin bh symtab_p -- Seek back to the end of the file
163 -- Write the symbol table itself
164 symtab_next <- readFastMutInt (ud_symtab_next ud)
165 symtab_map <- readIORef (ud_symtab_map ud)
166 putSymbolTable bh symtab_next symtab_map
167 debugTraceMsg dflags 3 (text "writeBinIface:" <+> int symtab_next
170 -- NB. write the dictionary after the symbol table, because
171 -- writing the symbol table may create more dictionary entries.
173 -- Write the dictionary pointer at the fornt of the file
174 dict_p <- tellBin bh -- This is where the dictionary will start
175 putAt bh dict_p_p dict_p -- Fill in the placeholder
176 seekBin bh dict_p -- Seek back to the end of the file
178 -- Write the dictionary itself
179 dict_next <- readFastMutInt (ud_dict_next ud)
180 dict_map <- readIORef (ud_dict_map ud)
181 putDictionary bh dict_next dict_map
182 debugTraceMsg dflags 3 (text "writeBinIface:" <+> int dict_next
183 <+> text "dict entries")
185 -- And send the result to the file
186 writeBinMem bh hi_path
188 initBinMemSize :: Int
189 initBinMemSize = 1024 * 1024
191 -- The *host* architecture version:
192 #include "MachDeps.h"
194 binaryInterfaceMagic :: Word32
195 #if WORD_SIZE_IN_BITS == 32
196 binaryInterfaceMagic = 0x1face
197 #elif WORD_SIZE_IN_BITS == 64
198 binaryInterfaceMagic = 0x1face64
201 -- -----------------------------------------------------------------------------
204 putSymbolTable :: BinHandle -> Int -> UniqFM (Int,Name) -> IO ()
205 putSymbolTable bh next_off symtab = do
207 let names = elems (array (0,next_off-1) (eltsUFM symtab))
208 mapM_ (\n -> serialiseName bh n symtab) names
210 getSymbolTable :: BinHandle -> NameCache -> IO (NameCache, Array Int Name)
211 getSymbolTable bh namecache = do
213 od_names <- sequence (replicate sz (get bh))
215 arr = listArray (0,sz-1) names
216 (namecache', names) =
217 mapAccumR (fromOnDiskName arr) namecache od_names
219 return (namecache', arr)
221 type OnDiskName = (PackageId, ModuleName, OccName)
228 fromOnDiskName _ nc (pid, mod_name, occ) =
230 mod = mkModule pid mod_name
233 case lookupOrigNameCache cache mod occ of
234 Just name -> (nc, name)
238 uniq = uniqFromSupply us
239 name = mkExternalName uniq mod occ noSrcSpan
240 new_cache = extendNameCache cache mod occ name
242 case splitUniqSupply us of { (us',_) ->
243 ( nc{ nsUniqs = us', nsNames = new_cache }, name )
246 serialiseName :: BinHandle -> Name -> UniqFM (Int,Name) -> IO ()
247 serialiseName bh name _ = do
248 let mod = nameModule name
249 put_ bh (modulePackageId mod, moduleName mod, nameOccName name)
251 -- -----------------------------------------------------------------------------
252 -- All the binary instances
255 {-! for IPName derive: Binary !-}
256 {-! for Fixity derive: Binary !-}
257 {-! for FixityDirection derive: Binary !-}
258 {-! for Boxity derive: Binary !-}
259 {-! for StrictnessMark derive: Binary !-}
260 {-! for Activation derive: Binary !-}
263 {-! for Demand derive: Binary !-}
264 {-! for Demands derive: Binary !-}
265 {-! for DmdResult derive: Binary !-}
266 {-! for StrictSig derive: Binary !-}
269 {-! for DefMeth derive: Binary !-}
272 {-! for HsPred derive: Binary !-}
273 {-! for HsType derive: Binary !-}
274 {-! for TupCon derive: Binary !-}
275 {-! for HsTyVarBndr derive: Binary !-}
278 {-! for UfExpr derive: Binary !-}
279 {-! for UfConAlt derive: Binary !-}
280 {-! for UfBinding derive: Binary !-}
281 {-! for UfBinder derive: Binary !-}
282 {-! for HsIdInfo derive: Binary !-}
283 {-! for UfNote derive: Binary !-}
286 {-! for ConDetails derive: Binary !-}
287 {-! for BangType derive: Binary !-}
290 {-! for IsCafCC derive: Binary !-}
291 {-! for IsDupdCC derive: Binary !-}
292 {-! for CostCentre derive: Binary !-}
296 -- ---------------------------------------------------------------------------
297 -- Reading a binary interface into ParsedIface
299 instance Binary ModIface where
303 mi_mod_vers = mod_vers,
305 mi_finsts = hasFamInsts,
308 mi_exports = exports,
309 mi_exp_vers = exp_vers,
310 mi_fixities = fixities,
311 mi_deprecs = deprecs,
314 mi_fam_insts = fam_insts,
316 mi_rule_vers = rule_vers,
317 mi_vect_info = vect_info,
318 mi_hpc = hpc_info }) = do
343 hasFamInsts <- get bh
345 usages <- {-# SCC "bin_usages" #-} lazyGet bh
346 exports <- {-# SCC "bin_exports" #-} get bh
348 fixities <- {-# SCC "bin_fixities" #-} get bh
349 deprecs <- {-# SCC "bin_deprecs" #-} lazyGet bh
350 decls <- {-# SCC "bin_tycldecls" #-} get bh
351 insts <- {-# SCC "bin_insts" #-} get bh
352 fam_insts <- {-# SCC "bin_fam_insts" #-} get bh
353 rules <- {-# SCC "bin_rules" #-} lazyGet bh
358 mi_module = mod_name,
360 mi_mod_vers = mod_vers,
362 mi_finsts = hasFamInsts,
365 mi_exports = exports,
366 mi_exp_vers = exp_vers,
367 mi_fixities = fixities,
368 mi_deprecs = deprecs,
370 mi_globals = Nothing,
372 mi_fam_insts = fam_insts,
374 mi_rule_vers = rule_vers,
375 mi_vect_info = vect_info,
377 -- And build the cached values
378 mi_dep_fn = mkIfaceDepCache deprecs,
379 mi_fix_fn = mkIfaceFixCache fixities,
380 mi_ver_fn = mkIfaceVerCache decls })
382 getWayDescr :: IO String
384 tag <- readIORef v_Build_tag
385 if cGhcUnregisterised == "YES" then return ('u':tag) else return tag
386 -- if this is an unregisterised build, make sure our interfaces
387 -- can't be used by a registerised build.
389 -------------------------------------------------------------------------
390 -- Types from: HscTypes
391 -------------------------------------------------------------------------
393 instance Binary Dependencies where
394 put_ bh deps = do put_ bh (dep_mods deps)
395 put_ bh (dep_pkgs deps)
396 put_ bh (dep_orphs deps)
397 put_ bh (dep_finsts deps)
399 get bh = do ms <- get bh
403 return (Deps { dep_mods = ms, dep_pkgs = ps, dep_orphs = os,
406 instance (Binary name) => Binary (GenAvailInfo name) where
407 put_ bh (Avail aa) = do
410 put_ bh (AvailTC ab ac) = do
421 return (AvailTC ab ac)
423 instance Binary Usage where
425 put_ bh (usg_name usg)
426 put_ bh (usg_mod usg)
427 put_ bh (usg_exports usg)
428 put_ bh (usg_entities usg)
429 put_ bh (usg_rules usg)
437 return (Usage { usg_name = nm, usg_mod = mod,
438 usg_exports = exps, usg_entities = ents,
441 instance Binary Deprecations where
442 put_ bh NoDeprecs = putByte bh 0
443 put_ bh (DeprecAll t) = do
446 put_ bh (DeprecSome ts) = do
453 0 -> return NoDeprecs
455 return (DeprecAll aa)
457 return (DeprecSome aa)
459 -------------------------------------------------------------------------
460 -- Types from: BasicTypes
461 -------------------------------------------------------------------------
463 instance Binary Activation where
464 put_ bh NeverActive = do
466 put_ bh AlwaysActive = do
468 put_ bh (ActiveBefore aa) = do
471 put_ bh (ActiveAfter ab) = do
477 0 -> do return NeverActive
478 1 -> do return AlwaysActive
480 return (ActiveBefore aa)
482 return (ActiveAfter ab)
484 instance Binary StrictnessMark where
485 put_ bh MarkedStrict = do
487 put_ bh MarkedUnboxed = do
489 put_ bh NotMarkedStrict = do
494 0 -> do return MarkedStrict
495 1 -> do return MarkedUnboxed
496 _ -> do return NotMarkedStrict
498 instance Binary Boxity where
507 _ -> do return Unboxed
509 instance Binary TupCon where
510 put_ bh (TupCon ab ac) = do
516 return (TupCon ab ac)
518 instance Binary RecFlag where
519 put_ bh Recursive = do
521 put_ bh NonRecursive = do
526 0 -> do return Recursive
527 _ -> do return NonRecursive
529 instance Binary DefMeth where
530 put_ bh NoDefMeth = putByte bh 0
531 put_ bh DefMeth = putByte bh 1
532 put_ bh GenDefMeth = putByte bh 2
536 0 -> return NoDefMeth
538 _ -> return GenDefMeth
540 instance Binary FixityDirection where
550 0 -> do return InfixL
551 1 -> do return InfixR
552 _ -> do return InfixN
554 instance Binary Fixity where
555 put_ bh (Fixity aa ab) = do
561 return (Fixity aa ab)
563 instance (Binary name) => Binary (IPName name) where
564 put_ bh (IPName aa) = put_ bh aa
565 get bh = do aa <- get bh
568 -------------------------------------------------------------------------
569 -- Types from: Demand
570 -------------------------------------------------------------------------
572 instance Binary DmdType where
573 -- Ignore DmdEnv when spitting out the DmdType
574 put bh (DmdType _ ds dr) = do p <- put bh ds; put bh dr; return (castBin p)
575 get bh = do ds <- get bh; dr <- get bh; return (DmdType emptyVarEnv ds dr)
577 instance Binary Demand where
582 put_ bh (Call aa) = do
585 put_ bh (Eval ab) = do
588 put_ bh (Defer ac) = do
591 put_ bh (Box ad) = do
611 instance Binary Demands where
612 put_ bh (Poly aa) = do
615 put_ bh (Prod ab) = do
626 instance Binary DmdResult where
636 0 -> do return TopRes
637 1 -> do return RetCPR -- Really use RetCPR even if -fcpr-off
638 -- The wrapper was generated for CPR in
639 -- the imported module!
640 _ -> do return BotRes
642 instance Binary StrictSig where
643 put_ bh (StrictSig aa) = do
647 return (StrictSig aa)
650 -------------------------------------------------------------------------
651 -- Types from: CostCentre
652 -------------------------------------------------------------------------
654 instance Binary IsCafCC where
657 put_ bh NotCafCC = do
663 _ -> do return NotCafCC
665 instance Binary IsDupdCC where
666 put_ bh OriginalCC = do
673 0 -> do return OriginalCC
674 _ -> do return DupdCC
676 instance Binary CostCentre where
677 put_ bh NoCostCentre = do
679 put_ bh (NormalCC aa ab ac ad) = do
685 put_ bh (AllCafsCC ae) = do
691 0 -> do return NoCostCentre
696 return (NormalCC aa ab ac ad)
698 return (AllCafsCC ae)
700 -------------------------------------------------------------------------
701 -- IfaceTypes and friends
702 -------------------------------------------------------------------------
704 instance Binary IfaceBndr where
705 put_ bh (IfaceIdBndr aa) = do
708 put_ bh (IfaceTvBndr ab) = do
715 return (IfaceIdBndr aa)
717 return (IfaceTvBndr ab)
719 instance Binary IfaceLetBndr where
720 put_ bh (IfLetBndr a b c) = do
724 get bh = do a <- get bh
727 return (IfLetBndr a b c)
729 instance Binary IfaceType where
730 put_ bh (IfaceForAllTy aa ab) = do
734 put_ bh (IfaceTyVar ad) = do
737 put_ bh (IfaceAppTy ae af) = do
741 put_ bh (IfaceFunTy ag ah) = do
745 put_ bh (IfacePredTy aq) = do
749 -- Simple compression for common cases of TyConApp
750 put_ bh (IfaceTyConApp IfaceIntTc []) = putByte bh 6
751 put_ bh (IfaceTyConApp IfaceCharTc []) = putByte bh 7
752 put_ bh (IfaceTyConApp IfaceBoolTc []) = putByte bh 8
753 put_ bh (IfaceTyConApp IfaceListTc [ty]) = do { putByte bh 9; put_ bh ty }
754 -- Unit tuple and pairs
755 put_ bh (IfaceTyConApp (IfaceTupTc Boxed 0) []) = putByte bh 10
756 put_ bh (IfaceTyConApp (IfaceTupTc Boxed 2) [t1,t2]) = do { putByte bh 11; put_ bh t1; put_ bh t2 }
758 put_ bh (IfaceTyConApp IfaceLiftedTypeKindTc []) = putByte bh 12
759 put_ bh (IfaceTyConApp IfaceOpenTypeKindTc []) = putByte bh 13
760 put_ bh (IfaceTyConApp IfaceUnliftedTypeKindTc []) = putByte bh 14
761 put_ bh (IfaceTyConApp IfaceUbxTupleKindTc []) = putByte bh 15
762 put_ bh (IfaceTyConApp IfaceArgTypeKindTc []) = putByte bh 16
766 put_ bh (IfaceTyConApp (IfaceTc tc) tys) = do { putByte bh 18; put_ bh tc; put_ bh tys }
767 put_ bh (IfaceTyConApp tc tys) = do { putByte bh 19; put_ bh tc; put_ bh tys }
774 return (IfaceForAllTy aa ab)
776 return (IfaceTyVar ad)
779 return (IfaceAppTy ae af)
782 return (IfaceFunTy ag ah)
784 return (IfacePredTy ap)
786 -- Now the special cases for TyConApp
787 6 -> return (IfaceTyConApp IfaceIntTc [])
788 7 -> return (IfaceTyConApp IfaceCharTc [])
789 8 -> return (IfaceTyConApp IfaceBoolTc [])
790 9 -> do { ty <- get bh; return (IfaceTyConApp IfaceListTc [ty]) }
791 10 -> return (IfaceTyConApp (IfaceTupTc Boxed 0) [])
792 11 -> do { t1 <- get bh; t2 <- get bh; return (IfaceTyConApp (IfaceTupTc Boxed 2) [t1,t2]) }
793 12 -> return (IfaceTyConApp IfaceLiftedTypeKindTc [])
794 13 -> return (IfaceTyConApp IfaceOpenTypeKindTc [])
795 14 -> return (IfaceTyConApp IfaceUnliftedTypeKindTc [])
796 15 -> return (IfaceTyConApp IfaceUbxTupleKindTc [])
797 16 -> return (IfaceTyConApp IfaceArgTypeKindTc [])
799 18 -> do { tc <- get bh; tys <- get bh; return (IfaceTyConApp (IfaceTc tc) tys) }
800 _ -> do { tc <- get bh; tys <- get bh; return (IfaceTyConApp tc tys) }
802 instance Binary IfaceTyCon where
803 -- Int,Char,Bool can't show up here because they can't not be saturated
805 put_ bh IfaceIntTc = putByte bh 1
806 put_ bh IfaceBoolTc = putByte bh 2
807 put_ bh IfaceCharTc = putByte bh 3
808 put_ bh IfaceListTc = putByte bh 4
809 put_ bh IfacePArrTc = putByte bh 5
810 put_ bh IfaceLiftedTypeKindTc = putByte bh 6
811 put_ bh IfaceOpenTypeKindTc = putByte bh 7
812 put_ bh IfaceUnliftedTypeKindTc = putByte bh 8
813 put_ bh IfaceUbxTupleKindTc = putByte bh 9
814 put_ bh IfaceArgTypeKindTc = putByte bh 10
815 put_ bh (IfaceTupTc bx ar) = do { putByte bh 11; put_ bh bx; put_ bh ar }
816 put_ bh (IfaceTc ext) = do { putByte bh 12; put_ bh ext }
821 1 -> return IfaceIntTc
822 2 -> return IfaceBoolTc
823 3 -> return IfaceCharTc
824 4 -> return IfaceListTc
825 5 -> return IfacePArrTc
826 6 -> return IfaceLiftedTypeKindTc
827 7 -> return IfaceOpenTypeKindTc
828 8 -> return IfaceUnliftedTypeKindTc
829 9 -> return IfaceUbxTupleKindTc
830 10 -> return IfaceArgTypeKindTc
831 11 -> do { bx <- get bh; ar <- get bh; return (IfaceTupTc bx ar) }
832 _ -> do { ext <- get bh; return (IfaceTc ext) }
834 instance Binary IfacePredType where
835 put_ bh (IfaceClassP aa ab) = do
839 put_ bh (IfaceIParam ac ad) = do
843 put_ bh (IfaceEqPred ac ad) = do
852 return (IfaceClassP aa ab)
855 return (IfaceIParam ac ad)
858 return (IfaceEqPred ac ad)
859 _ -> panic ("get IfacePredType " ++ show h)
861 -------------------------------------------------------------------------
862 -- IfaceExpr and friends
863 -------------------------------------------------------------------------
865 instance Binary IfaceExpr where
866 put_ bh (IfaceLcl aa) = do
869 put_ bh (IfaceType ab) = do
872 put_ bh (IfaceTuple ac ad) = do
876 put_ bh (IfaceLam ae af) = do
880 put_ bh (IfaceApp ag ah) = do
885 put_ bh (IfaceCase ai aj al ak) = do
892 put_ bh (IfaceLet al am) = do
896 put_ bh (IfaceNote an ao) = do
900 put_ bh (IfaceLit ap) = do
903 put_ bh (IfaceFCall as at) = do
907 put_ bh (IfaceExt aa) = do
910 put_ bh (IfaceCast ie ico) = do
914 put_ bh (IfaceTick m ix) = do
924 return (IfaceType ab)
927 return (IfaceTuple ac ad)
930 return (IfaceLam ae af)
933 return (IfaceApp ag ah)
940 return (IfaceCase ai aj al ak)
943 return (IfaceLet al am)
946 return (IfaceNote an ao)
951 return (IfaceFCall as at)
952 10 -> do aa <- get bh
954 11 -> do ie <- get bh
956 return (IfaceCast ie ico)
959 return (IfaceTick m ix)
960 _ -> panic ("get IfaceExpr " ++ show h)
962 instance Binary IfaceConAlt where
963 put_ bh IfaceDefault = do
965 put_ bh (IfaceDataAlt aa) = do
968 put_ bh (IfaceTupleAlt ab) = do
971 put_ bh (IfaceLitAlt ac) = do
977 0 -> do return IfaceDefault
979 return (IfaceDataAlt aa)
981 return (IfaceTupleAlt ab)
983 return (IfaceLitAlt ac)
985 instance Binary IfaceBinding where
986 put_ bh (IfaceNonRec aa ab) = do
990 put_ bh (IfaceRec ac) = do
998 return (IfaceNonRec aa ab)
1000 return (IfaceRec ac)
1002 instance Binary IfaceIdInfo where
1003 put_ bh NoInfo = putByte bh 0
1004 put_ bh (HasInfo i) = do
1006 lazyPut bh i -- NB lazyPut
1012 _ -> do info <- lazyGet bh -- NB lazyGet
1013 return (HasInfo info)
1015 instance Binary IfaceInfoItem where
1016 put_ bh (HsArity aa) = do
1019 put_ bh (HsStrictness ab) = do
1022 put_ bh (HsUnfold ad) = do
1025 put_ bh (HsInline ad) = do
1028 put_ bh HsNoCafRefs = do
1030 put_ bh (HsWorker ae af) = do
1037 0 -> do aa <- get bh
1039 1 -> do ab <- get bh
1040 return (HsStrictness ab)
1041 2 -> do ad <- get bh
1042 return (HsUnfold ad)
1043 3 -> do ad <- get bh
1044 return (HsInline ad)
1045 4 -> do return HsNoCafRefs
1046 _ -> do ae <- get bh
1048 return (HsWorker ae af)
1050 instance Binary IfaceNote where
1051 put_ bh (IfaceSCC aa) = do
1054 put_ bh IfaceInlineMe = do
1056 put_ bh (IfaceCoreNote s) = do
1062 0 -> do aa <- get bh
1063 return (IfaceSCC aa)
1064 3 -> do return IfaceInlineMe
1065 4 -> do ac <- get bh
1066 return (IfaceCoreNote ac)
1067 _ -> panic ("get IfaceNote " ++ show h)
1069 -------------------------------------------------------------------------
1070 -- IfaceDecl and friends
1071 -------------------------------------------------------------------------
1073 -- A bit of magic going on here: there's no need to store the OccName
1074 -- for a decl on the disk, since we can infer the namespace from the
1075 -- context; however it is useful to have the OccName in the IfaceDecl
1076 -- to avoid re-building it in various places. So we build the OccName
1077 -- when de-serialising.
1079 instance Binary IfaceDecl where
1080 put_ bh (IfaceId name ty idinfo) = do
1082 put_ bh (occNameFS name)
1085 put_ _ (IfaceForeign _ _) =
1086 error "Binary.put_(IfaceDecl): IfaceForeign"
1087 put_ bh (IfaceData a1 a2 a3 a4 a5 a6 a7 a8) = do
1089 put_ bh (occNameFS a1)
1097 put_ bh (IfaceSyn a1 a2 a3 a4 a5) = do
1099 put_ bh (occNameFS a1)
1104 put_ bh (IfaceClass a1 a2 a3 a4 a5 a6 a7) = do
1107 put_ bh (occNameFS a2)
1116 0 -> do name <- get bh
1119 occ <- return $! mkOccNameFS varName name
1120 return (IfaceId occ ty idinfo)
1121 1 -> error "Binary.get(TyClDecl): ForeignType"
1131 occ <- return $! mkOccNameFS tcName a1
1132 return (IfaceData occ a2 a3 a4 a5 a6 a7 a8)
1139 occ <- return $! mkOccNameFS tcName a1
1140 return (IfaceSyn occ a2 a3 a4 a5)
1149 occ <- return $! mkOccNameFS clsName a2
1150 return (IfaceClass a1 occ a3 a4 a5 a6 a7)
1152 instance Binary IfaceInst where
1153 put_ bh (IfaceInst cls tys dfun flag orph) = do
1159 get bh = do cls <- get bh
1164 return (IfaceInst cls tys dfun flag orph)
1166 instance Binary IfaceFamInst where
1167 put_ bh (IfaceFamInst fam tys tycon) = do
1171 get bh = do fam <- get bh
1174 return (IfaceFamInst fam tys tycon)
1176 instance Binary OverlapFlag where
1177 put_ bh NoOverlap = putByte bh 0
1178 put_ bh OverlapOk = putByte bh 1
1179 put_ bh Incoherent = putByte bh 2
1180 get bh = do h <- getByte bh
1182 0 -> return NoOverlap
1183 1 -> return OverlapOk
1184 2 -> return Incoherent
1185 _ -> panic ("get OverlapFlag " ++ show h)
1187 instance Binary IfaceConDecls where
1188 put_ bh IfAbstractTyCon = putByte bh 0
1189 put_ bh IfOpenDataTyCon = putByte bh 1
1190 put_ bh (IfDataTyCon cs) = do { putByte bh 2
1192 put_ bh (IfNewTyCon c) = do { putByte bh 3
1197 0 -> return IfAbstractTyCon
1198 1 -> return IfOpenDataTyCon
1199 2 -> do cs <- get bh
1200 return (IfDataTyCon cs)
1201 _ -> do aa <- get bh
1202 return (IfNewTyCon aa)
1204 instance Binary IfaceConDecl where
1205 put_ bh (IfCon a1 a2 a3 a4 a5 a6 a7 a8 a9) = do
1215 get bh = do a1 <- get bh
1224 return (IfCon a1 a2 a3 a4 a5 a6 a7 a8 a9)
1226 instance Binary IfaceClassOp where
1227 put_ bh (IfaceClassOp n def ty) = do
1228 put_ bh (occNameFS n)
1235 occ <- return $! mkOccNameFS varName n
1236 return (IfaceClassOp occ def ty)
1238 instance Binary IfaceRule where
1239 put_ bh (IfaceRule a1 a2 a3 a4 a5 a6 a7) = do
1255 return (IfaceRule a1 a2 a3 a4 a5 a6 a7)
1257 instance Binary IfaceVectInfo where
1258 put_ bh (IfaceVectInfo a1 a2 a3) = do
1266 return (IfaceVectInfo a1 a2 a3)