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
98 mi_mod_vers = mod_vers,
99 mi_package = _, -- we ignore the package on output
103 mi_exports = exports,
104 mi_exp_vers = exp_vers,
105 mi_fixities = fixities,
106 mi_deprecs = deprecs,
110 mi_rule_vers = rule_vers }) = do
111 put_ bh (show opt_HiVersion)
112 build_tag <- readIORef v_Build_tag
131 let our_ver = show opt_HiVersion
132 when (check_ver /= our_ver) $
133 -- use userError because this will be caught by readIface
134 -- which will emit an error msg containing the iface module name.
135 throwDyn (ProgramError (
136 "mismatched interface file versions: expected "
137 ++ our_ver ++ ", found " ++ check_ver))
140 ignore_way <- readIORef v_IgnoreHiWay
141 build_tag <- readIORef v_Build_tag
142 when (not ignore_way && check_way /= build_tag) $
143 -- use userError because this will be caught by readIface
144 -- which will emit an error msg containing the iface module name.
145 throwDyn (ProgramError (
146 "mismatched interface file ways: expected "
147 ++ 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 = HomePackage, -- to be filled in properly later
165 mi_module = mod_name,
167 mi_mod_vers = mod_vers,
171 mi_exports = exports,
172 mi_exp_vers = exp_vers,
173 mi_fixities = fixities,
174 mi_deprecs = deprecs,
176 mi_globals = Nothing,
179 mi_rule_vers = rule_vers,
180 -- And build the cached values
181 mi_dep_fn = mkIfaceDepCache deprecs,
182 mi_fix_fn = mkIfaceFixCache fixities,
183 mi_ver_fn = mkIfaceVerCache decls })
185 GLOBAL_VAR(v_IgnoreHiWay, False, Bool)
187 -------------------------------------------------------------------------
188 -- Types from: HscTypes
189 -------------------------------------------------------------------------
191 instance Binary Dependencies where
192 put_ bh deps = do put_ bh (dep_mods deps)
193 put_ bh (dep_pkgs deps)
194 put_ bh (dep_orphs deps)
196 get bh = do ms <- get bh
199 return (Deps { dep_mods = ms, dep_pkgs = ps, dep_orphs = os })
201 instance (Binary name) => Binary (GenAvailInfo name) where
202 put_ bh (Avail aa) = do
205 put_ bh (AvailTC ab ac) = do
216 return (AvailTC ab ac)
218 instance Binary Usage where
220 put_ bh (usg_name usg)
221 put_ bh (usg_mod usg)
222 put_ bh (usg_exports usg)
223 put_ bh (usg_entities usg)
224 put_ bh (usg_rules usg)
232 return (Usage { usg_name = nm, usg_mod = mod,
233 usg_exports = exps, usg_entities = ents,
236 instance Binary a => Binary (Deprecs a) where
237 put_ bh NoDeprecs = putByte bh 0
238 put_ bh (DeprecAll t) = do
241 put_ bh (DeprecSome ts) = do
248 0 -> return NoDeprecs
250 return (DeprecAll aa)
252 return (DeprecSome aa)
254 -------------------------------------------------------------------------
255 -- Types from: BasicTypes
256 -------------------------------------------------------------------------
258 instance Binary Activation where
259 put_ bh NeverActive = do
261 put_ bh AlwaysActive = do
263 put_ bh (ActiveBefore aa) = do
266 put_ bh (ActiveAfter ab) = do
272 0 -> do return NeverActive
273 1 -> do return AlwaysActive
275 return (ActiveBefore aa)
277 return (ActiveAfter ab)
279 instance Binary StrictnessMark where
280 put_ bh MarkedStrict = do
282 put_ bh MarkedUnboxed = do
284 put_ bh NotMarkedStrict = do
289 0 -> do return MarkedStrict
290 1 -> do return MarkedUnboxed
291 _ -> do return NotMarkedStrict
293 instance Binary Boxity where
302 _ -> do return Unboxed
304 instance Binary TupCon where
305 put_ bh (TupCon ab ac) = do
311 return (TupCon ab ac)
313 instance Binary RecFlag where
314 put_ bh Recursive = do
316 put_ bh NonRecursive = do
321 0 -> do return Recursive
322 _ -> do return NonRecursive
324 instance Binary DefMeth where
325 put_ bh NoDefMeth = putByte bh 0
326 put_ bh DefMeth = putByte bh 1
327 put_ bh GenDefMeth = putByte bh 2
331 0 -> return NoDefMeth
333 _ -> return GenDefMeth
335 instance Binary FixityDirection where
345 0 -> do return InfixL
346 1 -> do return InfixR
347 _ -> do return InfixN
349 instance Binary Fixity where
350 put_ bh (Fixity aa ab) = do
356 return (Fixity aa ab)
358 instance (Binary name) => Binary (IPName name) where
359 put_ bh (Dupable aa) = do
362 put_ bh (Linear ab) = do
373 -------------------------------------------------------------------------
374 -- Types from: Demand
375 -------------------------------------------------------------------------
377 instance Binary DmdType where
378 -- Ignore DmdEnv when spitting out the DmdType
379 put bh (DmdType _ ds dr) = do p <- put bh ds; put bh dr; return (castBin p)
380 get bh = do ds <- get bh; dr <- get bh; return (DmdType emptyVarEnv ds dr)
382 instance Binary Demand where
387 put_ bh (Call aa) = do
390 put_ bh (Eval ab) = do
393 put_ bh (Defer ac) = do
396 put_ bh (Box ad) = do
416 instance Binary Demands where
417 put_ bh (Poly aa) = do
420 put_ bh (Prod ab) = do
431 instance Binary DmdResult where
441 0 -> do return TopRes
442 1 -> do return RetCPR -- Really use RetCPR even if -fcpr-off
443 -- The wrapper was generated for CPR in
444 -- the imported module!
445 _ -> do return BotRes
447 instance Binary StrictSig where
448 put_ bh (StrictSig aa) = do
452 return (StrictSig aa)
455 -------------------------------------------------------------------------
456 -- Types from: CostCentre
457 -------------------------------------------------------------------------
459 instance Binary IsCafCC where
462 put_ bh NotCafCC = do
468 _ -> do return NotCafCC
470 instance Binary IsDupdCC where
471 put_ bh OriginalCC = do
478 0 -> do return OriginalCC
479 _ -> do return DupdCC
481 instance Binary CostCentre where
482 put_ bh NoCostCentre = do
484 put_ bh (NormalCC aa ab ac ad) = do
490 put_ bh (AllCafsCC ae) = do
496 0 -> do return NoCostCentre
501 return (NormalCC aa ab ac ad)
503 return (AllCafsCC ae)
505 -------------------------------------------------------------------------
506 -- IfaceTypes and friends
507 -------------------------------------------------------------------------
509 instance Binary IfaceExtName where
510 put_ bh (ExtPkg mod occ) = do
514 put_ bh (HomePkg mod occ vers) = do
519 put_ bh (LocalTop occ) = do
522 put_ bh (LocalTopSub occ _) = do -- Write LocalTopSub just like LocalTop
529 0 -> do mod <- get bh
531 return (ExtPkg mod occ)
532 1 -> do mod <- get bh
535 return (HomePkg mod occ vers)
536 _ -> do occ <- get bh
537 return (LocalTop occ)
539 instance Binary IfaceBndr where
540 put_ bh (IfaceIdBndr aa) = do
543 put_ bh (IfaceTvBndr ab) = do
550 return (IfaceIdBndr aa)
552 return (IfaceTvBndr ab)
554 instance Binary Kind where
555 put_ bh LiftedTypeKind = putByte bh 0
556 put_ bh UnliftedTypeKind = putByte bh 1
557 put_ bh OpenTypeKind = putByte bh 2
558 put_ bh ArgTypeKind = putByte bh 3
559 put_ bh UbxTupleKind = putByte bh 4
560 put_ bh (FunKind k1 k2) = do
564 put_ bh (KindVar kv) = pprPanic "BinIface.put_: kind var" (ppr kv)
569 0 -> return LiftedTypeKind
570 1 -> return UnliftedTypeKind
571 2 -> return OpenTypeKind
572 3 -> return ArgTypeKind
573 4 -> return UbxTupleKind
576 return (FunKind k1 k2)
578 instance Binary IfaceType where
579 put_ bh (IfaceForAllTy aa ab) = do
583 put_ bh (IfaceTyVar ad) = do
586 put_ bh (IfaceAppTy ae af) = do
590 put_ bh (IfaceFunTy ag ah) = do
594 put_ bh (IfacePredTy aq) = do
598 -- Simple compression for common cases of TyConApp
599 put_ bh (IfaceTyConApp IfaceIntTc []) = putByte bh 6
600 put_ bh (IfaceTyConApp IfaceCharTc []) = putByte bh 7
601 put_ bh (IfaceTyConApp IfaceBoolTc []) = putByte bh 8
602 put_ bh (IfaceTyConApp IfaceListTc [ty]) = do { putByte bh 9; put_ bh ty }
603 -- Unit tuple and pairs
604 put_ bh (IfaceTyConApp (IfaceTupTc Boxed 0) []) = putByte bh 10
605 put_ bh (IfaceTyConApp (IfaceTupTc Boxed 2) [t1,t2]) = do { putByte bh 11; put_ bh t1; put_ bh t2 }
607 put_ bh (IfaceTyConApp (IfaceTc tc) tys) = do { putByte bh 12; put_ bh tc; put_ bh tys }
608 put_ bh (IfaceTyConApp tc tys) = do { putByte bh 13; put_ bh tc; put_ bh tys }
615 return (IfaceForAllTy aa ab)
617 return (IfaceTyVar ad)
620 return (IfaceAppTy ae af)
623 return (IfaceFunTy ag ah)
625 return (IfacePredTy ap)
627 -- Now the special cases for TyConApp
628 6 -> return (IfaceTyConApp IfaceIntTc [])
629 7 -> return (IfaceTyConApp IfaceCharTc [])
630 8 -> return (IfaceTyConApp IfaceBoolTc [])
631 9 -> do { ty <- get bh; return (IfaceTyConApp IfaceListTc [ty]) }
632 10 -> return (IfaceTyConApp (IfaceTupTc Boxed 0) [])
633 11 -> do { t1 <- get bh; t2 <- get bh; return (IfaceTyConApp (IfaceTupTc Boxed 2) [t1,t2]) }
634 12 -> do { tc <- get bh; tys <- get bh; return (IfaceTyConApp (IfaceTc tc) tys) }
635 _ -> do { tc <- get bh; tys <- get bh; return (IfaceTyConApp tc tys) }
637 instance Binary IfaceTyCon where
638 -- Int,Char,Bool can't show up here because they can't not be saturated
639 put_ bh IfaceListTc = putByte bh 1
640 put_ bh IfacePArrTc = putByte bh 2
641 put_ bh (IfaceTupTc bx ar) = do { putByte bh 3; put_ bh bx; put_ bh ar }
642 put_ bh tc = pprPanic "BinIface.put:" (ppr tc) -- Dealt with by the IfaceType instance
647 1 -> return IfaceListTc
648 2 -> return IfacePArrTc
649 _ -> do { bx <- get bh; ar <- get bh; return (IfaceTupTc bx ar) }
651 instance Binary IfacePredType where
652 put_ bh (IfaceClassP aa ab) = do
656 put_ bh (IfaceIParam ac ad) = do
665 return (IfaceClassP aa ab)
668 return (IfaceIParam ac ad)
670 -------------------------------------------------------------------------
671 -- IfaceExpr and friends
672 -------------------------------------------------------------------------
674 instance Binary IfaceExpr where
675 put_ bh (IfaceLcl aa) = do
678 put_ bh (IfaceType ab) = do
681 put_ bh (IfaceTuple ac ad) = do
685 put_ bh (IfaceLam ae af) = do
689 put_ bh (IfaceApp ag ah) = do
694 put_ bh (IfaceCase ai aj al 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)
741 return (IfaceCase ai aj al ak)
744 return (IfaceLet al am)
747 return (IfaceNote an ao)
752 return (IfaceFCall as at)
756 instance Binary IfaceConAlt where
757 put_ bh IfaceDefault = do
759 put_ bh (IfaceDataAlt aa) = do
762 put_ bh (IfaceTupleAlt ab) = do
765 put_ bh (IfaceLitAlt ac) = do
771 0 -> do return IfaceDefault
773 return (IfaceDataAlt aa)
775 return (IfaceTupleAlt ab)
777 return (IfaceLitAlt ac)
779 instance Binary IfaceBinding where
780 put_ bh (IfaceNonRec aa ab) = do
784 put_ bh (IfaceRec ac) = do
792 return (IfaceNonRec aa ab)
796 instance Binary IfaceIdInfo where
797 put_ bh NoInfo = putByte bh 0
798 put_ bh (HasInfo i) = do
806 _ -> do info <- lazyGet bh
807 return (HasInfo info)
809 instance Binary IfaceInfoItem where
810 put_ bh (HsArity aa) = do
813 put_ bh (HsStrictness ab) = do
816 put_ bh (HsUnfold ac ad) = do
820 put_ bh HsNoCafRefs = do
822 put_ bh (HsWorker ae af) = do
832 return (HsStrictness ab)
835 return (HsUnfold ac ad)
836 3 -> do return HsNoCafRefs
839 return (HsWorker ae af)
841 instance Binary IfaceNote where
842 put_ bh (IfaceSCC aa) = do
845 put_ bh (IfaceCoerce ab) = do
848 put_ bh IfaceInlineCall = do
850 put_ bh IfaceInlineMe = do
852 put_ bh (IfaceCoreNote s) = do
861 return (IfaceCoerce ab)
862 2 -> do return IfaceInlineCall
863 3 -> do return IfaceInlineMe
865 return (IfaceCoreNote ac)
868 -------------------------------------------------------------------------
869 -- IfaceDecl and friends
870 -------------------------------------------------------------------------
872 instance Binary IfaceDecl where
873 put_ bh (IfaceId name ty idinfo) = do
878 put_ bh (IfaceForeign ae af) =
879 error "Binary.put_(IfaceDecl): IfaceForeign"
880 put_ bh (IfaceData a1 a2 a3 a4 a5 a6) = do
889 put_ bh (IfaceSyn aq ar as at) = do
895 put_ bh (IfaceClass a1 a2 a3 a4 a5 a6 a7) = do
907 0 -> do name <- get bh
910 return (IfaceId name ty idinfo)
911 1 -> error "Binary.get(TyClDecl): ForeignType"
919 return (IfaceData a1 a2 a3 a4 a5 a6)
925 return (IfaceSyn aq ar as at)
934 return (IfaceClass a1 a2 a3 a4 a5 a6 a7)
936 instance Binary IfaceInst where
937 put_ bh (IfaceInst ty dfun) = do
940 get bh = do ty <- get bh
942 return (IfaceInst ty dfun)
944 instance Binary IfaceConDecls where
945 put_ bh IfAbstractTyCon = putByte bh 0
946 put_ bh (IfDataTyCon st cs) = do { putByte bh 1
949 put_ bh (IfNewTyCon c) = do { putByte bh 2
954 0 -> return IfAbstractTyCon
957 return (IfDataTyCon st cs)
959 return (IfNewTyCon aa)
961 instance Binary IfaceConDecl where
962 put_ bh (IfVanillaCon a1 a2 a3 a4 a5) = do
969 put_ bh (IfGadtCon a1 a2 a3 a4 a5 a6) = do
985 return (IfVanillaCon a1 a2 a3 a4 a5)
992 return (IfGadtCon a1 a2 a3 a4 a5 a6)
994 instance Binary IfaceClassOp where
995 put_ bh (IfaceClassOp n def ty) = do
1003 return (IfaceClassOp n def ty)
1005 instance Binary IfaceRule where
1006 -- IfaceBuiltinRule should not happen here
1007 put_ bh (IfaceRule a1 a2 a3 a4 a5 a6) = do
1021 return (IfaceRule a1 a2 a3 a4 a5 a6)