2 -- The above warning supression flag is a temporary kludge.
3 -- While working on this module you are encouraged to remove it and fix
4 -- any warnings in the module. See
5 -- http://hackage.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#Warnings
9 -- (c) The University of Glasgow 2002-2006
11 -- Binary interface file support.
13 module BinIface ( writeBinIface, readBinIface,
14 CheckHiWay(..), TraceBinIFaceReading(..) ) where
16 #include "HsVersions.h"
49 import Control.Exception
52 data CheckHiWay = CheckHiWay | IgnoreHiWay
55 data TraceBinIFaceReading = TraceBinIFaceReading | QuietBinIFaceReading
58 -- ---------------------------------------------------------------------------
59 -- Reading and writing binary interface files
61 readBinIface :: CheckHiWay -> TraceBinIFaceReading -> FilePath
62 -> TcRnIf a b ModIface
63 readBinIface checkHiWay traceBinIFaceReading hi_path = do
65 (new_nc, iface) <- liftIO $
66 readBinIface_ checkHiWay traceBinIFaceReading hi_path nc
70 readBinIface_ :: CheckHiWay -> TraceBinIFaceReading -> FilePath -> NameCache
71 -> IO (NameCache, ModIface)
72 readBinIface_ checkHiWay traceBinIFaceReading hi_path nc = do
73 let printer :: SDoc -> IO ()
74 printer = case traceBinIFaceReading of
75 TraceBinIFaceReading -> \sd -> printSDoc sd defaultDumpStyle
76 QuietBinIFaceReading -> \_ -> return ()
77 wantedGot :: Outputable a => String -> a -> a -> IO ()
78 wantedGot what wanted got
79 = printer (text what <> text ": " <>
80 vcat [text "Wanted " <> ppr wanted <> text ",",
81 text "got " <> ppr got])
82 bh <- Binary.readBinMem hi_path
84 -- Read the magic number to check that this really is a GHC .hi file
85 -- (This magic number does not change when we change
86 -- GHC interface file format)
88 wantedGot "Magic" binaryInterfaceMagic magic
89 when (magic /= binaryInterfaceMagic) $
90 throwDyn (ProgramError (
91 "magic number mismatch: old/corrupt interface file?"))
93 -- Get the dictionary pointer. We won't attempt to actually
94 -- read the dictionary until we've done the version checks below,
95 -- just in case this isn't a valid interface. In retrospect the
96 -- version should have come before the dictionary pointer, but this
97 -- is the way it was done originally, and we can't change it now.
98 dict_p <- Binary.get bh -- Get the dictionary ptr
100 -- Check the interface file version and ways.
102 let our_ver = show opt_HiVersion
103 wantedGot "Version" our_ver check_ver
104 when (check_ver /= our_ver) $
105 -- This will be caught by readIface which will emit an error
106 -- msg containing the iface module name.
107 throwDyn (ProgramError (
108 "mismatched interface file versions: expected "
109 ++ our_ver ++ ", found " ++ check_ver))
112 way_descr <- getWayDescr
113 wantedGot "Way" way_descr check_way
114 when (checkHiWay == CheckHiWay && check_way /= way_descr) $
115 -- This will be caught by readIface
116 -- which will emit an error msg containing the iface module name.
117 throwDyn (ProgramError (
118 "mismatched interface file ways: expected "
119 ++ way_descr ++ ", found " ++ check_way))
121 -- Read the dictionary
122 -- The next word in the file is a pointer to where the dictionary is
123 -- (probably at the end of the file)
124 data_p <- tellBin bh -- Remember where we are now
126 dict <- getDictionary bh
127 seekBin bh data_p -- Back to where we were before
129 -- Initialise the user-data field of bh
130 ud <- newReadState dict
131 bh <- return (setUserData bh ud)
133 symtab_p <- Binary.get bh -- Get the symtab ptr
134 data_p <- tellBin bh -- Remember where we are now
136 (nc', symtab) <- getSymbolTable bh nc
137 seekBin bh data_p -- Back to where we were before
138 let ud = getUserData bh
139 bh <- return $! setUserData bh ud{ud_symtab = symtab}
144 writeBinIface :: DynFlags -> FilePath -> ModIface -> IO ()
145 writeBinIface dflags hi_path mod_iface = do
146 bh <- openBinMem initBinMemSize
147 put_ bh binaryInterfaceMagic
149 -- Remember where the dictionary pointer will go
150 dict_p_p <- tellBin bh
151 put_ bh dict_p_p -- Placeholder for ptr to dictionary
153 -- The version and way descriptor go next
154 put_ bh (show opt_HiVersion)
155 way_descr <- getWayDescr
158 -- Remember where the symbol table pointer will go
159 symtab_p_p <- tellBin bh
162 -- Make some intial state
165 -- Put the main thing,
166 bh <- return $ setUserData bh ud
169 -- Write the symtab pointer at the fornt of the file
170 symtab_p <- tellBin bh -- This is where the symtab will start
171 putAt bh symtab_p_p symtab_p -- Fill in the placeholder
172 seekBin bh symtab_p -- Seek back to the end of the file
174 -- Write the symbol table itself
175 symtab_next <- readFastMutInt (ud_symtab_next ud)
176 symtab_map <- readIORef (ud_symtab_map ud)
177 putSymbolTable bh symtab_next symtab_map
178 debugTraceMsg dflags 3 (text "writeBinIface:" <+> int symtab_next
181 -- NB. write the dictionary after the symbol table, because
182 -- writing the symbol table may create more dictionary entries.
184 -- Write the dictionary pointer at the fornt of the file
185 dict_p <- tellBin bh -- This is where the dictionary will start
186 putAt bh dict_p_p dict_p -- Fill in the placeholder
187 seekBin bh dict_p -- Seek back to the end of the file
189 -- Write the dictionary itself
190 dict_next <- readFastMutInt (ud_dict_next ud)
191 dict_map <- readIORef (ud_dict_map ud)
192 putDictionary bh dict_next dict_map
193 debugTraceMsg dflags 3 (text "writeBinIface:" <+> int dict_next
194 <+> text "dict entries")
196 -- And send the result to the file
197 writeBinMem bh hi_path
199 initBinMemSize = (1024*1024) :: Int
201 -- The *host* architecture version:
202 #include "MachDeps.h"
204 #if WORD_SIZE_IN_BITS == 32
205 binaryInterfaceMagic = 0x1face :: Word32
206 #elif WORD_SIZE_IN_BITS == 64
207 binaryInterfaceMagic = 0x1face64 :: Word32
210 -- -----------------------------------------------------------------------------
213 putSymbolTable :: BinHandle -> Int -> UniqFM (Int,Name) -> IO ()
214 putSymbolTable bh next_off symtab = do
216 let names = elems (array (0,next_off-1) (eltsUFM symtab))
217 mapM_ (\n -> serialiseName bh n symtab) names
219 getSymbolTable :: BinHandle -> NameCache -> IO (NameCache, Array Int Name)
220 getSymbolTable bh namecache = do
222 od_names <- sequence (replicate sz (get bh))
224 arr = listArray (0,sz-1) names
225 (namecache', names) =
226 mapAccumR (fromOnDiskName arr) namecache od_names
228 return (namecache', arr)
230 type OnDiskName = (PackageId, ModuleName, OccName)
237 fromOnDiskName arr nc (pid, mod_name, occ) =
239 mod = mkModule pid mod_name
242 case lookupOrigNameCache cache mod occ of
243 Just name -> (nc, name)
247 uniq = uniqFromSupply us
248 name = mkExternalName uniq mod occ noSrcSpan
249 new_cache = extendNameCache cache mod occ name
251 case splitUniqSupply us of { (us',_) ->
252 ( nc{ nsUniqs = us', nsNames = new_cache }, name )
255 serialiseName :: BinHandle -> Name -> UniqFM (Int,Name) -> IO ()
256 serialiseName bh name symtab = do
257 let mod = nameModule name
258 put_ bh (modulePackageId mod, moduleName mod, nameOccName name)
260 -- -----------------------------------------------------------------------------
261 -- All the binary instances
264 {-! for IPName derive: Binary !-}
265 {-! for Fixity derive: Binary !-}
266 {-! for FixityDirection derive: Binary !-}
267 {-! for Boxity derive: Binary !-}
268 {-! for StrictnessMark derive: Binary !-}
269 {-! for Activation derive: Binary !-}
272 {-! for Demand derive: Binary !-}
273 {-! for Demands derive: Binary !-}
274 {-! for DmdResult derive: Binary !-}
275 {-! for StrictSig derive: Binary !-}
278 {-! for DefMeth derive: Binary !-}
281 {-! for HsPred derive: Binary !-}
282 {-! for HsType derive: Binary !-}
283 {-! for TupCon derive: Binary !-}
284 {-! for HsTyVarBndr derive: Binary !-}
287 {-! for UfExpr derive: Binary !-}
288 {-! for UfConAlt derive: Binary !-}
289 {-! for UfBinding derive: Binary !-}
290 {-! for UfBinder derive: Binary !-}
291 {-! for HsIdInfo derive: Binary !-}
292 {-! for UfNote derive: Binary !-}
295 {-! for ConDetails derive: Binary !-}
296 {-! for BangType derive: Binary !-}
299 {-! for IsCafCC derive: Binary !-}
300 {-! for IsDupdCC derive: Binary !-}
301 {-! for CostCentre derive: Binary !-}
305 -- ---------------------------------------------------------------------------
306 -- Reading a binary interface into ParsedIface
308 instance Binary ModIface where
312 mi_mod_vers = mod_vers,
314 mi_finsts = hasFamInsts,
317 mi_exports = exports,
318 mi_exp_vers = exp_vers,
319 mi_fixities = fixities,
320 mi_deprecs = deprecs,
323 mi_fam_insts = fam_insts,
325 mi_rule_vers = rule_vers,
326 mi_vect_info = vect_info,
327 mi_hpc = hpc_info }) = do
352 hasFamInsts <- get bh
354 usages <- {-# SCC "bin_usages" #-} lazyGet bh
355 exports <- {-# SCC "bin_exports" #-} get bh
357 fixities <- {-# SCC "bin_fixities" #-} get bh
358 deprecs <- {-# SCC "bin_deprecs" #-} lazyGet bh
359 decls <- {-# SCC "bin_tycldecls" #-} get bh
360 insts <- {-# SCC "bin_insts" #-} get bh
361 fam_insts <- {-# SCC "bin_fam_insts" #-} get bh
362 rules <- {-# SCC "bin_rules" #-} lazyGet bh
367 mi_module = mod_name,
369 mi_mod_vers = mod_vers,
371 mi_finsts = hasFamInsts,
374 mi_exports = exports,
375 mi_exp_vers = exp_vers,
376 mi_fixities = fixities,
377 mi_deprecs = deprecs,
379 mi_globals = Nothing,
381 mi_fam_insts = fam_insts,
383 mi_rule_vers = rule_vers,
384 mi_vect_info = vect_info,
386 -- And build the cached values
387 mi_dep_fn = mkIfaceDepCache deprecs,
388 mi_fix_fn = mkIfaceFixCache fixities,
389 mi_ver_fn = mkIfaceVerCache decls })
391 getWayDescr :: IO String
393 tag <- readIORef v_Build_tag
394 if cGhcUnregisterised == "YES" then return ('u':tag) else return tag
395 -- if this is an unregisterised build, make sure our interfaces
396 -- can't be used by a registerised build.
398 -------------------------------------------------------------------------
399 -- Types from: HscTypes
400 -------------------------------------------------------------------------
402 instance Binary Dependencies where
403 put_ bh deps = do put_ bh (dep_mods deps)
404 put_ bh (dep_pkgs deps)
405 put_ bh (dep_orphs deps)
406 put_ bh (dep_finsts deps)
408 get bh = do ms <- get bh
412 return (Deps { dep_mods = ms, dep_pkgs = ps, dep_orphs = os,
415 instance (Binary name) => Binary (GenAvailInfo name) where
416 put_ bh (Avail aa) = do
419 put_ bh (AvailTC ab ac) = do
430 return (AvailTC ab ac)
432 instance Binary Usage where
434 put_ bh (usg_name usg)
435 put_ bh (usg_mod usg)
436 put_ bh (usg_exports usg)
437 put_ bh (usg_entities usg)
438 put_ bh (usg_rules usg)
446 return (Usage { usg_name = nm, usg_mod = mod,
447 usg_exports = exps, usg_entities = ents,
450 instance Binary Deprecations where
451 put_ bh NoDeprecs = putByte bh 0
452 put_ bh (DeprecAll t) = do
455 put_ bh (DeprecSome ts) = do
462 0 -> return NoDeprecs
464 return (DeprecAll aa)
466 return (DeprecSome aa)
468 -------------------------------------------------------------------------
469 -- Types from: BasicTypes
470 -------------------------------------------------------------------------
472 instance Binary Activation where
473 put_ bh NeverActive = do
475 put_ bh AlwaysActive = do
477 put_ bh (ActiveBefore aa) = do
480 put_ bh (ActiveAfter ab) = do
486 0 -> do return NeverActive
487 1 -> do return AlwaysActive
489 return (ActiveBefore aa)
491 return (ActiveAfter ab)
493 instance Binary StrictnessMark where
494 put_ bh MarkedStrict = do
496 put_ bh MarkedUnboxed = do
498 put_ bh NotMarkedStrict = do
503 0 -> do return MarkedStrict
504 1 -> do return MarkedUnboxed
505 _ -> do return NotMarkedStrict
507 instance Binary Boxity where
516 _ -> do return Unboxed
518 instance Binary TupCon where
519 put_ bh (TupCon ab ac) = do
525 return (TupCon ab ac)
527 instance Binary RecFlag where
528 put_ bh Recursive = do
530 put_ bh NonRecursive = do
535 0 -> do return Recursive
536 _ -> do return NonRecursive
538 instance Binary DefMeth where
539 put_ bh NoDefMeth = putByte bh 0
540 put_ bh DefMeth = putByte bh 1
541 put_ bh GenDefMeth = putByte bh 2
545 0 -> return NoDefMeth
547 _ -> return GenDefMeth
549 instance Binary FixityDirection where
559 0 -> do return InfixL
560 1 -> do return InfixR
561 _ -> do return InfixN
563 instance Binary Fixity where
564 put_ bh (Fixity aa ab) = do
570 return (Fixity aa ab)
572 instance (Binary name) => Binary (IPName name) where
573 put_ bh (IPName aa) = put_ bh aa
574 get bh = do aa <- get bh
577 -------------------------------------------------------------------------
578 -- Types from: Demand
579 -------------------------------------------------------------------------
581 instance Binary DmdType where
582 -- Ignore DmdEnv when spitting out the DmdType
583 put bh (DmdType _ ds dr) = do p <- put bh ds; put bh dr; return (castBin p)
584 get bh = do ds <- get bh; dr <- get bh; return (DmdType emptyVarEnv ds dr)
586 instance Binary Demand where
591 put_ bh (Call aa) = do
594 put_ bh (Eval ab) = do
597 put_ bh (Defer ac) = do
600 put_ bh (Box ad) = do
620 instance Binary Demands where
621 put_ bh (Poly aa) = do
624 put_ bh (Prod ab) = do
635 instance Binary DmdResult where
645 0 -> do return TopRes
646 1 -> do return RetCPR -- Really use RetCPR even if -fcpr-off
647 -- The wrapper was generated for CPR in
648 -- the imported module!
649 _ -> do return BotRes
651 instance Binary StrictSig where
652 put_ bh (StrictSig aa) = do
656 return (StrictSig aa)
659 -------------------------------------------------------------------------
660 -- Types from: CostCentre
661 -------------------------------------------------------------------------
663 instance Binary IsCafCC where
666 put_ bh NotCafCC = do
672 _ -> do return NotCafCC
674 instance Binary IsDupdCC where
675 put_ bh OriginalCC = do
682 0 -> do return OriginalCC
683 _ -> do return DupdCC
685 instance Binary CostCentre where
686 put_ bh NoCostCentre = do
688 put_ bh (NormalCC aa ab ac ad) = do
694 put_ bh (AllCafsCC ae) = do
700 0 -> do return NoCostCentre
705 return (NormalCC aa ab ac ad)
707 return (AllCafsCC ae)
709 -------------------------------------------------------------------------
710 -- IfaceTypes and friends
711 -------------------------------------------------------------------------
713 instance Binary IfaceBndr where
714 put_ bh (IfaceIdBndr aa) = do
717 put_ bh (IfaceTvBndr ab) = do
724 return (IfaceIdBndr aa)
726 return (IfaceTvBndr ab)
728 instance Binary IfaceLetBndr where
729 put_ bh (IfLetBndr a b c) = do
733 get bh = do a <- get bh
736 return (IfLetBndr a b c)
738 instance Binary IfaceType where
739 put_ bh (IfaceForAllTy aa ab) = do
743 put_ bh (IfaceTyVar ad) = do
746 put_ bh (IfaceAppTy ae af) = do
750 put_ bh (IfaceFunTy ag ah) = do
754 put_ bh (IfacePredTy aq) = do
758 -- Simple compression for common cases of TyConApp
759 put_ bh (IfaceTyConApp IfaceIntTc []) = putByte bh 6
760 put_ bh (IfaceTyConApp IfaceCharTc []) = putByte bh 7
761 put_ bh (IfaceTyConApp IfaceBoolTc []) = putByte bh 8
762 put_ bh (IfaceTyConApp IfaceListTc [ty]) = do { putByte bh 9; put_ bh ty }
763 -- Unit tuple and pairs
764 put_ bh (IfaceTyConApp (IfaceTupTc Boxed 0) []) = putByte bh 10
765 put_ bh (IfaceTyConApp (IfaceTupTc Boxed 2) [t1,t2]) = do { putByte bh 11; put_ bh t1; put_ bh t2 }
767 put_ bh (IfaceTyConApp IfaceLiftedTypeKindTc []) = putByte bh 12
768 put_ bh (IfaceTyConApp IfaceOpenTypeKindTc []) = putByte bh 13
769 put_ bh (IfaceTyConApp IfaceUnliftedTypeKindTc []) = putByte bh 14
770 put_ bh (IfaceTyConApp IfaceUbxTupleKindTc []) = putByte bh 15
771 put_ bh (IfaceTyConApp IfaceArgTypeKindTc []) = putByte bh 16
775 put_ bh (IfaceTyConApp (IfaceTc tc) tys) = do { putByte bh 18; put_ bh tc; put_ bh tys }
776 put_ bh (IfaceTyConApp tc tys) = do { putByte bh 19; put_ bh tc; put_ bh tys }
783 return (IfaceForAllTy aa ab)
785 return (IfaceTyVar ad)
788 return (IfaceAppTy ae af)
791 return (IfaceFunTy ag ah)
793 return (IfacePredTy ap)
795 -- Now the special cases for TyConApp
796 6 -> return (IfaceTyConApp IfaceIntTc [])
797 7 -> return (IfaceTyConApp IfaceCharTc [])
798 8 -> return (IfaceTyConApp IfaceBoolTc [])
799 9 -> do { ty <- get bh; return (IfaceTyConApp IfaceListTc [ty]) }
800 10 -> return (IfaceTyConApp (IfaceTupTc Boxed 0) [])
801 11 -> do { t1 <- get bh; t2 <- get bh; return (IfaceTyConApp (IfaceTupTc Boxed 2) [t1,t2]) }
802 12 -> return (IfaceTyConApp IfaceLiftedTypeKindTc [])
803 13 -> return (IfaceTyConApp IfaceOpenTypeKindTc [])
804 14 -> return (IfaceTyConApp IfaceUnliftedTypeKindTc [])
805 15 -> return (IfaceTyConApp IfaceUbxTupleKindTc [])
806 16 -> return (IfaceTyConApp IfaceArgTypeKindTc [])
808 18 -> do { tc <- get bh; tys <- get bh; return (IfaceTyConApp (IfaceTc tc) tys) }
809 _ -> do { tc <- get bh; tys <- get bh; return (IfaceTyConApp tc tys) }
811 instance Binary IfaceTyCon where
812 -- Int,Char,Bool can't show up here because they can't not be saturated
814 put_ bh IfaceIntTc = putByte bh 1
815 put_ bh IfaceBoolTc = putByte bh 2
816 put_ bh IfaceCharTc = putByte bh 3
817 put_ bh IfaceListTc = putByte bh 4
818 put_ bh IfacePArrTc = putByte bh 5
819 put_ bh IfaceLiftedTypeKindTc = putByte bh 6
820 put_ bh IfaceOpenTypeKindTc = putByte bh 7
821 put_ bh IfaceUnliftedTypeKindTc = putByte bh 8
822 put_ bh IfaceUbxTupleKindTc = putByte bh 9
823 put_ bh IfaceArgTypeKindTc = putByte bh 10
824 put_ bh (IfaceTupTc bx ar) = do { putByte bh 11; put_ bh bx; put_ bh ar }
825 put_ bh (IfaceTc ext) = do { putByte bh 12; put_ bh ext }
830 1 -> return IfaceIntTc
831 2 -> return IfaceBoolTc
832 3 -> return IfaceCharTc
833 4 -> return IfaceListTc
834 5 -> return IfacePArrTc
835 6 -> return IfaceLiftedTypeKindTc
836 7 -> return IfaceOpenTypeKindTc
837 8 -> return IfaceUnliftedTypeKindTc
838 9 -> return IfaceUbxTupleKindTc
839 10 -> return IfaceArgTypeKindTc
840 11 -> do { bx <- get bh; ar <- get bh; return (IfaceTupTc bx ar) }
841 _ -> do { ext <- get bh; return (IfaceTc ext) }
843 instance Binary IfacePredType where
844 put_ bh (IfaceClassP aa ab) = do
848 put_ bh (IfaceIParam ac ad) = do
852 put_ bh (IfaceEqPred ac ad) = do
861 return (IfaceClassP aa ab)
864 return (IfaceIParam ac ad)
867 return (IfaceEqPred ac ad)
869 -------------------------------------------------------------------------
870 -- IfaceExpr and friends
871 -------------------------------------------------------------------------
873 instance Binary IfaceExpr where
874 put_ bh (IfaceLcl aa) = do
877 put_ bh (IfaceType ab) = do
880 put_ bh (IfaceTuple ac ad) = do
884 put_ bh (IfaceLam ae af) = do
888 put_ bh (IfaceApp ag ah) = do
893 put_ bh (IfaceCase ai aj al ak) = do
900 put_ bh (IfaceLet al am) = do
904 put_ bh (IfaceNote an ao) = do
908 put_ bh (IfaceLit ap) = do
911 put_ bh (IfaceFCall as at) = do
915 put_ bh (IfaceExt aa) = do
918 put_ bh (IfaceCast ie ico) = do
922 put_ bh (IfaceTick m ix) = do
932 return (IfaceType ab)
935 return (IfaceTuple ac ad)
938 return (IfaceLam ae af)
941 return (IfaceApp ag ah)
948 return (IfaceCase ai aj al ak)
951 return (IfaceLet al am)
954 return (IfaceNote an ao)
959 return (IfaceFCall as at)
960 10 -> do aa <- get bh
962 11 -> do ie <- get bh
964 return (IfaceCast ie ico)
967 return (IfaceTick m ix)
969 instance Binary IfaceConAlt where
970 put_ bh IfaceDefault = do
972 put_ bh (IfaceDataAlt aa) = do
975 put_ bh (IfaceTupleAlt ab) = do
978 put_ bh (IfaceLitAlt ac) = do
984 0 -> do return IfaceDefault
986 return (IfaceDataAlt aa)
988 return (IfaceTupleAlt ab)
990 return (IfaceLitAlt ac)
992 instance Binary IfaceBinding where
993 put_ bh (IfaceNonRec aa ab) = do
997 put_ bh (IfaceRec ac) = do
1003 0 -> do aa <- get bh
1005 return (IfaceNonRec aa ab)
1006 _ -> do ac <- get bh
1007 return (IfaceRec ac)
1009 instance Binary IfaceIdInfo where
1010 put_ bh NoInfo = putByte bh 0
1011 put_ bh (HasInfo i) = do
1013 lazyPut bh i -- NB lazyPut
1019 _ -> do info <- lazyGet bh -- NB lazyGet
1020 return (HasInfo info)
1022 instance Binary IfaceInfoItem where
1023 put_ bh (HsArity aa) = do
1026 put_ bh (HsStrictness ab) = do
1029 put_ bh (HsUnfold ad) = do
1032 put_ bh (HsInline ad) = do
1035 put_ bh HsNoCafRefs = do
1037 put_ bh (HsWorker ae af) = do
1044 0 -> do aa <- get bh
1046 1 -> do ab <- get bh
1047 return (HsStrictness ab)
1048 2 -> do ad <- get bh
1049 return (HsUnfold ad)
1050 3 -> do ad <- get bh
1051 return (HsInline ad)
1052 4 -> do return HsNoCafRefs
1053 _ -> do ae <- get bh
1055 return (HsWorker ae af)
1057 instance Binary IfaceNote where
1058 put_ bh (IfaceSCC aa) = do
1061 put_ bh IfaceInlineMe = do
1063 put_ bh (IfaceCoreNote s) = do
1069 0 -> do aa <- get bh
1070 return (IfaceSCC aa)
1071 3 -> do return IfaceInlineMe
1072 4 -> do ac <- get bh
1073 return (IfaceCoreNote ac)
1075 -------------------------------------------------------------------------
1076 -- IfaceDecl and friends
1077 -------------------------------------------------------------------------
1079 -- A bit of magic going on here: there's no need to store the OccName
1080 -- for a decl on the disk, since we can infer the namespace from the
1081 -- context; however it is useful to have the OccName in the IfaceDecl
1082 -- to avoid re-building it in various places. So we build the OccName
1083 -- when de-serialising.
1085 instance Binary IfaceDecl where
1086 put_ bh (IfaceId name ty idinfo) = do
1088 put_ bh (occNameFS name)
1091 put_ bh (IfaceForeign ae af) =
1092 error "Binary.put_(IfaceDecl): IfaceForeign"
1093 put_ bh (IfaceData a1 a2 a3 a4 a5 a6 a7 a8) = do
1095 put_ bh (occNameFS a1)
1103 put_ bh (IfaceSyn a1 a2 a3 a4 a5) = do
1105 put_ bh (occNameFS a1)
1110 put_ bh (IfaceClass a1 a2 a3 a4 a5 a6 a7) = do
1113 put_ bh (occNameFS a2)
1122 0 -> do name <- get bh
1125 occ <- return $! mkOccNameFS varName name
1126 return (IfaceId occ ty idinfo)
1127 1 -> error "Binary.get(TyClDecl): ForeignType"
1137 occ <- return $! mkOccNameFS tcName a1
1138 return (IfaceData occ a2 a3 a4 a5 a6 a7 a8)
1145 occ <- return $! mkOccNameFS tcName a1
1146 return (IfaceSyn occ a2 a3 a4 a5)
1155 occ <- return $! mkOccNameFS clsName a2
1156 return (IfaceClass a1 occ a3 a4 a5 a6 a7)
1158 instance Binary IfaceInst where
1159 put_ bh (IfaceInst cls tys dfun flag orph) = do
1165 get bh = do cls <- get bh
1170 return (IfaceInst cls tys dfun flag orph)
1172 instance Binary IfaceFamInst where
1173 put_ bh (IfaceFamInst fam tys tycon) = do
1177 get bh = do fam <- get bh
1180 return (IfaceFamInst fam tys tycon)
1182 instance Binary OverlapFlag where
1183 put_ bh NoOverlap = putByte bh 0
1184 put_ bh OverlapOk = putByte bh 1
1185 put_ bh Incoherent = putByte bh 2
1186 get bh = do h <- getByte bh
1188 0 -> return NoOverlap
1189 1 -> return OverlapOk
1190 2 -> return Incoherent
1192 instance Binary IfaceConDecls where
1193 put_ bh IfAbstractTyCon = putByte bh 0
1194 put_ bh IfOpenDataTyCon = putByte bh 1
1195 put_ bh (IfDataTyCon cs) = do { putByte bh 2
1197 put_ bh (IfNewTyCon c) = do { putByte bh 3
1202 0 -> return IfAbstractTyCon
1203 1 -> return IfOpenDataTyCon
1204 2 -> do cs <- get bh
1205 return (IfDataTyCon cs)
1206 _ -> do aa <- get bh
1207 return (IfNewTyCon aa)
1209 instance Binary IfaceConDecl where
1210 put_ bh (IfCon a1 a2 a3 a4 a5 a6 a7 a8 a9) = do
1220 get bh = do a1 <- get bh
1229 return (IfCon a1 a2 a3 a4 a5 a6 a7 a8 a9)
1231 instance Binary IfaceClassOp where
1232 put_ bh (IfaceClassOp n def ty) = do
1233 put_ bh (occNameFS n)
1240 occ <- return $! mkOccNameFS varName n
1241 return (IfaceClassOp occ def ty)
1243 instance Binary IfaceRule where
1244 put_ bh (IfaceRule a1 a2 a3 a4 a5 a6 a7) = do
1260 return (IfaceRule a1 a2 a3 a4 a5 a6 a7)
1262 instance Binary IfaceVectInfo where
1263 put_ bh (IfaceVectInfo a1 a2 a3) = do
1271 return (IfaceVectInfo a1 a2 a3)