1 {-% DrIFT (Automatic class derivations for Haskell) v1.1 %-}
2 {-% DrIFT (Automatic class derivations for Haskell) v1.1 %-}
4 -- (c) The University of Glasgow 2002
6 -- Binary interface file support.
8 module BinIface ( writeBinIface, readBinIface, v_IgnoreHiWay ) where
10 #include "HsVersions.h"
17 import Class ( DefMeth(..) )
19 import Module ( moduleName, mkModule )
20 import DriverState ( v_Build_tag )
21 import CmdLineOpts ( opt_HiVersion )
22 import Kind ( Kind(..) )
28 import EXCEPTION ( throwDyn )
32 #include "HsVersions.h"
34 -- ---------------------------------------------------------------------------
35 writeBinIface :: FilePath -> ModIface -> IO ()
36 writeBinIface hi_path mod_iface
37 = putBinFileWithDict hi_path mod_iface
39 readBinIface :: FilePath -> IO ModIface
40 readBinIface hi_path = getBinFileWithDict hi_path
43 -- %*********************************************************
45 -- All the Binary instances
47 -- %*********************************************************
50 {-! for IPName derive: Binary !-}
51 {-! for Fixity derive: Binary !-}
52 {-! for FixityDirection derive: Binary !-}
53 {-! for Boxity derive: Binary !-}
54 {-! for StrictnessMark derive: Binary !-}
55 {-! for Activation derive: Binary !-}
58 {-! for Demand derive: Binary !-}
59 {-! for Demands derive: Binary !-}
60 {-! for DmdResult derive: Binary !-}
61 {-! for StrictSig derive: Binary !-}
64 {-! for DefMeth derive: Binary !-}
67 {-! for HsPred derive: Binary !-}
68 {-! for HsType derive: Binary !-}
69 {-! for TupCon derive: Binary !-}
70 {-! for HsTyVarBndr derive: Binary !-}
73 {-! for UfExpr derive: Binary !-}
74 {-! for UfConAlt derive: Binary !-}
75 {-! for UfBinding derive: Binary !-}
76 {-! for UfBinder derive: Binary !-}
77 {-! for HsIdInfo derive: Binary !-}
78 {-! for UfNote derive: Binary !-}
81 {-! for ConDetails derive: Binary !-}
82 {-! for BangType derive: Binary !-}
85 {-! for IsCafCC derive: Binary !-}
86 {-! for IsDupdCC derive: Binary !-}
87 {-! for CostCentre derive: Binary !-}
91 -- ---------------------------------------------------------------------------
92 -- Reading a binary interface into ParsedIface
94 instance Binary ModIface where
97 mi_mod_vers = mod_vers,
98 mi_package = pkg_name,
102 mi_exports = exports,
103 mi_exp_vers = exp_vers,
104 mi_fixities = fixities,
105 mi_deprecs = deprecs,
109 mi_rule_vers = rule_vers }) = do
110 put_ bh (show opt_HiVersion)
111 build_tag <- readIORef v_Build_tag
114 put_ bh (moduleName mod)
130 let our_ver = show opt_HiVersion
131 when (check_ver /= our_ver) $
132 -- use userError because this will be caught by readIface
133 -- which will emit an error msg containing the iface module name.
134 throwDyn (ProgramError (
135 "mismatched interface file versions: expected "
136 ++ our_ver ++ ", found " ++ check_ver))
139 ignore_way <- readIORef v_IgnoreHiWay
140 build_tag <- readIORef v_Build_tag
141 when (not ignore_way && check_way /= build_tag) $
142 -- use userError because this will be caught by readIface
143 -- which will emit an error msg containing the iface module name.
144 throwDyn (ProgramError (
145 "mismatched interface file ways: expected "
146 ++ build_tag ++ ", found " ++ check_way))
154 usages <- {-# SCC "bin_usages" #-} lazyGet bh
155 exports <- {-# SCC "bin_exports" #-} get bh
157 fixities <- {-# SCC "bin_fixities" #-} get bh
158 deprecs <- {-# SCC "bin_deprecs" #-} lazyGet bh
159 decls <- {-# SCC "bin_tycldecls" #-} get bh
160 insts <- {-# SCC "bin_insts" #-} get bh
161 rules <- {-# SCC "bin_rules" #-} lazyGet bh
164 mi_package = pkg_name,
165 mi_module = mkModule pkg_name mod_name,
166 -- We write the module as a ModuleName, becuase whether
167 -- or not it's a home-package module depends on the importer
168 -- mkModule reconstructs the Module, by comparing the static
169 -- opt_InPackage flag with the package name in the interface file
170 mi_mod_vers = mod_vers,
171 mi_boot = False, -- Binary interfaces are never .hi-boot files!
175 mi_exports = exports,
176 mi_exp_vers = exp_vers,
177 mi_fixities = fixities,
178 mi_deprecs = deprecs,
182 mi_rule_vers = rule_vers,
183 -- And build the cached values
184 mi_dep_fn = mkIfaceDepCache deprecs,
185 mi_fix_fn = mkIfaceFixCache fixities,
186 mi_ver_fn = mkIfaceVerCache decls })
188 GLOBAL_VAR(v_IgnoreHiWay, False, Bool)
190 -------------------------------------------------------------------------
191 -- Types from: HscTypes
192 -------------------------------------------------------------------------
194 instance Binary Dependencies where
195 put_ bh deps = do put_ bh (dep_mods deps)
196 put_ bh (dep_pkgs deps)
197 put_ bh (dep_orphs deps)
199 get bh = do ms <- get bh
202 return (Deps { dep_mods = ms, dep_pkgs = ps, dep_orphs = os })
204 instance (Binary name) => Binary (GenAvailInfo name) where
205 put_ bh (Avail aa) = do
208 put_ bh (AvailTC ab ac) = do
219 return (AvailTC ab ac)
221 instance Binary Usage where
223 put_ bh (usg_name usg)
224 put_ bh (usg_mod usg)
225 put_ bh (usg_exports usg)
226 put_ bh (usg_entities usg)
227 put_ bh (usg_rules usg)
235 return (Usage { usg_name = nm, usg_mod = mod,
236 usg_exports = exps, usg_entities = ents,
239 instance Binary a => Binary (Deprecs a) where
240 put_ bh NoDeprecs = putByte bh 0
241 put_ bh (DeprecAll t) = do
244 put_ bh (DeprecSome ts) = do
251 0 -> return NoDeprecs
253 return (DeprecAll aa)
255 return (DeprecSome aa)
257 -------------------------------------------------------------------------
258 -- Types from: BasicTypes
259 -------------------------------------------------------------------------
261 instance Binary Activation where
262 put_ bh NeverActive = do
264 put_ bh AlwaysActive = do
266 put_ bh (ActiveBefore aa) = do
269 put_ bh (ActiveAfter ab) = do
275 0 -> do return NeverActive
276 1 -> do return AlwaysActive
278 return (ActiveBefore aa)
280 return (ActiveAfter ab)
282 instance Binary StrictnessMark where
283 put_ bh MarkedStrict = do
285 put_ bh MarkedUnboxed = do
287 put_ bh NotMarkedStrict = do
292 0 -> do return MarkedStrict
293 1 -> do return MarkedUnboxed
294 _ -> do return NotMarkedStrict
296 instance Binary Boxity where
305 _ -> do return Unboxed
307 instance Binary TupCon where
308 put_ bh (TupCon ab ac) = do
314 return (TupCon ab ac)
316 instance Binary RecFlag where
317 put_ bh Recursive = do
319 put_ bh NonRecursive = do
324 0 -> do return Recursive
325 _ -> do return NonRecursive
327 instance Binary DefMeth where
328 put_ bh NoDefMeth = putByte bh 0
329 put_ bh DefMeth = putByte bh 1
330 put_ bh GenDefMeth = putByte bh 2
334 0 -> return NoDefMeth
336 _ -> return GenDefMeth
338 instance Binary FixityDirection where
348 0 -> do return InfixL
349 1 -> do return InfixR
350 _ -> do return InfixN
352 instance Binary Fixity where
353 put_ bh (Fixity aa ab) = do
359 return (Fixity aa ab)
361 instance (Binary name) => Binary (IPName name) where
362 put_ bh (Dupable aa) = do
365 put_ bh (Linear ab) = do
376 -------------------------------------------------------------------------
377 -- Types from: Demand
378 -------------------------------------------------------------------------
380 instance Binary DmdType where
381 -- Ignore DmdEnv when spitting out the DmdType
382 put bh (DmdType _ ds dr) = do p <- put bh ds; put bh dr; return (castBin p)
383 get bh = do ds <- get bh; dr <- get bh; return (DmdType emptyVarEnv ds dr)
385 instance Binary Demand where
390 put_ bh (Call aa) = do
393 put_ bh (Eval ab) = do
396 put_ bh (Defer ac) = do
399 put_ bh (Box ad) = do
419 instance Binary Demands where
420 put_ bh (Poly aa) = do
423 put_ bh (Prod ab) = do
434 instance Binary DmdResult where
444 0 -> do return TopRes
445 1 -> do return RetCPR -- Really use RetCPR even if -fcpr-off
446 -- The wrapper was generated for CPR in
447 -- the imported module!
448 _ -> do return BotRes
450 instance Binary StrictSig where
451 put_ bh (StrictSig aa) = do
455 return (StrictSig aa)
458 -------------------------------------------------------------------------
459 -- Types from: CostCentre
460 -------------------------------------------------------------------------
462 instance Binary IsCafCC where
465 put_ bh NotCafCC = do
471 _ -> do return NotCafCC
473 instance Binary IsDupdCC where
474 put_ bh OriginalCC = do
481 0 -> do return OriginalCC
482 _ -> do return DupdCC
484 instance Binary CostCentre where
485 put_ bh NoCostCentre = do
487 put_ bh (NormalCC aa ab ac ad) = do
493 put_ bh (AllCafsCC ae) = do
499 0 -> do return NoCostCentre
504 return (NormalCC aa ab ac ad)
506 return (AllCafsCC ae)
508 -------------------------------------------------------------------------
509 -- IfaceTypes and friends
510 -------------------------------------------------------------------------
512 instance Binary IfaceExtName where
513 put_ bh (ExtPkg mod occ) = do
517 put_ bh (HomePkg mod occ vers) = do
522 put_ bh (LocalTop occ) = do
525 put_ bh (LocalTopSub occ _) = do -- Write LocalTopSub just like LocalTop
532 0 -> do mod <- get bh
534 return (ExtPkg mod occ)
535 1 -> do mod <- get bh
538 return (HomePkg mod occ vers)
539 _ -> do occ <- get bh
540 return (LocalTop occ)
542 instance Binary IfaceBndr where
543 put_ bh (IfaceIdBndr aa) = do
546 put_ bh (IfaceTvBndr ab) = do
553 return (IfaceIdBndr aa)
555 return (IfaceTvBndr ab)
557 instance Binary Kind where
558 put_ bh LiftedTypeKind = putByte bh 0
559 put_ bh UnliftedTypeKind = putByte bh 1
560 put_ bh OpenTypeKind = putByte bh 2
561 put_ bh ArgTypeKind = putByte bh 3
562 put_ bh UbxTupleKind = putByte bh 4
563 put_ bh (FunKind k1 k2) = do
567 put_ bh (KindVar kv) = pprPanic "BinIface.put_: kind var" (ppr kv)
572 0 -> return LiftedTypeKind
573 1 -> return UnliftedTypeKind
574 2 -> return OpenTypeKind
575 3 -> return ArgTypeKind
576 4 -> return UbxTupleKind
579 return (FunKind k1 k2)
581 instance Binary IfaceType where
582 put_ bh (IfaceForAllTy aa ab) = do
586 put_ bh (IfaceTyVar ad) = do
589 put_ bh (IfaceAppTy ae af) = do
593 put_ bh (IfaceFunTy ag ah) = do
597 put_ bh (IfacePredTy aq) = do
601 -- Simple compression for common cases of TyConApp
602 put_ bh (IfaceTyConApp IfaceIntTc []) = putByte bh 6
603 put_ bh (IfaceTyConApp IfaceCharTc []) = putByte bh 7
604 put_ bh (IfaceTyConApp IfaceBoolTc []) = putByte bh 8
605 put_ bh (IfaceTyConApp IfaceListTc [ty]) = do { putByte bh 9; put_ bh ty }
606 -- Unit tuple and pairs
607 put_ bh (IfaceTyConApp (IfaceTupTc Boxed 0) []) = putByte bh 10
608 put_ bh (IfaceTyConApp (IfaceTupTc Boxed 2) [t1,t2]) = do { putByte bh 11; put_ bh t1; put_ bh t2 }
610 put_ bh (IfaceTyConApp (IfaceTc tc) tys) = do { putByte bh 12; put_ bh tc; put_ bh tys }
611 put_ bh (IfaceTyConApp tc tys) = do { putByte bh 13; put_ bh tc; put_ bh tys }
618 return (IfaceForAllTy aa ab)
620 return (IfaceTyVar ad)
623 return (IfaceAppTy ae af)
626 return (IfaceFunTy ag ah)
628 return (IfacePredTy ap)
630 -- Now the special cases for TyConApp
631 6 -> return (IfaceTyConApp IfaceIntTc [])
632 7 -> return (IfaceTyConApp IfaceCharTc [])
633 8 -> return (IfaceTyConApp IfaceBoolTc [])
634 9 -> do { ty <- get bh; return (IfaceTyConApp IfaceListTc [ty]) }
635 10 -> return (IfaceTyConApp (IfaceTupTc Boxed 0) [])
636 11 -> do { t1 <- get bh; t2 <- get bh; return (IfaceTyConApp (IfaceTupTc Boxed 2) [t1,t2]) }
637 12 -> do { tc <- get bh; tys <- get bh; return (IfaceTyConApp (IfaceTc tc) tys) }
638 _ -> do { tc <- get bh; tys <- get bh; return (IfaceTyConApp tc tys) }
640 instance Binary IfaceTyCon where
641 -- Int,Char,Bool can't show up here because they can't not be saturated
642 put_ bh IfaceListTc = putByte bh 1
643 put_ bh IfacePArrTc = putByte bh 2
644 put_ bh (IfaceTupTc bx ar) = do { putByte bh 3; put_ bh bx; put_ bh ar }
645 put_ bh tc = pprPanic "BinIface.put:" (ppr tc) -- Dealt with by the IfaceType instance
650 1 -> return IfaceListTc
651 2 -> return IfacePArrTc
652 _ -> do { bx <- get bh; ar <- get bh; return (IfaceTupTc bx ar) }
654 instance Binary IfacePredType where
655 put_ bh (IfaceClassP aa ab) = do
659 put_ bh (IfaceIParam ac ad) = do
668 return (IfaceClassP aa ab)
671 return (IfaceIParam ac ad)
673 -------------------------------------------------------------------------
674 -- IfaceExpr and friends
675 -------------------------------------------------------------------------
677 instance Binary IfaceExpr where
678 put_ bh (IfaceLcl aa) = do
681 put_ bh (IfaceType ab) = do
684 put_ bh (IfaceTuple ac ad) = do
688 put_ bh (IfaceLam ae af) = do
692 put_ bh (IfaceApp ag ah) = do
696 put_ bh (IfaceCase ai aj ak) = do
701 put_ bh (IfaceLet al am) = do
705 put_ bh (IfaceNote an ao) = do
709 put_ bh (IfaceLit ap) = do
712 put_ bh (IfaceFCall as at) = do
716 put_ bh (IfaceExt aa) = do
725 return (IfaceType ab)
728 return (IfaceTuple ac ad)
731 return (IfaceLam ae af)
734 return (IfaceApp ag ah)
738 return (IfaceCase ai aj ak)
741 return (IfaceLet al am)
744 return (IfaceNote an ao)
749 return (IfaceFCall as at)
753 instance Binary IfaceConAlt where
754 put_ bh IfaceDefault = do
756 put_ bh (IfaceDataAlt aa) = do
759 put_ bh (IfaceTupleAlt ab) = do
762 put_ bh (IfaceLitAlt ac) = do
768 0 -> do return IfaceDefault
770 return (IfaceDataAlt aa)
772 return (IfaceTupleAlt ab)
774 return (IfaceLitAlt ac)
776 instance Binary IfaceBinding where
777 put_ bh (IfaceNonRec aa ab) = do
781 put_ bh (IfaceRec ac) = do
789 return (IfaceNonRec aa ab)
793 instance Binary IfaceIdInfo where
794 put_ bh NoInfo = putByte bh 0
795 put_ bh (HasInfo i) = do
803 _ -> do info <- lazyGet bh
804 return (HasInfo info)
806 instance Binary IfaceInfoItem where
807 put_ bh (HsArity aa) = do
810 put_ bh (HsStrictness ab) = do
813 put_ bh (HsUnfold ac ad) = do
817 put_ bh HsNoCafRefs = do
819 put_ bh (HsWorker ae af) = do
829 return (HsStrictness ab)
832 return (HsUnfold ac ad)
833 3 -> do return HsNoCafRefs
836 return (HsWorker ae af)
838 instance Binary IfaceNote where
839 put_ bh (IfaceSCC aa) = do
842 put_ bh (IfaceCoerce ab) = do
845 put_ bh IfaceInlineCall = do
847 put_ bh IfaceInlineMe = do
849 put_ bh (IfaceCoreNote s) = do
858 return (IfaceCoerce ab)
859 2 -> do return IfaceInlineCall
860 3 -> do return IfaceInlineMe
862 return (IfaceCoreNote ac)
865 -------------------------------------------------------------------------
866 -- IfaceDecl and friends
867 -------------------------------------------------------------------------
869 instance Binary IfaceDecl where
870 put_ bh (IfaceId name ty idinfo) = do
875 put_ bh (IfaceForeign ae af) =
876 error "Binary.put_(IfaceDecl): IfaceForeign"
877 put_ bh (IfaceData a1 a2 a3 a4 a5 a6 a7) = do
887 put_ bh (IfaceSyn aq ar as at) = do
893 put_ bh (IfaceClass a1 a2 a3 a4 a5 a6 a7) = do
905 0 -> do name <- get bh
908 return (IfaceId name ty idinfo)
909 1 -> error "Binary.get(TyClDecl): ForeignType"
918 return (IfaceData a1 a2 a3 a4 a5 a6 a7)
924 return (IfaceSyn aq ar as at)
933 return (IfaceClass a1 a2 a3 a4 a5 a6 a7)
935 instance Binary IfaceInst where
936 put_ bh (IfaceInst ty dfun) = do
939 get bh = do ty <- get bh
941 return (IfaceInst ty dfun)
943 instance Binary IfaceConDecls where
944 put_ bh IfAbstractTyCon = putByte bh 0
945 put_ bh (IfDataTyCon cs) = do { putByte bh 1
947 put_ bh (IfNewTyCon c) = do { putByte bh 2
952 0 -> return IfAbstractTyCon
954 return (IfDataTyCon aa)
956 return (IfNewTyCon aa)
958 instance Binary IfaceConDecl where
959 put_ bh (IfaceConDecl a1 a2 a3 a4 a5 a6 a7) = do
975 return (IfaceConDecl a1 a2 a3 a4 a5 a6 a7)
977 instance Binary IfaceClassOp where
978 put_ bh (IfaceClassOp n def ty) = do
986 return (IfaceClassOp n def ty)
988 instance Binary IfaceRule where
989 -- IfaceBuiltinRule should not happen here
990 put_ bh (IfaceRule a1 a2 a3 a4 a5 a6) = do
1004 return (IfaceRule a1 a2 a3 a4 a5 a6)