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
61 (new_nc, iface) <- liftIO $
62 readBinIface_ checkHiWay traceBinIFaceReading hi_path nc
66 readBinIface_ :: CheckHiWay -> TraceBinIFaceReading -> FilePath -> NameCache
67 -> IO (NameCache, ModIface)
68 readBinIface_ checkHiWay traceBinIFaceReading hi_path nc = do
69 let printer :: SDoc -> IO ()
70 printer = case traceBinIFaceReading of
71 TraceBinIFaceReading -> \sd -> printSDoc sd defaultDumpStyle
72 QuietBinIFaceReading -> \_ -> return ()
73 wantedGot :: Outputable a => String -> a -> a -> IO ()
74 wantedGot what wanted got
75 = printer (text what <> text ": " <>
76 vcat [text "Wanted " <> ppr wanted <> text ",",
77 text "got " <> ppr got])
79 errorOnMismatch :: (Eq a, Show a) => String -> a -> a -> IO ()
80 errorOnMismatch what wanted got
81 -- This will be caught by readIface which will emit an error
82 -- msg containing the iface module name.
83 = when (wanted /= got) $ ghcError $ ProgramError
84 (what ++ " (wanted " ++ show wanted
85 ++ ", got " ++ show got ++ ")")
86 bh <- Binary.readBinMem hi_path
88 -- Read the magic number to check that this really is a GHC .hi file
89 -- (This magic number does not change when we change
90 -- GHC interface file format)
92 wantedGot "Magic" binaryInterfaceMagic magic
93 errorOnMismatch "magic number mismatch: old/corrupt interface file?"
94 binaryInterfaceMagic magic
96 -- Get the dictionary pointer. We won't attempt to actually
97 -- read the dictionary until we've done the version checks below,
98 -- just in case this isn't a valid interface. In retrospect the
99 -- version should have come before the dictionary pointer, but this
100 -- is the way it was done originally, and we can't change it now.
101 dict_p <- Binary.get bh -- Get the dictionary ptr
103 -- Check the interface file version and ways.
105 let our_ver = show opt_HiVersion
106 wantedGot "Version" our_ver check_ver
107 errorOnMismatch "mismatched interface file versions" our_ver check_ver
110 way_descr <- getWayDescr
111 wantedGot "Way" way_descr check_way
112 when (checkHiWay == CheckHiWay) $
113 errorOnMismatch "mismatched interface file ways" way_descr check_way
115 -- Read the dictionary
116 -- The next word in the file is a pointer to where the dictionary is
117 -- (probably at the end of the file)
118 data_p <- tellBin bh -- Remember where we are now
120 dict <- getDictionary bh
121 seekBin bh data_p -- Back to where we were before
123 -- Initialise the user-data field of bh
124 ud <- newReadState dict
125 bh <- return (setUserData bh ud)
127 symtab_p <- Binary.get bh -- Get the symtab ptr
128 data_p <- tellBin bh -- Remember where we are now
130 (nc', symtab) <- getSymbolTable bh nc
131 seekBin bh data_p -- Back to where we were before
132 let ud = getUserData bh
133 bh <- return $! setUserData bh ud{ud_symtab = symtab}
138 writeBinIface :: DynFlags -> FilePath -> ModIface -> IO ()
139 writeBinIface dflags hi_path mod_iface = do
140 bh <- openBinMem initBinMemSize
141 put_ bh binaryInterfaceMagic
143 -- Remember where the dictionary pointer will go
144 dict_p_p <- tellBin bh
145 put_ bh dict_p_p -- Placeholder for ptr to dictionary
147 -- The version and way descriptor go next
148 put_ bh (show opt_HiVersion)
149 way_descr <- getWayDescr
152 -- Remember where the symbol table pointer will go
153 symtab_p_p <- tellBin bh
156 -- Make some intial state
157 symtab_next <- newFastMutInt
158 writeFastMutInt symtab_next 0
159 symtab_map <- newIORef emptyUFM
160 let bin_symtab = BinSymbolTable {
161 bin_symtab_next = symtab_next,
162 bin_symtab_map = symtab_map }
163 dict_next_ref <- newFastMutInt
164 writeFastMutInt dict_next_ref 0
165 dict_map_ref <- newIORef emptyUFM
166 let bin_dict = BinDictionary {
167 bin_dict_next = dict_next_ref,
168 bin_dict_map = dict_map_ref }
169 ud <- newWriteState (putName bin_symtab) (putFastString bin_dict)
171 -- Put the main thing,
172 bh <- return $ setUserData bh ud
175 -- Write the symtab pointer at the fornt of the file
176 symtab_p <- tellBin bh -- This is where the symtab will start
177 putAt bh symtab_p_p symtab_p -- Fill in the placeholder
178 seekBin bh symtab_p -- Seek back to the end of the file
180 -- Write the symbol table itself
181 symtab_next <- readFastMutInt symtab_next
182 symtab_map <- readIORef symtab_map
183 putSymbolTable bh symtab_next symtab_map
184 debugTraceMsg dflags 3 (text "writeBinIface:" <+> int symtab_next
187 -- NB. write the dictionary after the symbol table, because
188 -- writing the symbol table may create more dictionary entries.
190 -- Write the dictionary pointer at the fornt of the file
191 dict_p <- tellBin bh -- This is where the dictionary will start
192 putAt bh dict_p_p dict_p -- Fill in the placeholder
193 seekBin bh dict_p -- Seek back to the end of the file
195 -- Write the dictionary itself
196 dict_next <- readFastMutInt dict_next_ref
197 dict_map <- readIORef dict_map_ref
198 putDictionary bh dict_next dict_map
199 debugTraceMsg dflags 3 (text "writeBinIface:" <+> int dict_next
200 <+> text "dict entries")
202 -- And send the result to the file
203 writeBinMem bh hi_path
205 initBinMemSize :: Int
206 initBinMemSize = 1024 * 1024
208 -- The *host* architecture version:
209 #include "../includes/MachDeps.h"
211 binaryInterfaceMagic :: Word32
212 #if WORD_SIZE_IN_BITS == 32
213 binaryInterfaceMagic = 0x1face
214 #elif WORD_SIZE_IN_BITS == 64
215 binaryInterfaceMagic = 0x1face64
218 -- -----------------------------------------------------------------------------
221 putSymbolTable :: BinHandle -> Int -> UniqFM (Int,Name) -> IO ()
222 putSymbolTable bh next_off symtab = do
224 let names = elems (array (0,next_off-1) (eltsUFM symtab))
225 mapM_ (\n -> serialiseName bh n symtab) names
227 getSymbolTable :: BinHandle -> NameCache -> IO (NameCache, Array Int Name)
228 getSymbolTable bh namecache = do
230 od_names <- sequence (replicate sz (get bh))
232 arr = listArray (0,sz-1) names
233 (namecache', names) =
234 mapAccumR (fromOnDiskName arr) namecache od_names
236 return (namecache', arr)
238 type OnDiskName = (PackageId, ModuleName, OccName)
245 fromOnDiskName _ nc (pid, mod_name, occ) =
247 mod = mkModule pid mod_name
250 case lookupOrigNameCache cache mod occ of
251 Just name -> (nc, name)
255 uniq = uniqFromSupply us
256 name = mkExternalName uniq mod occ noSrcSpan
257 new_cache = extendNameCache cache mod occ name
259 case splitUniqSupply us of { (us',_) ->
260 ( nc{ nsUniqs = us', nsNames = new_cache }, name )
263 serialiseName :: BinHandle -> Name -> UniqFM (Int,Name) -> IO ()
264 serialiseName bh name _ = do
265 let mod = ASSERT2( isExternalName name, ppr name ) nameModule name
266 put_ bh (modulePackageId mod, moduleName mod, nameOccName name)
269 putName :: BinSymbolTable -> BinHandle -> Name -> IO ()
270 putName BinSymbolTable{
271 bin_symtab_map = symtab_map_ref,
272 bin_symtab_next = symtab_next } bh name
274 symtab_map <- readIORef symtab_map_ref
275 case lookupUFM symtab_map name of
276 Just (off,_) -> put_ bh off
278 off <- readFastMutInt symtab_next
279 writeFastMutInt symtab_next (off+1)
280 writeIORef symtab_map_ref
281 $! addToUFM symtab_map name (off,name)
285 data BinSymbolTable = BinSymbolTable {
286 bin_symtab_next :: !FastMutInt, -- The next index to use
287 bin_symtab_map :: !(IORef (UniqFM (Int,Name)))
292 putFastString :: BinDictionary -> BinHandle -> FastString -> IO ()
293 putFastString BinDictionary { bin_dict_next = j_r,
294 bin_dict_map = out_r} bh f
296 out <- readIORef out_r
297 let uniq = getUnique f
298 case lookupUFM out uniq of
299 Just (j, _) -> put_ bh j
301 j <- readFastMutInt j_r
303 writeFastMutInt j_r (j + 1)
304 writeIORef out_r $! addToUFM out uniq (j, f)
307 data BinDictionary = BinDictionary {
308 bin_dict_next :: !FastMutInt, -- The next index to use
309 bin_dict_map :: !(IORef (UniqFM (Int,FastString)))
310 -- indexed by FastString
313 -- -----------------------------------------------------------------------------
314 -- All the binary instances
317 {-! for IPName derive: Binary !-}
318 {-! for Fixity derive: Binary !-}
319 {-! for FixityDirection derive: Binary !-}
320 {-! for Boxity derive: Binary !-}
321 {-! for StrictnessMark derive: Binary !-}
322 {-! for Activation derive: Binary !-}
325 {-! for Demand derive: Binary !-}
326 {-! for Demands derive: Binary !-}
327 {-! for DmdResult derive: Binary !-}
328 {-! for StrictSig derive: Binary !-}
331 {-! for DefMeth derive: Binary !-}
334 {-! for HsPred derive: Binary !-}
335 {-! for HsType derive: Binary !-}
336 {-! for TupCon derive: Binary !-}
337 {-! for HsTyVarBndr derive: Binary !-}
340 {-! for UfExpr derive: Binary !-}
341 {-! for UfConAlt derive: Binary !-}
342 {-! for UfBinding derive: Binary !-}
343 {-! for UfBinder derive: Binary !-}
344 {-! for HsIdInfo derive: Binary !-}
345 {-! for UfNote derive: Binary !-}
348 {-! for ConDetails derive: Binary !-}
349 {-! for BangType derive: Binary !-}
352 {-! for IsCafCC derive: Binary !-}
353 {-! for IsDupdCC derive: Binary !-}
354 {-! for CostCentre derive: Binary !-}
358 -- ---------------------------------------------------------------------------
359 -- Reading a binary interface into ParsedIface
361 instance Binary ModIface where
365 mi_iface_hash= iface_hash,
366 mi_mod_hash = mod_hash,
368 mi_finsts = hasFamInsts,
371 mi_exports = exports,
372 mi_exp_hash = exp_hash,
373 mi_fixities = fixities,
378 mi_fam_insts = fam_insts,
380 mi_orphan_hash = orphan_hash,
381 mi_vect_info = vect_info,
382 mi_hpc = hpc_info }) = do
410 hasFamInsts <- get bh
412 usages <- {-# SCC "bin_usages" #-} lazyGet bh
413 exports <- {-# SCC "bin_exports" #-} get bh
415 fixities <- {-# SCC "bin_fixities" #-} get bh
416 warns <- {-# SCC "bin_warns" #-} lazyGet bh
417 anns <- {-# SCC "bin_anns" #-} lazyGet bh
418 decls <- {-# SCC "bin_tycldecls" #-} get bh
419 insts <- {-# SCC "bin_insts" #-} get bh
420 fam_insts <- {-# SCC "bin_fam_insts" #-} get bh
421 rules <- {-# SCC "bin_rules" #-} lazyGet bh
422 orphan_hash <- get bh
426 mi_module = mod_name,
428 mi_iface_hash = iface_hash,
429 mi_mod_hash = mod_hash,
431 mi_finsts = hasFamInsts,
434 mi_exports = exports,
435 mi_exp_hash = exp_hash,
437 mi_fixities = fixities,
440 mi_globals = Nothing,
442 mi_fam_insts = fam_insts,
444 mi_orphan_hash = orphan_hash,
445 mi_vect_info = vect_info,
447 -- And build the cached values
448 mi_warn_fn = mkIfaceWarnCache warns,
449 mi_fix_fn = mkIfaceFixCache fixities,
450 mi_hash_fn = mkIfaceHashCache decls })
452 getWayDescr :: IO String
454 tag <- readIORef v_Build_tag
455 if cGhcUnregisterised == "YES" then return ('u':tag) else return tag
456 -- if this is an unregisterised build, make sure our interfaces
457 -- can't be used by a registerised build.
459 -------------------------------------------------------------------------
460 -- Types from: HscTypes
461 -------------------------------------------------------------------------
463 instance Binary Dependencies where
464 put_ bh deps = do put_ bh (dep_mods deps)
465 put_ bh (dep_pkgs deps)
466 put_ bh (dep_orphs deps)
467 put_ bh (dep_finsts deps)
469 get bh = do ms <- get bh
473 return (Deps { dep_mods = ms, dep_pkgs = ps, dep_orphs = os,
476 instance (Binary name) => Binary (GenAvailInfo name) where
477 put_ bh (Avail aa) = do
480 put_ bh (AvailTC ab ac) = do
491 return (AvailTC ab ac)
493 instance Binary Usage where
494 put_ bh usg@UsagePackageModule{} = do
496 put_ bh (usg_mod usg)
497 put_ bh (usg_mod_hash usg)
498 put_ bh usg@UsageHomeModule{} = do
500 put_ bh (usg_mod_name usg)
501 put_ bh (usg_mod_hash usg)
502 put_ bh (usg_exports usg)
503 put_ bh (usg_entities usg)
511 return UsagePackageModule { usg_mod = nm, usg_mod_hash = mod }
517 return UsageHomeModule { usg_mod_name = nm, usg_mod_hash = mod,
518 usg_exports = exps, usg_entities = ents }
520 instance Binary Warnings where
521 put_ bh NoWarnings = putByte bh 0
522 put_ bh (WarnAll t) = do
525 put_ bh (WarnSome ts) = do
532 0 -> return NoWarnings
538 instance Binary WarningTxt where
539 put_ bh (WarningTxt w) = do
542 put_ bh (DeprecatedTxt d) = do
550 return (WarningTxt w)
552 return (DeprecatedTxt d)
554 -------------------------------------------------------------------------
555 -- Types from: BasicTypes
556 -------------------------------------------------------------------------
558 instance Binary Activation where
559 put_ bh NeverActive = do
561 put_ bh AlwaysActive = do
563 put_ bh (ActiveBefore aa) = do
566 put_ bh (ActiveAfter ab) = do
572 0 -> do return NeverActive
573 1 -> do return AlwaysActive
575 return (ActiveBefore aa)
577 return (ActiveAfter ab)
579 instance Binary RuleMatchInfo where
580 put_ bh FunLike = putByte bh 0
581 put_ bh ConLike = putByte bh 1
584 if h == 1 then return ConLike
587 instance Binary InlinePragma where
588 put_ bh (InlinePragma activation match_info) = do
595 return (InlinePragma act info)
597 instance Binary StrictnessMark where
598 put_ bh MarkedStrict = putByte bh 0
599 put_ bh MarkedUnboxed = putByte bh 1
600 put_ bh NotMarkedStrict = putByte bh 2
604 0 -> do return MarkedStrict
605 1 -> do return MarkedUnboxed
606 _ -> do return NotMarkedStrict
608 instance Binary Boxity where
609 put_ bh Boxed = putByte bh 0
610 put_ bh Unboxed = putByte bh 1
615 _ -> do return Unboxed
617 instance Binary TupCon where
618 put_ bh (TupCon ab ac) = do
624 return (TupCon ab ac)
626 instance Binary RecFlag where
627 put_ bh Recursive = do
629 put_ bh NonRecursive = do
634 0 -> do return Recursive
635 _ -> do return NonRecursive
637 instance Binary DefMeth where
638 put_ bh NoDefMeth = putByte bh 0
639 put_ bh DefMeth = putByte bh 1
640 put_ bh GenDefMeth = putByte bh 2
644 0 -> return NoDefMeth
646 _ -> return GenDefMeth
648 instance Binary FixityDirection where
658 0 -> do return InfixL
659 1 -> do return InfixR
660 _ -> do return InfixN
662 instance Binary Fixity where
663 put_ bh (Fixity aa ab) = do
669 return (Fixity aa ab)
671 instance (Binary name) => Binary (IPName name) where
672 put_ bh (IPName aa) = put_ bh aa
673 get bh = do aa <- get bh
676 -------------------------------------------------------------------------
677 -- Types from: Demand
678 -------------------------------------------------------------------------
680 instance Binary DmdType where
681 -- Ignore DmdEnv when spitting out the DmdType
682 put bh (DmdType _ ds dr) = do p <- put bh ds; put_ bh dr; return (castBin p)
683 get bh = do ds <- get bh; dr <- get bh; return (DmdType emptyVarEnv ds dr)
685 instance Binary Demand where
690 put_ bh (Call aa) = do
693 put_ bh (Eval ab) = do
696 put_ bh (Defer ac) = do
699 put_ bh (Box ad) = do
719 instance Binary Demands where
720 put_ bh (Poly aa) = do
723 put_ bh (Prod ab) = do
734 instance Binary DmdResult where
744 0 -> do return TopRes
745 1 -> do return RetCPR -- Really use RetCPR even if -fcpr-off
746 -- The wrapper was generated for CPR in
747 -- the imported module!
748 _ -> do return BotRes
750 instance Binary StrictSig where
751 put_ bh (StrictSig aa) = do
755 return (StrictSig aa)
758 -------------------------------------------------------------------------
759 -- Types from: CostCentre
760 -------------------------------------------------------------------------
762 instance Binary IsCafCC where
765 put_ bh NotCafCC = do
771 _ -> do return NotCafCC
773 instance Binary IsDupdCC where
774 put_ bh OriginalCC = do
781 0 -> do return OriginalCC
782 _ -> do return DupdCC
784 instance Binary CostCentre where
785 put_ bh NoCostCentre = do
787 put_ bh (NormalCC aa ab ac ad) = do
793 put_ bh (AllCafsCC ae) = do
799 0 -> do return NoCostCentre
804 return (NormalCC aa ab ac ad)
806 return (AllCafsCC ae)
808 -------------------------------------------------------------------------
809 -- IfaceTypes and friends
810 -------------------------------------------------------------------------
812 instance Binary IfaceBndr where
813 put_ bh (IfaceIdBndr aa) = do
816 put_ bh (IfaceTvBndr ab) = do
823 return (IfaceIdBndr aa)
825 return (IfaceTvBndr ab)
827 instance Binary IfaceLetBndr where
828 put_ bh (IfLetBndr a b c) = do
832 get bh = do a <- get bh
835 return (IfLetBndr a b c)
837 instance Binary IfaceType where
838 put_ bh (IfaceForAllTy aa ab) = do
842 put_ bh (IfaceTyVar ad) = do
845 put_ bh (IfaceAppTy ae af) = do
849 put_ bh (IfaceFunTy ag ah) = do
853 put_ bh (IfacePredTy aq) = do
857 -- Simple compression for common cases of TyConApp
858 put_ bh (IfaceTyConApp IfaceIntTc []) = putByte bh 6
859 put_ bh (IfaceTyConApp IfaceCharTc []) = putByte bh 7
860 put_ bh (IfaceTyConApp IfaceBoolTc []) = putByte bh 8
861 put_ bh (IfaceTyConApp IfaceListTc [ty]) = do { putByte bh 9; put_ bh ty }
862 -- Unit tuple and pairs
863 put_ bh (IfaceTyConApp (IfaceTupTc Boxed 0) []) = putByte bh 10
864 put_ bh (IfaceTyConApp (IfaceTupTc Boxed 2) [t1,t2]) = do { putByte bh 11; put_ bh t1; put_ bh t2 }
866 put_ bh (IfaceTyConApp IfaceLiftedTypeKindTc []) = putByte bh 12
867 put_ bh (IfaceTyConApp IfaceOpenTypeKindTc []) = putByte bh 13
868 put_ bh (IfaceTyConApp IfaceUnliftedTypeKindTc []) = putByte bh 14
869 put_ bh (IfaceTyConApp IfaceUbxTupleKindTc []) = putByte bh 15
870 put_ bh (IfaceTyConApp IfaceArgTypeKindTc []) = putByte bh 16
874 put_ bh (IfaceTyConApp (IfaceTc tc) tys) = do { putByte bh 18; put_ bh tc; put_ bh tys }
875 put_ bh (IfaceTyConApp tc tys) = do { putByte bh 19; put_ bh tc; put_ bh tys }
882 return (IfaceForAllTy aa ab)
884 return (IfaceTyVar ad)
887 return (IfaceAppTy ae af)
890 return (IfaceFunTy ag ah)
892 return (IfacePredTy ap)
894 -- Now the special cases for TyConApp
895 6 -> return (IfaceTyConApp IfaceIntTc [])
896 7 -> return (IfaceTyConApp IfaceCharTc [])
897 8 -> return (IfaceTyConApp IfaceBoolTc [])
898 9 -> do { ty <- get bh; return (IfaceTyConApp IfaceListTc [ty]) }
899 10 -> return (IfaceTyConApp (IfaceTupTc Boxed 0) [])
900 11 -> do { t1 <- get bh; t2 <- get bh; return (IfaceTyConApp (IfaceTupTc Boxed 2) [t1,t2]) }
901 12 -> return (IfaceTyConApp IfaceLiftedTypeKindTc [])
902 13 -> return (IfaceTyConApp IfaceOpenTypeKindTc [])
903 14 -> return (IfaceTyConApp IfaceUnliftedTypeKindTc [])
904 15 -> return (IfaceTyConApp IfaceUbxTupleKindTc [])
905 16 -> return (IfaceTyConApp IfaceArgTypeKindTc [])
907 18 -> do { tc <- get bh; tys <- get bh; return (IfaceTyConApp (IfaceTc tc) tys) }
908 _ -> do { tc <- get bh; tys <- get bh; return (IfaceTyConApp tc tys) }
910 instance Binary IfaceTyCon where
911 -- Int,Char,Bool can't show up here because they can't not be saturated
913 put_ bh IfaceIntTc = putByte bh 1
914 put_ bh IfaceBoolTc = putByte bh 2
915 put_ bh IfaceCharTc = putByte bh 3
916 put_ bh IfaceListTc = putByte bh 4
917 put_ bh IfacePArrTc = putByte bh 5
918 put_ bh IfaceLiftedTypeKindTc = putByte bh 6
919 put_ bh IfaceOpenTypeKindTc = putByte bh 7
920 put_ bh IfaceUnliftedTypeKindTc = putByte bh 8
921 put_ bh IfaceUbxTupleKindTc = putByte bh 9
922 put_ bh IfaceArgTypeKindTc = putByte bh 10
923 put_ bh (IfaceTupTc bx ar) = do { putByte bh 11; put_ bh bx; put_ bh ar }
924 put_ bh (IfaceTc ext) = do { putByte bh 12; put_ bh ext }
929 1 -> return IfaceIntTc
930 2 -> return IfaceBoolTc
931 3 -> return IfaceCharTc
932 4 -> return IfaceListTc
933 5 -> return IfacePArrTc
934 6 -> return IfaceLiftedTypeKindTc
935 7 -> return IfaceOpenTypeKindTc
936 8 -> return IfaceUnliftedTypeKindTc
937 9 -> return IfaceUbxTupleKindTc
938 10 -> return IfaceArgTypeKindTc
939 11 -> do { bx <- get bh; ar <- get bh; return (IfaceTupTc bx ar) }
940 _ -> do { ext <- get bh; return (IfaceTc ext) }
942 instance Binary IfacePredType where
943 put_ bh (IfaceClassP aa ab) = do
947 put_ bh (IfaceIParam ac ad) = do
951 put_ bh (IfaceEqPred ac ad) = do
960 return (IfaceClassP aa ab)
963 return (IfaceIParam ac ad)
966 return (IfaceEqPred ac ad)
967 _ -> panic ("get IfacePredType " ++ show h)
969 -------------------------------------------------------------------------
970 -- IfaceExpr and friends
971 -------------------------------------------------------------------------
973 instance Binary IfaceExpr where
974 put_ bh (IfaceLcl aa) = do
977 put_ bh (IfaceType ab) = do
980 put_ bh (IfaceTuple ac ad) = do
984 put_ bh (IfaceLam ae af) = do
988 put_ bh (IfaceApp ag ah) = do
993 put_ bh (IfaceCase ai aj al ak) = do
1000 put_ bh (IfaceLet al am) = do
1004 put_ bh (IfaceNote an ao) = do
1008 put_ bh (IfaceLit ap) = do
1011 put_ bh (IfaceFCall as at) = do
1015 put_ bh (IfaceExt aa) = do
1018 put_ bh (IfaceCast ie ico) = do
1022 put_ bh (IfaceTick m ix) = do
1029 0 -> do aa <- get bh
1030 return (IfaceLcl aa)
1031 1 -> do ab <- get bh
1032 return (IfaceType ab)
1033 2 -> do ac <- get bh
1035 return (IfaceTuple ac ad)
1036 3 -> do ae <- get bh
1038 return (IfaceLam ae af)
1039 4 -> do ag <- get bh
1041 return (IfaceApp ag ah)
1042 5 -> do ai <- get bh
1048 return (IfaceCase ai aj al ak)
1049 6 -> do al <- get bh
1051 return (IfaceLet al am)
1052 7 -> do an <- get bh
1054 return (IfaceNote an ao)
1055 8 -> do ap <- get bh
1056 return (IfaceLit ap)
1057 9 -> do as <- get bh
1059 return (IfaceFCall as at)
1060 10 -> do aa <- get bh
1061 return (IfaceExt aa)
1062 11 -> do ie <- get bh
1064 return (IfaceCast ie ico)
1065 12 -> do m <- get bh
1067 return (IfaceTick m ix)
1068 _ -> panic ("get IfaceExpr " ++ show h)
1070 instance Binary IfaceConAlt where
1071 put_ bh IfaceDefault = do
1073 put_ bh (IfaceDataAlt aa) = do
1076 put_ bh (IfaceTupleAlt ab) = do
1079 put_ bh (IfaceLitAlt ac) = do
1085 0 -> do return IfaceDefault
1086 1 -> do aa <- get bh
1087 return (IfaceDataAlt aa)
1088 2 -> do ab <- get bh
1089 return (IfaceTupleAlt ab)
1090 _ -> do ac <- get bh
1091 return (IfaceLitAlt ac)
1093 instance Binary IfaceBinding where
1094 put_ bh (IfaceNonRec aa ab) = do
1098 put_ bh (IfaceRec ac) = do
1104 0 -> do aa <- get bh
1106 return (IfaceNonRec aa ab)
1107 _ -> do ac <- get bh
1108 return (IfaceRec ac)
1110 instance Binary IfaceIdDetails where
1111 put_ bh IfVanillaId = putByte bh 0
1112 put_ bh (IfRecSelId a b) = do { putByte bh 1; put_ bh a; put_ bh b }
1113 put_ bh IfDFunId = putByte bh 2
1117 0 -> return IfVanillaId
1120 return (IfRecSelId a b)
1121 _ -> return IfDFunId
1123 instance Binary IfaceIdInfo where
1124 put_ bh NoInfo = putByte bh 0
1125 put_ bh (HasInfo i) = do
1127 lazyPut bh i -- NB lazyPut
1133 _ -> do info <- lazyGet bh -- NB lazyGet
1134 return (HasInfo info)
1136 instance Binary IfaceInfoItem where
1137 put_ bh (HsArity aa) = do
1140 put_ bh (HsStrictness ab) = do
1143 put_ bh (HsUnfold ad) = do
1146 put_ bh (HsInline ad) = do
1149 put_ bh HsNoCafRefs = do
1151 put_ bh (HsWorker ae af) = do
1158 0 -> do aa <- get bh
1160 1 -> do ab <- get bh
1161 return (HsStrictness ab)
1162 2 -> do ad <- get bh
1163 return (HsUnfold ad)
1164 3 -> do ad <- get bh
1165 return (HsInline ad)
1166 4 -> do return HsNoCafRefs
1167 _ -> do ae <- get bh
1169 return (HsWorker ae af)
1171 instance Binary IfaceNote where
1172 put_ bh (IfaceSCC aa) = do
1175 put_ bh IfaceInlineMe = do
1177 put_ bh (IfaceCoreNote s) = do
1183 0 -> do aa <- get bh
1184 return (IfaceSCC aa)
1185 3 -> do return IfaceInlineMe
1186 4 -> do ac <- get bh
1187 return (IfaceCoreNote ac)
1188 _ -> panic ("get IfaceNote " ++ show h)
1190 -------------------------------------------------------------------------
1191 -- IfaceDecl and friends
1192 -------------------------------------------------------------------------
1194 -- A bit of magic going on here: there's no need to store the OccName
1195 -- for a decl on the disk, since we can infer the namespace from the
1196 -- context; however it is useful to have the OccName in the IfaceDecl
1197 -- to avoid re-building it in various places. So we build the OccName
1198 -- when de-serialising.
1200 instance Binary IfaceDecl where
1201 put_ bh (IfaceId name ty details idinfo) = do
1203 put_ bh (occNameFS name)
1207 put_ _ (IfaceForeign _ _) =
1208 error "Binary.put_(IfaceDecl): IfaceForeign"
1209 put_ bh (IfaceData a1 a2 a3 a4 a5 a6 a7 a8) = do
1211 put_ bh (occNameFS a1)
1219 put_ bh (IfaceSyn a1 a2 a3 a4 a5) = do
1221 put_ bh (occNameFS a1)
1226 put_ bh (IfaceClass a1 a2 a3 a4 a5 a6 a7) = do
1229 put_ bh (occNameFS a2)
1238 0 -> do name <- get bh
1242 occ <- return $! mkOccNameFS varName name
1243 return (IfaceId occ ty details idinfo)
1244 1 -> error "Binary.get(TyClDecl): ForeignType"
1254 occ <- return $! mkOccNameFS tcName a1
1255 return (IfaceData occ a2 a3 a4 a5 a6 a7 a8)
1262 occ <- return $! mkOccNameFS tcName a1
1263 return (IfaceSyn occ a2 a3 a4 a5)
1272 occ <- return $! mkOccNameFS clsName a2
1273 return (IfaceClass a1 occ a3 a4 a5 a6 a7)
1275 instance Binary IfaceInst where
1276 put_ bh (IfaceInst cls tys dfun flag orph) = do
1282 get bh = do cls <- get bh
1287 return (IfaceInst cls tys dfun flag orph)
1289 instance Binary IfaceFamInst where
1290 put_ bh (IfaceFamInst fam tys tycon) = do
1294 get bh = do fam <- get bh
1297 return (IfaceFamInst fam tys tycon)
1299 instance Binary OverlapFlag where
1300 put_ bh NoOverlap = putByte bh 0
1301 put_ bh OverlapOk = putByte bh 1
1302 put_ bh Incoherent = putByte bh 2
1303 get bh = do h <- getByte bh
1305 0 -> return NoOverlap
1306 1 -> return OverlapOk
1307 2 -> return Incoherent
1308 _ -> panic ("get OverlapFlag " ++ show h)
1310 instance Binary IfaceConDecls where
1311 put_ bh IfAbstractTyCon = putByte bh 0
1312 put_ bh IfOpenDataTyCon = putByte bh 1
1313 put_ bh (IfDataTyCon cs) = do { putByte bh 2
1315 put_ bh (IfNewTyCon c) = do { putByte bh 3
1320 0 -> return IfAbstractTyCon
1321 1 -> return IfOpenDataTyCon
1322 2 -> do cs <- get bh
1323 return (IfDataTyCon cs)
1324 _ -> do aa <- get bh
1325 return (IfNewTyCon aa)
1327 instance Binary IfaceConDecl where
1328 put_ bh (IfCon a1 a2 a3 a4 a5 a6 a7 a8 a9 a10) = do
1339 get bh = do a1 <- get bh
1349 return (IfCon a1 a2 a3 a4 a5 a6 a7 a8 a9 a10)
1351 instance Binary IfaceClassOp where
1352 put_ bh (IfaceClassOp n def ty) = do
1353 put_ bh (occNameFS n)
1360 occ <- return $! mkOccNameFS varName n
1361 return (IfaceClassOp occ def ty)
1363 instance Binary IfaceRule where
1364 put_ bh (IfaceRule a1 a2 a3 a4 a5 a6 a7) = do
1380 return (IfaceRule a1 a2 a3 a4 a5 a6 a7)
1382 instance Binary IfaceAnnotation where
1383 put_ bh (IfaceAnnotation a1 a2) = do
1389 return (IfaceAnnotation a1 a2)
1391 instance Binary name => Binary (AnnTarget name) where
1392 put_ bh (NamedTarget a) = do
1395 put_ bh (ModuleTarget a) = do
1402 return (NamedTarget a)
1404 return (ModuleTarget a)
1406 instance Binary IfaceVectInfo where
1407 put_ bh (IfaceVectInfo a1 a2 a3) = do
1415 return (IfaceVectInfo a1 a2 a3)