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 InstEnv ( OverlapFlag(..) )
18 import Packages ( PackageIdH(..) )
19 import Class ( DefMeth(..) )
21 import StaticFlags ( opt_HiVersion, v_Build_tag )
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
640 put_ bh IfaceIntTc = putByte bh 1
641 put_ bh IfaceBoolTc = putByte bh 2
642 put_ bh IfaceCharTc = putByte bh 3
643 put_ bh IfaceListTc = putByte bh 4
644 put_ bh IfacePArrTc = putByte bh 5
645 put_ bh (IfaceTupTc bx ar) = do { putByte bh 6; put_ bh bx; put_ bh ar }
646 put_ bh (IfaceTc ext) = do { putByte bh 7; put_ bh ext }
651 1 -> return IfaceIntTc
652 2 -> return IfaceBoolTc
653 3 -> return IfaceCharTc
654 4 -> return IfaceListTc
655 5 -> return IfacePArrTc
656 6 -> do { bx <- get bh; ar <- get bh; return (IfaceTupTc bx ar) }
657 _ -> do { ext <- get bh; return (IfaceTc ext) }
659 instance Binary IfacePredType where
660 put_ bh (IfaceClassP aa ab) = do
664 put_ bh (IfaceIParam ac ad) = do
673 return (IfaceClassP aa ab)
676 return (IfaceIParam ac ad)
678 -------------------------------------------------------------------------
679 -- IfaceExpr and friends
680 -------------------------------------------------------------------------
682 instance Binary IfaceExpr where
683 put_ bh (IfaceLcl aa) = do
686 put_ bh (IfaceType ab) = do
689 put_ bh (IfaceTuple ac ad) = do
693 put_ bh (IfaceLam ae af) = do
697 put_ bh (IfaceApp ag ah) = do
702 put_ bh (IfaceCase ai aj al ak) = do
709 put_ bh (IfaceLet al am) = do
713 put_ bh (IfaceNote an ao) = do
717 put_ bh (IfaceLit ap) = do
720 put_ bh (IfaceFCall as at) = do
724 put_ bh (IfaceExt aa) = do
733 return (IfaceType ab)
736 return (IfaceTuple ac ad)
739 return (IfaceLam ae af)
742 return (IfaceApp ag ah)
749 return (IfaceCase ai aj al ak)
752 return (IfaceLet al am)
755 return (IfaceNote an ao)
760 return (IfaceFCall as at)
764 instance Binary IfaceConAlt where
765 put_ bh IfaceDefault = do
767 put_ bh (IfaceDataAlt aa) = do
770 put_ bh (IfaceTupleAlt ab) = do
773 put_ bh (IfaceLitAlt ac) = do
779 0 -> do return IfaceDefault
781 return (IfaceDataAlt aa)
783 return (IfaceTupleAlt ab)
785 return (IfaceLitAlt ac)
787 instance Binary IfaceBinding where
788 put_ bh (IfaceNonRec aa ab) = do
792 put_ bh (IfaceRec ac) = do
800 return (IfaceNonRec aa ab)
804 instance Binary IfaceIdInfo where
805 put_ bh NoInfo = putByte bh 0
806 put_ bh (HasInfo i) = do
808 lazyPut bh i -- NB lazyPut
814 _ -> do info <- lazyGet bh -- NB lazyGet
815 return (HasInfo info)
817 instance Binary IfaceInfoItem where
818 put_ bh (HsArity aa) = do
821 put_ bh (HsStrictness ab) = do
824 put_ bh (HsUnfold ac ad) = do
828 put_ bh HsNoCafRefs = do
830 put_ bh (HsWorker ae af) = do
840 return (HsStrictness ab)
843 return (HsUnfold ac ad)
844 3 -> do return HsNoCafRefs
847 return (HsWorker ae af)
849 instance Binary IfaceNote where
850 put_ bh (IfaceSCC aa) = do
853 put_ bh (IfaceCoerce ab) = do
856 put_ bh IfaceInlineCall = do
858 put_ bh IfaceInlineMe = do
860 put_ bh (IfaceCoreNote s) = do
869 return (IfaceCoerce ab)
870 2 -> do return IfaceInlineCall
871 3 -> do return IfaceInlineMe
873 return (IfaceCoreNote ac)
876 -------------------------------------------------------------------------
877 -- IfaceDecl and friends
878 -------------------------------------------------------------------------
880 instance Binary IfaceDecl where
881 put_ bh (IfaceId name ty idinfo) = do
886 put_ bh (IfaceForeign ae af) =
887 error "Binary.put_(IfaceDecl): IfaceForeign"
888 put_ bh (IfaceData a1 a2 a3 a4 a5 a6 a7) = do
898 put_ bh (IfaceSyn aq ar as at) = do
904 put_ bh (IfaceClass a1 a2 a3 a4 a5 a6 a7) = do
916 0 -> do name <- get bh
919 return (IfaceId name ty idinfo)
920 1 -> error "Binary.get(TyClDecl): ForeignType"
929 return (IfaceData a1 a2 a3 a4 a5 a6 a7)
935 return (IfaceSyn aq ar as at)
944 return (IfaceClass a1 a2 a3 a4 a5 a6 a7)
946 instance Binary IfaceInst where
947 put_ bh (IfaceInst cls tys dfun flag orph) = do
953 get bh = do cls <- get bh
958 return (IfaceInst cls tys dfun flag orph)
960 instance Binary OverlapFlag where
961 put_ bh NoOverlap = putByte bh 0
962 put_ bh OverlapOk = putByte bh 1
963 put_ bh Incoherent = putByte bh 2
964 get bh = do h <- getByte bh
966 0 -> return NoOverlap
967 1 -> return OverlapOk
968 2 -> return Incoherent
970 instance Binary IfaceConDecls where
971 put_ bh IfAbstractTyCon = putByte bh 0
972 put_ bh (IfDataTyCon cs) = do { putByte bh 1
974 put_ bh (IfNewTyCon c) = do { putByte bh 2
979 0 -> return IfAbstractTyCon
981 return (IfDataTyCon cs)
983 return (IfNewTyCon aa)
985 instance Binary IfaceConDecl where
986 put_ bh (IfVanillaCon a1 a2 a3 a4 a5) = do
993 put_ bh (IfGadtCon a1 a2 a3 a4 a5 a6) = do
1004 0 -> do a1 <- get bh
1009 return (IfVanillaCon a1 a2 a3 a4 a5)
1010 _ -> do a1 <- get bh
1016 return (IfGadtCon a1 a2 a3 a4 a5 a6)
1018 instance Binary IfaceClassOp where
1019 put_ bh (IfaceClassOp n def ty) = do
1027 return (IfaceClassOp n def ty)
1029 instance Binary IfaceRule where
1030 put_ bh (IfaceRule a1 a2 a3 a4 a5 a6 a7) = do
1046 return (IfaceRule a1 a2 a3 a4 a5 a6 a7)