3 -- We always optimise this, otherwise performance of a non-optimised
4 -- compiler is severely affected
7 -- (c) The University of Glasgow 2002-2006
9 -- Binary interface file support.
11 module BinIface ( writeBinIface, readBinIface,
12 CheckHiWay(..), TraceBinIFaceReading(..) ) where
14 #include "HsVersions.h"
48 data CheckHiWay = CheckHiWay | IgnoreHiWay
51 data TraceBinIFaceReading = TraceBinIFaceReading | QuietBinIFaceReading
54 -- ---------------------------------------------------------------------------
55 -- Reading and writing binary interface files
57 readBinIface :: CheckHiWay -> TraceBinIFaceReading -> FilePath
58 -> TcRnIf a b ModIface
59 readBinIface checkHiWay traceBinIFaceReading hi_path = do
60 lockedUpdNameCache $ \nc ->
61 readBinIface_ checkHiWay traceBinIFaceReading hi_path nc
63 readBinIface_ :: CheckHiWay -> TraceBinIFaceReading -> FilePath -> NameCache
64 -> IO (NameCache, ModIface)
65 readBinIface_ checkHiWay traceBinIFaceReading hi_path nc = do
66 let printer :: SDoc -> IO ()
67 printer = case traceBinIFaceReading of
68 TraceBinIFaceReading -> \sd -> printSDoc sd defaultDumpStyle
69 QuietBinIFaceReading -> \_ -> return ()
70 wantedGot :: Outputable a => String -> a -> a -> IO ()
71 wantedGot what wanted got
72 = printer (text what <> text ": " <>
73 vcat [text "Wanted " <> ppr wanted <> text ",",
74 text "got " <> ppr got])
76 errorOnMismatch :: (Eq a, Show a) => String -> a -> a -> IO ()
77 errorOnMismatch what wanted got
78 -- This will be caught by readIface which will emit an error
79 -- msg containing the iface module name.
80 = when (wanted /= got) $ ghcError $ ProgramError
81 (what ++ " (wanted " ++ show wanted
82 ++ ", got " ++ show got ++ ")")
83 bh <- Binary.readBinMem hi_path
85 -- Read the magic number to check that this really is a GHC .hi file
86 -- (This magic number does not change when we change
87 -- GHC interface file format)
89 wantedGot "Magic" binaryInterfaceMagic magic
90 errorOnMismatch "magic number mismatch: old/corrupt interface file?"
91 binaryInterfaceMagic magic
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 errorOnMismatch "mismatched interface file versions" our_ver check_ver
107 way_descr <- getWayDescr
108 wantedGot "Way" way_descr check_way
109 when (checkHiWay == CheckHiWay) $
110 errorOnMismatch "mismatched interface file ways" way_descr check_way
112 -- Read the dictionary
113 -- The next word in the file is a pointer to where the dictionary is
114 -- (probably at the end of the file)
115 data_p <- tellBin bh -- Remember where we are now
117 dict <- getDictionary bh
118 seekBin bh data_p -- Back to where we were before
120 -- Initialise the user-data field of bh
121 ud <- newReadState dict
122 bh <- return (setUserData bh ud)
124 symtab_p <- Binary.get bh -- Get the symtab ptr
125 data_p <- tellBin bh -- Remember where we are now
127 (nc', symtab) <- getSymbolTable bh nc
128 seekBin bh data_p -- Back to where we were before
129 let ud = getUserData bh
130 bh <- return $! setUserData bh ud{ud_symtab = symtab}
135 writeBinIface :: DynFlags -> FilePath -> ModIface -> IO ()
136 writeBinIface dflags hi_path mod_iface = do
137 bh <- openBinMem initBinMemSize
138 put_ bh binaryInterfaceMagic
140 -- Remember where the dictionary pointer will go
141 dict_p_p <- tellBin bh
142 put_ bh dict_p_p -- Placeholder for ptr to dictionary
144 -- The version and way descriptor go next
145 put_ bh (show opt_HiVersion)
146 way_descr <- getWayDescr
149 -- Remember where the symbol table pointer will go
150 symtab_p_p <- tellBin bh
153 -- Make some intial state
154 symtab_next <- newFastMutInt
155 writeFastMutInt symtab_next 0
156 symtab_map <- newIORef emptyUFM
157 let bin_symtab = BinSymbolTable {
158 bin_symtab_next = symtab_next,
159 bin_symtab_map = symtab_map }
160 dict_next_ref <- newFastMutInt
161 writeFastMutInt dict_next_ref 0
162 dict_map_ref <- newIORef emptyUFM
163 let bin_dict = BinDictionary {
164 bin_dict_next = dict_next_ref,
165 bin_dict_map = dict_map_ref }
166 ud <- newWriteState (putName bin_symtab) (putFastString bin_dict)
168 -- Put the main thing,
169 bh <- return $ setUserData bh ud
172 -- Write the symtab pointer at the fornt of the file
173 symtab_p <- tellBin bh -- This is where the symtab will start
174 putAt bh symtab_p_p symtab_p -- Fill in the placeholder
175 seekBin bh symtab_p -- Seek back to the end of the file
177 -- Write the symbol table itself
178 symtab_next <- readFastMutInt symtab_next
179 symtab_map <- readIORef symtab_map
180 putSymbolTable bh symtab_next symtab_map
181 debugTraceMsg dflags 3 (text "writeBinIface:" <+> int symtab_next
184 -- NB. write the dictionary after the symbol table, because
185 -- writing the symbol table may create more dictionary entries.
187 -- Write the dictionary pointer at the fornt of the file
188 dict_p <- tellBin bh -- This is where the dictionary will start
189 putAt bh dict_p_p dict_p -- Fill in the placeholder
190 seekBin bh dict_p -- Seek back to the end of the file
192 -- Write the dictionary itself
193 dict_next <- readFastMutInt dict_next_ref
194 dict_map <- readIORef dict_map_ref
195 putDictionary bh dict_next dict_map
196 debugTraceMsg dflags 3 (text "writeBinIface:" <+> int dict_next
197 <+> text "dict entries")
199 -- And send the result to the file
200 writeBinMem bh hi_path
202 initBinMemSize :: Int
203 initBinMemSize = 1024 * 1024
205 -- The *host* architecture version:
206 #include "../includes/MachDeps.h"
208 binaryInterfaceMagic :: Word32
209 #if WORD_SIZE_IN_BITS == 32
210 binaryInterfaceMagic = 0x1face
211 #elif WORD_SIZE_IN_BITS == 64
212 binaryInterfaceMagic = 0x1face64
215 -- -----------------------------------------------------------------------------
218 putSymbolTable :: BinHandle -> Int -> UniqFM (Int,Name) -> IO ()
219 putSymbolTable bh next_off symtab = do
221 let names = elems (array (0,next_off-1) (eltsUFM symtab))
222 mapM_ (\n -> serialiseName bh n symtab) names
224 getSymbolTable :: BinHandle -> NameCache -> IO (NameCache, Array Int Name)
225 getSymbolTable bh namecache = do
227 od_names <- sequence (replicate sz (get bh))
229 arr = listArray (0,sz-1) names
230 (namecache', names) =
231 mapAccumR (fromOnDiskName arr) namecache od_names
233 return (namecache', arr)
235 type OnDiskName = (PackageId, ModuleName, OccName)
242 fromOnDiskName _ nc (pid, mod_name, occ) =
244 mod = mkModule pid mod_name
247 case lookupOrigNameCache cache mod occ of
248 Just name -> (nc, name)
252 uniq = uniqFromSupply us
253 name = mkExternalName uniq mod occ noSrcSpan
254 new_cache = extendNameCache cache mod occ name
256 case splitUniqSupply us of { (us',_) ->
257 ( nc{ nsUniqs = us', nsNames = new_cache }, name )
260 serialiseName :: BinHandle -> Name -> UniqFM (Int,Name) -> IO ()
261 serialiseName bh name _ = do
262 let mod = ASSERT2( isExternalName name, ppr name ) nameModule name
263 put_ bh (modulePackageId mod, moduleName mod, nameOccName name)
266 putName :: BinSymbolTable -> BinHandle -> Name -> IO ()
267 putName BinSymbolTable{
268 bin_symtab_map = symtab_map_ref,
269 bin_symtab_next = symtab_next } bh name
271 symtab_map <- readIORef symtab_map_ref
272 case lookupUFM symtab_map name of
273 Just (off,_) -> put_ bh off
275 off <- readFastMutInt symtab_next
276 writeFastMutInt symtab_next (off+1)
277 writeIORef symtab_map_ref
278 $! addToUFM symtab_map name (off,name)
282 data BinSymbolTable = BinSymbolTable {
283 bin_symtab_next :: !FastMutInt, -- The next index to use
284 bin_symtab_map :: !(IORef (UniqFM (Int,Name)))
289 putFastString :: BinDictionary -> BinHandle -> FastString -> IO ()
290 putFastString BinDictionary { bin_dict_next = j_r,
291 bin_dict_map = out_r} bh f
293 out <- readIORef out_r
294 let uniq = getUnique f
295 case lookupUFM out uniq of
296 Just (j, _) -> put_ bh j
298 j <- readFastMutInt j_r
300 writeFastMutInt j_r (j + 1)
301 writeIORef out_r $! addToUFM out uniq (j, f)
304 data BinDictionary = BinDictionary {
305 bin_dict_next :: !FastMutInt, -- The next index to use
306 bin_dict_map :: !(IORef (UniqFM (Int,FastString)))
307 -- indexed by FastString
310 -- -----------------------------------------------------------------------------
311 -- All the binary instances
314 {-! for IPName derive: Binary !-}
315 {-! for Fixity derive: Binary !-}
316 {-! for FixityDirection derive: Binary !-}
317 {-! for Boxity derive: Binary !-}
318 {-! for StrictnessMark derive: Binary !-}
319 {-! for Activation derive: Binary !-}
322 {-! for Demand derive: Binary !-}
323 {-! for Demands derive: Binary !-}
324 {-! for DmdResult derive: Binary !-}
325 {-! for StrictSig derive: Binary !-}
328 {-! for DefMeth derive: Binary !-}
331 {-! for HsPred derive: Binary !-}
332 {-! for HsType derive: Binary !-}
333 {-! for TupCon derive: Binary !-}
334 {-! for HsTyVarBndr derive: Binary !-}
337 {-! for UfExpr derive: Binary !-}
338 {-! for UfConAlt derive: Binary !-}
339 {-! for UfBinding derive: Binary !-}
340 {-! for UfBinder derive: Binary !-}
341 {-! for HsIdInfo derive: Binary !-}
342 {-! for UfNote derive: Binary !-}
345 {-! for ConDetails derive: Binary !-}
346 {-! for BangType derive: Binary !-}
349 {-! for IsCafCC derive: Binary !-}
350 {-! for IsDupdCC derive: Binary !-}
351 {-! for CostCentre derive: Binary !-}
355 -- ---------------------------------------------------------------------------
356 -- Reading a binary interface into ParsedIface
358 instance Binary ModIface where
362 mi_iface_hash= iface_hash,
363 mi_mod_hash = mod_hash,
365 mi_finsts = hasFamInsts,
368 mi_exports = exports,
369 mi_exp_hash = exp_hash,
370 mi_fixities = fixities,
375 mi_fam_insts = fam_insts,
377 mi_orphan_hash = orphan_hash,
378 mi_vect_info = vect_info,
379 mi_hpc = hpc_info }) = do
407 hasFamInsts <- get bh
409 usages <- {-# SCC "bin_usages" #-} lazyGet bh
410 exports <- {-# SCC "bin_exports" #-} get bh
412 fixities <- {-# SCC "bin_fixities" #-} get bh
413 warns <- {-# SCC "bin_warns" #-} lazyGet bh
414 anns <- {-# SCC "bin_anns" #-} lazyGet bh
415 decls <- {-# SCC "bin_tycldecls" #-} get bh
416 insts <- {-# SCC "bin_insts" #-} get bh
417 fam_insts <- {-# SCC "bin_fam_insts" #-} get bh
418 rules <- {-# SCC "bin_rules" #-} lazyGet bh
419 orphan_hash <- get bh
423 mi_module = mod_name,
425 mi_iface_hash = iface_hash,
426 mi_mod_hash = mod_hash,
428 mi_finsts = hasFamInsts,
431 mi_exports = exports,
432 mi_exp_hash = exp_hash,
434 mi_fixities = fixities,
437 mi_globals = Nothing,
439 mi_fam_insts = fam_insts,
441 mi_orphan_hash = orphan_hash,
442 mi_vect_info = vect_info,
444 -- And build the cached values
445 mi_warn_fn = mkIfaceWarnCache warns,
446 mi_fix_fn = mkIfaceFixCache fixities,
447 mi_hash_fn = mkIfaceHashCache decls })
449 getWayDescr :: IO String
451 tag <- readIORef v_Build_tag
452 if cGhcUnregisterised == "YES" then return ('u':tag) else return tag
453 -- if this is an unregisterised build, make sure our interfaces
454 -- can't be used by a registerised build.
456 -------------------------------------------------------------------------
457 -- Types from: HscTypes
458 -------------------------------------------------------------------------
460 instance Binary Dependencies where
461 put_ bh deps = do put_ bh (dep_mods deps)
462 put_ bh (dep_pkgs deps)
463 put_ bh (dep_orphs deps)
464 put_ bh (dep_finsts deps)
466 get bh = do ms <- get bh
470 return (Deps { dep_mods = ms, dep_pkgs = ps, dep_orphs = os,
473 instance (Binary name) => Binary (GenAvailInfo name) where
474 put_ bh (Avail aa) = do
477 put_ bh (AvailTC ab ac) = do
488 return (AvailTC ab ac)
490 instance Binary Usage where
491 put_ bh usg@UsagePackageModule{} = do
493 put_ bh (usg_mod usg)
494 put_ bh (usg_mod_hash usg)
495 put_ bh usg@UsageHomeModule{} = do
497 put_ bh (usg_mod_name usg)
498 put_ bh (usg_mod_hash usg)
499 put_ bh (usg_exports usg)
500 put_ bh (usg_entities usg)
508 return UsagePackageModule { usg_mod = nm, usg_mod_hash = mod }
514 return UsageHomeModule { usg_mod_name = nm, usg_mod_hash = mod,
515 usg_exports = exps, usg_entities = ents }
517 instance Binary Warnings where
518 put_ bh NoWarnings = putByte bh 0
519 put_ bh (WarnAll t) = do
522 put_ bh (WarnSome ts) = do
529 0 -> return NoWarnings
535 instance Binary WarningTxt where
536 put_ bh (WarningTxt w) = do
539 put_ bh (DeprecatedTxt d) = do
547 return (WarningTxt w)
549 return (DeprecatedTxt d)
551 -------------------------------------------------------------------------
552 -- Types from: BasicTypes
553 -------------------------------------------------------------------------
555 instance Binary Activation where
556 put_ bh NeverActive = do
558 put_ bh AlwaysActive = do
560 put_ bh (ActiveBefore aa) = do
563 put_ bh (ActiveAfter ab) = do
569 0 -> do return NeverActive
570 1 -> do return AlwaysActive
572 return (ActiveBefore aa)
574 return (ActiveAfter ab)
576 instance Binary RuleMatchInfo where
577 put_ bh FunLike = putByte bh 0
578 put_ bh ConLike = putByte bh 1
581 if h == 1 then return ConLike
584 instance Binary InlinePragma where
585 put_ bh (InlinePragma activation match_info) = do
592 return (InlinePragma act info)
594 instance Binary StrictnessMark where
595 put_ bh MarkedStrict = putByte bh 0
596 put_ bh MarkedUnboxed = putByte bh 1
597 put_ bh NotMarkedStrict = putByte bh 2
601 0 -> do return MarkedStrict
602 1 -> do return MarkedUnboxed
603 _ -> do return NotMarkedStrict
605 instance Binary Boxity where
606 put_ bh Boxed = putByte bh 0
607 put_ bh Unboxed = putByte bh 1
612 _ -> do return Unboxed
614 instance Binary TupCon where
615 put_ bh (TupCon ab ac) = do
621 return (TupCon ab ac)
623 instance Binary RecFlag where
624 put_ bh Recursive = do
626 put_ bh NonRecursive = do
631 0 -> do return Recursive
632 _ -> do return NonRecursive
634 instance Binary DefMeth where
635 put_ bh NoDefMeth = putByte bh 0
636 put_ bh DefMeth = putByte bh 1
637 put_ bh GenDefMeth = putByte bh 2
641 0 -> return NoDefMeth
643 _ -> return GenDefMeth
645 instance Binary FixityDirection where
655 0 -> do return InfixL
656 1 -> do return InfixR
657 _ -> do return InfixN
659 instance Binary Fixity where
660 put_ bh (Fixity aa ab) = do
666 return (Fixity aa ab)
668 instance (Binary name) => Binary (IPName name) where
669 put_ bh (IPName aa) = put_ bh aa
670 get bh = do aa <- get bh
673 -------------------------------------------------------------------------
674 -- Types from: Demand
675 -------------------------------------------------------------------------
677 instance Binary DmdType where
678 -- Ignore DmdEnv when spitting out the DmdType
679 put bh (DmdType _ ds dr) = do p <- put bh ds; put_ bh dr; return (castBin p)
680 get bh = do ds <- get bh; dr <- get bh; return (DmdType emptyVarEnv ds dr)
682 instance Binary Demand where
687 put_ bh (Call aa) = do
690 put_ bh (Eval ab) = do
693 put_ bh (Defer ac) = do
696 put_ bh (Box ad) = do
716 instance Binary Demands where
717 put_ bh (Poly aa) = do
720 put_ bh (Prod ab) = do
731 instance Binary DmdResult where
741 0 -> do return TopRes
742 1 -> do return RetCPR -- Really use RetCPR even if -fcpr-off
743 -- The wrapper was generated for CPR in
744 -- the imported module!
745 _ -> do return BotRes
747 instance Binary StrictSig where
748 put_ bh (StrictSig aa) = do
752 return (StrictSig aa)
755 -------------------------------------------------------------------------
756 -- Types from: CostCentre
757 -------------------------------------------------------------------------
759 instance Binary IsCafCC where
762 put_ bh NotCafCC = do
768 _ -> do return NotCafCC
770 instance Binary IsDupdCC where
771 put_ bh OriginalCC = do
778 0 -> do return OriginalCC
779 _ -> do return DupdCC
781 instance Binary CostCentre where
782 put_ bh NoCostCentre = do
784 put_ bh (NormalCC aa ab ac ad) = do
790 put_ bh (AllCafsCC ae) = do
796 0 -> do return NoCostCentre
801 return (NormalCC aa ab ac ad)
803 return (AllCafsCC ae)
805 -------------------------------------------------------------------------
806 -- IfaceTypes and friends
807 -------------------------------------------------------------------------
809 instance Binary IfaceBndr where
810 put_ bh (IfaceIdBndr aa) = do
813 put_ bh (IfaceTvBndr ab) = do
820 return (IfaceIdBndr aa)
822 return (IfaceTvBndr ab)
824 instance Binary IfaceLetBndr where
825 put_ bh (IfLetBndr a b c) = do
829 get bh = do a <- get bh
832 return (IfLetBndr a b c)
834 instance Binary IfaceType where
835 put_ bh (IfaceForAllTy aa ab) = do
839 put_ bh (IfaceTyVar ad) = do
842 put_ bh (IfaceAppTy ae af) = do
846 put_ bh (IfaceFunTy ag ah) = do
850 put_ bh (IfacePredTy aq) = do
854 -- Simple compression for common cases of TyConApp
855 put_ bh (IfaceTyConApp IfaceIntTc []) = putByte bh 6
856 put_ bh (IfaceTyConApp IfaceCharTc []) = putByte bh 7
857 put_ bh (IfaceTyConApp IfaceBoolTc []) = putByte bh 8
858 put_ bh (IfaceTyConApp IfaceListTc [ty]) = do { putByte bh 9; put_ bh ty }
859 -- Unit tuple and pairs
860 put_ bh (IfaceTyConApp (IfaceTupTc Boxed 0) []) = putByte bh 10
861 put_ bh (IfaceTyConApp (IfaceTupTc Boxed 2) [t1,t2]) = do { putByte bh 11; put_ bh t1; put_ bh t2 }
863 put_ bh (IfaceTyConApp IfaceLiftedTypeKindTc []) = putByte bh 12
864 put_ bh (IfaceTyConApp IfaceOpenTypeKindTc []) = putByte bh 13
865 put_ bh (IfaceTyConApp IfaceUnliftedTypeKindTc []) = putByte bh 14
866 put_ bh (IfaceTyConApp IfaceUbxTupleKindTc []) = putByte bh 15
867 put_ bh (IfaceTyConApp IfaceArgTypeKindTc []) = putByte bh 16
871 put_ bh (IfaceTyConApp (IfaceTc tc) tys) = do { putByte bh 18; put_ bh tc; put_ bh tys }
872 put_ bh (IfaceTyConApp tc tys) = do { putByte bh 19; put_ bh tc; put_ bh tys }
879 return (IfaceForAllTy aa ab)
881 return (IfaceTyVar ad)
884 return (IfaceAppTy ae af)
887 return (IfaceFunTy ag ah)
889 return (IfacePredTy ap)
891 -- Now the special cases for TyConApp
892 6 -> return (IfaceTyConApp IfaceIntTc [])
893 7 -> return (IfaceTyConApp IfaceCharTc [])
894 8 -> return (IfaceTyConApp IfaceBoolTc [])
895 9 -> do { ty <- get bh; return (IfaceTyConApp IfaceListTc [ty]) }
896 10 -> return (IfaceTyConApp (IfaceTupTc Boxed 0) [])
897 11 -> do { t1 <- get bh; t2 <- get bh; return (IfaceTyConApp (IfaceTupTc Boxed 2) [t1,t2]) }
898 12 -> return (IfaceTyConApp IfaceLiftedTypeKindTc [])
899 13 -> return (IfaceTyConApp IfaceOpenTypeKindTc [])
900 14 -> return (IfaceTyConApp IfaceUnliftedTypeKindTc [])
901 15 -> return (IfaceTyConApp IfaceUbxTupleKindTc [])
902 16 -> return (IfaceTyConApp IfaceArgTypeKindTc [])
904 18 -> do { tc <- get bh; tys <- get bh; return (IfaceTyConApp (IfaceTc tc) tys) }
905 _ -> do { tc <- get bh; tys <- get bh; return (IfaceTyConApp tc tys) }
907 instance Binary IfaceTyCon where
908 -- Int,Char,Bool can't show up here because they can't not be saturated
910 put_ bh IfaceIntTc = putByte bh 1
911 put_ bh IfaceBoolTc = putByte bh 2
912 put_ bh IfaceCharTc = putByte bh 3
913 put_ bh IfaceListTc = putByte bh 4
914 put_ bh IfacePArrTc = putByte bh 5
915 put_ bh IfaceLiftedTypeKindTc = putByte bh 6
916 put_ bh IfaceOpenTypeKindTc = putByte bh 7
917 put_ bh IfaceUnliftedTypeKindTc = putByte bh 8
918 put_ bh IfaceUbxTupleKindTc = putByte bh 9
919 put_ bh IfaceArgTypeKindTc = putByte bh 10
920 put_ bh (IfaceTupTc bx ar) = do { putByte bh 11; put_ bh bx; put_ bh ar }
921 put_ bh (IfaceTc ext) = do { putByte bh 12; put_ bh ext }
926 1 -> return IfaceIntTc
927 2 -> return IfaceBoolTc
928 3 -> return IfaceCharTc
929 4 -> return IfaceListTc
930 5 -> return IfacePArrTc
931 6 -> return IfaceLiftedTypeKindTc
932 7 -> return IfaceOpenTypeKindTc
933 8 -> return IfaceUnliftedTypeKindTc
934 9 -> return IfaceUbxTupleKindTc
935 10 -> return IfaceArgTypeKindTc
936 11 -> do { bx <- get bh; ar <- get bh; return (IfaceTupTc bx ar) }
937 _ -> do { ext <- get bh; return (IfaceTc ext) }
939 instance Binary IfacePredType where
940 put_ bh (IfaceClassP aa ab) = do
944 put_ bh (IfaceIParam ac ad) = do
948 put_ bh (IfaceEqPred ac ad) = do
957 return (IfaceClassP aa ab)
960 return (IfaceIParam ac ad)
963 return (IfaceEqPred ac ad)
964 _ -> panic ("get IfacePredType " ++ show h)
966 -------------------------------------------------------------------------
967 -- IfaceExpr and friends
968 -------------------------------------------------------------------------
970 instance Binary IfaceExpr where
971 put_ bh (IfaceLcl aa) = do
974 put_ bh (IfaceType ab) = do
977 put_ bh (IfaceTuple ac ad) = do
981 put_ bh (IfaceLam ae af) = do
985 put_ bh (IfaceApp ag ah) = do
990 put_ bh (IfaceCase ai aj al ak) = do
997 put_ bh (IfaceLet al am) = do
1001 put_ bh (IfaceNote an ao) = do
1005 put_ bh (IfaceLit ap) = do
1008 put_ bh (IfaceFCall as at) = do
1012 put_ bh (IfaceExt aa) = do
1015 put_ bh (IfaceCast ie ico) = do
1019 put_ bh (IfaceTick m ix) = do
1026 0 -> do aa <- get bh
1027 return (IfaceLcl aa)
1028 1 -> do ab <- get bh
1029 return (IfaceType ab)
1030 2 -> do ac <- get bh
1032 return (IfaceTuple ac ad)
1033 3 -> do ae <- get bh
1035 return (IfaceLam ae af)
1036 4 -> do ag <- get bh
1038 return (IfaceApp ag ah)
1039 5 -> do ai <- get bh
1045 return (IfaceCase ai aj al ak)
1046 6 -> do al <- get bh
1048 return (IfaceLet al am)
1049 7 -> do an <- get bh
1051 return (IfaceNote an ao)
1052 8 -> do ap <- get bh
1053 return (IfaceLit ap)
1054 9 -> do as <- get bh
1056 return (IfaceFCall as at)
1057 10 -> do aa <- get bh
1058 return (IfaceExt aa)
1059 11 -> do ie <- get bh
1061 return (IfaceCast ie ico)
1062 12 -> do m <- get bh
1064 return (IfaceTick m ix)
1065 _ -> panic ("get IfaceExpr " ++ show h)
1067 instance Binary IfaceConAlt where
1068 put_ bh IfaceDefault = do
1070 put_ bh (IfaceDataAlt aa) = do
1073 put_ bh (IfaceTupleAlt ab) = do
1076 put_ bh (IfaceLitAlt ac) = do
1082 0 -> do return IfaceDefault
1083 1 -> do aa <- get bh
1084 return (IfaceDataAlt aa)
1085 2 -> do ab <- get bh
1086 return (IfaceTupleAlt ab)
1087 _ -> do ac <- get bh
1088 return (IfaceLitAlt ac)
1090 instance Binary IfaceBinding where
1091 put_ bh (IfaceNonRec aa ab) = do
1095 put_ bh (IfaceRec ac) = do
1101 0 -> do aa <- get bh
1103 return (IfaceNonRec aa ab)
1104 _ -> do ac <- get bh
1105 return (IfaceRec ac)
1107 instance Binary IfaceIdDetails where
1108 put_ bh IfVanillaId = putByte bh 0
1109 put_ bh (IfRecSelId a b) = do { putByte bh 1; put_ bh a; put_ bh b }
1110 put_ bh IfDFunId = putByte bh 2
1114 0 -> return IfVanillaId
1117 return (IfRecSelId a b)
1118 _ -> return IfDFunId
1120 instance Binary IfaceIdInfo where
1121 put_ bh NoInfo = putByte bh 0
1122 put_ bh (HasInfo i) = do
1124 lazyPut bh i -- NB lazyPut
1130 _ -> do info <- lazyGet bh -- NB lazyGet
1131 return (HasInfo info)
1133 instance Binary IfaceInfoItem where
1134 put_ bh (HsArity aa) = do
1137 put_ bh (HsStrictness ab) = do
1140 put_ bh (HsUnfold ad) = do
1143 put_ bh (HsInline ad) = do
1146 put_ bh HsNoCafRefs = do
1148 put_ bh (HsWorker ae af) = do
1155 0 -> do aa <- get bh
1157 1 -> do ab <- get bh
1158 return (HsStrictness ab)
1159 2 -> do ad <- get bh
1160 return (HsUnfold ad)
1161 3 -> do ad <- get bh
1162 return (HsInline ad)
1163 4 -> do return HsNoCafRefs
1164 _ -> do ae <- get bh
1166 return (HsWorker ae af)
1168 instance Binary IfaceNote where
1169 put_ bh (IfaceSCC aa) = do
1172 put_ bh IfaceInlineMe = do
1174 put_ bh (IfaceCoreNote s) = do
1180 0 -> do aa <- get bh
1181 return (IfaceSCC aa)
1182 3 -> do return IfaceInlineMe
1183 4 -> do ac <- get bh
1184 return (IfaceCoreNote ac)
1185 _ -> panic ("get IfaceNote " ++ show h)
1187 -------------------------------------------------------------------------
1188 -- IfaceDecl and friends
1189 -------------------------------------------------------------------------
1191 -- A bit of magic going on here: there's no need to store the OccName
1192 -- for a decl on the disk, since we can infer the namespace from the
1193 -- context; however it is useful to have the OccName in the IfaceDecl
1194 -- to avoid re-building it in various places. So we build the OccName
1195 -- when de-serialising.
1197 instance Binary IfaceDecl where
1198 put_ bh (IfaceId name ty details idinfo) = do
1200 put_ bh (occNameFS name)
1204 put_ _ (IfaceForeign _ _) =
1205 error "Binary.put_(IfaceDecl): IfaceForeign"
1206 put_ bh (IfaceData a1 a2 a3 a4 a5 a6 a7 a8) = do
1208 put_ bh (occNameFS a1)
1216 put_ bh (IfaceSyn a1 a2 a3 a4 a5) = do
1218 put_ bh (occNameFS a1)
1223 put_ bh (IfaceClass a1 a2 a3 a4 a5 a6 a7) = do
1226 put_ bh (occNameFS a2)
1235 0 -> do name <- get bh
1239 occ <- return $! mkOccNameFS varName name
1240 return (IfaceId occ ty details idinfo)
1241 1 -> error "Binary.get(TyClDecl): ForeignType"
1251 occ <- return $! mkOccNameFS tcName a1
1252 return (IfaceData occ a2 a3 a4 a5 a6 a7 a8)
1259 occ <- return $! mkOccNameFS tcName a1
1260 return (IfaceSyn occ a2 a3 a4 a5)
1269 occ <- return $! mkOccNameFS clsName a2
1270 return (IfaceClass a1 occ a3 a4 a5 a6 a7)
1272 instance Binary IfaceInst where
1273 put_ bh (IfaceInst cls tys dfun flag orph) = do
1279 get bh = do cls <- get bh
1284 return (IfaceInst cls tys dfun flag orph)
1286 instance Binary IfaceFamInst where
1287 put_ bh (IfaceFamInst fam tys tycon) = do
1291 get bh = do fam <- get bh
1294 return (IfaceFamInst fam tys tycon)
1296 instance Binary OverlapFlag where
1297 put_ bh NoOverlap = putByte bh 0
1298 put_ bh OverlapOk = putByte bh 1
1299 put_ bh Incoherent = putByte bh 2
1300 get bh = do h <- getByte bh
1302 0 -> return NoOverlap
1303 1 -> return OverlapOk
1304 2 -> return Incoherent
1305 _ -> panic ("get OverlapFlag " ++ show h)
1307 instance Binary IfaceConDecls where
1308 put_ bh IfAbstractTyCon = putByte bh 0
1309 put_ bh IfOpenDataTyCon = putByte bh 1
1310 put_ bh (IfDataTyCon cs) = do { putByte bh 2
1312 put_ bh (IfNewTyCon c) = do { putByte bh 3
1317 0 -> return IfAbstractTyCon
1318 1 -> return IfOpenDataTyCon
1319 2 -> do cs <- get bh
1320 return (IfDataTyCon cs)
1321 _ -> do aa <- get bh
1322 return (IfNewTyCon aa)
1324 instance Binary IfaceConDecl where
1325 put_ bh (IfCon a1 a2 a3 a4 a5 a6 a7 a8 a9 a10) = do
1336 get bh = do a1 <- get bh
1346 return (IfCon a1 a2 a3 a4 a5 a6 a7 a8 a9 a10)
1348 instance Binary IfaceClassOp where
1349 put_ bh (IfaceClassOp n def ty) = do
1350 put_ bh (occNameFS n)
1357 occ <- return $! mkOccNameFS varName n
1358 return (IfaceClassOp occ def ty)
1360 instance Binary IfaceRule where
1361 put_ bh (IfaceRule a1 a2 a3 a4 a5 a6 a7) = do
1377 return (IfaceRule a1 a2 a3 a4 a5 a6 a7)
1379 instance Binary IfaceAnnotation where
1380 put_ bh (IfaceAnnotation a1 a2) = do
1386 return (IfaceAnnotation a1 a2)
1388 instance Binary name => Binary (AnnTarget name) where
1389 put_ bh (NamedTarget a) = do
1392 put_ bh (ModuleTarget a) = do
1399 return (NamedTarget a)
1401 return (ModuleTarget a)
1403 instance Binary IfaceVectInfo where
1404 put_ bh (IfaceVectInfo a1 a2 a3) = do
1412 return (IfaceVectInfo a1 a2 a3)