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 Packages ( PackageIdH(..) )
18 import Class ( DefMeth(..) )
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 = _, -- we ignore the package on output
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
129 let our_ver = show opt_HiVersion
130 when (check_ver /= our_ver) $
131 -- use userError because this will be caught by readIface
132 -- which will emit an error msg containing the iface module name.
133 throwDyn (ProgramError (
134 "mismatched interface file versions: expected "
135 ++ our_ver ++ ", found " ++ check_ver))
138 ignore_way <- readIORef v_IgnoreHiWay
139 build_tag <- readIORef v_Build_tag
140 when (not ignore_way && check_way /= build_tag) $
141 -- use userError because this will be caught by readIface
142 -- which will emit an error msg containing the iface module name.
143 throwDyn (ProgramError (
144 "mismatched interface file ways: expected "
145 ++ build_tag ++ ", found " ++ check_way))
152 usages <- {-# SCC "bin_usages" #-} lazyGet bh
153 exports <- {-# SCC "bin_exports" #-} get bh
155 fixities <- {-# SCC "bin_fixities" #-} get bh
156 deprecs <- {-# SCC "bin_deprecs" #-} lazyGet bh
157 decls <- {-# SCC "bin_tycldecls" #-} get bh
158 insts <- {-# SCC "bin_insts" #-} get bh
159 rules <- {-# SCC "bin_rules" #-} lazyGet bh
162 mi_package = HomePackage, -- to be filled in properly later
163 mi_module = mod_name,
164 mi_mod_vers = mod_vers,
165 mi_boot = False, -- Binary interfaces are never .hi-boot files!
169 mi_exports = exports,
170 mi_exp_vers = exp_vers,
171 mi_fixities = fixities,
172 mi_deprecs = deprecs,
176 mi_rule_vers = rule_vers,
177 -- And build the cached values
178 mi_dep_fn = mkIfaceDepCache deprecs,
179 mi_fix_fn = mkIfaceFixCache fixities,
180 mi_ver_fn = mkIfaceVerCache decls })
182 GLOBAL_VAR(v_IgnoreHiWay, False, Bool)
184 -------------------------------------------------------------------------
185 -- Types from: HscTypes
186 -------------------------------------------------------------------------
188 instance Binary Dependencies where
189 put_ bh deps = do put_ bh (dep_mods deps)
190 put_ bh (dep_pkgs deps)
191 put_ bh (dep_orphs deps)
193 get bh = do ms <- get bh
196 return (Deps { dep_mods = ms, dep_pkgs = ps, dep_orphs = os })
198 instance (Binary name) => Binary (GenAvailInfo name) where
199 put_ bh (Avail aa) = do
202 put_ bh (AvailTC ab ac) = do
213 return (AvailTC ab ac)
215 instance Binary Usage where
217 put_ bh (usg_name usg)
218 put_ bh (usg_mod usg)
219 put_ bh (usg_exports usg)
220 put_ bh (usg_entities usg)
221 put_ bh (usg_rules usg)
229 return (Usage { usg_name = nm, usg_mod = mod,
230 usg_exports = exps, usg_entities = ents,
233 instance Binary a => Binary (Deprecs a) where
234 put_ bh NoDeprecs = putByte bh 0
235 put_ bh (DeprecAll t) = do
238 put_ bh (DeprecSome ts) = do
245 0 -> return NoDeprecs
247 return (DeprecAll aa)
249 return (DeprecSome aa)
251 -------------------------------------------------------------------------
252 -- Types from: BasicTypes
253 -------------------------------------------------------------------------
255 instance Binary Activation where
256 put_ bh NeverActive = do
258 put_ bh AlwaysActive = do
260 put_ bh (ActiveBefore aa) = do
263 put_ bh (ActiveAfter ab) = do
269 0 -> do return NeverActive
270 1 -> do return AlwaysActive
272 return (ActiveBefore aa)
274 return (ActiveAfter ab)
276 instance Binary StrictnessMark where
277 put_ bh MarkedStrict = do
279 put_ bh MarkedUnboxed = do
281 put_ bh NotMarkedStrict = do
286 0 -> do return MarkedStrict
287 1 -> do return MarkedUnboxed
288 _ -> do return NotMarkedStrict
290 instance Binary Boxity where
299 _ -> do return Unboxed
301 instance Binary TupCon where
302 put_ bh (TupCon ab ac) = do
308 return (TupCon ab ac)
310 instance Binary RecFlag where
311 put_ bh Recursive = do
313 put_ bh NonRecursive = do
318 0 -> do return Recursive
319 _ -> do return NonRecursive
321 instance Binary DefMeth where
322 put_ bh NoDefMeth = putByte bh 0
323 put_ bh DefMeth = putByte bh 1
324 put_ bh GenDefMeth = putByte bh 2
328 0 -> return NoDefMeth
330 _ -> return GenDefMeth
332 instance Binary FixityDirection where
342 0 -> do return InfixL
343 1 -> do return InfixR
344 _ -> do return InfixN
346 instance Binary Fixity where
347 put_ bh (Fixity aa ab) = do
353 return (Fixity aa ab)
355 instance (Binary name) => Binary (IPName name) where
356 put_ bh (Dupable aa) = do
359 put_ bh (Linear ab) = do
370 -------------------------------------------------------------------------
371 -- Types from: Demand
372 -------------------------------------------------------------------------
374 instance Binary DmdType where
375 -- Ignore DmdEnv when spitting out the DmdType
376 put bh (DmdType _ ds dr) = do p <- put bh ds; put bh dr; return (castBin p)
377 get bh = do ds <- get bh; dr <- get bh; return (DmdType emptyVarEnv ds dr)
379 instance Binary Demand where
384 put_ bh (Call aa) = do
387 put_ bh (Eval ab) = do
390 put_ bh (Defer ac) = do
393 put_ bh (Box ad) = do
413 instance Binary Demands where
414 put_ bh (Poly aa) = do
417 put_ bh (Prod ab) = do
428 instance Binary DmdResult where
438 0 -> do return TopRes
439 1 -> do return RetCPR -- Really use RetCPR even if -fcpr-off
440 -- The wrapper was generated for CPR in
441 -- the imported module!
442 _ -> do return BotRes
444 instance Binary StrictSig where
445 put_ bh (StrictSig aa) = do
449 return (StrictSig aa)
452 -------------------------------------------------------------------------
453 -- Types from: CostCentre
454 -------------------------------------------------------------------------
456 instance Binary IsCafCC where
459 put_ bh NotCafCC = do
465 _ -> do return NotCafCC
467 instance Binary IsDupdCC where
468 put_ bh OriginalCC = do
475 0 -> do return OriginalCC
476 _ -> do return DupdCC
478 instance Binary CostCentre where
479 put_ bh NoCostCentre = do
481 put_ bh (NormalCC aa ab ac ad) = do
487 put_ bh (AllCafsCC ae) = do
493 0 -> do return NoCostCentre
498 return (NormalCC aa ab ac ad)
500 return (AllCafsCC ae)
502 -------------------------------------------------------------------------
503 -- IfaceTypes and friends
504 -------------------------------------------------------------------------
506 instance Binary IfaceExtName where
507 put_ bh (ExtPkg mod occ) = do
511 put_ bh (HomePkg mod occ vers) = do
516 put_ bh (LocalTop occ) = do
519 put_ bh (LocalTopSub occ _) = do -- Write LocalTopSub just like LocalTop
526 0 -> do mod <- get bh
528 return (ExtPkg mod occ)
529 1 -> do mod <- get bh
532 return (HomePkg mod occ vers)
533 _ -> do occ <- get bh
534 return (LocalTop occ)
536 instance Binary IfaceBndr where
537 put_ bh (IfaceIdBndr aa) = do
540 put_ bh (IfaceTvBndr ab) = do
547 return (IfaceIdBndr aa)
549 return (IfaceTvBndr ab)
551 instance Binary Kind where
552 put_ bh LiftedTypeKind = putByte bh 0
553 put_ bh UnliftedTypeKind = putByte bh 1
554 put_ bh OpenTypeKind = putByte bh 2
555 put_ bh ArgTypeKind = putByte bh 3
556 put_ bh UbxTupleKind = putByte bh 4
557 put_ bh (FunKind k1 k2) = do
561 put_ bh (KindVar kv) = pprPanic "BinIface.put_: kind var" (ppr kv)
566 0 -> return LiftedTypeKind
567 1 -> return UnliftedTypeKind
568 2 -> return OpenTypeKind
569 3 -> return ArgTypeKind
570 4 -> return UbxTupleKind
573 return (FunKind k1 k2)
575 instance Binary IfaceType where
576 put_ bh (IfaceForAllTy aa ab) = do
580 put_ bh (IfaceTyVar ad) = do
583 put_ bh (IfaceAppTy ae af) = do
587 put_ bh (IfaceFunTy ag ah) = do
591 put_ bh (IfacePredTy aq) = do
595 -- Simple compression for common cases of TyConApp
596 put_ bh (IfaceTyConApp IfaceIntTc []) = putByte bh 6
597 put_ bh (IfaceTyConApp IfaceCharTc []) = putByte bh 7
598 put_ bh (IfaceTyConApp IfaceBoolTc []) = putByte bh 8
599 put_ bh (IfaceTyConApp IfaceListTc [ty]) = do { putByte bh 9; put_ bh ty }
600 -- Unit tuple and pairs
601 put_ bh (IfaceTyConApp (IfaceTupTc Boxed 0) []) = putByte bh 10
602 put_ bh (IfaceTyConApp (IfaceTupTc Boxed 2) [t1,t2]) = do { putByte bh 11; put_ bh t1; put_ bh t2 }
604 put_ bh (IfaceTyConApp (IfaceTc tc) tys) = do { putByte bh 12; put_ bh tc; put_ bh tys }
605 put_ bh (IfaceTyConApp tc tys) = do { putByte bh 13; put_ bh tc; put_ bh tys }
612 return (IfaceForAllTy aa ab)
614 return (IfaceTyVar ad)
617 return (IfaceAppTy ae af)
620 return (IfaceFunTy ag ah)
622 return (IfacePredTy ap)
624 -- Now the special cases for TyConApp
625 6 -> return (IfaceTyConApp IfaceIntTc [])
626 7 -> return (IfaceTyConApp IfaceCharTc [])
627 8 -> return (IfaceTyConApp IfaceBoolTc [])
628 9 -> do { ty <- get bh; return (IfaceTyConApp IfaceListTc [ty]) }
629 10 -> return (IfaceTyConApp (IfaceTupTc Boxed 0) [])
630 11 -> do { t1 <- get bh; t2 <- get bh; return (IfaceTyConApp (IfaceTupTc Boxed 2) [t1,t2]) }
631 12 -> do { tc <- get bh; tys <- get bh; return (IfaceTyConApp (IfaceTc tc) tys) }
632 _ -> do { tc <- get bh; tys <- get bh; return (IfaceTyConApp tc tys) }
634 instance Binary IfaceTyCon where
635 -- Int,Char,Bool can't show up here because they can't not be saturated
636 put_ bh IfaceListTc = putByte bh 1
637 put_ bh IfacePArrTc = putByte bh 2
638 put_ bh (IfaceTupTc bx ar) = do { putByte bh 3; put_ bh bx; put_ bh ar }
639 put_ bh tc = pprPanic "BinIface.put:" (ppr tc) -- Dealt with by the IfaceType instance
644 1 -> return IfaceListTc
645 2 -> return IfacePArrTc
646 _ -> do { bx <- get bh; ar <- get bh; return (IfaceTupTc bx ar) }
648 instance Binary IfacePredType where
649 put_ bh (IfaceClassP aa ab) = do
653 put_ bh (IfaceIParam ac ad) = do
662 return (IfaceClassP aa ab)
665 return (IfaceIParam ac ad)
667 -------------------------------------------------------------------------
668 -- IfaceExpr and friends
669 -------------------------------------------------------------------------
671 instance Binary IfaceExpr where
672 put_ bh (IfaceLcl aa) = do
675 put_ bh (IfaceType ab) = do
678 put_ bh (IfaceTuple ac ad) = do
682 put_ bh (IfaceLam ae af) = do
686 put_ bh (IfaceApp ag ah) = do
691 put_ bh (IfaceCase ai aj al ak) = do
698 put_ bh (IfaceLet al am) = do
702 put_ bh (IfaceNote an ao) = do
706 put_ bh (IfaceLit ap) = do
709 put_ bh (IfaceFCall as at) = do
713 put_ bh (IfaceExt aa) = do
722 return (IfaceType ab)
725 return (IfaceTuple ac ad)
728 return (IfaceLam ae af)
731 return (IfaceApp ag ah)
738 return (IfaceCase ai aj al 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) = do
886 put_ bh (IfaceSyn aq ar as at) = do
892 put_ bh (IfaceClass a1 a2 a3 a4 a5 a6 a7) = do
904 0 -> do name <- get bh
907 return (IfaceId name ty idinfo)
908 1 -> error "Binary.get(TyClDecl): ForeignType"
916 return (IfaceData a1 a2 a3 a4 a5 a6)
922 return (IfaceSyn aq ar as at)
931 return (IfaceClass a1 a2 a3 a4 a5 a6 a7)
933 instance Binary IfaceInst where
934 put_ bh (IfaceInst ty dfun) = do
937 get bh = do ty <- get bh
939 return (IfaceInst ty dfun)
941 instance Binary IfaceConDecls where
942 put_ bh IfAbstractTyCon = putByte bh 0
943 put_ bh (IfDataTyCon st cs) = do { putByte bh 1
946 put_ bh (IfNewTyCon c) = do { putByte bh 2
951 0 -> return IfAbstractTyCon
954 return (IfDataTyCon st cs)
956 return (IfNewTyCon aa)
958 instance Binary IfaceConDecl where
959 put_ bh (IfVanillaCon a1 a2 a3 a4 a5) = do
966 put_ bh (IfGadtCon a1 a2 a3 a4 a5 a6) = do
982 return (IfVanillaCon a1 a2 a3 a4 a5)
989 return (IfGadtCon a1 a2 a3 a4 a5 a6)
991 instance Binary IfaceClassOp where
992 put_ bh (IfaceClassOp n def ty) = do
1000 return (IfaceClassOp n def ty)
1002 instance Binary IfaceRule where
1003 -- IfaceBuiltinRule should not happen here
1004 put_ bh (IfaceRule a1 a2 a3 a4 a5 a6) = do
1018 return (IfaceRule a1 a2 a3 a4 a5 a6)