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"
49 data CheckHiWay = CheckHiWay | IgnoreHiWay
52 data TraceBinIFaceReading = TraceBinIFaceReading | QuietBinIFaceReading
55 -- ---------------------------------------------------------------------------
56 -- Reading and writing binary interface files
58 readBinIface :: CheckHiWay -> TraceBinIFaceReading -> FilePath
59 -> TcRnIf a b ModIface
60 readBinIface checkHiWay traceBinIFaceReading hi_path = do
61 update_nc <- mkNameCacheUpdater
63 liftIO $ readBinIface_ dflags checkHiWay traceBinIFaceReading hi_path update_nc
65 readBinIface_ :: DynFlags -> CheckHiWay -> TraceBinIFaceReading -> FilePath
66 -> NameCacheUpdater (Array Int Name)
68 readBinIface_ dflags checkHiWay traceBinIFaceReading hi_path update_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 -- Note [dummy iface field]
97 -- read a dummy 32/64 bit value. This field used to hold the
98 -- dictionary pointer in old interface file formats, but now
99 -- the dictionary pointer is after the version (where it
100 -- should be). Also, the serialisation of value of type "Bin
101 -- a" used to depend on the word size of the machine, now they
102 -- are always 32 bits.
105 then do _ <- Binary.get bh :: IO Word32; return ()
106 else do _ <- Binary.get bh :: IO Word64; return ()
108 -- Check the interface file version and ways.
110 let our_ver = show opt_HiVersion
111 wantedGot "Version" our_ver check_ver
112 errorOnMismatch "mismatched interface file versions" our_ver check_ver
115 let way_descr = getWayDescr dflags
116 wantedGot "Way" way_descr check_way
117 when (checkHiWay == CheckHiWay) $
118 errorOnMismatch "mismatched interface file ways" way_descr check_way
120 -- Read the dictionary
121 -- The next word in the file is a pointer to where the dictionary is
122 -- (probably at the end of the file)
123 dict_p <- Binary.get bh
124 data_p <- tellBin bh -- Remember where we are now
126 dict <- getDictionary bh
127 seekBin bh data_p -- Back to where we were before
129 -- Initialise the user-data field of bh
130 ud <- newReadState dict
131 bh <- return (setUserData bh ud)
133 symtab_p <- Binary.get bh -- Get the symtab ptr
134 data_p <- tellBin bh -- Remember where we are now
136 symtab <- getSymbolTable bh update_nc
137 seekBin bh data_p -- Back to where we were before
138 let ud = getUserData bh
139 bh <- return $! setUserData bh ud{ud_symtab = symtab}
144 writeBinIface :: DynFlags -> FilePath -> ModIface -> IO ()
145 writeBinIface dflags hi_path mod_iface = do
146 bh <- openBinMem initBinMemSize
147 put_ bh binaryInterfaceMagic
149 -- dummy 32/64-bit field before the version/way for
150 -- compatibility with older interface file formats.
151 -- See Note [dummy iface field] above.
153 then Binary.put_ bh (0 :: Word32)
154 else Binary.put_ bh (0 :: Word64)
156 -- The version and way descriptor go next
157 put_ bh (show opt_HiVersion)
158 let way_descr = getWayDescr dflags
161 -- Remember where the dictionary pointer will go
162 dict_p_p <- tellBin bh
163 put_ bh dict_p_p -- Placeholder for ptr to dictionary
165 -- Remember where the symbol table pointer will go
166 symtab_p_p <- tellBin bh
169 -- Make some intial state
170 symtab_next <- newFastMutInt
171 writeFastMutInt symtab_next 0
172 symtab_map <- newIORef emptyUFM
173 let bin_symtab = BinSymbolTable {
174 bin_symtab_next = symtab_next,
175 bin_symtab_map = symtab_map }
176 dict_next_ref <- newFastMutInt
177 writeFastMutInt dict_next_ref 0
178 dict_map_ref <- newIORef emptyUFM
179 let bin_dict = BinDictionary {
180 bin_dict_next = dict_next_ref,
181 bin_dict_map = dict_map_ref }
182 ud <- newWriteState (putName bin_symtab) (putFastString bin_dict)
184 -- Put the main thing,
185 bh <- return $ setUserData bh ud
188 -- Write the symtab pointer at the fornt of the file
189 symtab_p <- tellBin bh -- This is where the symtab will start
190 putAt bh symtab_p_p symtab_p -- Fill in the placeholder
191 seekBin bh symtab_p -- Seek back to the end of the file
193 -- Write the symbol table itself
194 symtab_next <- readFastMutInt symtab_next
195 symtab_map <- readIORef symtab_map
196 putSymbolTable bh symtab_next symtab_map
197 debugTraceMsg dflags 3 (text "writeBinIface:" <+> int symtab_next
200 -- NB. write the dictionary after the symbol table, because
201 -- writing the symbol table may create more dictionary entries.
203 -- Write the dictionary pointer at the fornt of the file
204 dict_p <- tellBin bh -- This is where the dictionary will start
205 putAt bh dict_p_p dict_p -- Fill in the placeholder
206 seekBin bh dict_p -- Seek back to the end of the file
208 -- Write the dictionary itself
209 dict_next <- readFastMutInt dict_next_ref
210 dict_map <- readIORef dict_map_ref
211 putDictionary bh dict_next dict_map
212 debugTraceMsg dflags 3 (text "writeBinIface:" <+> int dict_next
213 <+> text "dict entries")
215 -- And send the result to the file
216 writeBinMem bh hi_path
218 initBinMemSize :: Int
219 initBinMemSize = 1024 * 1024
221 -- The *host* architecture version:
222 #include "../includes/MachDeps.h"
224 binaryInterfaceMagic :: Word32
225 #if WORD_SIZE_IN_BITS == 32
226 binaryInterfaceMagic = 0x1face
227 #elif WORD_SIZE_IN_BITS == 64
228 binaryInterfaceMagic = 0x1face64
231 -- -----------------------------------------------------------------------------
234 putSymbolTable :: BinHandle -> Int -> UniqFM (Int,Name) -> IO ()
235 putSymbolTable bh next_off symtab = do
237 let names = elems (array (0,next_off-1) (eltsUFM symtab))
238 mapM_ (\n -> serialiseName bh n symtab) names
240 getSymbolTable :: BinHandle -> NameCacheUpdater (Array Int Name)
241 -> IO (Array Int Name)
242 getSymbolTable bh update_namecache = do
244 od_names <- sequence (replicate sz (get bh))
245 update_namecache $ \namecache ->
247 arr = listArray (0,sz-1) names
248 (namecache', names) =
249 mapAccumR (fromOnDiskName arr) namecache od_names
252 type OnDiskName = (PackageId, ModuleName, OccName)
259 fromOnDiskName _ nc (pid, mod_name, occ) =
261 mod = mkModule pid mod_name
264 case lookupOrigNameCache cache mod occ of
265 Just name -> (nc, name)
269 uniq = uniqFromSupply us
270 name = mkExternalName uniq mod occ noSrcSpan
271 new_cache = extendNameCache cache mod occ name
273 case splitUniqSupply us of { (us',_) ->
274 ( nc{ nsUniqs = us', nsNames = new_cache }, name )
277 serialiseName :: BinHandle -> Name -> UniqFM (Int,Name) -> IO ()
278 serialiseName bh name _ = do
279 let mod = ASSERT2( isExternalName name, ppr name ) nameModule name
280 put_ bh (modulePackageId mod, moduleName mod, nameOccName name)
283 putName :: BinSymbolTable -> BinHandle -> Name -> IO ()
284 putName BinSymbolTable{
285 bin_symtab_map = symtab_map_ref,
286 bin_symtab_next = symtab_next } bh name
288 symtab_map <- readIORef symtab_map_ref
289 case lookupUFM symtab_map name of
290 Just (off,_) -> put_ bh (fromIntegral off :: Word32)
292 off <- readFastMutInt symtab_next
293 writeFastMutInt symtab_next (off+1)
294 writeIORef symtab_map_ref
295 $! addToUFM symtab_map name (off,name)
296 put_ bh (fromIntegral off :: Word32)
299 data BinSymbolTable = BinSymbolTable {
300 bin_symtab_next :: !FastMutInt, -- The next index to use
301 bin_symtab_map :: !(IORef (UniqFM (Int,Name)))
306 putFastString :: BinDictionary -> BinHandle -> FastString -> IO ()
307 putFastString BinDictionary { bin_dict_next = j_r,
308 bin_dict_map = out_r} bh f
310 out <- readIORef out_r
311 let uniq = getUnique f
312 case lookupUFM out uniq of
313 Just (j, _) -> put_ bh (fromIntegral j :: Word32)
315 j <- readFastMutInt j_r
316 put_ bh (fromIntegral j :: Word32)
317 writeFastMutInt j_r (j + 1)
318 writeIORef out_r $! addToUFM out uniq (j, f)
321 data BinDictionary = BinDictionary {
322 bin_dict_next :: !FastMutInt, -- The next index to use
323 bin_dict_map :: !(IORef (UniqFM (Int,FastString)))
324 -- indexed by FastString
327 -- -----------------------------------------------------------------------------
328 -- All the binary instances
331 {-! for IPName derive: Binary !-}
332 {-! for Fixity derive: Binary !-}
333 {-! for FixityDirection derive: Binary !-}
334 {-! for Boxity derive: Binary !-}
335 {-! for StrictnessMark derive: Binary !-}
336 {-! for Activation derive: Binary !-}
339 {-! for Demand derive: Binary !-}
340 {-! for Demands derive: Binary !-}
341 {-! for DmdResult derive: Binary !-}
342 {-! for StrictSig derive: Binary !-}
345 {-! for DefMeth derive: Binary !-}
348 {-! for HsPred derive: Binary !-}
349 {-! for HsType derive: Binary !-}
350 {-! for TupCon derive: Binary !-}
351 {-! for HsTyVarBndr derive: Binary !-}
354 {-! for UfExpr derive: Binary !-}
355 {-! for UfConAlt derive: Binary !-}
356 {-! for UfBinding derive: Binary !-}
357 {-! for UfBinder derive: Binary !-}
358 {-! for HsIdInfo derive: Binary !-}
359 {-! for UfNote derive: Binary !-}
362 {-! for ConDetails derive: Binary !-}
363 {-! for BangType derive: Binary !-}
366 {-! for IsCafCC derive: Binary !-}
367 {-! for IsDupdCC derive: Binary !-}
368 {-! for CostCentre derive: Binary !-}
372 -- ---------------------------------------------------------------------------
373 -- Reading a binary interface into ParsedIface
375 instance Binary ModIface where
379 mi_iface_hash= iface_hash,
380 mi_mod_hash = mod_hash,
382 mi_finsts = hasFamInsts,
385 mi_exports = exports,
386 mi_exp_hash = exp_hash,
387 mi_fixities = fixities,
392 mi_fam_insts = fam_insts,
394 mi_orphan_hash = orphan_hash,
395 mi_vect_info = vect_info,
396 mi_hpc = hpc_info }) = do
424 hasFamInsts <- get bh
426 usages <- {-# SCC "bin_usages" #-} lazyGet bh
427 exports <- {-# SCC "bin_exports" #-} get bh
429 fixities <- {-# SCC "bin_fixities" #-} get bh
430 warns <- {-# SCC "bin_warns" #-} lazyGet bh
431 anns <- {-# SCC "bin_anns" #-} lazyGet bh
432 decls <- {-# SCC "bin_tycldecls" #-} get bh
433 insts <- {-# SCC "bin_insts" #-} get bh
434 fam_insts <- {-# SCC "bin_fam_insts" #-} get bh
435 rules <- {-# SCC "bin_rules" #-} lazyGet bh
436 orphan_hash <- get bh
440 mi_module = mod_name,
442 mi_iface_hash = iface_hash,
443 mi_mod_hash = mod_hash,
445 mi_finsts = hasFamInsts,
448 mi_exports = exports,
449 mi_exp_hash = exp_hash,
451 mi_fixities = fixities,
454 mi_globals = Nothing,
456 mi_fam_insts = fam_insts,
458 mi_orphan_hash = orphan_hash,
459 mi_vect_info = vect_info,
461 -- And build the cached values
462 mi_warn_fn = mkIfaceWarnCache warns,
463 mi_fix_fn = mkIfaceFixCache fixities,
464 mi_hash_fn = mkIfaceHashCache decls })
466 getWayDescr :: DynFlags -> String
468 | cGhcUnregisterised == "YES" = 'u':tag
470 where tag = buildTag dflags
471 -- if this is an unregisterised build, make sure our interfaces
472 -- can't be used by a registerised build.
474 -------------------------------------------------------------------------
475 -- Types from: HscTypes
476 -------------------------------------------------------------------------
478 instance Binary Dependencies where
479 put_ bh deps = do put_ bh (dep_mods deps)
480 put_ bh (dep_pkgs deps)
481 put_ bh (dep_orphs deps)
482 put_ bh (dep_finsts deps)
484 get bh = do ms <- get bh
488 return (Deps { dep_mods = ms, dep_pkgs = ps, dep_orphs = os,
491 instance (Binary name) => Binary (GenAvailInfo name) where
492 put_ bh (Avail aa) = do
495 put_ bh (AvailTC ab ac) = do
506 return (AvailTC ab ac)
508 instance Binary Usage where
509 put_ bh usg@UsagePackageModule{} = do
511 put_ bh (usg_mod usg)
512 put_ bh (usg_mod_hash usg)
513 put_ bh usg@UsageHomeModule{} = do
515 put_ bh (usg_mod_name usg)
516 put_ bh (usg_mod_hash usg)
517 put_ bh (usg_exports usg)
518 put_ bh (usg_entities usg)
526 return UsagePackageModule { usg_mod = nm, usg_mod_hash = mod }
532 return UsageHomeModule { usg_mod_name = nm, usg_mod_hash = mod,
533 usg_exports = exps, usg_entities = ents }
535 instance Binary Warnings where
536 put_ bh NoWarnings = putByte bh 0
537 put_ bh (WarnAll t) = do
540 put_ bh (WarnSome ts) = do
547 0 -> return NoWarnings
553 instance Binary WarningTxt where
554 put_ bh (WarningTxt w) = do
557 put_ bh (DeprecatedTxt d) = do
565 return (WarningTxt w)
567 return (DeprecatedTxt d)
569 -------------------------------------------------------------------------
570 -- Types from: BasicTypes
571 -------------------------------------------------------------------------
573 instance Binary Activation where
574 put_ bh NeverActive = do
576 put_ bh AlwaysActive = do
578 put_ bh (ActiveBefore aa) = do
581 put_ bh (ActiveAfter ab) = do
587 0 -> do return NeverActive
588 1 -> do return AlwaysActive
590 return (ActiveBefore aa)
592 return (ActiveAfter ab)
594 instance Binary RuleMatchInfo where
595 put_ bh FunLike = putByte bh 0
596 put_ bh ConLike = putByte bh 1
599 if h == 1 then return ConLike
602 instance Binary InlinePragma where
603 put_ bh (InlinePragma a b c d) = do
614 return (InlinePragma a b c d)
616 instance Binary StrictnessMark where
617 put_ bh MarkedStrict = putByte bh 0
618 put_ bh MarkedUnboxed = putByte bh 1
619 put_ bh NotMarkedStrict = putByte bh 2
623 0 -> do return MarkedStrict
624 1 -> do return MarkedUnboxed
625 _ -> do return NotMarkedStrict
627 instance Binary Boxity where
628 put_ bh Boxed = putByte bh 0
629 put_ bh Unboxed = putByte bh 1
634 _ -> do return Unboxed
636 instance Binary TupCon where
637 put_ bh (TupCon ab ac) = do
643 return (TupCon ab ac)
645 instance Binary RecFlag where
646 put_ bh Recursive = do
648 put_ bh NonRecursive = do
653 0 -> do return Recursive
654 _ -> do return NonRecursive
656 instance Binary DefMeth where
657 put_ bh NoDefMeth = putByte bh 0
658 put_ bh DefMeth = putByte bh 1
659 put_ bh GenDefMeth = putByte bh 2
663 0 -> return NoDefMeth
665 _ -> return GenDefMeth
667 instance Binary FixityDirection where
677 0 -> do return InfixL
678 1 -> do return InfixR
679 _ -> do return InfixN
681 instance Binary Fixity where
682 put_ bh (Fixity aa ab) = do
688 return (Fixity aa ab)
690 instance (Binary name) => Binary (IPName name) where
691 put_ bh (IPName aa) = put_ bh aa
692 get bh = do aa <- get bh
695 -------------------------------------------------------------------------
696 -- Types from: Demand
697 -------------------------------------------------------------------------
699 instance Binary DmdType where
700 -- Ignore DmdEnv when spitting out the DmdType
701 put bh (DmdType _ ds dr) = do p <- put bh ds; put_ bh dr; return (castBin p)
702 get bh = do ds <- get bh; dr <- get bh; return (DmdType emptyVarEnv ds dr)
704 instance Binary Demand where
709 put_ bh (Call aa) = do
712 put_ bh (Eval ab) = do
715 put_ bh (Defer ac) = do
718 put_ bh (Box ad) = do
738 instance Binary Demands where
739 put_ bh (Poly aa) = do
742 put_ bh (Prod ab) = do
753 instance Binary DmdResult where
763 0 -> do return TopRes
764 1 -> do return RetCPR -- Really use RetCPR even if -fcpr-off
765 -- The wrapper was generated for CPR in
766 -- the imported module!
767 _ -> do return BotRes
769 instance Binary StrictSig where
770 put_ bh (StrictSig aa) = do
774 return (StrictSig aa)
777 -------------------------------------------------------------------------
778 -- Types from: CostCentre
779 -------------------------------------------------------------------------
781 instance Binary IsCafCC where
784 put_ bh NotCafCC = do
790 _ -> do return NotCafCC
792 instance Binary IsDupdCC where
793 put_ bh OriginalCC = do
800 0 -> do return OriginalCC
801 _ -> do return DupdCC
803 instance Binary CostCentre where
804 put_ bh NoCostCentre = do
806 put_ bh (NormalCC aa ab ac ad) = do
812 put_ bh (AllCafsCC ae) = do
818 0 -> do return NoCostCentre
823 return (NormalCC aa ab ac ad)
825 return (AllCafsCC ae)
827 -------------------------------------------------------------------------
828 -- IfaceTypes and friends
829 -------------------------------------------------------------------------
831 instance Binary IfaceBndr where
832 put_ bh (IfaceIdBndr aa) = do
835 put_ bh (IfaceTvBndr ab) = do
842 return (IfaceIdBndr aa)
844 return (IfaceTvBndr ab)
846 instance Binary IfaceLetBndr where
847 put_ bh (IfLetBndr a b c) = do
851 get bh = do a <- get bh
854 return (IfLetBndr a b c)
856 instance Binary IfaceType where
857 put_ bh (IfaceForAllTy aa ab) = do
861 put_ bh (IfaceTyVar ad) = do
864 put_ bh (IfaceAppTy ae af) = do
868 put_ bh (IfaceFunTy ag ah) = do
872 put_ bh (IfacePredTy aq) = do
876 -- Simple compression for common cases of TyConApp
877 put_ bh (IfaceTyConApp IfaceIntTc []) = putByte bh 6
878 put_ bh (IfaceTyConApp IfaceCharTc []) = putByte bh 7
879 put_ bh (IfaceTyConApp IfaceBoolTc []) = putByte bh 8
880 put_ bh (IfaceTyConApp IfaceListTc [ty]) = do { putByte bh 9; put_ bh ty }
881 -- Unit tuple and pairs
882 put_ bh (IfaceTyConApp (IfaceTupTc Boxed 0) []) = putByte bh 10
883 put_ bh (IfaceTyConApp (IfaceTupTc Boxed 2) [t1,t2]) = do { putByte bh 11; put_ bh t1; put_ bh t2 }
885 put_ bh (IfaceTyConApp IfaceLiftedTypeKindTc []) = putByte bh 12
886 put_ bh (IfaceTyConApp IfaceOpenTypeKindTc []) = putByte bh 13
887 put_ bh (IfaceTyConApp IfaceUnliftedTypeKindTc []) = putByte bh 14
888 put_ bh (IfaceTyConApp IfaceUbxTupleKindTc []) = putByte bh 15
889 put_ bh (IfaceTyConApp IfaceArgTypeKindTc []) = putByte bh 16
890 put_ bh (IfaceTyConApp (IfaceAnyTc k) []) = do { putByte bh 17; put_ bh k }
894 put_ bh (IfaceTyConApp (IfaceTc tc) tys) = do { putByte bh 18; put_ bh tc; put_ bh tys }
895 put_ bh (IfaceTyConApp tc tys) = do { putByte bh 19; put_ bh tc; put_ bh tys }
902 return (IfaceForAllTy aa ab)
904 return (IfaceTyVar ad)
907 return (IfaceAppTy ae af)
910 return (IfaceFunTy ag ah)
912 return (IfacePredTy ap)
914 -- Now the special cases for TyConApp
915 6 -> return (IfaceTyConApp IfaceIntTc [])
916 7 -> return (IfaceTyConApp IfaceCharTc [])
917 8 -> return (IfaceTyConApp IfaceBoolTc [])
918 9 -> do { ty <- get bh; return (IfaceTyConApp IfaceListTc [ty]) }
919 10 -> return (IfaceTyConApp (IfaceTupTc Boxed 0) [])
920 11 -> do { t1 <- get bh; t2 <- get bh; return (IfaceTyConApp (IfaceTupTc Boxed 2) [t1,t2]) }
921 12 -> return (IfaceTyConApp IfaceLiftedTypeKindTc [])
922 13 -> return (IfaceTyConApp IfaceOpenTypeKindTc [])
923 14 -> return (IfaceTyConApp IfaceUnliftedTypeKindTc [])
924 15 -> return (IfaceTyConApp IfaceUbxTupleKindTc [])
925 16 -> return (IfaceTyConApp IfaceArgTypeKindTc [])
926 17 -> do { k <- get bh; return (IfaceTyConApp (IfaceAnyTc k) []) }
928 18 -> do { tc <- get bh; tys <- get bh; return (IfaceTyConApp (IfaceTc tc) tys) }
929 _ -> do { tc <- get bh; tys <- get bh; return (IfaceTyConApp tc tys) }
931 instance Binary IfaceTyCon where
932 -- Int,Char,Bool can't show up here because they can't not be saturated
934 put_ bh IfaceIntTc = putByte bh 1
935 put_ bh IfaceBoolTc = putByte bh 2
936 put_ bh IfaceCharTc = putByte bh 3
937 put_ bh IfaceListTc = putByte bh 4
938 put_ bh IfacePArrTc = putByte bh 5
939 put_ bh IfaceLiftedTypeKindTc = putByte bh 6
940 put_ bh IfaceOpenTypeKindTc = putByte bh 7
941 put_ bh IfaceUnliftedTypeKindTc = putByte bh 8
942 put_ bh IfaceUbxTupleKindTc = putByte bh 9
943 put_ bh IfaceArgTypeKindTc = putByte bh 10
944 put_ bh (IfaceTupTc bx ar) = do { putByte bh 11; put_ bh bx; put_ bh ar }
945 put_ bh (IfaceTc ext) = do { putByte bh 12; put_ bh ext }
946 put_ bh (IfaceAnyTc k) = do { putByte bh 13; put_ bh k }
951 1 -> return IfaceIntTc
952 2 -> return IfaceBoolTc
953 3 -> return IfaceCharTc
954 4 -> return IfaceListTc
955 5 -> return IfacePArrTc
956 6 -> return IfaceLiftedTypeKindTc
957 7 -> return IfaceOpenTypeKindTc
958 8 -> return IfaceUnliftedTypeKindTc
959 9 -> return IfaceUbxTupleKindTc
960 10 -> return IfaceArgTypeKindTc
961 11 -> do { bx <- get bh; ar <- get bh; return (IfaceTupTc bx ar) }
962 12 -> do { ext <- get bh; return (IfaceTc ext) }
963 _ -> do { k <- get bh; return (IfaceAnyTc k) }
965 instance Binary IfacePredType where
966 put_ bh (IfaceClassP aa ab) = do
970 put_ bh (IfaceIParam ac ad) = do
974 put_ bh (IfaceEqPred ac ad) = do
983 return (IfaceClassP aa ab)
986 return (IfaceIParam ac ad)
989 return (IfaceEqPred ac ad)
990 _ -> panic ("get IfacePredType " ++ show h)
992 -------------------------------------------------------------------------
993 -- IfaceExpr and friends
994 -------------------------------------------------------------------------
996 instance Binary IfaceExpr where
997 put_ bh (IfaceLcl aa) = do
1000 put_ bh (IfaceType ab) = do
1003 put_ bh (IfaceTuple ac ad) = do
1007 put_ bh (IfaceLam ae af) = do
1011 put_ bh (IfaceApp ag ah) = do
1016 put_ bh (IfaceCase ai aj al ak) = do
1023 put_ bh (IfaceLet al am) = do
1027 put_ bh (IfaceNote an ao) = do
1031 put_ bh (IfaceLit ap) = do
1034 put_ bh (IfaceFCall as at) = do
1038 put_ bh (IfaceExt aa) = do
1041 put_ bh (IfaceCast ie ico) = do
1045 put_ bh (IfaceTick m ix) = do
1052 0 -> do aa <- get bh
1053 return (IfaceLcl aa)
1054 1 -> do ab <- get bh
1055 return (IfaceType ab)
1056 2 -> do ac <- get bh
1058 return (IfaceTuple ac ad)
1059 3 -> do ae <- get bh
1061 return (IfaceLam ae af)
1062 4 -> do ag <- get bh
1064 return (IfaceApp ag ah)
1065 5 -> do ai <- get bh
1071 return (IfaceCase ai aj al ak)
1072 6 -> do al <- get bh
1074 return (IfaceLet al am)
1075 7 -> do an <- get bh
1077 return (IfaceNote an ao)
1078 8 -> do ap <- get bh
1079 return (IfaceLit ap)
1080 9 -> do as <- get bh
1082 return (IfaceFCall as at)
1083 10 -> do aa <- get bh
1084 return (IfaceExt aa)
1085 11 -> do ie <- get bh
1087 return (IfaceCast ie ico)
1088 12 -> do m <- get bh
1090 return (IfaceTick m ix)
1091 _ -> panic ("get IfaceExpr " ++ show h)
1093 instance Binary IfaceConAlt where
1094 put_ bh IfaceDefault = do
1096 put_ bh (IfaceDataAlt aa) = do
1099 put_ bh (IfaceTupleAlt ab) = do
1102 put_ bh (IfaceLitAlt ac) = do
1108 0 -> do return IfaceDefault
1109 1 -> do aa <- get bh
1110 return (IfaceDataAlt aa)
1111 2 -> do ab <- get bh
1112 return (IfaceTupleAlt ab)
1113 _ -> do ac <- get bh
1114 return (IfaceLitAlt ac)
1116 instance Binary IfaceBinding where
1117 put_ bh (IfaceNonRec aa ab) = do
1121 put_ bh (IfaceRec ac) = do
1127 0 -> do aa <- get bh
1129 return (IfaceNonRec aa ab)
1130 _ -> do ac <- get bh
1131 return (IfaceRec ac)
1133 instance Binary IfaceIdDetails where
1134 put_ bh IfVanillaId = putByte bh 0
1135 put_ bh (IfRecSelId a b) = do { putByte bh 1; put_ bh a; put_ bh b }
1136 put_ bh IfDFunId = putByte bh 2
1140 0 -> return IfVanillaId
1143 return (IfRecSelId a b)
1144 _ -> return IfDFunId
1146 instance Binary IfaceIdInfo where
1147 put_ bh NoInfo = putByte bh 0
1148 put_ bh (HasInfo i) = do
1150 lazyPut bh i -- NB lazyPut
1156 _ -> do info <- lazyGet bh -- NB lazyGet
1157 return (HasInfo info)
1159 instance Binary IfaceInfoItem where
1160 put_ bh (HsArity aa) = do
1163 put_ bh (HsStrictness ab) = do
1166 put_ bh (HsUnfold lb ad) = do
1170 put_ bh (HsInline ad) = do
1173 put_ bh HsNoCafRefs = do
1178 0 -> do aa <- get bh
1180 1 -> do ab <- get bh
1181 return (HsStrictness ab)
1182 2 -> do lb <- get bh
1184 return (HsUnfold lb ad)
1185 3 -> do ad <- get bh
1186 return (HsInline ad)
1187 _ -> do return HsNoCafRefs
1189 instance Binary IfaceUnfolding where
1190 put_ bh (IfCoreUnfold e) = do
1193 put_ bh (IfInlineRule a b c d) = do
1199 put_ bh (IfWrapper a n) = do
1203 put_ bh (IfDFunUnfold as) = do
1206 put_ bh (IfCompulsory e) = do
1213 return (IfCoreUnfold e)
1218 return (IfInlineRule a b c d)
1221 return (IfWrapper a n)
1222 3 -> do as <- get bh
1223 return (IfDFunUnfold as)
1225 return (IfCompulsory e)
1227 instance Binary IfaceNote where
1228 put_ bh (IfaceSCC aa) = do
1231 put_ bh (IfaceCoreNote s) = do
1237 0 -> do aa <- get bh
1238 return (IfaceSCC aa)
1239 4 -> do ac <- get bh
1240 return (IfaceCoreNote ac)
1241 _ -> panic ("get IfaceNote " ++ show h)
1243 -------------------------------------------------------------------------
1244 -- IfaceDecl and friends
1245 -------------------------------------------------------------------------
1247 -- A bit of magic going on here: there's no need to store the OccName
1248 -- for a decl on the disk, since we can infer the namespace from the
1249 -- context; however it is useful to have the OccName in the IfaceDecl
1250 -- to avoid re-building it in various places. So we build the OccName
1251 -- when de-serialising.
1253 instance Binary IfaceDecl where
1254 put_ bh (IfaceId name ty details idinfo) = do
1256 put_ bh (occNameFS name)
1260 put_ _ (IfaceForeign _ _) =
1261 error "Binary.put_(IfaceDecl): IfaceForeign"
1262 put_ bh (IfaceData a1 a2 a3 a4 a5 a6 a7 a8) = do
1264 put_ bh (occNameFS a1)
1272 put_ bh (IfaceSyn a1 a2 a3 a4 a5) = do
1274 put_ bh (occNameFS a1)
1279 put_ bh (IfaceClass a1 a2 a3 a4 a5 a6 a7) = do
1282 put_ bh (occNameFS a2)
1291 0 -> do name <- get bh
1295 occ <- return $! mkOccNameFS varName name
1296 return (IfaceId occ ty details idinfo)
1297 1 -> error "Binary.get(TyClDecl): ForeignType"
1307 occ <- return $! mkOccNameFS tcName a1
1308 return (IfaceData occ a2 a3 a4 a5 a6 a7 a8)
1315 occ <- return $! mkOccNameFS tcName a1
1316 return (IfaceSyn occ a2 a3 a4 a5)
1325 occ <- return $! mkOccNameFS clsName a2
1326 return (IfaceClass a1 occ a3 a4 a5 a6 a7)
1328 instance Binary IfaceInst where
1329 put_ bh (IfaceInst cls tys dfun flag orph) = do
1335 get bh = do cls <- get bh
1340 return (IfaceInst cls tys dfun flag orph)
1342 instance Binary IfaceFamInst where
1343 put_ bh (IfaceFamInst fam tys tycon) = do
1347 get bh = do fam <- get bh
1350 return (IfaceFamInst fam tys tycon)
1352 instance Binary OverlapFlag where
1353 put_ bh NoOverlap = putByte bh 0
1354 put_ bh OverlapOk = putByte bh 1
1355 put_ bh Incoherent = putByte bh 2
1356 get bh = do h <- getByte bh
1358 0 -> return NoOverlap
1359 1 -> return OverlapOk
1360 2 -> return Incoherent
1361 _ -> panic ("get OverlapFlag " ++ show h)
1363 instance Binary IfaceConDecls where
1364 put_ bh IfAbstractTyCon = putByte bh 0
1365 put_ bh IfOpenDataTyCon = putByte bh 1
1366 put_ bh (IfDataTyCon cs) = do { putByte bh 2
1368 put_ bh (IfNewTyCon c) = do { putByte bh 3
1373 0 -> return IfAbstractTyCon
1374 1 -> return IfOpenDataTyCon
1375 2 -> do cs <- get bh
1376 return (IfDataTyCon cs)
1377 _ -> do aa <- get bh
1378 return (IfNewTyCon aa)
1380 instance Binary IfaceConDecl where
1381 put_ bh (IfCon a1 a2 a3 a4 a5 a6 a7 a8 a9 a10) = do
1392 get bh = do a1 <- get bh
1402 return (IfCon a1 a2 a3 a4 a5 a6 a7 a8 a9 a10)
1404 instance Binary IfaceClassOp where
1405 put_ bh (IfaceClassOp n def ty) = do
1406 put_ bh (occNameFS n)
1413 occ <- return $! mkOccNameFS varName n
1414 return (IfaceClassOp occ def ty)
1416 instance Binary IfaceRule where
1417 put_ bh (IfaceRule a1 a2 a3 a4 a5 a6 a7) = do
1433 return (IfaceRule a1 a2 a3 a4 a5 a6 a7)
1435 instance Binary IfaceAnnotation where
1436 put_ bh (IfaceAnnotation a1 a2) = do
1442 return (IfaceAnnotation a1 a2)
1444 instance Binary name => Binary (AnnTarget name) where
1445 put_ bh (NamedTarget a) = do
1448 put_ bh (ModuleTarget a) = do
1455 return (NamedTarget a)
1457 return (ModuleTarget a)
1459 instance Binary IfaceVectInfo where
1460 put_ bh (IfaceVectInfo a1 a2 a3) = do
1468 return (IfaceVectInfo a1 a2 a3)