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
62 liftIO $ readBinIface_ dflags checkHiWay traceBinIFaceReading hi_path update_nc
64 readBinIface_ :: DynFlags -> CheckHiWay -> TraceBinIFaceReading -> FilePath
65 -> NameCacheUpdater (Array Int Name)
67 readBinIface_ dflags checkHiWay traceBinIFaceReading hi_path update_nc = do
68 let printer :: SDoc -> IO ()
69 printer = case traceBinIFaceReading of
70 TraceBinIFaceReading -> \sd -> printSDoc sd defaultDumpStyle
71 QuietBinIFaceReading -> \_ -> return ()
72 wantedGot :: Outputable a => String -> a -> a -> IO ()
73 wantedGot what wanted got
74 = printer (text what <> text ": " <>
75 vcat [text "Wanted " <> ppr wanted <> text ",",
76 text "got " <> ppr got])
78 errorOnMismatch :: (Eq a, Show a) => String -> a -> a -> IO ()
79 errorOnMismatch what wanted got
80 -- This will be caught by readIface which will emit an error
81 -- msg containing the iface module name.
82 = when (wanted /= got) $ ghcError $ ProgramError
83 (what ++ " (wanted " ++ show wanted
84 ++ ", got " ++ show got ++ ")")
85 bh <- Binary.readBinMem hi_path
87 -- Read the magic number to check that this really is a GHC .hi file
88 -- (This magic number does not change when we change
89 -- GHC interface file format)
91 wantedGot "Magic" binaryInterfaceMagic magic
92 errorOnMismatch "magic number mismatch: old/corrupt interface file?"
93 binaryInterfaceMagic magic
95 -- Note [dummy iface field]
96 -- read a dummy 32/64 bit value. This field used to hold the
97 -- dictionary pointer in old interface file formats, but now
98 -- the dictionary pointer is after the version (where it
99 -- should be). Also, the serialisation of value of type "Bin
100 -- a" used to depend on the word size of the machine, now they
101 -- are always 32 bits.
104 then do _ <- Binary.get bh :: IO Word32; return ()
105 else do _ <- Binary.get bh :: IO Word64; return ()
107 -- Check the interface file version and ways.
109 let our_ver = show opt_HiVersion
110 wantedGot "Version" our_ver check_ver
111 errorOnMismatch "mismatched interface file versions" our_ver check_ver
114 let way_descr = getWayDescr dflags
115 wantedGot "Way" way_descr check_way
116 when (checkHiWay == CheckHiWay) $
117 errorOnMismatch "mismatched interface file ways" way_descr check_way
119 -- Read the dictionary
120 -- The next word in the file is a pointer to where the dictionary is
121 -- (probably at the end of the file)
122 dict_p <- Binary.get bh
123 data_p <- tellBin bh -- Remember where we are now
125 dict <- getDictionary bh
126 seekBin bh data_p -- Back to where we were before
128 -- Initialise the user-data field of bh
129 ud <- newReadState dict
130 bh <- return (setUserData bh ud)
132 symtab_p <- Binary.get bh -- Get the symtab ptr
133 data_p <- tellBin bh -- Remember where we are now
135 symtab <- getSymbolTable bh update_nc
136 seekBin bh data_p -- Back to where we were before
137 let ud = getUserData bh
138 bh <- return $! setUserData bh ud{ud_symtab = symtab}
143 writeBinIface :: DynFlags -> FilePath -> ModIface -> IO ()
144 writeBinIface dflags hi_path mod_iface = do
145 bh <- openBinMem initBinMemSize
146 put_ bh binaryInterfaceMagic
148 -- dummy 32/64-bit field before the version/way for
149 -- compatibility with older interface file formats.
150 -- See Note [dummy iface field] above.
152 then Binary.put_ bh (0 :: Word32)
153 else Binary.put_ bh (0 :: Word64)
155 -- The version and way descriptor go next
156 put_ bh (show opt_HiVersion)
157 let way_descr = getWayDescr dflags
160 -- Remember where the dictionary pointer will go
161 dict_p_p <- tellBin bh
162 put_ bh dict_p_p -- Placeholder for ptr to dictionary
164 -- Remember where the symbol table pointer will go
165 symtab_p_p <- tellBin bh
168 -- Make some intial state
169 symtab_next <- newFastMutInt
170 writeFastMutInt symtab_next 0
171 symtab_map <- newIORef emptyUFM
172 let bin_symtab = BinSymbolTable {
173 bin_symtab_next = symtab_next,
174 bin_symtab_map = symtab_map }
175 dict_next_ref <- newFastMutInt
176 writeFastMutInt dict_next_ref 0
177 dict_map_ref <- newIORef emptyUFM
178 let bin_dict = BinDictionary {
179 bin_dict_next = dict_next_ref,
180 bin_dict_map = dict_map_ref }
181 ud <- newWriteState (putName bin_symtab) (putFastString bin_dict)
183 -- Put the main thing,
184 bh <- return $ setUserData bh ud
187 -- Write the symtab pointer at the fornt of the file
188 symtab_p <- tellBin bh -- This is where the symtab will start
189 putAt bh symtab_p_p symtab_p -- Fill in the placeholder
190 seekBin bh symtab_p -- Seek back to the end of the file
192 -- Write the symbol table itself
193 symtab_next <- readFastMutInt symtab_next
194 symtab_map <- readIORef symtab_map
195 putSymbolTable bh symtab_next symtab_map
196 debugTraceMsg dflags 3 (text "writeBinIface:" <+> int symtab_next
199 -- NB. write the dictionary after the symbol table, because
200 -- writing the symbol table may create more dictionary entries.
202 -- Write the dictionary pointer at the fornt of the file
203 dict_p <- tellBin bh -- This is where the dictionary will start
204 putAt bh dict_p_p dict_p -- Fill in the placeholder
205 seekBin bh dict_p -- Seek back to the end of the file
207 -- Write the dictionary itself
208 dict_next <- readFastMutInt dict_next_ref
209 dict_map <- readIORef dict_map_ref
210 putDictionary bh dict_next dict_map
211 debugTraceMsg dflags 3 (text "writeBinIface:" <+> int dict_next
212 <+> text "dict entries")
214 -- And send the result to the file
215 writeBinMem bh hi_path
217 initBinMemSize :: Int
218 initBinMemSize = 1024 * 1024
220 -- The *host* architecture version:
221 #include "../includes/MachDeps.h"
223 binaryInterfaceMagic :: Word32
224 #if WORD_SIZE_IN_BITS == 32
225 binaryInterfaceMagic = 0x1face
226 #elif WORD_SIZE_IN_BITS == 64
227 binaryInterfaceMagic = 0x1face64
230 -- -----------------------------------------------------------------------------
233 putSymbolTable :: BinHandle -> Int -> UniqFM (Int,Name) -> IO ()
234 putSymbolTable bh next_off symtab = do
236 let names = elems (array (0,next_off-1) (eltsUFM symtab))
237 mapM_ (\n -> serialiseName bh n symtab) names
239 getSymbolTable :: BinHandle -> NameCacheUpdater (Array Int Name)
240 -> IO (Array Int Name)
241 getSymbolTable bh update_namecache = do
243 od_names <- sequence (replicate sz (get bh))
244 update_namecache $ \namecache ->
246 arr = listArray (0,sz-1) names
247 (namecache', names) =
248 mapAccumR (fromOnDiskName arr) namecache od_names
251 type OnDiskName = (PackageId, ModuleName, OccName)
258 fromOnDiskName _ nc (pid, mod_name, occ) =
260 mod = mkModule pid mod_name
263 case lookupOrigNameCache cache mod occ of
264 Just name -> (nc, name)
266 case takeUniqFromSupply (nsUniqs nc) of
269 name = mkExternalName uniq mod occ noSrcSpan
270 new_cache = extendNameCache cache mod occ name
272 ( nc{ nsUniqs = us, nsNames = new_cache }, name )
274 serialiseName :: BinHandle -> Name -> UniqFM (Int,Name) -> IO ()
275 serialiseName bh name _ = do
276 let mod = ASSERT2( isExternalName name, ppr name ) nameModule name
277 put_ bh (modulePackageId mod, moduleName mod, nameOccName name)
280 putName :: BinSymbolTable -> BinHandle -> Name -> IO ()
281 putName BinSymbolTable{
282 bin_symtab_map = symtab_map_ref,
283 bin_symtab_next = symtab_next } bh name
285 symtab_map <- readIORef symtab_map_ref
286 case lookupUFM symtab_map name of
287 Just (off,_) -> put_ bh (fromIntegral off :: Word32)
289 off <- readFastMutInt symtab_next
290 writeFastMutInt symtab_next (off+1)
291 writeIORef symtab_map_ref
292 $! addToUFM symtab_map name (off,name)
293 put_ bh (fromIntegral off :: Word32)
296 data BinSymbolTable = BinSymbolTable {
297 bin_symtab_next :: !FastMutInt, -- The next index to use
298 bin_symtab_map :: !(IORef (UniqFM (Int,Name)))
303 putFastString :: BinDictionary -> BinHandle -> FastString -> IO ()
304 putFastString BinDictionary { bin_dict_next = j_r,
305 bin_dict_map = out_r} bh f
307 out <- readIORef out_r
308 let uniq = getUnique f
309 case lookupUFM out uniq of
310 Just (j, _) -> put_ bh (fromIntegral j :: Word32)
312 j <- readFastMutInt j_r
313 put_ bh (fromIntegral j :: Word32)
314 writeFastMutInt j_r (j + 1)
315 writeIORef out_r $! addToUFM out uniq (j, f)
318 data BinDictionary = BinDictionary {
319 bin_dict_next :: !FastMutInt, -- The next index to use
320 bin_dict_map :: !(IORef (UniqFM (Int,FastString)))
321 -- indexed by FastString
324 -- -----------------------------------------------------------------------------
325 -- All the binary instances
328 {-! for IPName derive: Binary !-}
329 {-! for Fixity derive: Binary !-}
330 {-! for FixityDirection derive: Binary !-}
331 {-! for Boxity derive: Binary !-}
332 {-! for StrictnessMark derive: Binary !-}
333 {-! for Activation derive: Binary !-}
336 {-! for Demand derive: Binary !-}
337 {-! for Demands derive: Binary !-}
338 {-! for DmdResult derive: Binary !-}
339 {-! for StrictSig derive: Binary !-}
342 {-! for DefMeth derive: Binary !-}
345 {-! for HsPred derive: Binary !-}
346 {-! for HsType derive: Binary !-}
347 {-! for TupCon derive: Binary !-}
348 {-! for HsTyVarBndr derive: Binary !-}
351 {-! for UfExpr derive: Binary !-}
352 {-! for UfConAlt derive: Binary !-}
353 {-! for UfBinding derive: Binary !-}
354 {-! for UfBinder derive: Binary !-}
355 {-! for HsIdInfo derive: Binary !-}
356 {-! for UfNote derive: Binary !-}
359 {-! for ConDetails derive: Binary !-}
360 {-! for BangType derive: Binary !-}
363 {-! for IsCafCC derive: Binary !-}
364 {-! for IsDupdCC derive: Binary !-}
365 {-! for CostCentre derive: Binary !-}
369 -- ---------------------------------------------------------------------------
370 -- Reading a binary interface into ParsedIface
372 instance Binary ModIface where
376 mi_iface_hash= iface_hash,
377 mi_mod_hash = mod_hash,
379 mi_finsts = hasFamInsts,
382 mi_exports = exports,
383 mi_exp_hash = exp_hash,
384 mi_fixities = fixities,
389 mi_fam_insts = fam_insts,
391 mi_orphan_hash = orphan_hash,
392 mi_vect_info = vect_info,
393 mi_hpc = hpc_info }) = do
421 hasFamInsts <- get bh
423 usages <- {-# SCC "bin_usages" #-} lazyGet bh
424 exports <- {-# SCC "bin_exports" #-} get bh
426 fixities <- {-# SCC "bin_fixities" #-} get bh
427 warns <- {-# SCC "bin_warns" #-} lazyGet bh
428 anns <- {-# SCC "bin_anns" #-} lazyGet bh
429 decls <- {-# SCC "bin_tycldecls" #-} get bh
430 insts <- {-# SCC "bin_insts" #-} get bh
431 fam_insts <- {-# SCC "bin_fam_insts" #-} get bh
432 rules <- {-# SCC "bin_rules" #-} lazyGet bh
433 orphan_hash <- get bh
437 mi_module = mod_name,
439 mi_iface_hash = iface_hash,
440 mi_mod_hash = mod_hash,
442 mi_finsts = hasFamInsts,
445 mi_exports = exports,
446 mi_exp_hash = exp_hash,
448 mi_fixities = fixities,
451 mi_globals = Nothing,
453 mi_fam_insts = fam_insts,
455 mi_orphan_hash = orphan_hash,
456 mi_vect_info = vect_info,
458 -- And build the cached values
459 mi_warn_fn = mkIfaceWarnCache warns,
460 mi_fix_fn = mkIfaceFixCache fixities,
461 mi_hash_fn = mkIfaceHashCache decls })
463 getWayDescr :: DynFlags -> String
465 | cGhcUnregisterised == "YES" = 'u':tag
467 where tag = buildTag dflags
468 -- if this is an unregisterised build, make sure our interfaces
469 -- can't be used by a registerised build.
471 -------------------------------------------------------------------------
472 -- Types from: HscTypes
473 -------------------------------------------------------------------------
475 instance Binary Dependencies where
476 put_ bh deps = do put_ bh (dep_mods deps)
477 put_ bh (dep_pkgs deps)
478 put_ bh (dep_orphs deps)
479 put_ bh (dep_finsts deps)
481 get bh = do ms <- get bh
485 return (Deps { dep_mods = ms, dep_pkgs = ps, dep_orphs = os,
488 instance (Binary name) => Binary (GenAvailInfo name) where
489 put_ bh (Avail aa) = do
492 put_ bh (AvailTC ab ac) = do
503 return (AvailTC ab ac)
505 instance Binary Usage where
506 put_ bh usg@UsagePackageModule{} = do
508 put_ bh (usg_mod usg)
509 put_ bh (usg_mod_hash usg)
510 put_ bh usg@UsageHomeModule{} = do
512 put_ bh (usg_mod_name usg)
513 put_ bh (usg_mod_hash usg)
514 put_ bh (usg_exports usg)
515 put_ bh (usg_entities usg)
523 return UsagePackageModule { usg_mod = nm, usg_mod_hash = mod }
529 return UsageHomeModule { usg_mod_name = nm, usg_mod_hash = mod,
530 usg_exports = exps, usg_entities = ents }
532 instance Binary Warnings where
533 put_ bh NoWarnings = putByte bh 0
534 put_ bh (WarnAll t) = do
537 put_ bh (WarnSome ts) = do
544 0 -> return NoWarnings
550 instance Binary WarningTxt where
551 put_ bh (WarningTxt w) = do
554 put_ bh (DeprecatedTxt d) = do
562 return (WarningTxt w)
564 return (DeprecatedTxt d)
566 -------------------------------------------------------------------------
567 -- Types from: BasicTypes
568 -------------------------------------------------------------------------
570 instance Binary Activation where
571 put_ bh NeverActive = do
573 put_ bh AlwaysActive = do
575 put_ bh (ActiveBefore aa) = do
578 put_ bh (ActiveAfter ab) = do
584 0 -> do return NeverActive
585 1 -> do return AlwaysActive
587 return (ActiveBefore aa)
589 return (ActiveAfter ab)
591 instance Binary RuleMatchInfo where
592 put_ bh FunLike = putByte bh 0
593 put_ bh ConLike = putByte bh 1
596 if h == 1 then return ConLike
599 instance Binary InlinePragma where
600 put_ bh (InlinePragma a b c d) = do
611 return (InlinePragma a b c d)
613 instance Binary InlineSpec where
614 put_ bh EmptyInlineSpec = putByte bh 0
615 put_ bh Inline = putByte bh 1
616 put_ bh Inlinable = putByte bh 2
617 put_ bh NoInline = putByte bh 3
619 get bh = do h <- getByte bh
621 0 -> return EmptyInlineSpec
623 2 -> return Inlinable
626 instance Binary HsBang where
627 put_ bh HsNoBang = putByte bh 0
628 put_ bh HsStrict = putByte bh 1
629 put_ bh HsUnpack = putByte bh 2
630 put_ bh HsUnpackFailed = putByte bh 3
634 0 -> do return HsNoBang
635 1 -> do return HsStrict
636 2 -> do return HsUnpack
637 _ -> do return HsUnpackFailed
639 instance Binary Boxity where
640 put_ bh Boxed = putByte bh 0
641 put_ bh Unboxed = putByte bh 1
646 _ -> do return Unboxed
648 instance Binary TupCon where
649 put_ bh (TupCon ab ac) = do
655 return (TupCon ab ac)
657 instance Binary RecFlag where
658 put_ bh Recursive = do
660 put_ bh NonRecursive = do
665 0 -> do return Recursive
666 _ -> do return NonRecursive
668 instance Binary DefMethSpec where
669 put_ bh NoDM = putByte bh 0
670 put_ bh VanillaDM = putByte bh 1
671 put_ bh GenericDM = putByte bh 2
676 1 -> return VanillaDM
677 _ -> return GenericDM
679 instance Binary FixityDirection where
689 0 -> do return InfixL
690 1 -> do return InfixR
691 _ -> do return InfixN
693 instance Binary Fixity where
694 put_ bh (Fixity aa ab) = do
700 return (Fixity aa ab)
702 instance (Binary name) => Binary (IPName name) where
703 put_ bh (IPName aa) = put_ bh aa
704 get bh = do aa <- get bh
707 -------------------------------------------------------------------------
708 -- Types from: Demand
709 -------------------------------------------------------------------------
711 instance Binary DmdType where
712 -- Ignore DmdEnv when spitting out the DmdType
713 put bh (DmdType _ ds dr) = do p <- put bh ds; put_ bh dr; return (castBin p)
714 get bh = do ds <- get bh; dr <- get bh; return (DmdType emptyVarEnv ds dr)
716 instance Binary Demand where
721 put_ bh (Call aa) = do
724 put_ bh (Eval ab) = do
727 put_ bh (Defer ac) = do
730 put_ bh (Box ad) = do
750 instance Binary Demands where
751 put_ bh (Poly aa) = do
754 put_ bh (Prod ab) = do
765 instance Binary DmdResult where
775 0 -> do return TopRes
776 1 -> do return RetCPR -- Really use RetCPR even if -fcpr-off
777 -- The wrapper was generated for CPR in
778 -- the imported module!
779 _ -> do return BotRes
781 instance Binary StrictSig where
782 put_ bh (StrictSig aa) = do
786 return (StrictSig aa)
789 -------------------------------------------------------------------------
790 -- Types from: CostCentre
791 -------------------------------------------------------------------------
793 instance Binary IsCafCC where
796 put_ bh NotCafCC = do
802 _ -> do return NotCafCC
804 instance Binary IsDupdCC where
805 put_ bh OriginalCC = do
812 0 -> do return OriginalCC
813 _ -> do return DupdCC
815 instance Binary CostCentre where
816 put_ bh NoCostCentre = do
818 put_ bh (NormalCC aa ab ac ad) = do
824 put_ bh (AllCafsCC ae) = do
830 0 -> do return NoCostCentre
835 return (NormalCC aa ab ac ad)
837 return (AllCafsCC ae)
839 -------------------------------------------------------------------------
840 -- IfaceTypes and friends
841 -------------------------------------------------------------------------
843 instance Binary IfaceBndr where
844 put_ bh (IfaceIdBndr aa) = do
847 put_ bh (IfaceTvBndr ab) = do
854 return (IfaceIdBndr aa)
856 return (IfaceTvBndr ab)
858 instance Binary IfaceLetBndr where
859 put_ bh (IfLetBndr a b c) = do
863 get bh = do a <- get bh
866 return (IfLetBndr a b c)
868 instance Binary IfaceType where
869 put_ bh (IfaceForAllTy aa ab) = do
873 put_ bh (IfaceTyVar ad) = do
876 put_ bh (IfaceAppTy ae af) = do
880 put_ bh (IfaceFunTy ag ah) = do
884 put_ bh (IfacePredTy aq) = do
888 -- Simple compression for common cases of TyConApp
889 put_ bh (IfaceTyConApp IfaceIntTc []) = putByte bh 6
890 put_ bh (IfaceTyConApp IfaceCharTc []) = putByte bh 7
891 put_ bh (IfaceTyConApp IfaceBoolTc []) = putByte bh 8
892 put_ bh (IfaceTyConApp IfaceListTc [ty]) = do { putByte bh 9; put_ bh ty }
893 -- Unit tuple and pairs
894 put_ bh (IfaceTyConApp (IfaceTupTc Boxed 0) []) = putByte bh 10
895 put_ bh (IfaceTyConApp (IfaceTupTc Boxed 2) [t1,t2]) = do { putByte bh 11; put_ bh t1; put_ bh t2 }
897 put_ bh (IfaceTyConApp IfaceLiftedTypeKindTc []) = putByte bh 12
898 put_ bh (IfaceTyConApp IfaceOpenTypeKindTc []) = putByte bh 13
899 put_ bh (IfaceTyConApp IfaceUnliftedTypeKindTc []) = putByte bh 14
900 put_ bh (IfaceTyConApp IfaceUbxTupleKindTc []) = putByte bh 15
901 put_ bh (IfaceTyConApp IfaceArgTypeKindTc []) = putByte bh 16
902 put_ bh (IfaceTyConApp (IfaceAnyTc k) []) = do { putByte bh 17; put_ bh k }
906 put_ bh (IfaceTyConApp (IfaceTc tc) tys) = do { putByte bh 18; put_ bh tc; put_ bh tys }
907 put_ bh (IfaceTyConApp tc tys) = do { putByte bh 19; put_ bh tc; put_ bh tys }
914 return (IfaceForAllTy aa ab)
916 return (IfaceTyVar ad)
919 return (IfaceAppTy ae af)
922 return (IfaceFunTy ag ah)
924 return (IfacePredTy ap)
926 -- Now the special cases for TyConApp
927 6 -> return (IfaceTyConApp IfaceIntTc [])
928 7 -> return (IfaceTyConApp IfaceCharTc [])
929 8 -> return (IfaceTyConApp IfaceBoolTc [])
930 9 -> do { ty <- get bh; return (IfaceTyConApp IfaceListTc [ty]) }
931 10 -> return (IfaceTyConApp (IfaceTupTc Boxed 0) [])
932 11 -> do { t1 <- get bh; t2 <- get bh; return (IfaceTyConApp (IfaceTupTc Boxed 2) [t1,t2]) }
933 12 -> return (IfaceTyConApp IfaceLiftedTypeKindTc [])
934 13 -> return (IfaceTyConApp IfaceOpenTypeKindTc [])
935 14 -> return (IfaceTyConApp IfaceUnliftedTypeKindTc [])
936 15 -> return (IfaceTyConApp IfaceUbxTupleKindTc [])
937 16 -> return (IfaceTyConApp IfaceArgTypeKindTc [])
938 17 -> do { k <- get bh; return (IfaceTyConApp (IfaceAnyTc k) []) }
940 18 -> do { tc <- get bh; tys <- get bh; return (IfaceTyConApp (IfaceTc tc) tys) }
941 _ -> do { tc <- get bh; tys <- get bh; return (IfaceTyConApp tc tys) }
943 instance Binary IfaceTyCon where
944 -- Int,Char,Bool can't show up here because they can't not be saturated
946 put_ bh IfaceIntTc = putByte bh 1
947 put_ bh IfaceBoolTc = putByte bh 2
948 put_ bh IfaceCharTc = putByte bh 3
949 put_ bh IfaceListTc = putByte bh 4
950 put_ bh IfacePArrTc = putByte bh 5
951 put_ bh IfaceLiftedTypeKindTc = putByte bh 6
952 put_ bh IfaceOpenTypeKindTc = putByte bh 7
953 put_ bh IfaceUnliftedTypeKindTc = putByte bh 8
954 put_ bh IfaceUbxTupleKindTc = putByte bh 9
955 put_ bh IfaceArgTypeKindTc = putByte bh 10
956 put_ bh (IfaceTupTc bx ar) = do { putByte bh 11; put_ bh bx; put_ bh ar }
957 put_ bh (IfaceTc ext) = do { putByte bh 12; put_ bh ext }
958 put_ bh (IfaceAnyTc k) = do { putByte bh 13; put_ bh k }
963 1 -> return IfaceIntTc
964 2 -> return IfaceBoolTc
965 3 -> return IfaceCharTc
966 4 -> return IfaceListTc
967 5 -> return IfacePArrTc
968 6 -> return IfaceLiftedTypeKindTc
969 7 -> return IfaceOpenTypeKindTc
970 8 -> return IfaceUnliftedTypeKindTc
971 9 -> return IfaceUbxTupleKindTc
972 10 -> return IfaceArgTypeKindTc
973 11 -> do { bx <- get bh; ar <- get bh; return (IfaceTupTc bx ar) }
974 12 -> do { ext <- get bh; return (IfaceTc ext) }
975 _ -> do { k <- get bh; return (IfaceAnyTc k) }
977 instance Binary IfacePredType where
978 put_ bh (IfaceClassP aa ab) = do
982 put_ bh (IfaceIParam ac ad) = do
986 put_ bh (IfaceEqPred ac ad) = do
995 return (IfaceClassP aa ab)
998 return (IfaceIParam ac ad)
1001 return (IfaceEqPred ac ad)
1002 _ -> panic ("get IfacePredType " ++ show h)
1004 -------------------------------------------------------------------------
1005 -- IfaceExpr and friends
1006 -------------------------------------------------------------------------
1008 instance Binary IfaceExpr where
1009 put_ bh (IfaceLcl aa) = do
1012 put_ bh (IfaceType ab) = do
1015 put_ bh (IfaceTuple ac ad) = do
1019 put_ bh (IfaceLam ae af) = do
1023 put_ bh (IfaceApp ag ah) = do
1028 put_ bh (IfaceCase ai aj al ak) = do
1035 put_ bh (IfaceLet al am) = do
1039 put_ bh (IfaceNote an ao) = do
1043 put_ bh (IfaceLit ap) = do
1046 put_ bh (IfaceFCall as at) = do
1050 put_ bh (IfaceExt aa) = do
1053 put_ bh (IfaceCast ie ico) = do
1057 put_ bh (IfaceTick m ix) = do
1064 0 -> do aa <- get bh
1065 return (IfaceLcl aa)
1066 1 -> do ab <- get bh
1067 return (IfaceType ab)
1068 2 -> do ac <- get bh
1070 return (IfaceTuple ac ad)
1071 3 -> do ae <- get bh
1073 return (IfaceLam ae af)
1074 4 -> do ag <- get bh
1076 return (IfaceApp ag ah)
1077 5 -> do ai <- get bh
1083 return (IfaceCase ai aj al ak)
1084 6 -> do al <- get bh
1086 return (IfaceLet al am)
1087 7 -> do an <- get bh
1089 return (IfaceNote an ao)
1090 8 -> do ap <- get bh
1091 return (IfaceLit ap)
1092 9 -> do as <- get bh
1094 return (IfaceFCall as at)
1095 10 -> do aa <- get bh
1096 return (IfaceExt aa)
1097 11 -> do ie <- get bh
1099 return (IfaceCast ie ico)
1100 12 -> do m <- get bh
1102 return (IfaceTick m ix)
1103 _ -> panic ("get IfaceExpr " ++ show h)
1105 instance Binary IfaceConAlt where
1106 put_ bh IfaceDefault = do
1108 put_ bh (IfaceDataAlt aa) = do
1111 put_ bh (IfaceTupleAlt ab) = do
1114 put_ bh (IfaceLitAlt ac) = do
1120 0 -> do return IfaceDefault
1121 1 -> do aa <- get bh
1122 return (IfaceDataAlt aa)
1123 2 -> do ab <- get bh
1124 return (IfaceTupleAlt ab)
1125 _ -> do ac <- get bh
1126 return (IfaceLitAlt ac)
1128 instance Binary IfaceBinding where
1129 put_ bh (IfaceNonRec aa ab) = do
1133 put_ bh (IfaceRec ac) = do
1139 0 -> do aa <- get bh
1141 return (IfaceNonRec aa ab)
1142 _ -> do ac <- get bh
1143 return (IfaceRec ac)
1145 instance Binary IfaceIdDetails where
1146 put_ bh IfVanillaId = putByte bh 0
1147 put_ bh (IfRecSelId a b) = do { putByte bh 1; put_ bh a; put_ bh b }
1148 put_ bh IfDFunId = putByte bh 2
1152 0 -> return IfVanillaId
1155 return (IfRecSelId a b)
1156 _ -> return IfDFunId
1158 instance Binary IfaceIdInfo where
1159 put_ bh NoInfo = putByte bh 0
1160 put_ bh (HasInfo i) = do
1162 lazyPut bh i -- NB lazyPut
1168 _ -> do info <- lazyGet bh -- NB lazyGet
1169 return (HasInfo info)
1171 instance Binary IfaceInfoItem where
1172 put_ bh (HsArity aa) = do
1175 put_ bh (HsStrictness ab) = do
1178 put_ bh (HsUnfold lb ad) = do
1182 put_ bh (HsInline ad) = do
1185 put_ bh HsNoCafRefs = do
1190 0 -> do aa <- get bh
1192 1 -> do ab <- get bh
1193 return (HsStrictness ab)
1194 2 -> do lb <- get bh
1196 return (HsUnfold lb ad)
1197 3 -> do ad <- get bh
1198 return (HsInline ad)
1199 _ -> do return HsNoCafRefs
1201 instance Binary IfaceUnfolding where
1202 put_ bh (IfCoreUnfold s e) = do
1206 put_ bh (IfInlineRule a b c d) = do
1212 put_ bh (IfLclWrapper a n) = do
1216 put_ bh (IfExtWrapper a n) = do
1220 put_ bh (IfDFunUnfold as) = do
1223 put_ bh (IfCompulsory e) = do
1231 return (IfCoreUnfold s e)
1236 return (IfInlineRule a b c d)
1239 return (IfLclWrapper a n)
1242 return (IfExtWrapper a n)
1243 4 -> do as <- get bh
1244 return (IfDFunUnfold as)
1246 return (IfCompulsory e)
1248 instance Binary IfaceNote where
1249 put_ bh (IfaceSCC aa) = do
1252 put_ bh (IfaceCoreNote s) = do
1258 0 -> do aa <- get bh
1259 return (IfaceSCC aa)
1260 4 -> do ac <- get bh
1261 return (IfaceCoreNote ac)
1262 _ -> panic ("get IfaceNote " ++ show h)
1264 -------------------------------------------------------------------------
1265 -- IfaceDecl and friends
1266 -------------------------------------------------------------------------
1268 -- A bit of magic going on here: there's no need to store the OccName
1269 -- for a decl on the disk, since we can infer the namespace from the
1270 -- context; however it is useful to have the OccName in the IfaceDecl
1271 -- to avoid re-building it in various places. So we build the OccName
1272 -- when de-serialising.
1274 instance Binary IfaceDecl where
1275 put_ bh (IfaceId name ty details idinfo) = do
1277 put_ bh (occNameFS name)
1281 put_ _ (IfaceForeign _ _) =
1282 error "Binary.put_(IfaceDecl): IfaceForeign"
1283 put_ bh (IfaceData a1 a2 a3 a4 a5 a6 a7 a8) = do
1285 put_ bh (occNameFS a1)
1293 put_ bh (IfaceSyn a1 a2 a3 a4 a5) = do
1295 put_ bh (occNameFS a1)
1300 put_ bh (IfaceClass a1 a2 a3 a4 a5 a6 a7) = do
1303 put_ bh (occNameFS a2)
1312 0 -> do name <- get bh
1316 occ <- return $! mkOccNameFS varName name
1317 return (IfaceId occ ty details idinfo)
1318 1 -> error "Binary.get(TyClDecl): ForeignType"
1328 occ <- return $! mkOccNameFS tcName a1
1329 return (IfaceData occ a2 a3 a4 a5 a6 a7 a8)
1336 occ <- return $! mkOccNameFS tcName a1
1337 return (IfaceSyn occ a2 a3 a4 a5)
1346 occ <- return $! mkOccNameFS clsName a2
1347 return (IfaceClass a1 occ a3 a4 a5 a6 a7)
1349 instance Binary IfaceInst where
1350 put_ bh (IfaceInst cls tys dfun flag orph) = do
1356 get bh = do cls <- get bh
1361 return (IfaceInst cls tys dfun flag orph)
1363 instance Binary IfaceFamInst where
1364 put_ bh (IfaceFamInst fam tys tycon) = do
1368 get bh = do fam <- get bh
1371 return (IfaceFamInst fam tys tycon)
1373 instance Binary OverlapFlag where
1374 put_ bh NoOverlap = putByte bh 0
1375 put_ bh OverlapOk = putByte bh 1
1376 put_ bh Incoherent = putByte bh 2
1377 get bh = do h <- getByte bh
1379 0 -> return NoOverlap
1380 1 -> return OverlapOk
1381 2 -> return Incoherent
1382 _ -> panic ("get OverlapFlag " ++ show h)
1384 instance Binary IfaceConDecls where
1385 put_ bh IfAbstractTyCon = putByte bh 0
1386 put_ bh IfOpenDataTyCon = putByte bh 1
1387 put_ bh (IfDataTyCon cs) = do { putByte bh 2
1389 put_ bh (IfNewTyCon c) = do { putByte bh 3
1394 0 -> return IfAbstractTyCon
1395 1 -> return IfOpenDataTyCon
1396 2 -> do cs <- get bh
1397 return (IfDataTyCon cs)
1398 _ -> do aa <- get bh
1399 return (IfNewTyCon aa)
1401 instance Binary IfaceConDecl where
1402 put_ bh (IfCon a1 a2 a3 a4 a5 a6 a7 a8 a9 a10) = do
1413 get bh = do a1 <- get bh
1423 return (IfCon a1 a2 a3 a4 a5 a6 a7 a8 a9 a10)
1425 instance Binary IfaceClassOp where
1426 put_ bh (IfaceClassOp n def ty) = do
1427 put_ bh (occNameFS n)
1434 occ <- return $! mkOccNameFS varName n
1435 return (IfaceClassOp occ def ty)
1437 instance Binary IfaceRule where
1438 put_ bh (IfaceRule a1 a2 a3 a4 a5 a6 a7 a8) = do
1456 return (IfaceRule a1 a2 a3 a4 a5 a6 a7 a8)
1458 instance Binary IfaceAnnotation where
1459 put_ bh (IfaceAnnotation a1 a2) = do
1465 return (IfaceAnnotation a1 a2)
1467 instance Binary name => Binary (AnnTarget name) where
1468 put_ bh (NamedTarget a) = do
1471 put_ bh (ModuleTarget a) = do
1478 return (NamedTarget a)
1480 return (ModuleTarget a)
1482 instance Binary IfaceVectInfo where
1483 put_ bh (IfaceVectInfo a1 a2 a3) = do
1491 return (IfaceVectInfo a1 a2 a3)