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"
50 data CheckHiWay = CheckHiWay | IgnoreHiWay
53 data TraceBinIFaceReading = TraceBinIFaceReading | QuietBinIFaceReading
56 -- ---------------------------------------------------------------------------
57 -- Reading and writing binary interface files
59 readBinIface :: CheckHiWay -> TraceBinIFaceReading -> FilePath
60 -> TcRnIf a b ModIface
61 readBinIface checkHiWay traceBinIFaceReading hi_path = do
63 (new_nc, iface) <- liftIO $
64 readBinIface_ checkHiWay traceBinIFaceReading hi_path nc
68 readBinIface_ :: CheckHiWay -> TraceBinIFaceReading -> FilePath -> NameCache
69 -> IO (NameCache, ModIface)
70 readBinIface_ checkHiWay traceBinIFaceReading hi_path nc = do
71 let printer :: SDoc -> IO ()
72 printer = case traceBinIFaceReading of
73 TraceBinIFaceReading -> \sd -> printSDoc sd defaultDumpStyle
74 QuietBinIFaceReading -> \_ -> return ()
75 wantedGot :: Outputable a => String -> a -> a -> IO ()
76 wantedGot what wanted got
77 = printer (text what <> text ": " <>
78 vcat [text "Wanted " <> ppr wanted <> text ",",
79 text "got " <> ppr got])
81 errorOnMismatch :: (Eq a, Show a) => String -> a -> a -> IO ()
82 errorOnMismatch what wanted got
83 -- This will be caught by readIface which will emit an error
84 -- msg containing the iface module name.
85 = when (wanted /= got) $ ghcError $ ProgramError
86 (what ++ " (wanted " ++ show wanted
87 ++ ", got " ++ show got ++ ")")
88 bh <- Binary.readBinMem hi_path
90 -- Read the magic number to check that this really is a GHC .hi file
91 -- (This magic number does not change when we change
92 -- GHC interface file format)
94 wantedGot "Magic" binaryInterfaceMagic magic
95 errorOnMismatch "magic number mismatch: old/corrupt interface file?"
96 binaryInterfaceMagic magic
98 -- Get the dictionary pointer. We won't attempt to actually
99 -- read the dictionary until we've done the version checks below,
100 -- just in case this isn't a valid interface. In retrospect the
101 -- version should have come before the dictionary pointer, but this
102 -- is the way it was done originally, and we can't change it now.
103 dict_p <- Binary.get bh -- Get the dictionary ptr
105 -- Check the interface file version and ways.
107 let our_ver = show opt_HiVersion
108 wantedGot "Version" our_ver check_ver
109 errorOnMismatch "mismatched interface file versions" our_ver check_ver
112 way_descr <- getWayDescr
113 wantedGot "Way" way_descr check_way
114 when (checkHiWay == CheckHiWay) $
115 errorOnMismatch "mismatched interface file ways" way_descr check_way
117 -- Read the dictionary
118 -- The next word in the file is a pointer to where the dictionary is
119 -- (probably at the end of the file)
120 data_p <- tellBin bh -- Remember where we are now
122 dict <- getDictionary bh
123 seekBin bh data_p -- Back to where we were before
125 -- Initialise the user-data field of bh
126 ud <- newReadState dict
127 bh <- return (setUserData bh ud)
129 symtab_p <- Binary.get bh -- Get the symtab ptr
130 data_p <- tellBin bh -- Remember where we are now
132 (nc', symtab) <- getSymbolTable bh nc
133 seekBin bh data_p -- Back to where we were before
134 let ud = getUserData bh
135 bh <- return $! setUserData bh ud{ud_symtab = symtab}
140 writeBinIface :: DynFlags -> FilePath -> ModIface -> IO ()
141 writeBinIface dflags hi_path mod_iface = do
142 bh <- openBinMem initBinMemSize
143 put_ bh binaryInterfaceMagic
145 -- Remember where the dictionary pointer will go
146 dict_p_p <- tellBin bh
147 put_ bh dict_p_p -- Placeholder for ptr to dictionary
149 -- The version and way descriptor go next
150 put_ bh (show opt_HiVersion)
151 way_descr <- getWayDescr
154 -- Remember where the symbol table pointer will go
155 symtab_p_p <- tellBin bh
158 -- Make some intial state
159 symtab_next <- newFastMutInt
160 writeFastMutInt symtab_next 0
161 symtab_map <- newIORef emptyUFM
162 let bin_symtab = BinSymbolTable {
163 bin_symtab_next = symtab_next,
164 bin_symtab_map = symtab_map }
165 dict_next_ref <- newFastMutInt
166 writeFastMutInt dict_next_ref 0
167 dict_map_ref <- newIORef emptyUFM
168 let bin_dict = BinDictionary {
169 bin_dict_next = dict_next_ref,
170 bin_dict_map = dict_map_ref }
171 ud <- newWriteState (putName bin_symtab) (putFastString bin_dict)
173 -- Put the main thing,
174 bh <- return $ setUserData bh ud
177 -- Write the symtab pointer at the fornt of the file
178 symtab_p <- tellBin bh -- This is where the symtab will start
179 putAt bh symtab_p_p symtab_p -- Fill in the placeholder
180 seekBin bh symtab_p -- Seek back to the end of the file
182 -- Write the symbol table itself
183 symtab_next <- readFastMutInt symtab_next
184 symtab_map <- readIORef symtab_map
185 putSymbolTable bh symtab_next symtab_map
186 debugTraceMsg dflags 3 (text "writeBinIface:" <+> int symtab_next
189 -- NB. write the dictionary after the symbol table, because
190 -- writing the symbol table may create more dictionary entries.
192 -- Write the dictionary pointer at the fornt of the file
193 dict_p <- tellBin bh -- This is where the dictionary will start
194 putAt bh dict_p_p dict_p -- Fill in the placeholder
195 seekBin bh dict_p -- Seek back to the end of the file
197 -- Write the dictionary itself
198 dict_next <- readFastMutInt dict_next_ref
199 dict_map <- readIORef dict_map_ref
200 putDictionary bh dict_next dict_map
201 debugTraceMsg dflags 3 (text "writeBinIface:" <+> int dict_next
202 <+> text "dict entries")
204 -- And send the result to the file
205 writeBinMem bh hi_path
207 initBinMemSize :: Int
208 initBinMemSize = 1024 * 1024
210 -- The *host* architecture version:
211 #include "MachDeps.h"
213 binaryInterfaceMagic :: Word32
214 #if WORD_SIZE_IN_BITS == 32
215 binaryInterfaceMagic = 0x1face
216 #elif WORD_SIZE_IN_BITS == 64
217 binaryInterfaceMagic = 0x1face64
220 -- -----------------------------------------------------------------------------
223 putSymbolTable :: BinHandle -> Int -> UniqFM (Int,Name) -> IO ()
224 putSymbolTable bh next_off symtab = do
226 let names = elems (array (0,next_off-1) (eltsUFM symtab))
227 mapM_ (\n -> serialiseName bh n symtab) names
229 getSymbolTable :: BinHandle -> NameCache -> IO (NameCache, Array Int Name)
230 getSymbolTable bh namecache = do
232 od_names <- sequence (replicate sz (get bh))
234 arr = listArray (0,sz-1) names
235 (namecache', names) =
236 mapAccumR (fromOnDiskName arr) namecache od_names
238 return (namecache', arr)
240 type OnDiskName = (PackageId, ModuleName, OccName)
247 fromOnDiskName _ nc (pid, mod_name, occ) =
249 mod = mkModule pid mod_name
252 case lookupOrigNameCache cache mod occ of
253 Just name -> (nc, name)
257 uniq = uniqFromSupply us
258 name = mkExternalName uniq mod occ noSrcSpan
259 new_cache = extendNameCache cache mod occ name
261 case splitUniqSupply us of { (us',_) ->
262 ( nc{ nsUniqs = us', nsNames = new_cache }, name )
265 serialiseName :: BinHandle -> Name -> UniqFM (Int,Name) -> IO ()
266 serialiseName bh name _ = do
267 let mod = ASSERT2( isExternalName name, ppr name ) nameModule name
268 put_ bh (modulePackageId mod, moduleName mod, nameOccName name)
271 putName :: BinSymbolTable -> BinHandle -> Name -> IO ()
272 putName BinSymbolTable{
273 bin_symtab_map = symtab_map_ref,
274 bin_symtab_next = symtab_next } bh name
276 symtab_map <- readIORef symtab_map_ref
277 case lookupUFM symtab_map name of
278 Just (off,_) -> put_ bh off
280 off <- readFastMutInt symtab_next
281 writeFastMutInt symtab_next (off+1)
282 writeIORef symtab_map_ref
283 $! addToUFM symtab_map name (off,name)
287 data BinSymbolTable = BinSymbolTable {
288 bin_symtab_next :: !FastMutInt, -- The next index to use
289 bin_symtab_map :: !(IORef (UniqFM (Int,Name)))
294 putFastString :: BinDictionary -> BinHandle -> FastString -> IO ()
295 putFastString BinDictionary { bin_dict_next = j_r,
296 bin_dict_map = out_r} bh f
298 out <- readIORef out_r
299 let uniq = getUnique f
300 case lookupUFM out uniq of
301 Just (j, _) -> put_ bh j
303 j <- readFastMutInt j_r
305 writeFastMutInt j_r (j + 1)
306 writeIORef out_r $! addToUFM out uniq (j, f)
309 data BinDictionary = BinDictionary {
310 bin_dict_next :: !FastMutInt, -- The next index to use
311 bin_dict_map :: !(IORef (UniqFM (Int,FastString)))
312 -- indexed by FastString
315 -- -----------------------------------------------------------------------------
316 -- All the binary instances
319 {-! for IPName derive: Binary !-}
320 {-! for Fixity derive: Binary !-}
321 {-! for FixityDirection derive: Binary !-}
322 {-! for Boxity derive: Binary !-}
323 {-! for StrictnessMark derive: Binary !-}
324 {-! for Activation derive: Binary !-}
327 {-! for Demand derive: Binary !-}
328 {-! for Demands derive: Binary !-}
329 {-! for DmdResult derive: Binary !-}
330 {-! for StrictSig derive: Binary !-}
333 {-! for DefMeth derive: Binary !-}
336 {-! for HsPred derive: Binary !-}
337 {-! for HsType derive: Binary !-}
338 {-! for TupCon derive: Binary !-}
339 {-! for HsTyVarBndr derive: Binary !-}
342 {-! for UfExpr derive: Binary !-}
343 {-! for UfConAlt derive: Binary !-}
344 {-! for UfBinding derive: Binary !-}
345 {-! for UfBinder derive: Binary !-}
346 {-! for HsIdInfo derive: Binary !-}
347 {-! for UfNote derive: Binary !-}
350 {-! for ConDetails derive: Binary !-}
351 {-! for BangType derive: Binary !-}
354 {-! for IsCafCC derive: Binary !-}
355 {-! for IsDupdCC derive: Binary !-}
356 {-! for CostCentre derive: Binary !-}
360 -- ---------------------------------------------------------------------------
361 -- Reading a binary interface into ParsedIface
363 instance Binary ModIface where
367 mi_iface_hash= iface_hash,
368 mi_mod_hash = mod_hash,
370 mi_finsts = hasFamInsts,
373 mi_exports = exports,
374 mi_exp_hash = exp_hash,
375 mi_fixities = fixities,
380 mi_fam_insts = fam_insts,
382 mi_orphan_hash = orphan_hash,
383 mi_vect_info = vect_info,
384 mi_hpc = hpc_info }) = do
412 hasFamInsts <- get bh
414 usages <- {-# SCC "bin_usages" #-} lazyGet bh
415 exports <- {-# SCC "bin_exports" #-} get bh
417 fixities <- {-# SCC "bin_fixities" #-} get bh
418 warns <- {-# SCC "bin_warns" #-} lazyGet bh
419 anns <- {-# SCC "bin_anns" #-} lazyGet bh
420 decls <- {-# SCC "bin_tycldecls" #-} get bh
421 insts <- {-# SCC "bin_insts" #-} get bh
422 fam_insts <- {-# SCC "bin_fam_insts" #-} get bh
423 rules <- {-# SCC "bin_rules" #-} lazyGet bh
424 orphan_hash <- get bh
428 mi_module = mod_name,
430 mi_iface_hash = iface_hash,
431 mi_mod_hash = mod_hash,
433 mi_finsts = hasFamInsts,
436 mi_exports = exports,
437 mi_exp_hash = exp_hash,
439 mi_fixities = fixities,
442 mi_globals = Nothing,
444 mi_fam_insts = fam_insts,
446 mi_orphan_hash = orphan_hash,
447 mi_vect_info = vect_info,
449 -- And build the cached values
450 mi_warn_fn = mkIfaceWarnCache warns,
451 mi_fix_fn = mkIfaceFixCache fixities,
452 mi_hash_fn = mkIfaceHashCache decls })
454 getWayDescr :: IO String
456 tag <- readIORef v_Build_tag
457 if cGhcUnregisterised == "YES" then return ('u':tag) else return tag
458 -- if this is an unregisterised build, make sure our interfaces
459 -- can't be used by a registerised build.
461 -------------------------------------------------------------------------
462 -- Types from: HscTypes
463 -------------------------------------------------------------------------
465 instance Binary Dependencies where
466 put_ bh deps = do put_ bh (dep_mods deps)
467 put_ bh (dep_pkgs deps)
468 put_ bh (dep_orphs deps)
469 put_ bh (dep_finsts deps)
471 get bh = do ms <- get bh
475 return (Deps { dep_mods = ms, dep_pkgs = ps, dep_orphs = os,
478 instance (Binary name) => Binary (GenAvailInfo name) where
479 put_ bh (Avail aa) = do
482 put_ bh (AvailTC ab ac) = do
493 return (AvailTC ab ac)
495 instance Binary Usage where
496 put_ bh usg@UsagePackageModule{} = do
498 put_ bh (usg_mod usg)
499 put_ bh (usg_mod_hash usg)
500 put_ bh usg@UsageHomeModule{} = do
502 put_ bh (usg_mod_name usg)
503 put_ bh (usg_mod_hash usg)
504 put_ bh (usg_exports usg)
505 put_ bh (usg_entities usg)
513 return UsagePackageModule { usg_mod = nm, usg_mod_hash = mod }
519 return UsageHomeModule { usg_mod_name = nm, usg_mod_hash = mod,
520 usg_exports = exps, usg_entities = ents }
522 instance Binary Warnings where
523 put_ bh NoWarnings = putByte bh 0
524 put_ bh (WarnAll t) = do
527 put_ bh (WarnSome ts) = do
534 0 -> return NoWarnings
540 instance Binary WarningTxt where
541 put_ bh (WarningTxt w) = do
544 put_ bh (DeprecatedTxt d) = do
552 return (WarningTxt w)
554 return (DeprecatedTxt d)
556 -------------------------------------------------------------------------
557 -- Types from: BasicTypes
558 -------------------------------------------------------------------------
560 instance Binary Activation where
561 put_ bh NeverActive = do
563 put_ bh AlwaysActive = do
565 put_ bh (ActiveBefore aa) = do
568 put_ bh (ActiveAfter ab) = do
574 0 -> do return NeverActive
575 1 -> do return AlwaysActive
577 return (ActiveBefore aa)
579 return (ActiveAfter ab)
581 instance Binary StrictnessMark where
582 put_ bh MarkedStrict = do
584 put_ bh MarkedUnboxed = do
586 put_ bh NotMarkedStrict = do
591 0 -> do return MarkedStrict
592 1 -> do return MarkedUnboxed
593 _ -> do return NotMarkedStrict
595 instance Binary Boxity where
604 _ -> do return Unboxed
606 instance Binary TupCon where
607 put_ bh (TupCon ab ac) = do
613 return (TupCon ab ac)
615 instance Binary RecFlag where
616 put_ bh Recursive = do
618 put_ bh NonRecursive = do
623 0 -> do return Recursive
624 _ -> do return NonRecursive
626 instance Binary DefMeth where
627 put_ bh NoDefMeth = putByte bh 0
628 put_ bh DefMeth = putByte bh 1
629 put_ bh GenDefMeth = putByte bh 2
633 0 -> return NoDefMeth
635 _ -> return GenDefMeth
637 instance Binary FixityDirection where
647 0 -> do return InfixL
648 1 -> do return InfixR
649 _ -> do return InfixN
651 instance Binary Fixity where
652 put_ bh (Fixity aa ab) = do
658 return (Fixity aa ab)
660 instance (Binary name) => Binary (IPName name) where
661 put_ bh (IPName aa) = put_ bh aa
662 get bh = do aa <- get bh
665 -------------------------------------------------------------------------
666 -- Types from: Demand
667 -------------------------------------------------------------------------
669 instance Binary DmdType where
670 -- Ignore DmdEnv when spitting out the DmdType
671 put bh (DmdType _ ds dr) = do p <- put bh ds; put bh dr; return (castBin p)
672 get bh = do ds <- get bh; dr <- get bh; return (DmdType emptyVarEnv ds dr)
674 instance Binary Demand where
679 put_ bh (Call aa) = do
682 put_ bh (Eval ab) = do
685 put_ bh (Defer ac) = do
688 put_ bh (Box ad) = do
708 instance Binary Demands where
709 put_ bh (Poly aa) = do
712 put_ bh (Prod ab) = do
723 instance Binary DmdResult where
733 0 -> do return TopRes
734 1 -> do return RetCPR -- Really use RetCPR even if -fcpr-off
735 -- The wrapper was generated for CPR in
736 -- the imported module!
737 _ -> do return BotRes
739 instance Binary StrictSig where
740 put_ bh (StrictSig aa) = do
744 return (StrictSig aa)
747 -------------------------------------------------------------------------
748 -- Types from: CostCentre
749 -------------------------------------------------------------------------
751 instance Binary IsCafCC where
754 put_ bh NotCafCC = do
760 _ -> do return NotCafCC
762 instance Binary IsDupdCC where
763 put_ bh OriginalCC = do
770 0 -> do return OriginalCC
771 _ -> do return DupdCC
773 instance Binary CostCentre where
774 put_ bh NoCostCentre = do
776 put_ bh (NormalCC aa ab ac ad) = do
782 put_ bh (AllCafsCC ae) = do
788 0 -> do return NoCostCentre
793 return (NormalCC aa ab ac ad)
795 return (AllCafsCC ae)
797 -------------------------------------------------------------------------
798 -- IfaceTypes and friends
799 -------------------------------------------------------------------------
801 instance Binary IfaceBndr where
802 put_ bh (IfaceIdBndr aa) = do
805 put_ bh (IfaceTvBndr ab) = do
812 return (IfaceIdBndr aa)
814 return (IfaceTvBndr ab)
816 instance Binary IfaceLetBndr where
817 put_ bh (IfLetBndr a b c) = do
821 get bh = do a <- get bh
824 return (IfLetBndr a b c)
826 instance Binary IfaceType where
827 put_ bh (IfaceForAllTy aa ab) = do
831 put_ bh (IfaceTyVar ad) = do
834 put_ bh (IfaceAppTy ae af) = do
838 put_ bh (IfaceFunTy ag ah) = do
842 put_ bh (IfacePredTy aq) = do
846 -- Simple compression for common cases of TyConApp
847 put_ bh (IfaceTyConApp IfaceIntTc []) = putByte bh 6
848 put_ bh (IfaceTyConApp IfaceCharTc []) = putByte bh 7
849 put_ bh (IfaceTyConApp IfaceBoolTc []) = putByte bh 8
850 put_ bh (IfaceTyConApp IfaceListTc [ty]) = do { putByte bh 9; put_ bh ty }
851 -- Unit tuple and pairs
852 put_ bh (IfaceTyConApp (IfaceTupTc Boxed 0) []) = putByte bh 10
853 put_ bh (IfaceTyConApp (IfaceTupTc Boxed 2) [t1,t2]) = do { putByte bh 11; put_ bh t1; put_ bh t2 }
855 put_ bh (IfaceTyConApp IfaceLiftedTypeKindTc []) = putByte bh 12
856 put_ bh (IfaceTyConApp IfaceOpenTypeKindTc []) = putByte bh 13
857 put_ bh (IfaceTyConApp IfaceUnliftedTypeKindTc []) = putByte bh 14
858 put_ bh (IfaceTyConApp IfaceUbxTupleKindTc []) = putByte bh 15
859 put_ bh (IfaceTyConApp IfaceArgTypeKindTc []) = putByte bh 16
863 put_ bh (IfaceTyConApp (IfaceTc tc) tys) = do { putByte bh 18; put_ bh tc; put_ bh tys }
864 put_ bh (IfaceTyConApp tc tys) = do { putByte bh 19; put_ bh tc; put_ bh tys }
871 return (IfaceForAllTy aa ab)
873 return (IfaceTyVar ad)
876 return (IfaceAppTy ae af)
879 return (IfaceFunTy ag ah)
881 return (IfacePredTy ap)
883 -- Now the special cases for TyConApp
884 6 -> return (IfaceTyConApp IfaceIntTc [])
885 7 -> return (IfaceTyConApp IfaceCharTc [])
886 8 -> return (IfaceTyConApp IfaceBoolTc [])
887 9 -> do { ty <- get bh; return (IfaceTyConApp IfaceListTc [ty]) }
888 10 -> return (IfaceTyConApp (IfaceTupTc Boxed 0) [])
889 11 -> do { t1 <- get bh; t2 <- get bh; return (IfaceTyConApp (IfaceTupTc Boxed 2) [t1,t2]) }
890 12 -> return (IfaceTyConApp IfaceLiftedTypeKindTc [])
891 13 -> return (IfaceTyConApp IfaceOpenTypeKindTc [])
892 14 -> return (IfaceTyConApp IfaceUnliftedTypeKindTc [])
893 15 -> return (IfaceTyConApp IfaceUbxTupleKindTc [])
894 16 -> return (IfaceTyConApp IfaceArgTypeKindTc [])
896 18 -> do { tc <- get bh; tys <- get bh; return (IfaceTyConApp (IfaceTc tc) tys) }
897 _ -> do { tc <- get bh; tys <- get bh; return (IfaceTyConApp tc tys) }
899 instance Binary IfaceTyCon where
900 -- Int,Char,Bool can't show up here because they can't not be saturated
902 put_ bh IfaceIntTc = putByte bh 1
903 put_ bh IfaceBoolTc = putByte bh 2
904 put_ bh IfaceCharTc = putByte bh 3
905 put_ bh IfaceListTc = putByte bh 4
906 put_ bh IfacePArrTc = putByte bh 5
907 put_ bh IfaceLiftedTypeKindTc = putByte bh 6
908 put_ bh IfaceOpenTypeKindTc = putByte bh 7
909 put_ bh IfaceUnliftedTypeKindTc = putByte bh 8
910 put_ bh IfaceUbxTupleKindTc = putByte bh 9
911 put_ bh IfaceArgTypeKindTc = putByte bh 10
912 put_ bh (IfaceTupTc bx ar) = do { putByte bh 11; put_ bh bx; put_ bh ar }
913 put_ bh (IfaceTc ext) = do { putByte bh 12; put_ bh ext }
918 1 -> return IfaceIntTc
919 2 -> return IfaceBoolTc
920 3 -> return IfaceCharTc
921 4 -> return IfaceListTc
922 5 -> return IfacePArrTc
923 6 -> return IfaceLiftedTypeKindTc
924 7 -> return IfaceOpenTypeKindTc
925 8 -> return IfaceUnliftedTypeKindTc
926 9 -> return IfaceUbxTupleKindTc
927 10 -> return IfaceArgTypeKindTc
928 11 -> do { bx <- get bh; ar <- get bh; return (IfaceTupTc bx ar) }
929 _ -> do { ext <- get bh; return (IfaceTc ext) }
931 instance Binary IfacePredType where
932 put_ bh (IfaceClassP aa ab) = do
936 put_ bh (IfaceIParam ac ad) = do
940 put_ bh (IfaceEqPred ac ad) = do
949 return (IfaceClassP aa ab)
952 return (IfaceIParam ac ad)
955 return (IfaceEqPred ac ad)
956 _ -> panic ("get IfacePredType " ++ show h)
958 -------------------------------------------------------------------------
959 -- IfaceExpr and friends
960 -------------------------------------------------------------------------
962 instance Binary IfaceExpr where
963 put_ bh (IfaceLcl aa) = do
966 put_ bh (IfaceType ab) = do
969 put_ bh (IfaceTuple ac ad) = do
973 put_ bh (IfaceLam ae af) = do
977 put_ bh (IfaceApp ag ah) = do
982 put_ bh (IfaceCase ai aj al ak) = do
989 put_ bh (IfaceLet al am) = do
993 put_ bh (IfaceNote an ao) = do
997 put_ bh (IfaceLit ap) = do
1000 put_ bh (IfaceFCall as at) = do
1004 put_ bh (IfaceExt aa) = do
1007 put_ bh (IfaceCast ie ico) = do
1011 put_ bh (IfaceTick m ix) = do
1018 0 -> do aa <- get bh
1019 return (IfaceLcl aa)
1020 1 -> do ab <- get bh
1021 return (IfaceType ab)
1022 2 -> do ac <- get bh
1024 return (IfaceTuple ac ad)
1025 3 -> do ae <- get bh
1027 return (IfaceLam ae af)
1028 4 -> do ag <- get bh
1030 return (IfaceApp ag ah)
1031 5 -> do ai <- get bh
1037 return (IfaceCase ai aj al ak)
1038 6 -> do al <- get bh
1040 return (IfaceLet al am)
1041 7 -> do an <- get bh
1043 return (IfaceNote an ao)
1044 8 -> do ap <- get bh
1045 return (IfaceLit ap)
1046 9 -> do as <- get bh
1048 return (IfaceFCall as at)
1049 10 -> do aa <- get bh
1050 return (IfaceExt aa)
1051 11 -> do ie <- get bh
1053 return (IfaceCast ie ico)
1054 12 -> do m <- get bh
1056 return (IfaceTick m ix)
1057 _ -> panic ("get IfaceExpr " ++ show h)
1059 instance Binary IfaceConAlt where
1060 put_ bh IfaceDefault = do
1062 put_ bh (IfaceDataAlt aa) = do
1065 put_ bh (IfaceTupleAlt ab) = do
1068 put_ bh (IfaceLitAlt ac) = do
1074 0 -> do return IfaceDefault
1075 1 -> do aa <- get bh
1076 return (IfaceDataAlt aa)
1077 2 -> do ab <- get bh
1078 return (IfaceTupleAlt ab)
1079 _ -> do ac <- get bh
1080 return (IfaceLitAlt ac)
1082 instance Binary IfaceBinding where
1083 put_ bh (IfaceNonRec aa ab) = do
1087 put_ bh (IfaceRec ac) = do
1093 0 -> do aa <- get bh
1095 return (IfaceNonRec aa ab)
1096 _ -> do ac <- get bh
1097 return (IfaceRec ac)
1099 instance Binary IfaceIdInfo where
1100 put_ bh NoInfo = putByte bh 0
1101 put_ bh (HasInfo i) = do
1103 lazyPut bh i -- NB lazyPut
1109 _ -> do info <- lazyGet bh -- NB lazyGet
1110 return (HasInfo info)
1112 instance Binary IfaceInfoItem where
1113 put_ bh (HsArity aa) = do
1116 put_ bh (HsStrictness ab) = do
1119 put_ bh (HsUnfold ad) = do
1122 put_ bh (HsInline ad) = do
1125 put_ bh HsNoCafRefs = do
1127 put_ bh (HsWorker ae af) = do
1134 0 -> do aa <- get bh
1136 1 -> do ab <- get bh
1137 return (HsStrictness ab)
1138 2 -> do ad <- get bh
1139 return (HsUnfold ad)
1140 3 -> do ad <- get bh
1141 return (HsInline ad)
1142 4 -> do return HsNoCafRefs
1143 _ -> do ae <- get bh
1145 return (HsWorker ae af)
1147 instance Binary IfaceNote where
1148 put_ bh (IfaceSCC aa) = do
1151 put_ bh IfaceInlineMe = do
1153 put_ bh (IfaceCoreNote s) = do
1159 0 -> do aa <- get bh
1160 return (IfaceSCC aa)
1161 3 -> do return IfaceInlineMe
1162 4 -> do ac <- get bh
1163 return (IfaceCoreNote ac)
1164 _ -> panic ("get IfaceNote " ++ show h)
1166 -------------------------------------------------------------------------
1167 -- IfaceDecl and friends
1168 -------------------------------------------------------------------------
1170 -- A bit of magic going on here: there's no need to store the OccName
1171 -- for a decl on the disk, since we can infer the namespace from the
1172 -- context; however it is useful to have the OccName in the IfaceDecl
1173 -- to avoid re-building it in various places. So we build the OccName
1174 -- when de-serialising.
1176 instance Binary IfaceDecl where
1177 put_ bh (IfaceId name ty idinfo) = do
1179 put_ bh (occNameFS name)
1182 put_ _ (IfaceForeign _ _) =
1183 error "Binary.put_(IfaceDecl): IfaceForeign"
1184 put_ bh (IfaceData a1 a2 a3 a4 a5 a6 a7 a8) = do
1186 put_ bh (occNameFS a1)
1194 put_ bh (IfaceSyn a1 a2 a3 a4 a5) = do
1196 put_ bh (occNameFS a1)
1201 put_ bh (IfaceClass a1 a2 a3 a4 a5 a6 a7) = do
1204 put_ bh (occNameFS a2)
1213 0 -> do name <- get bh
1216 occ <- return $! mkOccNameFS varName name
1217 return (IfaceId occ ty idinfo)
1218 1 -> error "Binary.get(TyClDecl): ForeignType"
1228 occ <- return $! mkOccNameFS tcName a1
1229 return (IfaceData occ a2 a3 a4 a5 a6 a7 a8)
1236 occ <- return $! mkOccNameFS tcName a1
1237 return (IfaceSyn occ a2 a3 a4 a5)
1246 occ <- return $! mkOccNameFS clsName a2
1247 return (IfaceClass a1 occ a3 a4 a5 a6 a7)
1249 instance Binary IfaceInst where
1250 put_ bh (IfaceInst cls tys dfun flag orph) = do
1256 get bh = do cls <- get bh
1261 return (IfaceInst cls tys dfun flag orph)
1263 instance Binary IfaceFamInst where
1264 put_ bh (IfaceFamInst fam tys tycon) = do
1268 get bh = do fam <- get bh
1271 return (IfaceFamInst fam tys tycon)
1273 instance Binary OverlapFlag where
1274 put_ bh NoOverlap = putByte bh 0
1275 put_ bh OverlapOk = putByte bh 1
1276 put_ bh Incoherent = putByte bh 2
1277 get bh = do h <- getByte bh
1279 0 -> return NoOverlap
1280 1 -> return OverlapOk
1281 2 -> return Incoherent
1282 _ -> panic ("get OverlapFlag " ++ show h)
1284 instance Binary IfaceConDecls where
1285 put_ bh IfAbstractTyCon = putByte bh 0
1286 put_ bh IfOpenDataTyCon = putByte bh 1
1287 put_ bh (IfDataTyCon cs) = do { putByte bh 2
1289 put_ bh (IfNewTyCon c) = do { putByte bh 3
1294 0 -> return IfAbstractTyCon
1295 1 -> return IfOpenDataTyCon
1296 2 -> do cs <- get bh
1297 return (IfDataTyCon cs)
1298 _ -> do aa <- get bh
1299 return (IfNewTyCon aa)
1301 instance Binary IfaceConDecl where
1302 put_ bh (IfCon a1 a2 a3 a4 a5 a6 a7 a8 a9) = do
1312 get bh = do a1 <- get bh
1321 return (IfCon a1 a2 a3 a4 a5 a6 a7 a8 a9)
1323 instance Binary IfaceClassOp where
1324 put_ bh (IfaceClassOp n def ty) = do
1325 put_ bh (occNameFS n)
1332 occ <- return $! mkOccNameFS varName n
1333 return (IfaceClassOp occ def ty)
1335 instance Binary IfaceRule where
1336 put_ bh (IfaceRule a1 a2 a3 a4 a5 a6 a7) = do
1352 return (IfaceRule a1 a2 a3 a4 a5 a6 a7)
1354 instance Binary IfaceAnnotation where
1355 put_ bh (IfaceAnnotation a1 a2) = do
1361 return (IfaceAnnotation a1 a2)
1363 instance Binary name => Binary (AnnTarget name) where
1364 put_ bh (NamedTarget a) = do
1367 put_ bh (ModuleTarget a) = do
1374 return (NamedTarget a)
1376 return (ModuleTarget a)
1378 instance Binary IfaceVectInfo where
1379 put_ bh (IfaceVectInfo a1 a2 a3) = do
1387 return (IfaceVectInfo a1 a2 a3)