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 errorOnMismatch :: (Eq a, Show a) => String -> a -> a -> IO ()
83 errorOnMismatch what wanted got
84 -- This will be caught by readIface which will emit an error
85 -- msg containing the iface module name.
86 = when (wanted /= got) $ throwDyn $ ProgramError
87 (what ++ " (wanted " ++ show wanted
88 ++ ", got " ++ show got ++ ")")
89 bh <- Binary.readBinMem hi_path
91 -- Read the magic number to check that this really is a GHC .hi file
92 -- (This magic number does not change when we change
93 -- GHC interface file format)
95 wantedGot "Magic" binaryInterfaceMagic magic
96 errorOnMismatch "magic number mismatch: old/corrupt interface file?"
97 binaryInterfaceMagic magic
99 -- Get the dictionary pointer. We won't attempt to actually
100 -- read the dictionary until we've done the version checks below,
101 -- just in case this isn't a valid interface. In retrospect the
102 -- version should have come before the dictionary pointer, but this
103 -- is the way it was done originally, and we can't change it now.
104 dict_p <- Binary.get bh -- Get the dictionary ptr
106 -- Check the interface file version and ways.
108 let our_ver = show opt_HiVersion
109 wantedGot "Version" our_ver check_ver
110 errorOnMismatch "mismatched interface file versions" our_ver check_ver
113 way_descr <- getWayDescr
114 wantedGot "Way" way_descr check_way
115 when (checkHiWay == CheckHiWay) $
116 errorOnMismatch "mismatched interface file ways" way_descr check_way
118 -- Read the dictionary
119 -- The next word in the file is a pointer to where the dictionary is
120 -- (probably at the end of the file)
121 data_p <- tellBin bh -- Remember where we are now
123 dict <- getDictionary bh
124 seekBin bh data_p -- Back to where we were before
126 -- Initialise the user-data field of bh
127 ud <- newReadState dict
128 bh <- return (setUserData bh ud)
130 symtab_p <- Binary.get bh -- Get the symtab ptr
131 data_p <- tellBin bh -- Remember where we are now
133 (nc', symtab) <- getSymbolTable bh nc
134 seekBin bh data_p -- Back to where we were before
135 let ud = getUserData bh
136 bh <- return $! setUserData bh ud{ud_symtab = symtab}
141 writeBinIface :: DynFlags -> FilePath -> ModIface -> IO ()
142 writeBinIface dflags hi_path mod_iface = do
143 bh <- openBinMem initBinMemSize
144 put_ bh binaryInterfaceMagic
146 -- Remember where the dictionary pointer will go
147 dict_p_p <- tellBin bh
148 put_ bh dict_p_p -- Placeholder for ptr to dictionary
150 -- The version and way descriptor go next
151 put_ bh (show opt_HiVersion)
152 way_descr <- getWayDescr
155 -- Remember where the symbol table pointer will go
156 symtab_p_p <- tellBin bh
159 -- Make some intial state
162 -- Put the main thing,
163 bh <- return $ setUserData bh ud
166 -- Write the symtab pointer at the fornt of the file
167 symtab_p <- tellBin bh -- This is where the symtab will start
168 putAt bh symtab_p_p symtab_p -- Fill in the placeholder
169 seekBin bh symtab_p -- Seek back to the end of the file
171 -- Write the symbol table itself
172 symtab_next <- readFastMutInt (ud_symtab_next ud)
173 symtab_map <- readIORef (ud_symtab_map ud)
174 putSymbolTable bh symtab_next symtab_map
175 debugTraceMsg dflags 3 (text "writeBinIface:" <+> int symtab_next
178 -- NB. write the dictionary after the symbol table, because
179 -- writing the symbol table may create more dictionary entries.
181 -- Write the dictionary pointer at the fornt of the file
182 dict_p <- tellBin bh -- This is where the dictionary will start
183 putAt bh dict_p_p dict_p -- Fill in the placeholder
184 seekBin bh dict_p -- Seek back to the end of the file
186 -- Write the dictionary itself
187 dict_next <- readFastMutInt (ud_dict_next ud)
188 dict_map <- readIORef (ud_dict_map ud)
189 putDictionary bh dict_next dict_map
190 debugTraceMsg dflags 3 (text "writeBinIface:" <+> int dict_next
191 <+> text "dict entries")
193 -- And send the result to the file
194 writeBinMem bh hi_path
196 initBinMemSize = (1024*1024) :: Int
198 -- The *host* architecture version:
199 #include "MachDeps.h"
201 #if WORD_SIZE_IN_BITS == 32
202 binaryInterfaceMagic = 0x1face :: Word32
203 #elif WORD_SIZE_IN_BITS == 64
204 binaryInterfaceMagic = 0x1face64 :: Word32
207 -- -----------------------------------------------------------------------------
210 putSymbolTable :: BinHandle -> Int -> UniqFM (Int,Name) -> IO ()
211 putSymbolTable bh next_off symtab = do
213 let names = elems (array (0,next_off-1) (eltsUFM symtab))
214 mapM_ (\n -> serialiseName bh n symtab) names
216 getSymbolTable :: BinHandle -> NameCache -> IO (NameCache, Array Int Name)
217 getSymbolTable bh namecache = do
219 od_names <- sequence (replicate sz (get bh))
221 arr = listArray (0,sz-1) names
222 (namecache', names) =
223 mapAccumR (fromOnDiskName arr) namecache od_names
225 return (namecache', arr)
227 type OnDiskName = (PackageId, ModuleName, OccName)
234 fromOnDiskName arr nc (pid, mod_name, occ) =
236 mod = mkModule pid mod_name
239 case lookupOrigNameCache cache mod occ of
240 Just name -> (nc, name)
244 uniq = uniqFromSupply us
245 name = mkExternalName uniq mod occ noSrcSpan
246 new_cache = extendNameCache cache mod occ name
248 case splitUniqSupply us of { (us',_) ->
249 ( nc{ nsUniqs = us', nsNames = new_cache }, name )
252 serialiseName :: BinHandle -> Name -> UniqFM (Int,Name) -> IO ()
253 serialiseName bh name symtab = do
254 let mod = nameModule name
255 put_ bh (modulePackageId mod, moduleName mod, nameOccName name)
257 -- -----------------------------------------------------------------------------
258 -- All the binary instances
261 {-! for IPName derive: Binary !-}
262 {-! for Fixity derive: Binary !-}
263 {-! for FixityDirection derive: Binary !-}
264 {-! for Boxity derive: Binary !-}
265 {-! for StrictnessMark derive: Binary !-}
266 {-! for Activation derive: Binary !-}
269 {-! for Demand derive: Binary !-}
270 {-! for Demands derive: Binary !-}
271 {-! for DmdResult derive: Binary !-}
272 {-! for StrictSig derive: Binary !-}
275 {-! for DefMeth derive: Binary !-}
278 {-! for HsPred derive: Binary !-}
279 {-! for HsType derive: Binary !-}
280 {-! for TupCon derive: Binary !-}
281 {-! for HsTyVarBndr derive: Binary !-}
284 {-! for UfExpr derive: Binary !-}
285 {-! for UfConAlt derive: Binary !-}
286 {-! for UfBinding derive: Binary !-}
287 {-! for UfBinder derive: Binary !-}
288 {-! for HsIdInfo derive: Binary !-}
289 {-! for UfNote derive: Binary !-}
292 {-! for ConDetails derive: Binary !-}
293 {-! for BangType derive: Binary !-}
296 {-! for IsCafCC derive: Binary !-}
297 {-! for IsDupdCC derive: Binary !-}
298 {-! for CostCentre derive: Binary !-}
302 -- ---------------------------------------------------------------------------
303 -- Reading a binary interface into ParsedIface
305 instance Binary ModIface where
309 mi_mod_vers = mod_vers,
311 mi_finsts = hasFamInsts,
314 mi_exports = exports,
315 mi_exp_vers = exp_vers,
316 mi_fixities = fixities,
317 mi_deprecs = deprecs,
320 mi_fam_insts = fam_insts,
322 mi_rule_vers = rule_vers,
323 mi_vect_info = vect_info,
324 mi_hpc = hpc_info }) = do
349 hasFamInsts <- get bh
351 usages <- {-# SCC "bin_usages" #-} lazyGet bh
352 exports <- {-# SCC "bin_exports" #-} get bh
354 fixities <- {-# SCC "bin_fixities" #-} get bh
355 deprecs <- {-# SCC "bin_deprecs" #-} lazyGet bh
356 decls <- {-# SCC "bin_tycldecls" #-} get bh
357 insts <- {-# SCC "bin_insts" #-} get bh
358 fam_insts <- {-# SCC "bin_fam_insts" #-} get bh
359 rules <- {-# SCC "bin_rules" #-} lazyGet bh
364 mi_module = mod_name,
366 mi_mod_vers = mod_vers,
368 mi_finsts = hasFamInsts,
371 mi_exports = exports,
372 mi_exp_vers = exp_vers,
373 mi_fixities = fixities,
374 mi_deprecs = deprecs,
376 mi_globals = Nothing,
378 mi_fam_insts = fam_insts,
380 mi_rule_vers = rule_vers,
381 mi_vect_info = vect_info,
383 -- And build the cached values
384 mi_dep_fn = mkIfaceDepCache deprecs,
385 mi_fix_fn = mkIfaceFixCache fixities,
386 mi_ver_fn = mkIfaceVerCache decls })
388 getWayDescr :: IO String
390 tag <- readIORef v_Build_tag
391 if cGhcUnregisterised == "YES" then return ('u':tag) else return tag
392 -- if this is an unregisterised build, make sure our interfaces
393 -- can't be used by a registerised build.
395 -------------------------------------------------------------------------
396 -- Types from: HscTypes
397 -------------------------------------------------------------------------
399 instance Binary Dependencies where
400 put_ bh deps = do put_ bh (dep_mods deps)
401 put_ bh (dep_pkgs deps)
402 put_ bh (dep_orphs deps)
403 put_ bh (dep_finsts deps)
405 get bh = do ms <- get bh
409 return (Deps { dep_mods = ms, dep_pkgs = ps, dep_orphs = os,
412 instance (Binary name) => Binary (GenAvailInfo name) where
413 put_ bh (Avail aa) = do
416 put_ bh (AvailTC ab ac) = do
427 return (AvailTC ab ac)
429 instance Binary Usage where
431 put_ bh (usg_name usg)
432 put_ bh (usg_mod usg)
433 put_ bh (usg_exports usg)
434 put_ bh (usg_entities usg)
435 put_ bh (usg_rules usg)
443 return (Usage { usg_name = nm, usg_mod = mod,
444 usg_exports = exps, usg_entities = ents,
447 instance Binary Deprecations where
448 put_ bh NoDeprecs = putByte bh 0
449 put_ bh (DeprecAll t) = do
452 put_ bh (DeprecSome ts) = do
459 0 -> return NoDeprecs
461 return (DeprecAll aa)
463 return (DeprecSome aa)
465 -------------------------------------------------------------------------
466 -- Types from: BasicTypes
467 -------------------------------------------------------------------------
469 instance Binary Activation where
470 put_ bh NeverActive = do
472 put_ bh AlwaysActive = do
474 put_ bh (ActiveBefore aa) = do
477 put_ bh (ActiveAfter ab) = do
483 0 -> do return NeverActive
484 1 -> do return AlwaysActive
486 return (ActiveBefore aa)
488 return (ActiveAfter ab)
490 instance Binary StrictnessMark where
491 put_ bh MarkedStrict = do
493 put_ bh MarkedUnboxed = do
495 put_ bh NotMarkedStrict = do
500 0 -> do return MarkedStrict
501 1 -> do return MarkedUnboxed
502 _ -> do return NotMarkedStrict
504 instance Binary Boxity where
513 _ -> do return Unboxed
515 instance Binary TupCon where
516 put_ bh (TupCon ab ac) = do
522 return (TupCon ab ac)
524 instance Binary RecFlag where
525 put_ bh Recursive = do
527 put_ bh NonRecursive = do
532 0 -> do return Recursive
533 _ -> do return NonRecursive
535 instance Binary DefMeth where
536 put_ bh NoDefMeth = putByte bh 0
537 put_ bh DefMeth = putByte bh 1
538 put_ bh GenDefMeth = putByte bh 2
542 0 -> return NoDefMeth
544 _ -> return GenDefMeth
546 instance Binary FixityDirection where
556 0 -> do return InfixL
557 1 -> do return InfixR
558 _ -> do return InfixN
560 instance Binary Fixity where
561 put_ bh (Fixity aa ab) = do
567 return (Fixity aa ab)
569 instance (Binary name) => Binary (IPName name) where
570 put_ bh (IPName aa) = put_ bh aa
571 get bh = do aa <- get bh
574 -------------------------------------------------------------------------
575 -- Types from: Demand
576 -------------------------------------------------------------------------
578 instance Binary DmdType where
579 -- Ignore DmdEnv when spitting out the DmdType
580 put bh (DmdType _ ds dr) = do p <- put bh ds; put bh dr; return (castBin p)
581 get bh = do ds <- get bh; dr <- get bh; return (DmdType emptyVarEnv ds dr)
583 instance Binary Demand where
588 put_ bh (Call aa) = do
591 put_ bh (Eval ab) = do
594 put_ bh (Defer ac) = do
597 put_ bh (Box ad) = do
617 instance Binary Demands where
618 put_ bh (Poly aa) = do
621 put_ bh (Prod ab) = do
632 instance Binary DmdResult where
642 0 -> do return TopRes
643 1 -> do return RetCPR -- Really use RetCPR even if -fcpr-off
644 -- The wrapper was generated for CPR in
645 -- the imported module!
646 _ -> do return BotRes
648 instance Binary StrictSig where
649 put_ bh (StrictSig aa) = do
653 return (StrictSig aa)
656 -------------------------------------------------------------------------
657 -- Types from: CostCentre
658 -------------------------------------------------------------------------
660 instance Binary IsCafCC where
663 put_ bh NotCafCC = do
669 _ -> do return NotCafCC
671 instance Binary IsDupdCC where
672 put_ bh OriginalCC = do
679 0 -> do return OriginalCC
680 _ -> do return DupdCC
682 instance Binary CostCentre where
683 put_ bh NoCostCentre = do
685 put_ bh (NormalCC aa ab ac ad) = do
691 put_ bh (AllCafsCC ae) = do
697 0 -> do return NoCostCentre
702 return (NormalCC aa ab ac ad)
704 return (AllCafsCC ae)
706 -------------------------------------------------------------------------
707 -- IfaceTypes and friends
708 -------------------------------------------------------------------------
710 instance Binary IfaceBndr where
711 put_ bh (IfaceIdBndr aa) = do
714 put_ bh (IfaceTvBndr ab) = do
721 return (IfaceIdBndr aa)
723 return (IfaceTvBndr ab)
725 instance Binary IfaceLetBndr where
726 put_ bh (IfLetBndr a b c) = do
730 get bh = do a <- get bh
733 return (IfLetBndr a b c)
735 instance Binary IfaceType where
736 put_ bh (IfaceForAllTy aa ab) = do
740 put_ bh (IfaceTyVar ad) = do
743 put_ bh (IfaceAppTy ae af) = do
747 put_ bh (IfaceFunTy ag ah) = do
751 put_ bh (IfacePredTy aq) = do
755 -- Simple compression for common cases of TyConApp
756 put_ bh (IfaceTyConApp IfaceIntTc []) = putByte bh 6
757 put_ bh (IfaceTyConApp IfaceCharTc []) = putByte bh 7
758 put_ bh (IfaceTyConApp IfaceBoolTc []) = putByte bh 8
759 put_ bh (IfaceTyConApp IfaceListTc [ty]) = do { putByte bh 9; put_ bh ty }
760 -- Unit tuple and pairs
761 put_ bh (IfaceTyConApp (IfaceTupTc Boxed 0) []) = putByte bh 10
762 put_ bh (IfaceTyConApp (IfaceTupTc Boxed 2) [t1,t2]) = do { putByte bh 11; put_ bh t1; put_ bh t2 }
764 put_ bh (IfaceTyConApp IfaceLiftedTypeKindTc []) = putByte bh 12
765 put_ bh (IfaceTyConApp IfaceOpenTypeKindTc []) = putByte bh 13
766 put_ bh (IfaceTyConApp IfaceUnliftedTypeKindTc []) = putByte bh 14
767 put_ bh (IfaceTyConApp IfaceUbxTupleKindTc []) = putByte bh 15
768 put_ bh (IfaceTyConApp IfaceArgTypeKindTc []) = putByte bh 16
772 put_ bh (IfaceTyConApp (IfaceTc tc) tys) = do { putByte bh 18; put_ bh tc; put_ bh tys }
773 put_ bh (IfaceTyConApp tc tys) = do { putByte bh 19; put_ bh tc; put_ bh tys }
780 return (IfaceForAllTy aa ab)
782 return (IfaceTyVar ad)
785 return (IfaceAppTy ae af)
788 return (IfaceFunTy ag ah)
790 return (IfacePredTy ap)
792 -- Now the special cases for TyConApp
793 6 -> return (IfaceTyConApp IfaceIntTc [])
794 7 -> return (IfaceTyConApp IfaceCharTc [])
795 8 -> return (IfaceTyConApp IfaceBoolTc [])
796 9 -> do { ty <- get bh; return (IfaceTyConApp IfaceListTc [ty]) }
797 10 -> return (IfaceTyConApp (IfaceTupTc Boxed 0) [])
798 11 -> do { t1 <- get bh; t2 <- get bh; return (IfaceTyConApp (IfaceTupTc Boxed 2) [t1,t2]) }
799 12 -> return (IfaceTyConApp IfaceLiftedTypeKindTc [])
800 13 -> return (IfaceTyConApp IfaceOpenTypeKindTc [])
801 14 -> return (IfaceTyConApp IfaceUnliftedTypeKindTc [])
802 15 -> return (IfaceTyConApp IfaceUbxTupleKindTc [])
803 16 -> return (IfaceTyConApp IfaceArgTypeKindTc [])
805 18 -> do { tc <- get bh; tys <- get bh; return (IfaceTyConApp (IfaceTc tc) tys) }
806 _ -> do { tc <- get bh; tys <- get bh; return (IfaceTyConApp tc tys) }
808 instance Binary IfaceTyCon where
809 -- Int,Char,Bool can't show up here because they can't not be saturated
811 put_ bh IfaceIntTc = putByte bh 1
812 put_ bh IfaceBoolTc = putByte bh 2
813 put_ bh IfaceCharTc = putByte bh 3
814 put_ bh IfaceListTc = putByte bh 4
815 put_ bh IfacePArrTc = putByte bh 5
816 put_ bh IfaceLiftedTypeKindTc = putByte bh 6
817 put_ bh IfaceOpenTypeKindTc = putByte bh 7
818 put_ bh IfaceUnliftedTypeKindTc = putByte bh 8
819 put_ bh IfaceUbxTupleKindTc = putByte bh 9
820 put_ bh IfaceArgTypeKindTc = putByte bh 10
821 put_ bh (IfaceTupTc bx ar) = do { putByte bh 11; put_ bh bx; put_ bh ar }
822 put_ bh (IfaceTc ext) = do { putByte bh 12; put_ bh ext }
827 1 -> return IfaceIntTc
828 2 -> return IfaceBoolTc
829 3 -> return IfaceCharTc
830 4 -> return IfaceListTc
831 5 -> return IfacePArrTc
832 6 -> return IfaceLiftedTypeKindTc
833 7 -> return IfaceOpenTypeKindTc
834 8 -> return IfaceUnliftedTypeKindTc
835 9 -> return IfaceUbxTupleKindTc
836 10 -> return IfaceArgTypeKindTc
837 11 -> do { bx <- get bh; ar <- get bh; return (IfaceTupTc bx ar) }
838 _ -> do { ext <- get bh; return (IfaceTc ext) }
840 instance Binary IfacePredType where
841 put_ bh (IfaceClassP aa ab) = do
845 put_ bh (IfaceIParam ac ad) = do
849 put_ bh (IfaceEqPred ac ad) = do
858 return (IfaceClassP aa ab)
861 return (IfaceIParam ac ad)
864 return (IfaceEqPred ac ad)
866 -------------------------------------------------------------------------
867 -- IfaceExpr and friends
868 -------------------------------------------------------------------------
870 instance Binary IfaceExpr where
871 put_ bh (IfaceLcl aa) = do
874 put_ bh (IfaceType ab) = do
877 put_ bh (IfaceTuple ac ad) = do
881 put_ bh (IfaceLam ae af) = do
885 put_ bh (IfaceApp ag ah) = do
890 put_ bh (IfaceCase ai aj al ak) = do
897 put_ bh (IfaceLet al am) = do
901 put_ bh (IfaceNote an ao) = do
905 put_ bh (IfaceLit ap) = do
908 put_ bh (IfaceFCall as at) = do
912 put_ bh (IfaceExt aa) = do
915 put_ bh (IfaceCast ie ico) = do
919 put_ bh (IfaceTick m ix) = do
929 return (IfaceType ab)
932 return (IfaceTuple ac ad)
935 return (IfaceLam ae af)
938 return (IfaceApp ag ah)
945 return (IfaceCase ai aj al ak)
948 return (IfaceLet al am)
951 return (IfaceNote an ao)
956 return (IfaceFCall as at)
957 10 -> do aa <- get bh
959 11 -> do ie <- get bh
961 return (IfaceCast ie ico)
964 return (IfaceTick m ix)
966 instance Binary IfaceConAlt where
967 put_ bh IfaceDefault = do
969 put_ bh (IfaceDataAlt aa) = do
972 put_ bh (IfaceTupleAlt ab) = do
975 put_ bh (IfaceLitAlt ac) = do
981 0 -> do return IfaceDefault
983 return (IfaceDataAlt aa)
985 return (IfaceTupleAlt ab)
987 return (IfaceLitAlt ac)
989 instance Binary IfaceBinding where
990 put_ bh (IfaceNonRec aa ab) = do
994 put_ bh (IfaceRec ac) = do
1000 0 -> do aa <- get bh
1002 return (IfaceNonRec aa ab)
1003 _ -> do ac <- get bh
1004 return (IfaceRec ac)
1006 instance Binary IfaceIdInfo where
1007 put_ bh NoInfo = putByte bh 0
1008 put_ bh (HasInfo i) = do
1010 lazyPut bh i -- NB lazyPut
1016 _ -> do info <- lazyGet bh -- NB lazyGet
1017 return (HasInfo info)
1019 instance Binary IfaceInfoItem where
1020 put_ bh (HsArity aa) = do
1023 put_ bh (HsStrictness ab) = do
1026 put_ bh (HsUnfold ad) = do
1029 put_ bh (HsInline ad) = do
1032 put_ bh HsNoCafRefs = do
1034 put_ bh (HsWorker ae af) = do
1041 0 -> do aa <- get bh
1043 1 -> do ab <- get bh
1044 return (HsStrictness ab)
1045 2 -> do ad <- get bh
1046 return (HsUnfold ad)
1047 3 -> do ad <- get bh
1048 return (HsInline ad)
1049 4 -> do return HsNoCafRefs
1050 _ -> do ae <- get bh
1052 return (HsWorker ae af)
1054 instance Binary IfaceNote where
1055 put_ bh (IfaceSCC aa) = do
1058 put_ bh IfaceInlineMe = do
1060 put_ bh (IfaceCoreNote s) = do
1066 0 -> do aa <- get bh
1067 return (IfaceSCC aa)
1068 3 -> do return IfaceInlineMe
1069 4 -> do ac <- get bh
1070 return (IfaceCoreNote ac)
1072 -------------------------------------------------------------------------
1073 -- IfaceDecl and friends
1074 -------------------------------------------------------------------------
1076 -- A bit of magic going on here: there's no need to store the OccName
1077 -- for a decl on the disk, since we can infer the namespace from the
1078 -- context; however it is useful to have the OccName in the IfaceDecl
1079 -- to avoid re-building it in various places. So we build the OccName
1080 -- when de-serialising.
1082 instance Binary IfaceDecl where
1083 put_ bh (IfaceId name ty idinfo) = do
1085 put_ bh (occNameFS name)
1088 put_ bh (IfaceForeign ae af) =
1089 error "Binary.put_(IfaceDecl): IfaceForeign"
1090 put_ bh (IfaceData a1 a2 a3 a4 a5 a6 a7 a8) = do
1092 put_ bh (occNameFS a1)
1100 put_ bh (IfaceSyn a1 a2 a3 a4 a5) = do
1102 put_ bh (occNameFS a1)
1107 put_ bh (IfaceClass a1 a2 a3 a4 a5 a6 a7) = do
1110 put_ bh (occNameFS a2)
1119 0 -> do name <- get bh
1122 occ <- return $! mkOccNameFS varName name
1123 return (IfaceId occ ty idinfo)
1124 1 -> error "Binary.get(TyClDecl): ForeignType"
1134 occ <- return $! mkOccNameFS tcName a1
1135 return (IfaceData occ a2 a3 a4 a5 a6 a7 a8)
1142 occ <- return $! mkOccNameFS tcName a1
1143 return (IfaceSyn occ a2 a3 a4 a5)
1152 occ <- return $! mkOccNameFS clsName a2
1153 return (IfaceClass a1 occ a3 a4 a5 a6 a7)
1155 instance Binary IfaceInst where
1156 put_ bh (IfaceInst cls tys dfun flag orph) = do
1162 get bh = do cls <- get bh
1167 return (IfaceInst cls tys dfun flag orph)
1169 instance Binary IfaceFamInst where
1170 put_ bh (IfaceFamInst fam tys tycon) = do
1174 get bh = do fam <- get bh
1177 return (IfaceFamInst fam tys tycon)
1179 instance Binary OverlapFlag where
1180 put_ bh NoOverlap = putByte bh 0
1181 put_ bh OverlapOk = putByte bh 1
1182 put_ bh Incoherent = putByte bh 2
1183 get bh = do h <- getByte bh
1185 0 -> return NoOverlap
1186 1 -> return OverlapOk
1187 2 -> return Incoherent
1189 instance Binary IfaceConDecls where
1190 put_ bh IfAbstractTyCon = putByte bh 0
1191 put_ bh IfOpenDataTyCon = putByte bh 1
1192 put_ bh (IfDataTyCon cs) = do { putByte bh 2
1194 put_ bh (IfNewTyCon c) = do { putByte bh 3
1199 0 -> return IfAbstractTyCon
1200 1 -> return IfOpenDataTyCon
1201 2 -> do cs <- get bh
1202 return (IfDataTyCon cs)
1203 _ -> do aa <- get bh
1204 return (IfNewTyCon aa)
1206 instance Binary IfaceConDecl where
1207 put_ bh (IfCon a1 a2 a3 a4 a5 a6 a7 a8 a9) = do
1217 get bh = do a1 <- get bh
1226 return (IfCon a1 a2 a3 a4 a5 a6 a7 a8 a9)
1228 instance Binary IfaceClassOp where
1229 put_ bh (IfaceClassOp n def ty) = do
1230 put_ bh (occNameFS n)
1237 occ <- return $! mkOccNameFS varName n
1238 return (IfaceClassOp occ def ty)
1240 instance Binary IfaceRule where
1241 put_ bh (IfaceRule a1 a2 a3 a4 a5 a6 a7) = do
1257 return (IfaceRule a1 a2 a3 a4 a5 a6 a7)
1259 instance Binary IfaceVectInfo where
1260 put_ bh (IfaceVectInfo a1 a2 a3) = do
1268 return (IfaceVectInfo a1 a2 a3)