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_IgnoreHiVersion ) where
10 #include "HsVersions.h"
17 import TyCon ( DataConDetails(..) )
18 import Class ( DefMeth(..) )
20 import Module ( moduleName, mkModule )
21 import OccName ( OccName )
22 import DriverState ( v_Build_tag )
23 import CmdLineOpts ( opt_HiVersion )
29 import EXCEPTION ( throwDyn )
33 #include "HsVersions.h"
35 -- ---------------------------------------------------------------------------
36 writeBinIface :: FilePath -> ModIface -> IO ()
37 writeBinIface hi_path mod_iface
38 = putBinFileWithDict hi_path mod_iface
40 readBinIface :: FilePath -> IO ModIface
41 readBinIface hi_path = getBinFileWithDict hi_path
44 -- %*********************************************************
46 -- All the Binary instances
48 -- %*********************************************************
51 {-! for IPName derive: Binary !-}
52 {-! for Fixity derive: Binary !-}
53 {-! for FixityDirection derive: Binary !-}
54 {-! for NewOrData derive: Binary !-}
55 {-! for Boxity derive: Binary !-}
56 {-! for StrictnessMark derive: Binary !-}
57 {-! for Activation derive: Binary !-}
60 {-! for Demand derive: Binary !-}
61 {-! for Demands derive: Binary !-}
62 {-! for DmdResult derive: Binary !-}
63 {-! for StrictSig derive: Binary !-}
66 {-! for DataConDetails derive: Binary !-}
69 {-! for DefMeth derive: Binary !-}
72 {-! for HsPred derive: Binary !-}
73 {-! for HsType derive: Binary !-}
74 {-! for TupCon derive: Binary !-}
75 {-! for HsTyVarBndr derive: Binary !-}
78 {-! for UfExpr derive: Binary !-}
79 {-! for UfConAlt derive: Binary !-}
80 {-! for UfBinding derive: Binary !-}
81 {-! for UfBinder derive: Binary !-}
82 {-! for HsIdInfo derive: Binary !-}
83 {-! for UfNote derive: Binary !-}
86 {-! for ConDetails derive: Binary !-}
87 {-! for BangType derive: Binary !-}
90 {-! for IsCafCC derive: Binary !-}
91 {-! for IsDupdCC derive: Binary !-}
92 {-! for CostCentre derive: Binary !-}
96 -- ---------------------------------------------------------------------------
97 -- Reading a binary interface into ParsedIface
99 instance Binary ModIface where
102 mi_mod_vers = mod_vers,
103 mi_package = pkg_name,
107 mi_exports = exports,
108 mi_exp_vers = exp_vers,
109 mi_fixities = fixities,
110 mi_deprecs = deprecs,
114 mi_rule_vers = rule_vers }) = do
115 build_tag <- readIORef v_Build_tag
116 put_ bh (show opt_HiVersion ++ build_tag)
118 put_ bh (moduleName mod)
134 ignore_ver <- readIORef v_IgnoreHiVersion
135 build_tag <- readIORef v_Build_tag
136 let our_ver = show opt_HiVersion ++ build_tag
137 when (check_ver /= our_ver && not ignore_ver) $
138 -- use userError because this will be caught by readIface
139 -- which will emit an error msg containing the iface module name.
140 throwDyn (ProgramError (
141 "mismatched interface file versions: expected "
142 ++ our_ver ++ ", found " ++ check_ver))
150 usages <- {-# SCC "bin_usages" #-} lazyGet bh
151 exports <- {-# SCC "bin_exports" #-} get bh
153 fixities <- {-# SCC "bin_fixities" #-} get bh
154 deprecs <- {-# SCC "bin_deprecs" #-} lazyGet bh
155 decls <- {-# SCC "bin_tycldecls" #-} get bh
156 insts <- {-# SCC "bin_insts" #-} get bh
157 rules <- {-# SCC "bin_rules" #-} lazyGet bh
160 mi_package = pkg_name,
161 mi_module = mkModule pkg_name mod_name,
162 -- We write the module as a ModuleName, becuase whether
163 -- or not it's a home-package module depends on the importer
164 -- mkModule reconstructs the Module, by comparing the static
165 -- opt_InPackage flag with the package name in the interface file
166 mi_mod_vers = mod_vers,
167 mi_boot = False, -- Binary interfaces are never .hi-boot files!
171 mi_exports = exports,
172 mi_exp_vers = exp_vers,
173 mi_fixities = fixities,
174 mi_deprecs = deprecs,
178 mi_rule_vers = rule_vers,
179 -- And build the cached values
180 mi_dep_fn = mkIfaceDepCache deprecs,
181 mi_fix_fn = mkIfaceFixCache fixities,
182 mi_ver_fn = mkIfaceVerCache decls })
184 GLOBAL_VAR(v_IgnoreHiVersion, False, Bool)
186 -------------------------------------------------------------------------
187 -- Types from: HscTypes
188 -------------------------------------------------------------------------
190 instance Binary Dependencies where
191 put_ bh deps = do put_ bh (dep_mods deps)
192 put_ bh (dep_pkgs deps)
193 put_ bh (dep_orphs deps)
195 get bh = do ms <- get bh
198 return (Deps { dep_mods = ms, dep_pkgs = ps, dep_orphs = os })
200 instance (Binary name) => Binary (GenAvailInfo name) where
201 put_ bh (Avail aa) = do
204 put_ bh (AvailTC ab ac) = do
215 return (AvailTC ab ac)
217 instance Binary Usage where
219 put_ bh (usg_name usg)
220 put_ bh (usg_mod usg)
221 put_ bh (usg_exports usg)
222 put_ bh (usg_entities usg)
223 put_ bh (usg_rules usg)
231 return (Usage { usg_name = nm, usg_mod = mod,
232 usg_exports = exps, usg_entities = ents,
235 instance Binary a => Binary (Deprecs a) where
236 put_ bh NoDeprecs = putByte bh 0
237 put_ bh (DeprecAll t) = do
240 put_ bh (DeprecSome ts) = do
247 0 -> return NoDeprecs
249 return (DeprecAll aa)
251 return (DeprecSome aa)
253 -------------------------------------------------------------------------
254 -- Types from: BasicTypes
255 -------------------------------------------------------------------------
257 instance Binary Activation where
258 put_ bh NeverActive = do
260 put_ bh AlwaysActive = do
262 put_ bh (ActiveBefore aa) = do
265 put_ bh (ActiveAfter ab) = do
271 0 -> do return NeverActive
272 1 -> do return AlwaysActive
274 return (ActiveBefore aa)
276 return (ActiveAfter ab)
278 instance Binary StrictnessMark where
279 put_ bh MarkedStrict = do
281 put_ bh MarkedUnboxed = do
283 put_ bh NotMarkedStrict = do
288 0 -> do return MarkedStrict
289 1 -> do return MarkedUnboxed
290 _ -> do return NotMarkedStrict
292 instance Binary Boxity where
301 _ -> do return Unboxed
303 instance Binary TupCon where
304 put_ bh (TupCon ab ac) = do
310 return (TupCon ab ac)
312 instance Binary NewOrData where
315 put_ bh DataType = do
320 0 -> do return NewType
321 _ -> do return DataType
323 instance Binary RecFlag where
324 put_ bh Recursive = do
326 put_ bh NonRecursive = do
331 0 -> do return Recursive
332 _ -> do return NonRecursive
334 instance Binary DefMeth where
335 put_ bh NoDefMeth = putByte bh 0
336 put_ bh DefMeth = putByte bh 1
337 put_ bh GenDefMeth = putByte bh 2
341 0 -> return NoDefMeth
343 _ -> return GenDefMeth
345 instance Binary FixityDirection where
355 0 -> do return InfixL
356 1 -> do return InfixR
357 _ -> do return InfixN
359 instance Binary Fixity where
360 put_ bh (Fixity aa ab) = do
366 return (Fixity aa ab)
368 instance (Binary name) => Binary (IPName name) where
369 put_ bh (Dupable aa) = do
372 put_ bh (Linear ab) = do
383 -------------------------------------------------------------------------
384 -- Types from: Demand
385 -------------------------------------------------------------------------
387 instance Binary DmdType where
388 -- Ignore DmdEnv when spitting out the DmdType
389 put bh (DmdType _ ds dr) = do p <- put bh ds; put bh dr; return (castBin p)
390 get bh = do ds <- get bh; dr <- get bh; return (DmdType emptyVarEnv ds dr)
392 instance Binary Demand where
397 put_ bh (Call aa) = do
400 put_ bh (Eval ab) = do
403 put_ bh (Defer ac) = do
406 put_ bh (Box ad) = do
426 instance Binary Demands where
427 put_ bh (Poly aa) = do
430 put_ bh (Prod ab) = do
441 instance Binary DmdResult where
451 0 -> do return TopRes
452 1 -> do return RetCPR -- Really use RetCPR even if -fcpr-off
453 -- The wrapper was generated for CPR in
454 -- the imported module!
455 _ -> do return BotRes
457 instance Binary StrictSig where
458 put_ bh (StrictSig aa) = do
462 return (StrictSig aa)
465 -------------------------------------------------------------------------
466 -- Types from: CostCentre
467 -------------------------------------------------------------------------
469 instance Binary IsCafCC where
472 put_ bh NotCafCC = do
478 _ -> do return NotCafCC
480 instance Binary IsDupdCC where
481 put_ bh OriginalCC = do
488 0 -> do return OriginalCC
489 _ -> do return DupdCC
491 instance Binary CostCentre where
492 put_ bh NoCostCentre = do
494 put_ bh (NormalCC aa ab ac ad) = do
500 put_ bh (AllCafsCC ae) = do
506 0 -> do return NoCostCentre
511 return (NormalCC aa ab ac ad)
513 return (AllCafsCC ae)
515 -------------------------------------------------------------------------
516 -- IfaceTypes and friends
517 -------------------------------------------------------------------------
519 instance Binary IfaceExtName where
520 put_ bh (ExtPkg mod occ) = do
524 put_ bh (HomePkg mod occ vers) = do
529 put_ bh (LocalTop occ) = do
532 put_ bh (LocalTopSub occ _) = do -- Write LocalTopSub just like LocalTop
539 0 -> do mod <- get bh
541 return (ExtPkg mod occ)
542 1 -> do mod <- get bh
545 return (HomePkg mod occ vers)
546 _ -> do occ <- get bh
547 return (LocalTop occ)
549 instance Binary IfaceBndr where
550 put_ bh (IfaceIdBndr aa) = do
553 put_ bh (IfaceTvBndr ab) = do
560 return (IfaceIdBndr aa)
562 return (IfaceTvBndr ab)
564 instance Binary IfaceKind where
565 put_ bh IfaceLiftedTypeKind = putByte bh 0
566 put_ bh IfaceUnliftedTypeKind = putByte bh 1
567 put_ bh IfaceOpenTypeKind = putByte bh 2
568 put_ bh (IfaceFunKind k1 k2) = do
575 0 -> return IfaceLiftedTypeKind
576 1 -> return IfaceUnliftedTypeKind
577 2 -> return IfaceOpenTypeKind
580 return (IfaceFunKind k1 k2)
582 instance Binary IfaceType where
583 put_ bh (IfaceForAllTy aa ab) = do
587 put_ bh (IfaceTyVar ad) = do
590 put_ bh (IfaceAppTy ae af) = do
594 put_ bh (IfaceFunTy ag ah) = do
598 put_ bh (IfacePredTy aq) = do
602 -- Simple compression for common cases of TyConApp
603 put_ bh (IfaceTyConApp IfaceIntTc []) = putByte bh 6
604 put_ bh (IfaceTyConApp IfaceCharTc []) = putByte bh 7
605 put_ bh (IfaceTyConApp IfaceBoolTc []) = putByte bh 8
606 put_ bh (IfaceTyConApp IfaceListTc [ty]) = do { putByte bh 9; put_ bh ty }
607 -- Unit tuple and pairs
608 put_ bh (IfaceTyConApp (IfaceTupTc Boxed 0) []) = putByte bh 10
609 put_ bh (IfaceTyConApp (IfaceTupTc Boxed 2) [t1,t2]) = do { putByte bh 11; put_ bh t1; put_ bh t2 }
611 put_ bh (IfaceTyConApp (IfaceTc tc) tys) = do { putByte bh 12; put_ bh tc; put_ bh tys }
612 put_ bh (IfaceTyConApp tc tys) = do { putByte bh 13; put_ bh tc; put_ bh tys }
619 return (IfaceForAllTy aa ab)
621 return (IfaceTyVar ad)
624 return (IfaceAppTy ae af)
627 return (IfaceFunTy ag ah)
629 return (IfacePredTy ap)
631 -- Now the special cases for TyConApp
632 6 -> return (IfaceTyConApp IfaceIntTc [])
633 7 -> return (IfaceTyConApp IfaceCharTc [])
634 8 -> return (IfaceTyConApp IfaceBoolTc [])
635 9 -> do { ty <- get bh; return (IfaceTyConApp IfaceListTc [ty]) }
636 10 -> return (IfaceTyConApp (IfaceTupTc Boxed 0) [])
637 11 -> do { t1 <- get bh; t2 <- get bh; return (IfaceTyConApp (IfaceTupTc Boxed 2) [t1,t2]) }
638 12 -> do { tc <- get bh; tys <- get bh; return (IfaceTyConApp (IfaceTc tc) tys) }
639 _ -> do { tc <- get bh; tys <- get bh; return (IfaceTyConApp tc tys) }
641 instance Binary IfaceTyCon where
642 -- Int,Char,Bool can't show up here because they can't not be saturated
643 put_ bh IfaceListTc = putByte bh 1
644 put_ bh IfacePArrTc = putByte bh 2
645 put_ bh (IfaceTupTc bx ar) = do { putByte bh 3; put_ bh bx; put_ bh ar }
646 put_ bh tc = pprPanic "BinIface.put:" (ppr tc) -- Dealt with by the IfaceType instance
651 1 -> return IfaceListTc
652 2 -> return IfacePArrTc
653 _ -> do { bx <- get bh; ar <- get bh; return (IfaceTupTc bx ar) }
655 instance Binary IfacePredType where
656 put_ bh (IfaceClassP aa ab) = do
660 put_ bh (IfaceIParam ac ad) = do
669 return (IfaceClassP aa ab)
672 return (IfaceIParam ac ad)
674 -------------------------------------------------------------------------
675 -- IfaceExpr and friends
676 -------------------------------------------------------------------------
678 instance Binary IfaceExpr where
679 put_ bh (IfaceLcl aa) = do
682 put_ bh (IfaceType ab) = do
685 put_ bh (IfaceTuple ac ad) = do
689 put_ bh (IfaceLam ae af) = do
693 put_ bh (IfaceApp ag ah) = do
697 put_ bh (IfaceCase ai aj ak) = do
702 put_ bh (IfaceLet al am) = do
706 put_ bh (IfaceNote an ao) = do
710 put_ bh (IfaceLit ap) = do
713 put_ bh (IfaceFCall as at) = do
717 put_ bh (IfaceExt aa) = do
726 return (IfaceType ab)
729 return (IfaceTuple ac ad)
732 return (IfaceLam ae af)
735 return (IfaceApp ag ah)
739 return (IfaceCase ai aj ak)
742 return (IfaceLet al am)
745 return (IfaceNote an ao)
750 return (IfaceFCall as at)
754 instance Binary IfaceConAlt where
755 put_ bh IfaceDefault = do
757 put_ bh (IfaceDataAlt aa) = do
760 put_ bh (IfaceTupleAlt ab) = do
763 put_ bh (IfaceLitAlt ac) = do
769 0 -> do return IfaceDefault
771 return (IfaceDataAlt aa)
773 return (IfaceTupleAlt ab)
775 return (IfaceLitAlt ac)
777 instance Binary IfaceBinding where
778 put_ bh (IfaceNonRec aa ab) = do
782 put_ bh (IfaceRec ac) = do
790 return (IfaceNonRec aa ab)
794 instance Binary IfaceIdInfo where
795 put_ bh NoInfo = putByte bh 0
796 put_ bh (HasInfo i) = do
799 put_ bh DiscardedInfo = panic "BinIface:DiscardedInfo"
805 _ -> do info <- lazyGet bh
806 return (HasInfo info)
808 instance Binary IfaceInfoItem where
809 put_ bh (HsArity aa) = do
812 put_ bh (HsStrictness ab) = do
815 put_ bh (HsUnfold ac ad) = do
819 put_ bh HsNoCafRefs = do
821 put_ bh (HsWorker ae af) = do
831 return (HsStrictness ab)
834 return (HsUnfold ac ad)
835 3 -> do return HsNoCafRefs
838 return (HsWorker ae af)
840 instance Binary IfaceNote where
841 put_ bh (IfaceSCC aa) = do
844 put_ bh (IfaceCoerce ab) = do
847 put_ bh IfaceInlineCall = do
849 put_ bh IfaceInlineMe = do
851 put_ bh (IfaceCoreNote s) = do
860 return (IfaceCoerce ab)
861 2 -> do return IfaceInlineCall
862 3 -> do return IfaceInlineMe
864 return (IfaceCoreNote ac)
867 -------------------------------------------------------------------------
868 -- IfaceDecl and friends
869 -------------------------------------------------------------------------
871 instance Binary IfaceDecl where
872 put_ bh (IfaceId name ty idinfo) = do
877 put_ bh (IfaceForeign ae af) =
878 error "Binary.put_(IfaceDecl): IfaceForeign"
879 put_ bh (IfaceData a1 a2 a3 a4 a5 a6 a7 a8) = do
890 put_ bh (IfaceSyn aq ar as at) = do
896 put_ bh (IfaceClass a1 a2 a3 a4 a5 a6 a7) = do
908 0 -> do name <- get bh
911 return (IfaceId name ty idinfo)
912 1 -> error "Binary.get(TyClDecl): ForeignType"
922 return (IfaceData a1 a2 a3 a4 a5 a6 a7 a8)
928 return (IfaceSyn aq ar as at)
937 return (IfaceClass a1 a2 a3 a4 a5 a6 a7)
939 instance Binary IfaceInst where
940 put_ bh (IfaceInst ty dfun) = do
943 get bh = do ty <- get bh
945 return (IfaceInst ty dfun)
947 instance Binary IfaceConDecl where
948 put_ bh (IfaceConDecl a1 a2 a3 a4 a5 a6) = do
962 return (IfaceConDecl a1 a2 a3 a4 a5 a6)
964 instance Binary IfaceClassOp where
965 put_ bh (IfaceClassOp n def ty) = do
973 return (IfaceClassOp n def ty)
975 instance Binary IfaceRule where
976 -- IfaceBuiltinRule should not happen here
977 put_ bh (IfaceRule a1 a2 a3 a4 a5 a6) = do
991 return (IfaceRule a1 a2 a3 a4 a5 a6)
993 instance (Binary datacon) => Binary (DataConDetails datacon) where
994 put_ bh (DataCons aa) = do
1002 0 -> do aa <- get bh
1003 return (DataCons aa)
1004 _ -> do return Unknown