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 update_nc <- mkNameCacheUpdater
61 liftIO $ readBinIface_ checkHiWay traceBinIFaceReading hi_path update_nc
63 readBinIface_ :: CheckHiWay -> TraceBinIFaceReading -> FilePath
64 -> NameCacheUpdater (Array Int Name)
66 readBinIface_ checkHiWay traceBinIFaceReading hi_path update_nc = do
67 let printer :: SDoc -> IO ()
68 printer = case traceBinIFaceReading of
69 TraceBinIFaceReading -> \sd -> printSDoc sd defaultDumpStyle
70 QuietBinIFaceReading -> \_ -> return ()
71 wantedGot :: Outputable a => String -> a -> a -> IO ()
72 wantedGot what wanted got
73 = printer (text what <> text ": " <>
74 vcat [text "Wanted " <> ppr wanted <> text ",",
75 text "got " <> ppr got])
77 errorOnMismatch :: (Eq a, Show a) => String -> a -> a -> IO ()
78 errorOnMismatch what wanted got
79 -- This will be caught by readIface which will emit an error
80 -- msg containing the iface module name.
81 = when (wanted /= got) $ ghcError $ ProgramError
82 (what ++ " (wanted " ++ show wanted
83 ++ ", got " ++ show got ++ ")")
84 bh <- Binary.readBinMem hi_path
86 -- Read the magic number to check that this really is a GHC .hi file
87 -- (This magic number does not change when we change
88 -- GHC interface file format)
90 wantedGot "Magic" binaryInterfaceMagic magic
91 errorOnMismatch "magic number mismatch: old/corrupt interface file?"
92 binaryInterfaceMagic magic
94 -- Get the dictionary pointer. We won't attempt to actually
95 -- read the dictionary until we've done the version checks below,
96 -- just in case this isn't a valid interface. In retrospect the
97 -- version should have come before the dictionary pointer, but this
98 -- is the way it was done originally, and we can't change it now.
99 dict_p <- Binary.get bh -- Get the dictionary ptr
101 -- Check the interface file version and ways.
103 let our_ver = show opt_HiVersion
104 wantedGot "Version" our_ver check_ver
105 errorOnMismatch "mismatched interface file versions" our_ver check_ver
108 way_descr <- getWayDescr
109 wantedGot "Way" way_descr check_way
110 when (checkHiWay == CheckHiWay) $
111 errorOnMismatch "mismatched interface file ways" way_descr check_way
113 -- Read the dictionary
114 -- The next word in the file is a pointer to where the dictionary is
115 -- (probably at the end of the file)
116 data_p <- tellBin bh -- Remember where we are now
118 dict <- getDictionary bh
119 seekBin bh data_p -- Back to where we were before
121 -- Initialise the user-data field of bh
122 ud <- newReadState dict
123 bh <- return (setUserData bh ud)
125 symtab_p <- Binary.get bh -- Get the symtab ptr
126 data_p <- tellBin bh -- Remember where we are now
128 symtab <- getSymbolTable bh update_nc
129 seekBin bh data_p -- Back to where we were before
130 let ud = getUserData bh
131 bh <- return $! setUserData bh ud{ud_symtab = symtab}
136 writeBinIface :: DynFlags -> FilePath -> ModIface -> IO ()
137 writeBinIface dflags hi_path mod_iface = do
138 bh <- openBinMem initBinMemSize
139 put_ bh binaryInterfaceMagic
141 -- Remember where the dictionary pointer will go
142 dict_p_p <- tellBin bh
143 put_ bh dict_p_p -- Placeholder for ptr to dictionary
145 -- The version and way descriptor go next
146 put_ bh (show opt_HiVersion)
147 way_descr <- getWayDescr
150 -- Remember where the symbol table pointer will go
151 symtab_p_p <- tellBin bh
154 -- Make some intial state
155 symtab_next <- newFastMutInt
156 writeFastMutInt symtab_next 0
157 symtab_map <- newIORef emptyUFM
158 let bin_symtab = BinSymbolTable {
159 bin_symtab_next = symtab_next,
160 bin_symtab_map = symtab_map }
161 dict_next_ref <- newFastMutInt
162 writeFastMutInt dict_next_ref 0
163 dict_map_ref <- newIORef emptyUFM
164 let bin_dict = BinDictionary {
165 bin_dict_next = dict_next_ref,
166 bin_dict_map = dict_map_ref }
167 ud <- newWriteState (putName bin_symtab) (putFastString bin_dict)
169 -- Put the main thing,
170 bh <- return $ setUserData bh ud
173 -- Write the symtab pointer at the fornt of the file
174 symtab_p <- tellBin bh -- This is where the symtab will start
175 putAt bh symtab_p_p symtab_p -- Fill in the placeholder
176 seekBin bh symtab_p -- Seek back to the end of the file
178 -- Write the symbol table itself
179 symtab_next <- readFastMutInt symtab_next
180 symtab_map <- readIORef symtab_map
181 putSymbolTable bh symtab_next symtab_map
182 debugTraceMsg dflags 3 (text "writeBinIface:" <+> int symtab_next
185 -- NB. write the dictionary after the symbol table, because
186 -- writing the symbol table may create more dictionary entries.
188 -- Write the dictionary pointer at the fornt of the file
189 dict_p <- tellBin bh -- This is where the dictionary will start
190 putAt bh dict_p_p dict_p -- Fill in the placeholder
191 seekBin bh dict_p -- Seek back to the end of the file
193 -- Write the dictionary itself
194 dict_next <- readFastMutInt dict_next_ref
195 dict_map <- readIORef dict_map_ref
196 putDictionary bh dict_next dict_map
197 debugTraceMsg dflags 3 (text "writeBinIface:" <+> int dict_next
198 <+> text "dict entries")
200 -- And send the result to the file
201 writeBinMem bh hi_path
203 initBinMemSize :: Int
204 initBinMemSize = 1024 * 1024
206 -- The *host* architecture version:
207 #include "../includes/MachDeps.h"
209 binaryInterfaceMagic :: Word32
210 #if WORD_SIZE_IN_BITS == 32
211 binaryInterfaceMagic = 0x1face
212 #elif WORD_SIZE_IN_BITS == 64
213 binaryInterfaceMagic = 0x1face64
216 -- -----------------------------------------------------------------------------
219 putSymbolTable :: BinHandle -> Int -> UniqFM (Int,Name) -> IO ()
220 putSymbolTable bh next_off symtab = do
222 let names = elems (array (0,next_off-1) (eltsUFM symtab))
223 mapM_ (\n -> serialiseName bh n symtab) names
225 getSymbolTable :: BinHandle -> NameCacheUpdater (Array Int Name)
226 -> IO (Array Int Name)
227 getSymbolTable bh update_namecache = do
229 od_names <- sequence (replicate sz (get bh))
230 update_namecache $ \namecache ->
232 arr = listArray (0,sz-1) names
233 (namecache', names) =
234 mapAccumR (fromOnDiskName arr) namecache od_names
237 type OnDiskName = (PackageId, ModuleName, OccName)
244 fromOnDiskName _ nc (pid, mod_name, occ) =
246 mod = mkModule pid mod_name
249 case lookupOrigNameCache cache mod occ of
250 Just name -> (nc, name)
254 uniq = uniqFromSupply us
255 name = mkExternalName uniq mod occ noSrcSpan
256 new_cache = extendNameCache cache mod occ name
258 case splitUniqSupply us of { (us',_) ->
259 ( nc{ nsUniqs = us', nsNames = new_cache }, name )
262 serialiseName :: BinHandle -> Name -> UniqFM (Int,Name) -> IO ()
263 serialiseName bh name _ = do
264 let mod = ASSERT2( isExternalName name, ppr name ) nameModule name
265 put_ bh (modulePackageId mod, moduleName mod, nameOccName name)
268 putName :: BinSymbolTable -> BinHandle -> Name -> IO ()
269 putName BinSymbolTable{
270 bin_symtab_map = symtab_map_ref,
271 bin_symtab_next = symtab_next } bh name
273 symtab_map <- readIORef symtab_map_ref
274 case lookupUFM symtab_map name of
275 Just (off,_) -> put_ bh off
277 off <- readFastMutInt symtab_next
278 writeFastMutInt symtab_next (off+1)
279 writeIORef symtab_map_ref
280 $! addToUFM symtab_map name (off,name)
284 data BinSymbolTable = BinSymbolTable {
285 bin_symtab_next :: !FastMutInt, -- The next index to use
286 bin_symtab_map :: !(IORef (UniqFM (Int,Name)))
291 putFastString :: BinDictionary -> BinHandle -> FastString -> IO ()
292 putFastString BinDictionary { bin_dict_next = j_r,
293 bin_dict_map = out_r} bh f
295 out <- readIORef out_r
296 let uniq = getUnique f
297 case lookupUFM out uniq of
298 Just (j, _) -> put_ bh j
300 j <- readFastMutInt j_r
302 writeFastMutInt j_r (j + 1)
303 writeIORef out_r $! addToUFM out uniq (j, f)
306 data BinDictionary = BinDictionary {
307 bin_dict_next :: !FastMutInt, -- The next index to use
308 bin_dict_map :: !(IORef (UniqFM (Int,FastString)))
309 -- indexed by FastString
312 -- -----------------------------------------------------------------------------
313 -- All the binary instances
316 {-! for IPName derive: Binary !-}
317 {-! for Fixity derive: Binary !-}
318 {-! for FixityDirection derive: Binary !-}
319 {-! for Boxity derive: Binary !-}
320 {-! for StrictnessMark derive: Binary !-}
321 {-! for Activation derive: Binary !-}
324 {-! for Demand derive: Binary !-}
325 {-! for Demands derive: Binary !-}
326 {-! for DmdResult derive: Binary !-}
327 {-! for StrictSig derive: Binary !-}
330 {-! for DefMeth derive: Binary !-}
333 {-! for HsPred derive: Binary !-}
334 {-! for HsType derive: Binary !-}
335 {-! for TupCon derive: Binary !-}
336 {-! for HsTyVarBndr derive: Binary !-}
339 {-! for UfExpr derive: Binary !-}
340 {-! for UfConAlt derive: Binary !-}
341 {-! for UfBinding derive: Binary !-}
342 {-! for UfBinder derive: Binary !-}
343 {-! for HsIdInfo derive: Binary !-}
344 {-! for UfNote derive: Binary !-}
347 {-! for ConDetails derive: Binary !-}
348 {-! for BangType derive: Binary !-}
351 {-! for IsCafCC derive: Binary !-}
352 {-! for IsDupdCC derive: Binary !-}
353 {-! for CostCentre derive: Binary !-}
357 -- ---------------------------------------------------------------------------
358 -- Reading a binary interface into ParsedIface
360 instance Binary ModIface where
364 mi_iface_hash= iface_hash,
365 mi_mod_hash = mod_hash,
367 mi_finsts = hasFamInsts,
370 mi_exports = exports,
371 mi_exp_hash = exp_hash,
372 mi_fixities = fixities,
377 mi_fam_insts = fam_insts,
379 mi_orphan_hash = orphan_hash,
380 mi_vect_info = vect_info,
381 mi_hpc = hpc_info }) = do
409 hasFamInsts <- get bh
411 usages <- {-# SCC "bin_usages" #-} lazyGet bh
412 exports <- {-# SCC "bin_exports" #-} get bh
414 fixities <- {-# SCC "bin_fixities" #-} get bh
415 warns <- {-# SCC "bin_warns" #-} lazyGet bh
416 anns <- {-# SCC "bin_anns" #-} lazyGet bh
417 decls <- {-# SCC "bin_tycldecls" #-} get bh
418 insts <- {-# SCC "bin_insts" #-} get bh
419 fam_insts <- {-# SCC "bin_fam_insts" #-} get bh
420 rules <- {-# SCC "bin_rules" #-} lazyGet bh
421 orphan_hash <- get bh
425 mi_module = mod_name,
427 mi_iface_hash = iface_hash,
428 mi_mod_hash = mod_hash,
430 mi_finsts = hasFamInsts,
433 mi_exports = exports,
434 mi_exp_hash = exp_hash,
436 mi_fixities = fixities,
439 mi_globals = Nothing,
441 mi_fam_insts = fam_insts,
443 mi_orphan_hash = orphan_hash,
444 mi_vect_info = vect_info,
446 -- And build the cached values
447 mi_warn_fn = mkIfaceWarnCache warns,
448 mi_fix_fn = mkIfaceFixCache fixities,
449 mi_hash_fn = mkIfaceHashCache decls })
451 getWayDescr :: IO String
453 tag <- readIORef v_Build_tag
454 if cGhcUnregisterised == "YES" then return ('u':tag) else return tag
455 -- if this is an unregisterised build, make sure our interfaces
456 -- can't be used by a registerised build.
458 -------------------------------------------------------------------------
459 -- Types from: HscTypes
460 -------------------------------------------------------------------------
462 instance Binary Dependencies where
463 put_ bh deps = do put_ bh (dep_mods deps)
464 put_ bh (dep_pkgs deps)
465 put_ bh (dep_orphs deps)
466 put_ bh (dep_finsts deps)
468 get bh = do ms <- get bh
472 return (Deps { dep_mods = ms, dep_pkgs = ps, dep_orphs = os,
475 instance (Binary name) => Binary (GenAvailInfo name) where
476 put_ bh (Avail aa) = do
479 put_ bh (AvailTC ab ac) = do
490 return (AvailTC ab ac)
492 instance Binary Usage where
493 put_ bh usg@UsagePackageModule{} = do
495 put_ bh (usg_mod usg)
496 put_ bh (usg_mod_hash usg)
497 put_ bh usg@UsageHomeModule{} = do
499 put_ bh (usg_mod_name usg)
500 put_ bh (usg_mod_hash usg)
501 put_ bh (usg_exports usg)
502 put_ bh (usg_entities usg)
510 return UsagePackageModule { usg_mod = nm, usg_mod_hash = mod }
516 return UsageHomeModule { usg_mod_name = nm, usg_mod_hash = mod,
517 usg_exports = exps, usg_entities = ents }
519 instance Binary Warnings where
520 put_ bh NoWarnings = putByte bh 0
521 put_ bh (WarnAll t) = do
524 put_ bh (WarnSome ts) = do
531 0 -> return NoWarnings
537 instance Binary WarningTxt where
538 put_ bh (WarningTxt w) = do
541 put_ bh (DeprecatedTxt d) = do
549 return (WarningTxt w)
551 return (DeprecatedTxt d)
553 -------------------------------------------------------------------------
554 -- Types from: BasicTypes
555 -------------------------------------------------------------------------
557 instance Binary Activation where
558 put_ bh NeverActive = do
560 put_ bh AlwaysActive = do
562 put_ bh (ActiveBefore aa) = do
565 put_ bh (ActiveAfter ab) = do
571 0 -> do return NeverActive
572 1 -> do return AlwaysActive
574 return (ActiveBefore aa)
576 return (ActiveAfter ab)
578 instance Binary RuleMatchInfo where
579 put_ bh FunLike = putByte bh 0
580 put_ bh ConLike = putByte bh 1
583 if h == 1 then return ConLike
586 instance Binary InlinePragma where
587 put_ bh (InlinePragma activation match_info) = do
594 return (InlinePragma act info)
596 instance Binary StrictnessMark where
597 put_ bh MarkedStrict = putByte bh 0
598 put_ bh MarkedUnboxed = putByte bh 1
599 put_ bh NotMarkedStrict = putByte bh 2
603 0 -> do return MarkedStrict
604 1 -> do return MarkedUnboxed
605 _ -> do return NotMarkedStrict
607 instance Binary Boxity where
608 put_ bh Boxed = putByte bh 0
609 put_ bh Unboxed = putByte bh 1
614 _ -> do return Unboxed
616 instance Binary TupCon where
617 put_ bh (TupCon ab ac) = do
623 return (TupCon ab ac)
625 instance Binary RecFlag where
626 put_ bh Recursive = do
628 put_ bh NonRecursive = do
633 0 -> do return Recursive
634 _ -> do return NonRecursive
636 instance Binary DefMeth where
637 put_ bh NoDefMeth = putByte bh 0
638 put_ bh DefMeth = putByte bh 1
639 put_ bh GenDefMeth = putByte bh 2
643 0 -> return NoDefMeth
645 _ -> return GenDefMeth
647 instance Binary FixityDirection where
657 0 -> do return InfixL
658 1 -> do return InfixR
659 _ -> do return InfixN
661 instance Binary Fixity where
662 put_ bh (Fixity aa ab) = do
668 return (Fixity aa ab)
670 instance (Binary name) => Binary (IPName name) where
671 put_ bh (IPName aa) = put_ bh aa
672 get bh = do aa <- get bh
675 -------------------------------------------------------------------------
676 -- Types from: Demand
677 -------------------------------------------------------------------------
679 instance Binary DmdType where
680 -- Ignore DmdEnv when spitting out the DmdType
681 put bh (DmdType _ ds dr) = do p <- put bh ds; put_ bh dr; return (castBin p)
682 get bh = do ds <- get bh; dr <- get bh; return (DmdType emptyVarEnv ds dr)
684 instance Binary Demand where
689 put_ bh (Call aa) = do
692 put_ bh (Eval ab) = do
695 put_ bh (Defer ac) = do
698 put_ bh (Box ad) = do
718 instance Binary Demands where
719 put_ bh (Poly aa) = do
722 put_ bh (Prod ab) = do
733 instance Binary DmdResult where
743 0 -> do return TopRes
744 1 -> do return RetCPR -- Really use RetCPR even if -fcpr-off
745 -- The wrapper was generated for CPR in
746 -- the imported module!
747 _ -> do return BotRes
749 instance Binary StrictSig where
750 put_ bh (StrictSig aa) = do
754 return (StrictSig aa)
757 -------------------------------------------------------------------------
758 -- Types from: CostCentre
759 -------------------------------------------------------------------------
761 instance Binary IsCafCC where
764 put_ bh NotCafCC = do
770 _ -> do return NotCafCC
772 instance Binary IsDupdCC where
773 put_ bh OriginalCC = do
780 0 -> do return OriginalCC
781 _ -> do return DupdCC
783 instance Binary CostCentre where
784 put_ bh NoCostCentre = do
786 put_ bh (NormalCC aa ab ac ad) = do
792 put_ bh (AllCafsCC ae) = do
798 0 -> do return NoCostCentre
803 return (NormalCC aa ab ac ad)
805 return (AllCafsCC ae)
807 -------------------------------------------------------------------------
808 -- IfaceTypes and friends
809 -------------------------------------------------------------------------
811 instance Binary IfaceBndr where
812 put_ bh (IfaceIdBndr aa) = do
815 put_ bh (IfaceTvBndr ab) = do
822 return (IfaceIdBndr aa)
824 return (IfaceTvBndr ab)
826 instance Binary IfaceLetBndr where
827 put_ bh (IfLetBndr a b c) = do
831 get bh = do a <- get bh
834 return (IfLetBndr a b c)
836 instance Binary IfaceType where
837 put_ bh (IfaceForAllTy aa ab) = do
841 put_ bh (IfaceTyVar ad) = do
844 put_ bh (IfaceAppTy ae af) = do
848 put_ bh (IfaceFunTy ag ah) = do
852 put_ bh (IfacePredTy aq) = do
856 -- Simple compression for common cases of TyConApp
857 put_ bh (IfaceTyConApp IfaceIntTc []) = putByte bh 6
858 put_ bh (IfaceTyConApp IfaceCharTc []) = putByte bh 7
859 put_ bh (IfaceTyConApp IfaceBoolTc []) = putByte bh 8
860 put_ bh (IfaceTyConApp IfaceListTc [ty]) = do { putByte bh 9; put_ bh ty }
861 -- Unit tuple and pairs
862 put_ bh (IfaceTyConApp (IfaceTupTc Boxed 0) []) = putByte bh 10
863 put_ bh (IfaceTyConApp (IfaceTupTc Boxed 2) [t1,t2]) = do { putByte bh 11; put_ bh t1; put_ bh t2 }
865 put_ bh (IfaceTyConApp IfaceLiftedTypeKindTc []) = putByte bh 12
866 put_ bh (IfaceTyConApp IfaceOpenTypeKindTc []) = putByte bh 13
867 put_ bh (IfaceTyConApp IfaceUnliftedTypeKindTc []) = putByte bh 14
868 put_ bh (IfaceTyConApp IfaceUbxTupleKindTc []) = putByte bh 15
869 put_ bh (IfaceTyConApp IfaceArgTypeKindTc []) = putByte bh 16
873 put_ bh (IfaceTyConApp (IfaceTc tc) tys) = do { putByte bh 18; put_ bh tc; put_ bh tys }
874 put_ bh (IfaceTyConApp tc tys) = do { putByte bh 19; put_ bh tc; put_ bh tys }
881 return (IfaceForAllTy aa ab)
883 return (IfaceTyVar ad)
886 return (IfaceAppTy ae af)
889 return (IfaceFunTy ag ah)
891 return (IfacePredTy ap)
893 -- Now the special cases for TyConApp
894 6 -> return (IfaceTyConApp IfaceIntTc [])
895 7 -> return (IfaceTyConApp IfaceCharTc [])
896 8 -> return (IfaceTyConApp IfaceBoolTc [])
897 9 -> do { ty <- get bh; return (IfaceTyConApp IfaceListTc [ty]) }
898 10 -> return (IfaceTyConApp (IfaceTupTc Boxed 0) [])
899 11 -> do { t1 <- get bh; t2 <- get bh; return (IfaceTyConApp (IfaceTupTc Boxed 2) [t1,t2]) }
900 12 -> return (IfaceTyConApp IfaceLiftedTypeKindTc [])
901 13 -> return (IfaceTyConApp IfaceOpenTypeKindTc [])
902 14 -> return (IfaceTyConApp IfaceUnliftedTypeKindTc [])
903 15 -> return (IfaceTyConApp IfaceUbxTupleKindTc [])
904 16 -> return (IfaceTyConApp IfaceArgTypeKindTc [])
906 18 -> do { tc <- get bh; tys <- get bh; return (IfaceTyConApp (IfaceTc tc) tys) }
907 _ -> do { tc <- get bh; tys <- get bh; return (IfaceTyConApp tc tys) }
909 instance Binary IfaceTyCon where
910 -- Int,Char,Bool can't show up here because they can't not be saturated
912 put_ bh IfaceIntTc = putByte bh 1
913 put_ bh IfaceBoolTc = putByte bh 2
914 put_ bh IfaceCharTc = putByte bh 3
915 put_ bh IfaceListTc = putByte bh 4
916 put_ bh IfacePArrTc = putByte bh 5
917 put_ bh IfaceLiftedTypeKindTc = putByte bh 6
918 put_ bh IfaceOpenTypeKindTc = putByte bh 7
919 put_ bh IfaceUnliftedTypeKindTc = putByte bh 8
920 put_ bh IfaceUbxTupleKindTc = putByte bh 9
921 put_ bh IfaceArgTypeKindTc = putByte bh 10
922 put_ bh (IfaceTupTc bx ar) = do { putByte bh 11; put_ bh bx; put_ bh ar }
923 put_ bh (IfaceTc ext) = do { putByte bh 12; put_ bh ext }
928 1 -> return IfaceIntTc
929 2 -> return IfaceBoolTc
930 3 -> return IfaceCharTc
931 4 -> return IfaceListTc
932 5 -> return IfacePArrTc
933 6 -> return IfaceLiftedTypeKindTc
934 7 -> return IfaceOpenTypeKindTc
935 8 -> return IfaceUnliftedTypeKindTc
936 9 -> return IfaceUbxTupleKindTc
937 10 -> return IfaceArgTypeKindTc
938 11 -> do { bx <- get bh; ar <- get bh; return (IfaceTupTc bx ar) }
939 _ -> do { ext <- get bh; return (IfaceTc ext) }
941 instance Binary IfacePredType where
942 put_ bh (IfaceClassP aa ab) = do
946 put_ bh (IfaceIParam ac ad) = do
950 put_ bh (IfaceEqPred ac ad) = do
959 return (IfaceClassP aa ab)
962 return (IfaceIParam ac ad)
965 return (IfaceEqPred ac ad)
966 _ -> panic ("get IfacePredType " ++ show h)
968 -------------------------------------------------------------------------
969 -- IfaceExpr and friends
970 -------------------------------------------------------------------------
972 instance Binary IfaceExpr where
973 put_ bh (IfaceLcl aa) = do
976 put_ bh (IfaceType ab) = do
979 put_ bh (IfaceTuple ac ad) = do
983 put_ bh (IfaceLam ae af) = do
987 put_ bh (IfaceApp ag ah) = do
992 put_ bh (IfaceCase ai aj al ak) = do
999 put_ bh (IfaceLet al am) = do
1003 put_ bh (IfaceNote an ao) = do
1007 put_ bh (IfaceLit ap) = do
1010 put_ bh (IfaceFCall as at) = do
1014 put_ bh (IfaceExt aa) = do
1017 put_ bh (IfaceCast ie ico) = do
1021 put_ bh (IfaceTick m ix) = do
1028 0 -> do aa <- get bh
1029 return (IfaceLcl aa)
1030 1 -> do ab <- get bh
1031 return (IfaceType ab)
1032 2 -> do ac <- get bh
1034 return (IfaceTuple ac ad)
1035 3 -> do ae <- get bh
1037 return (IfaceLam ae af)
1038 4 -> do ag <- get bh
1040 return (IfaceApp ag ah)
1041 5 -> do ai <- get bh
1047 return (IfaceCase ai aj al ak)
1048 6 -> do al <- get bh
1050 return (IfaceLet al am)
1051 7 -> do an <- get bh
1053 return (IfaceNote an ao)
1054 8 -> do ap <- get bh
1055 return (IfaceLit ap)
1056 9 -> do as <- get bh
1058 return (IfaceFCall as at)
1059 10 -> do aa <- get bh
1060 return (IfaceExt aa)
1061 11 -> do ie <- get bh
1063 return (IfaceCast ie ico)
1064 12 -> do m <- get bh
1066 return (IfaceTick m ix)
1067 _ -> panic ("get IfaceExpr " ++ show h)
1069 instance Binary IfaceConAlt where
1070 put_ bh IfaceDefault = do
1072 put_ bh (IfaceDataAlt aa) = do
1075 put_ bh (IfaceTupleAlt ab) = do
1078 put_ bh (IfaceLitAlt ac) = do
1084 0 -> do return IfaceDefault
1085 1 -> do aa <- get bh
1086 return (IfaceDataAlt aa)
1087 2 -> do ab <- get bh
1088 return (IfaceTupleAlt ab)
1089 _ -> do ac <- get bh
1090 return (IfaceLitAlt ac)
1092 instance Binary IfaceBinding where
1093 put_ bh (IfaceNonRec aa ab) = do
1097 put_ bh (IfaceRec ac) = do
1103 0 -> do aa <- get bh
1105 return (IfaceNonRec aa ab)
1106 _ -> do ac <- get bh
1107 return (IfaceRec ac)
1109 instance Binary IfaceIdDetails where
1110 put_ bh IfVanillaId = putByte bh 0
1111 put_ bh (IfRecSelId a b) = do { putByte bh 1; put_ bh a; put_ bh b }
1112 put_ bh IfDFunId = putByte bh 2
1116 0 -> return IfVanillaId
1119 return (IfRecSelId a b)
1120 _ -> return IfDFunId
1122 instance Binary IfaceIdInfo where
1123 put_ bh NoInfo = putByte bh 0
1124 put_ bh (HasInfo i) = do
1126 lazyPut bh i -- NB lazyPut
1132 _ -> do info <- lazyGet bh -- NB lazyGet
1133 return (HasInfo info)
1135 instance Binary IfaceInfoItem where
1136 put_ bh (HsArity aa) = do
1139 put_ bh (HsStrictness ab) = do
1142 put_ bh (HsUnfold ad) = do
1145 put_ bh (HsInline ad) = do
1148 put_ bh HsNoCafRefs = do
1150 put_ bh (HsWorker ae af) = do
1157 0 -> do aa <- get bh
1159 1 -> do ab <- get bh
1160 return (HsStrictness ab)
1161 2 -> do ad <- get bh
1162 return (HsUnfold ad)
1163 3 -> do ad <- get bh
1164 return (HsInline ad)
1165 4 -> do return HsNoCafRefs
1166 _ -> do ae <- get bh
1168 return (HsWorker ae af)
1170 instance Binary IfaceNote where
1171 put_ bh (IfaceSCC aa) = do
1174 put_ bh IfaceInlineMe = do
1176 put_ bh (IfaceCoreNote s) = do
1182 0 -> do aa <- get bh
1183 return (IfaceSCC aa)
1184 3 -> do return IfaceInlineMe
1185 4 -> do ac <- get bh
1186 return (IfaceCoreNote ac)
1187 _ -> panic ("get IfaceNote " ++ show h)
1189 -------------------------------------------------------------------------
1190 -- IfaceDecl and friends
1191 -------------------------------------------------------------------------
1193 -- A bit of magic going on here: there's no need to store the OccName
1194 -- for a decl on the disk, since we can infer the namespace from the
1195 -- context; however it is useful to have the OccName in the IfaceDecl
1196 -- to avoid re-building it in various places. So we build the OccName
1197 -- when de-serialising.
1199 instance Binary IfaceDecl where
1200 put_ bh (IfaceId name ty details idinfo) = do
1202 put_ bh (occNameFS name)
1206 put_ _ (IfaceForeign _ _) =
1207 error "Binary.put_(IfaceDecl): IfaceForeign"
1208 put_ bh (IfaceData a1 a2 a3 a4 a5 a6 a7 a8) = do
1210 put_ bh (occNameFS a1)
1218 put_ bh (IfaceSyn a1 a2 a3 a4 a5) = do
1220 put_ bh (occNameFS a1)
1225 put_ bh (IfaceClass a1 a2 a3 a4 a5 a6 a7) = do
1228 put_ bh (occNameFS a2)
1237 0 -> do name <- get bh
1241 occ <- return $! mkOccNameFS varName name
1242 return (IfaceId occ ty details idinfo)
1243 1 -> error "Binary.get(TyClDecl): ForeignType"
1253 occ <- return $! mkOccNameFS tcName a1
1254 return (IfaceData occ a2 a3 a4 a5 a6 a7 a8)
1261 occ <- return $! mkOccNameFS tcName a1
1262 return (IfaceSyn occ a2 a3 a4 a5)
1271 occ <- return $! mkOccNameFS clsName a2
1272 return (IfaceClass a1 occ a3 a4 a5 a6 a7)
1274 instance Binary IfaceInst where
1275 put_ bh (IfaceInst cls tys dfun flag orph) = do
1281 get bh = do cls <- get bh
1286 return (IfaceInst cls tys dfun flag orph)
1288 instance Binary IfaceFamInst where
1289 put_ bh (IfaceFamInst fam tys tycon) = do
1293 get bh = do fam <- get bh
1296 return (IfaceFamInst fam tys tycon)
1298 instance Binary OverlapFlag where
1299 put_ bh NoOverlap = putByte bh 0
1300 put_ bh OverlapOk = putByte bh 1
1301 put_ bh Incoherent = putByte bh 2
1302 get bh = do h <- getByte bh
1304 0 -> return NoOverlap
1305 1 -> return OverlapOk
1306 2 -> return Incoherent
1307 _ -> panic ("get OverlapFlag " ++ show h)
1309 instance Binary IfaceConDecls where
1310 put_ bh IfAbstractTyCon = putByte bh 0
1311 put_ bh IfOpenDataTyCon = putByte bh 1
1312 put_ bh (IfDataTyCon cs) = do { putByte bh 2
1314 put_ bh (IfNewTyCon c) = do { putByte bh 3
1319 0 -> return IfAbstractTyCon
1320 1 -> return IfOpenDataTyCon
1321 2 -> do cs <- get bh
1322 return (IfDataTyCon cs)
1323 _ -> do aa <- get bh
1324 return (IfNewTyCon aa)
1326 instance Binary IfaceConDecl where
1327 put_ bh (IfCon a1 a2 a3 a4 a5 a6 a7 a8 a9 a10) = do
1338 get bh = do a1 <- get bh
1348 return (IfCon a1 a2 a3 a4 a5 a6 a7 a8 a9 a10)
1350 instance Binary IfaceClassOp where
1351 put_ bh (IfaceClassOp n def ty) = do
1352 put_ bh (occNameFS n)
1359 occ <- return $! mkOccNameFS varName n
1360 return (IfaceClassOp occ def ty)
1362 instance Binary IfaceRule where
1363 put_ bh (IfaceRule a1 a2 a3 a4 a5 a6 a7) = do
1379 return (IfaceRule a1 a2 a3 a4 a5 a6 a7)
1381 instance Binary IfaceAnnotation where
1382 put_ bh (IfaceAnnotation a1 a2) = do
1388 return (IfaceAnnotation a1 a2)
1390 instance Binary name => Binary (AnnTarget name) where
1391 put_ bh (NamedTarget a) = do
1394 put_ bh (ModuleTarget a) = do
1401 return (NamedTarget a)
1403 return (ModuleTarget a)
1405 instance Binary IfaceVectInfo where
1406 put_ bh (IfaceVectInfo a1 a2 a3) = do
1414 return (IfaceVectInfo a1 a2 a3)