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(..) )
26 import Config ( cGhcUnregisterised )
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 Boxity derive: Binary !-}
55 {-! for StrictnessMark derive: Binary !-}
56 {-! for Activation derive: Binary !-}
59 {-! for Demand derive: Binary !-}
60 {-! for Demands derive: Binary !-}
61 {-! for DmdResult derive: Binary !-}
62 {-! for StrictSig derive: Binary !-}
65 {-! for DefMeth derive: Binary !-}
68 {-! for HsPred derive: Binary !-}
69 {-! for HsType derive: Binary !-}
70 {-! for TupCon derive: Binary !-}
71 {-! for HsTyVarBndr derive: Binary !-}
74 {-! for UfExpr derive: Binary !-}
75 {-! for UfConAlt derive: Binary !-}
76 {-! for UfBinding derive: Binary !-}
77 {-! for UfBinder derive: Binary !-}
78 {-! for HsIdInfo derive: Binary !-}
79 {-! for UfNote derive: Binary !-}
82 {-! for ConDetails derive: Binary !-}
83 {-! for BangType derive: Binary !-}
86 {-! for IsCafCC derive: Binary !-}
87 {-! for IsDupdCC derive: Binary !-}
88 {-! for CostCentre derive: Binary !-}
92 -- ---------------------------------------------------------------------------
93 -- Reading a binary interface into ParsedIface
95 instance Binary ModIface where
99 mi_mod_vers = mod_vers,
100 mi_package = _, -- we ignore the package on output
104 mi_exports = exports,
105 mi_exp_vers = exp_vers,
106 mi_fixities = fixities,
107 mi_deprecs = deprecs,
111 mi_rule_vers = rule_vers }) = do
112 put_ bh (show opt_HiVersion)
113 way_descr <- getWayDescr
132 let our_ver = show opt_HiVersion
133 when (check_ver /= our_ver) $
134 -- use userError because this will be caught by readIface
135 -- which will emit an error msg containing the iface module name.
136 throwDyn (ProgramError (
137 "mismatched interface file versions: expected "
138 ++ our_ver ++ ", found " ++ check_ver))
141 ignore_way <- readIORef v_IgnoreHiWay
142 way_descr <- getWayDescr
143 when (not ignore_way && check_way /= way_descr) $
144 -- use userError because this will be caught by readIface
145 -- which will emit an error msg containing the iface module name.
146 throwDyn (ProgramError (
147 "mismatched interface file ways: expected "
148 ++ way_descr ++ ", found " ++ check_way))
155 usages <- {-# SCC "bin_usages" #-} lazyGet bh
156 exports <- {-# SCC "bin_exports" #-} get bh
158 fixities <- {-# SCC "bin_fixities" #-} get bh
159 deprecs <- {-# SCC "bin_deprecs" #-} lazyGet bh
160 decls <- {-# SCC "bin_tycldecls" #-} get bh
161 insts <- {-# SCC "bin_insts" #-} get bh
162 rules <- {-# SCC "bin_rules" #-} lazyGet bh
165 mi_package = HomePackage, -- to be filled in properly later
166 mi_module = mod_name,
168 mi_mod_vers = mod_vers,
172 mi_exports = exports,
173 mi_exp_vers = exp_vers,
174 mi_fixities = fixities,
175 mi_deprecs = deprecs,
177 mi_globals = Nothing,
180 mi_rule_vers = rule_vers,
181 -- And build the cached values
182 mi_dep_fn = mkIfaceDepCache deprecs,
183 mi_fix_fn = mkIfaceFixCache fixities,
184 mi_ver_fn = mkIfaceVerCache decls })
186 GLOBAL_VAR(v_IgnoreHiWay, False, Bool)
188 getWayDescr :: IO String
190 tag <- readIORef v_Build_tag
191 if cGhcUnregisterised == "YES" then return ('u':tag) else return tag
192 -- if this is an unregisterised build, make sure our interfaces
193 -- can't be used by a registerised build.
195 -------------------------------------------------------------------------
196 -- Types from: HscTypes
197 -------------------------------------------------------------------------
199 instance Binary Dependencies where
200 put_ bh deps = do put_ bh (dep_mods deps)
201 put_ bh (dep_pkgs deps)
202 put_ bh (dep_orphs deps)
204 get bh = do ms <- get bh
207 return (Deps { dep_mods = ms, dep_pkgs = ps, dep_orphs = os })
209 instance (Binary name) => Binary (GenAvailInfo name) where
210 put_ bh (Avail aa) = do
213 put_ bh (AvailTC ab ac) = do
224 return (AvailTC ab ac)
226 instance Binary Usage where
228 put_ bh (usg_name usg)
229 put_ bh (usg_mod usg)
230 put_ bh (usg_exports usg)
231 put_ bh (usg_entities usg)
232 put_ bh (usg_rules usg)
240 return (Usage { usg_name = nm, usg_mod = mod,
241 usg_exports = exps, usg_entities = ents,
244 instance Binary a => Binary (Deprecs a) where
245 put_ bh NoDeprecs = putByte bh 0
246 put_ bh (DeprecAll t) = do
249 put_ bh (DeprecSome ts) = do
256 0 -> return NoDeprecs
258 return (DeprecAll aa)
260 return (DeprecSome aa)
262 -------------------------------------------------------------------------
263 -- Types from: BasicTypes
264 -------------------------------------------------------------------------
266 instance Binary Activation where
267 put_ bh NeverActive = do
269 put_ bh AlwaysActive = do
271 put_ bh (ActiveBefore aa) = do
274 put_ bh (ActiveAfter ab) = do
280 0 -> do return NeverActive
281 1 -> do return AlwaysActive
283 return (ActiveBefore aa)
285 return (ActiveAfter ab)
287 instance Binary StrictnessMark where
288 put_ bh MarkedStrict = do
290 put_ bh MarkedUnboxed = do
292 put_ bh NotMarkedStrict = do
297 0 -> do return MarkedStrict
298 1 -> do return MarkedUnboxed
299 _ -> do return NotMarkedStrict
301 instance Binary Boxity where
310 _ -> do return Unboxed
312 instance Binary TupCon where
313 put_ bh (TupCon ab ac) = do
319 return (TupCon ab ac)
321 instance Binary RecFlag where
322 put_ bh Recursive = do
324 put_ bh NonRecursive = do
329 0 -> do return Recursive
330 _ -> do return NonRecursive
332 instance Binary DefMeth where
333 put_ bh NoDefMeth = putByte bh 0
334 put_ bh DefMeth = putByte bh 1
335 put_ bh GenDefMeth = putByte bh 2
339 0 -> return NoDefMeth
341 _ -> return GenDefMeth
343 instance Binary FixityDirection where
353 0 -> do return InfixL
354 1 -> do return InfixR
355 _ -> do return InfixN
357 instance Binary Fixity where
358 put_ bh (Fixity aa ab) = do
364 return (Fixity aa ab)
366 instance (Binary name) => Binary (IPName name) where
367 put_ bh (Dupable aa) = do
370 put_ bh (Linear ab) = do
381 -------------------------------------------------------------------------
382 -- Types from: Demand
383 -------------------------------------------------------------------------
385 instance Binary DmdType where
386 -- Ignore DmdEnv when spitting out the DmdType
387 put bh (DmdType _ ds dr) = do p <- put bh ds; put bh dr; return (castBin p)
388 get bh = do ds <- get bh; dr <- get bh; return (DmdType emptyVarEnv ds dr)
390 instance Binary Demand where
395 put_ bh (Call aa) = do
398 put_ bh (Eval ab) = do
401 put_ bh (Defer ac) = do
404 put_ bh (Box ad) = do
424 instance Binary Demands where
425 put_ bh (Poly aa) = do
428 put_ bh (Prod ab) = do
439 instance Binary DmdResult where
449 0 -> do return TopRes
450 1 -> do return RetCPR -- Really use RetCPR even if -fcpr-off
451 -- The wrapper was generated for CPR in
452 -- the imported module!
453 _ -> do return BotRes
455 instance Binary StrictSig where
456 put_ bh (StrictSig aa) = do
460 return (StrictSig aa)
463 -------------------------------------------------------------------------
464 -- Types from: CostCentre
465 -------------------------------------------------------------------------
467 instance Binary IsCafCC where
470 put_ bh NotCafCC = do
476 _ -> do return NotCafCC
478 instance Binary IsDupdCC where
479 put_ bh OriginalCC = do
486 0 -> do return OriginalCC
487 _ -> do return DupdCC
489 instance Binary CostCentre where
490 put_ bh NoCostCentre = do
492 put_ bh (NormalCC aa ab ac ad) = do
498 put_ bh (AllCafsCC ae) = do
504 0 -> do return NoCostCentre
509 return (NormalCC aa ab ac ad)
511 return (AllCafsCC ae)
513 -------------------------------------------------------------------------
514 -- IfaceTypes and friends
515 -------------------------------------------------------------------------
517 instance Binary IfaceExtName where
518 put_ bh (ExtPkg mod occ) = do
522 put_ bh (HomePkg mod occ vers) = do
527 put_ bh (LocalTop occ) = do
530 put_ bh (LocalTopSub occ _) = do -- Write LocalTopSub just like LocalTop
537 0 -> do mod <- get bh
539 return (ExtPkg mod occ)
540 1 -> do mod <- get bh
543 return (HomePkg mod occ vers)
544 _ -> do occ <- get bh
545 return (LocalTop occ)
547 instance Binary IfaceBndr where
548 put_ bh (IfaceIdBndr aa) = do
551 put_ bh (IfaceTvBndr ab) = do
558 return (IfaceIdBndr aa)
560 return (IfaceTvBndr ab)
562 instance Binary Kind where
563 put_ bh LiftedTypeKind = putByte bh 0
564 put_ bh UnliftedTypeKind = putByte bh 1
565 put_ bh UnboxedTypeKind = putByte bh 2
566 put_ bh OpenTypeKind = putByte bh 3
567 put_ bh ArgTypeKind = putByte bh 4
568 put_ bh UbxTupleKind = putByte bh 5
569 put_ bh (FunKind k1 k2) = do
573 put_ bh (KindVar kv) = pprPanic "BinIface.put_: kind var" (ppr kv)
578 0 -> return LiftedTypeKind
579 1 -> return UnliftedTypeKind
580 2 -> return UnboxedTypeKind
581 3 -> return OpenTypeKind
582 4 -> return ArgTypeKind
583 5 -> return UbxTupleKind
586 return (FunKind k1 k2)
588 instance Binary IfaceType where
589 put_ bh (IfaceForAllTy aa ab) = do
593 put_ bh (IfaceTyVar ad) = do
596 put_ bh (IfaceAppTy ae af) = do
600 put_ bh (IfaceFunTy ag ah) = do
604 put_ bh (IfacePredTy aq) = do
608 -- Simple compression for common cases of TyConApp
609 put_ bh (IfaceTyConApp IfaceIntTc []) = putByte bh 6
610 put_ bh (IfaceTyConApp IfaceCharTc []) = putByte bh 7
611 put_ bh (IfaceTyConApp IfaceBoolTc []) = putByte bh 8
612 put_ bh (IfaceTyConApp IfaceListTc [ty]) = do { putByte bh 9; put_ bh ty }
613 -- Unit tuple and pairs
614 put_ bh (IfaceTyConApp (IfaceTupTc Boxed 0) []) = putByte bh 10
615 put_ bh (IfaceTyConApp (IfaceTupTc Boxed 2) [t1,t2]) = do { putByte bh 11; put_ bh t1; put_ bh t2 }
617 put_ bh (IfaceTyConApp (IfaceTc tc) tys) = do { putByte bh 12; put_ bh tc; put_ bh tys }
618 put_ bh (IfaceTyConApp tc tys) = do { putByte bh 13; put_ bh tc; put_ bh tys }
625 return (IfaceForAllTy aa ab)
627 return (IfaceTyVar ad)
630 return (IfaceAppTy ae af)
633 return (IfaceFunTy ag ah)
635 return (IfacePredTy ap)
637 -- Now the special cases for TyConApp
638 6 -> return (IfaceTyConApp IfaceIntTc [])
639 7 -> return (IfaceTyConApp IfaceCharTc [])
640 8 -> return (IfaceTyConApp IfaceBoolTc [])
641 9 -> do { ty <- get bh; return (IfaceTyConApp IfaceListTc [ty]) }
642 10 -> return (IfaceTyConApp (IfaceTupTc Boxed 0) [])
643 11 -> do { t1 <- get bh; t2 <- get bh; return (IfaceTyConApp (IfaceTupTc Boxed 2) [t1,t2]) }
644 12 -> do { tc <- get bh; tys <- get bh; return (IfaceTyConApp (IfaceTc tc) tys) }
645 _ -> do { tc <- get bh; tys <- get bh; return (IfaceTyConApp tc tys) }
647 instance Binary IfaceTyCon where
648 -- Int,Char,Bool can't show up here because they can't not be saturated
650 put_ bh IfaceIntTc = putByte bh 1
651 put_ bh IfaceBoolTc = putByte bh 2
652 put_ bh IfaceCharTc = putByte bh 3
653 put_ bh IfaceListTc = putByte bh 4
654 put_ bh IfacePArrTc = putByte bh 5
655 put_ bh (IfaceTupTc bx ar) = do { putByte bh 6; put_ bh bx; put_ bh ar }
656 put_ bh (IfaceTc ext) = do { putByte bh 7; put_ bh ext }
661 1 -> return IfaceIntTc
662 2 -> return IfaceBoolTc
663 3 -> return IfaceCharTc
664 4 -> return IfaceListTc
665 5 -> return IfacePArrTc
666 6 -> do { bx <- get bh; ar <- get bh; return (IfaceTupTc bx ar) }
667 _ -> do { ext <- get bh; return (IfaceTc ext) }
669 instance Binary IfacePredType where
670 put_ bh (IfaceClassP aa ab) = do
674 put_ bh (IfaceIParam ac ad) = do
683 return (IfaceClassP aa ab)
686 return (IfaceIParam ac ad)
688 -------------------------------------------------------------------------
689 -- IfaceExpr and friends
690 -------------------------------------------------------------------------
692 instance Binary IfaceExpr where
693 put_ bh (IfaceLcl aa) = do
696 put_ bh (IfaceType ab) = do
699 put_ bh (IfaceTuple ac ad) = do
703 put_ bh (IfaceLam ae af) = do
707 put_ bh (IfaceApp ag ah) = do
712 put_ bh (IfaceCase ai aj al ak) = do
719 put_ bh (IfaceLet al am) = do
723 put_ bh (IfaceNote an ao) = do
727 put_ bh (IfaceLit ap) = do
730 put_ bh (IfaceFCall as at) = do
734 put_ bh (IfaceExt aa) = do
743 return (IfaceType ab)
746 return (IfaceTuple ac ad)
749 return (IfaceLam ae af)
752 return (IfaceApp ag ah)
759 return (IfaceCase ai aj al ak)
762 return (IfaceLet al am)
765 return (IfaceNote an ao)
770 return (IfaceFCall as at)
774 instance Binary IfaceConAlt where
775 put_ bh IfaceDefault = do
777 put_ bh (IfaceDataAlt aa) = do
780 put_ bh (IfaceTupleAlt ab) = do
783 put_ bh (IfaceLitAlt ac) = do
789 0 -> do return IfaceDefault
791 return (IfaceDataAlt aa)
793 return (IfaceTupleAlt ab)
795 return (IfaceLitAlt ac)
797 instance Binary IfaceBinding where
798 put_ bh (IfaceNonRec aa ab) = do
802 put_ bh (IfaceRec ac) = do
810 return (IfaceNonRec aa ab)
814 instance Binary IfaceIdInfo where
815 put_ bh NoInfo = putByte bh 0
816 put_ bh (HasInfo i) = do
818 lazyPut bh i -- NB lazyPut
824 _ -> do info <- lazyGet bh -- NB lazyGet
825 return (HasInfo info)
827 instance Binary IfaceInfoItem where
828 put_ bh (HsArity aa) = do
831 put_ bh (HsStrictness ab) = do
834 put_ bh (HsUnfold ad) = do
837 put_ bh (HsInline ad) = do
840 put_ bh HsNoCafRefs = do
842 put_ bh (HsWorker ae af) = do
852 return (HsStrictness ab)
857 4 -> do return HsNoCafRefs
860 return (HsWorker ae af)
862 instance Binary IfaceNote where
863 put_ bh (IfaceSCC aa) = do
866 put_ bh (IfaceCoerce ab) = do
869 put_ bh IfaceInlineMe = do
871 put_ bh (IfaceCoreNote s) = do
880 return (IfaceCoerce ab)
881 3 -> do return IfaceInlineMe
883 return (IfaceCoreNote ac)
886 -------------------------------------------------------------------------
887 -- IfaceDecl and friends
888 -------------------------------------------------------------------------
890 instance Binary IfaceDecl where
891 put_ bh (IfaceId name ty idinfo) = do
896 put_ bh (IfaceForeign ae af) =
897 error "Binary.put_(IfaceDecl): IfaceForeign"
898 put_ bh (IfaceData a1 a2 a3 a4 a5 a6 a7) = do
908 put_ bh (IfaceSyn aq ar as at) = do
914 put_ bh (IfaceClass a1 a2 a3 a4 a5 a6 a7) = do
926 0 -> do name <- get bh
929 return (IfaceId name ty idinfo)
930 1 -> error "Binary.get(TyClDecl): ForeignType"
939 return (IfaceData a1 a2 a3 a4 a5 a6 a7)
945 return (IfaceSyn aq ar as at)
954 return (IfaceClass a1 a2 a3 a4 a5 a6 a7)
956 instance Binary IfaceInst where
957 put_ bh (IfaceInst cls tys dfun flag orph) = do
963 get bh = do cls <- get bh
968 return (IfaceInst cls tys dfun flag orph)
970 instance Binary OverlapFlag where
971 put_ bh NoOverlap = putByte bh 0
972 put_ bh OverlapOk = putByte bh 1
973 put_ bh Incoherent = putByte bh 2
974 get bh = do h <- getByte bh
976 0 -> return NoOverlap
977 1 -> return OverlapOk
978 2 -> return Incoherent
980 instance Binary IfaceConDecls where
981 put_ bh IfAbstractTyCon = putByte bh 0
982 put_ bh (IfDataTyCon cs) = do { putByte bh 1
984 put_ bh (IfNewTyCon c) = do { putByte bh 2
989 0 -> return IfAbstractTyCon
991 return (IfDataTyCon cs)
993 return (IfNewTyCon aa)
995 instance Binary IfaceConDecl where
996 put_ bh (IfVanillaCon a1 a2 a3 a4 a5) = do
1003 put_ bh (IfGadtCon a1 a2 a3 a4 a5 a6) = do
1014 0 -> do a1 <- get bh
1019 return (IfVanillaCon a1 a2 a3 a4 a5)
1020 _ -> do a1 <- get bh
1026 return (IfGadtCon a1 a2 a3 a4 a5 a6)
1028 instance Binary IfaceClassOp where
1029 put_ bh (IfaceClassOp n def ty) = do
1037 return (IfaceClassOp n def ty)
1039 instance Binary IfaceRule where
1040 put_ bh (IfaceRule a1 a2 a3 a4 a5 a6 a7) = do
1056 return (IfaceRule a1 a2 a3 a4 a5 a6 a7)