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 Class ( DefMeth(..) )
20 import StaticFlags ( opt_HiVersion, v_Build_tag )
24 import Config ( cGhcUnregisterised )
27 import EXCEPTION ( throwDyn )
31 #include "HsVersions.h"
33 -- ---------------------------------------------------------------------------
34 writeBinIface :: FilePath -> ModIface -> IO ()
35 writeBinIface hi_path mod_iface
36 = putBinFileWithDict hi_path mod_iface
38 readBinIface :: FilePath -> IO ModIface
39 readBinIface hi_path = getBinFileWithDict hi_path
42 -- %*********************************************************
44 -- All the Binary instances
46 -- %*********************************************************
49 {-! for IPName derive: Binary !-}
50 {-! for Fixity derive: Binary !-}
51 {-! for FixityDirection derive: Binary !-}
52 {-! for Boxity derive: Binary !-}
53 {-! for StrictnessMark derive: Binary !-}
54 {-! for Activation derive: Binary !-}
57 {-! for Demand derive: Binary !-}
58 {-! for Demands derive: Binary !-}
59 {-! for DmdResult derive: Binary !-}
60 {-! for StrictSig derive: Binary !-}
63 {-! for DefMeth derive: Binary !-}
66 {-! for HsPred derive: Binary !-}
67 {-! for HsType derive: Binary !-}
68 {-! for TupCon derive: Binary !-}
69 {-! for HsTyVarBndr derive: Binary !-}
72 {-! for UfExpr derive: Binary !-}
73 {-! for UfConAlt derive: Binary !-}
74 {-! for UfBinding derive: Binary !-}
75 {-! for UfBinder derive: Binary !-}
76 {-! for HsIdInfo derive: Binary !-}
77 {-! for UfNote derive: Binary !-}
80 {-! for ConDetails derive: Binary !-}
81 {-! for BangType derive: Binary !-}
84 {-! for IsCafCC derive: Binary !-}
85 {-! for IsDupdCC derive: Binary !-}
86 {-! for CostCentre derive: Binary !-}
90 -- ---------------------------------------------------------------------------
91 -- Reading a binary interface into ParsedIface
93 instance Binary ModIface where
97 mi_mod_vers = mod_vers,
101 mi_exports = exports,
102 mi_exp_vers = exp_vers,
103 mi_fixities = fixities,
104 mi_deprecs = deprecs,
107 mi_fam_insts = fam_insts,
109 mi_rule_vers = rule_vers }) = do
110 put_ bh (show opt_HiVersion)
111 way_descr <- getWayDescr
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 way_descr <- getWayDescr
142 when (not ignore_way && check_way /= way_descr) $
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 ++ way_descr ++ ", 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 fam_insts <- {-# SCC "bin_fam_insts" #-} get bh
162 rules <- {-# SCC "bin_rules" #-} lazyGet bh
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,
178 mi_fam_insts = fam_insts,
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 (IPName aa) = put_ bh aa
368 get bh = do aa <- get bh
371 -------------------------------------------------------------------------
372 -- Types from: Demand
373 -------------------------------------------------------------------------
375 instance Binary DmdType where
376 -- Ignore DmdEnv when spitting out the DmdType
377 put bh (DmdType _ ds dr) = do p <- put bh ds; put bh dr; return (castBin p)
378 get bh = do ds <- get bh; dr <- get bh; return (DmdType emptyVarEnv ds dr)
380 instance Binary Demand where
385 put_ bh (Call aa) = do
388 put_ bh (Eval ab) = do
391 put_ bh (Defer ac) = do
394 put_ bh (Box ad) = do
414 instance Binary Demands where
415 put_ bh (Poly aa) = do
418 put_ bh (Prod ab) = do
429 instance Binary DmdResult where
439 0 -> do return TopRes
440 1 -> do return RetCPR -- Really use RetCPR even if -fcpr-off
441 -- The wrapper was generated for CPR in
442 -- the imported module!
443 _ -> do return BotRes
445 instance Binary StrictSig where
446 put_ bh (StrictSig aa) = do
450 return (StrictSig aa)
453 -------------------------------------------------------------------------
454 -- Types from: CostCentre
455 -------------------------------------------------------------------------
457 instance Binary IsCafCC where
460 put_ bh NotCafCC = do
466 _ -> do return NotCafCC
468 instance Binary IsDupdCC where
469 put_ bh OriginalCC = do
476 0 -> do return OriginalCC
477 _ -> do return DupdCC
479 instance Binary CostCentre where
480 put_ bh NoCostCentre = do
482 put_ bh (NormalCC aa ab ac ad) = do
488 put_ bh (AllCafsCC ae) = do
494 0 -> do return NoCostCentre
499 return (NormalCC aa ab ac ad)
501 return (AllCafsCC ae)
503 -------------------------------------------------------------------------
504 -- IfaceTypes and friends
505 -------------------------------------------------------------------------
507 instance Binary IfaceExtName where
508 put_ bh (ExtPkg mod occ) = do
512 put_ bh (HomePkg mod occ vers) = do
517 put_ bh (LocalTop occ) = do
520 put_ bh (LocalTopSub occ _) = do -- Write LocalTopSub just like LocalTop
527 0 -> do mod <- get bh
529 return (ExtPkg mod occ)
530 1 -> do mod <- get bh
533 return (HomePkg mod occ vers)
534 _ -> do occ <- get bh
535 return (LocalTop occ)
537 instance Binary IfaceBndr where
538 put_ bh (IfaceIdBndr aa) = do
541 put_ bh (IfaceTvBndr ab) = do
548 return (IfaceIdBndr aa)
550 return (IfaceTvBndr ab)
552 instance Binary IfaceType where
553 put_ bh (IfaceForAllTy aa ab) = do
557 put_ bh (IfaceTyVar ad) = do
560 put_ bh (IfaceAppTy ae af) = do
564 put_ bh (IfaceFunTy ag ah) = do
568 put_ bh (IfacePredTy aq) = do
572 -- Simple compression for common cases of TyConApp
573 put_ bh (IfaceTyConApp IfaceIntTc []) = putByte bh 6
574 put_ bh (IfaceTyConApp IfaceCharTc []) = putByte bh 7
575 put_ bh (IfaceTyConApp IfaceBoolTc []) = putByte bh 8
576 put_ bh (IfaceTyConApp IfaceListTc [ty]) = do { putByte bh 9; put_ bh ty }
577 -- Unit tuple and pairs
578 put_ bh (IfaceTyConApp (IfaceTupTc Boxed 0) []) = putByte bh 10
579 put_ bh (IfaceTyConApp (IfaceTupTc Boxed 2) [t1,t2]) = do { putByte bh 11; put_ bh t1; put_ bh t2 }
581 put_ bh (IfaceTyConApp IfaceLiftedTypeKindTc []) = putByte bh 12
582 put_ bh (IfaceTyConApp IfaceOpenTypeKindTc []) = putByte bh 13
583 put_ bh (IfaceTyConApp IfaceUnliftedTypeKindTc []) = putByte bh 14
584 put_ bh (IfaceTyConApp IfaceUbxTupleKindTc []) = putByte bh 15
585 put_ bh (IfaceTyConApp IfaceArgTypeKindTc []) = putByte bh 16
589 put_ bh (IfaceTyConApp (IfaceTc tc) tys) = do { putByte bh 18; put_ bh tc; put_ bh tys }
590 put_ bh (IfaceTyConApp tc tys) = do { putByte bh 19; put_ bh tc; put_ bh tys }
597 return (IfaceForAllTy aa ab)
599 return (IfaceTyVar ad)
602 return (IfaceAppTy ae af)
605 return (IfaceFunTy ag ah)
607 return (IfacePredTy ap)
609 -- Now the special cases for TyConApp
610 6 -> return (IfaceTyConApp IfaceIntTc [])
611 7 -> return (IfaceTyConApp IfaceCharTc [])
612 8 -> return (IfaceTyConApp IfaceBoolTc [])
613 9 -> do { ty <- get bh; return (IfaceTyConApp IfaceListTc [ty]) }
614 10 -> return (IfaceTyConApp (IfaceTupTc Boxed 0) [])
615 11 -> do { t1 <- get bh; t2 <- get bh; return (IfaceTyConApp (IfaceTupTc Boxed 2) [t1,t2]) }
616 12 -> return (IfaceTyConApp IfaceLiftedTypeKindTc [])
617 13 -> return (IfaceTyConApp IfaceOpenTypeKindTc [])
618 14 -> return (IfaceTyConApp IfaceUnliftedTypeKindTc [])
619 15 -> return (IfaceTyConApp IfaceUbxTupleKindTc [])
620 16 -> return (IfaceTyConApp IfaceArgTypeKindTc [])
622 18 -> do { tc <- get bh; tys <- get bh; return (IfaceTyConApp (IfaceTc tc) tys) }
623 _ -> do { tc <- get bh; tys <- get bh; return (IfaceTyConApp tc tys) }
625 instance Binary IfaceTyCon where
626 -- Int,Char,Bool can't show up here because they can't not be saturated
628 put_ bh IfaceIntTc = putByte bh 1
629 put_ bh IfaceBoolTc = putByte bh 2
630 put_ bh IfaceCharTc = putByte bh 3
631 put_ bh IfaceListTc = putByte bh 4
632 put_ bh IfacePArrTc = putByte bh 5
633 put_ bh IfaceLiftedTypeKindTc = putByte bh 6
634 put_ bh IfaceOpenTypeKindTc = putByte bh 7
635 put_ bh IfaceUnliftedTypeKindTc = putByte bh 8
636 put_ bh IfaceUbxTupleKindTc = putByte bh 9
637 put_ bh IfaceArgTypeKindTc = putByte bh 10
638 put_ bh (IfaceTupTc bx ar) = do { putByte bh 11; put_ bh bx; put_ bh ar }
639 put_ bh (IfaceTc ext) = do { putByte bh 12; put_ bh ext }
644 1 -> return IfaceIntTc
645 2 -> return IfaceBoolTc
646 3 -> return IfaceCharTc
647 4 -> return IfaceListTc
648 5 -> return IfacePArrTc
649 6 -> return IfaceLiftedTypeKindTc
650 7 -> return IfaceOpenTypeKindTc
651 8 -> return IfaceUnliftedTypeKindTc
652 9 -> return IfaceUbxTupleKindTc
653 10 -> return IfaceArgTypeKindTc
654 11 -> do { bx <- get bh; ar <- get bh; return (IfaceTupTc bx ar) }
655 _ -> do { ext <- get bh; return (IfaceTc ext) }
657 instance Binary IfacePredType where
658 put_ bh (IfaceClassP aa ab) = do
662 put_ bh (IfaceIParam ac ad) = do
666 put_ bh (IfaceEqPred ac ad) = do
675 return (IfaceClassP aa ab)
678 return (IfaceIParam ac ad)
681 return (IfaceEqPred ac ad)
683 -------------------------------------------------------------------------
684 -- IfaceExpr and friends
685 -------------------------------------------------------------------------
687 instance Binary IfaceExpr where
688 put_ bh (IfaceLcl aa) = do
691 put_ bh (IfaceType ab) = do
694 put_ bh (IfaceTuple ac ad) = do
698 put_ bh (IfaceLam ae af) = do
702 put_ bh (IfaceApp ag ah) = do
707 put_ bh (IfaceCase ai aj al ak) = do
714 put_ bh (IfaceLet al am) = do
718 put_ bh (IfaceNote an ao) = do
722 put_ bh (IfaceLit ap) = do
725 put_ bh (IfaceFCall as at) = do
729 put_ bh (IfaceExt aa) = do
732 put_ bh (IfaceCast ie ico) = do
742 return (IfaceType ab)
745 return (IfaceTuple ac ad)
748 return (IfaceLam ae af)
751 return (IfaceApp ag ah)
758 return (IfaceCase ai aj al ak)
761 return (IfaceLet al am)
764 return (IfaceNote an ao)
769 return (IfaceFCall as at)
770 10 -> do aa <- get bh
772 11 -> do ie <- get bh
774 return (IfaceCast ie ico)
776 instance Binary IfaceConAlt where
777 put_ bh IfaceDefault = do
779 put_ bh (IfaceDataAlt aa) = do
782 put_ bh (IfaceTupleAlt ab) = do
785 put_ bh (IfaceLitAlt ac) = do
791 0 -> do return IfaceDefault
793 return (IfaceDataAlt aa)
795 return (IfaceTupleAlt ab)
797 return (IfaceLitAlt ac)
799 instance Binary IfaceBinding where
800 put_ bh (IfaceNonRec aa ab) = do
804 put_ bh (IfaceRec ac) = do
812 return (IfaceNonRec aa ab)
816 instance Binary IfaceIdInfo where
817 put_ bh NoInfo = putByte bh 0
818 put_ bh (HasInfo i) = do
820 lazyPut bh i -- NB lazyPut
826 _ -> do info <- lazyGet bh -- NB lazyGet
827 return (HasInfo info)
829 instance Binary IfaceInfoItem where
830 put_ bh (HsArity aa) = do
833 put_ bh (HsStrictness ab) = do
836 put_ bh (HsUnfold ad) = do
839 put_ bh (HsInline ad) = do
842 put_ bh HsNoCafRefs = do
844 put_ bh (HsWorker ae af) = do
854 return (HsStrictness ab)
859 4 -> do return HsNoCafRefs
862 return (HsWorker ae af)
864 instance Binary IfaceNote where
865 put_ bh (IfaceSCC aa) = do
868 put_ bh IfaceInlineMe = do
870 put_ bh (IfaceCoreNote s) = do
878 3 -> do return IfaceInlineMe
880 return (IfaceCoreNote ac)
883 -------------------------------------------------------------------------
884 -- IfaceDecl and friends
885 -------------------------------------------------------------------------
887 instance Binary IfaceDecl where
888 put_ bh (IfaceId name ty idinfo) = do
893 put_ bh (IfaceForeign ae af) =
894 error "Binary.put_(IfaceDecl): IfaceForeign"
895 put_ bh (IfaceData a1 a2 a3 a4 a5 a6 a7 a8) = do
905 put_ bh (IfaceSyn aq ar as at) = do
911 put_ bh (IfaceClass a1 a2 a3 a4 a5 a6 a7) = do
923 0 -> do name <- get bh
926 return (IfaceId name ty idinfo)
927 1 -> error "Binary.get(TyClDecl): ForeignType"
937 return (IfaceData a1 a2 a3 a4 a5 a6 a7 a8)
943 return (IfaceSyn aq ar as at)
952 return (IfaceClass a1 a2 a3 a4 a5 a6 a7)
954 instance Binary IfaceInst where
955 put_ bh (IfaceInst cls tys dfun flag orph) = do
961 get bh = do cls <- get bh
966 return (IfaceInst cls tys dfun flag orph)
968 instance Binary IfaceFamInst where
969 put_ bh (IfaceFamInst fam tys tycon) = do
973 get bh = do fam <- get bh
976 return (IfaceFamInst fam tys tycon)
978 instance Binary OverlapFlag where
979 put_ bh NoOverlap = putByte bh 0
980 put_ bh OverlapOk = putByte bh 1
981 put_ bh Incoherent = putByte bh 2
982 get bh = do h <- getByte bh
984 0 -> return NoOverlap
985 1 -> return OverlapOk
986 2 -> return Incoherent
988 instance Binary IfaceConDecls where
989 put_ bh IfAbstractTyCon = putByte bh 0
990 put_ bh IfOpenDataTyCon = putByte bh 1
991 put_ bh IfOpenNewTyCon = putByte bh 2
992 put_ bh (IfDataTyCon cs) = do { putByte bh 3
994 put_ bh (IfNewTyCon c) = do { putByte bh 4
999 0 -> return IfAbstractTyCon
1000 1 -> return IfOpenDataTyCon
1001 2 -> return IfOpenNewTyCon
1002 3 -> do cs <- get bh
1003 return (IfDataTyCon cs)
1004 _ -> do aa <- get bh
1005 return (IfNewTyCon aa)
1007 instance Binary IfaceConDecl where
1008 put_ bh (IfCon a1 a2 a3 a4 a5 a6 a7 a8 a9) = do
1018 get bh = do a1 <- get bh
1027 return (IfCon a1 a2 a3 a4 a5 a6 a7 a8 a9)
1029 instance Binary IfaceClassOp where
1030 put_ bh (IfaceClassOp n def ty) = do
1038 return (IfaceClassOp n def ty)
1040 instance Binary IfaceRule where
1041 put_ bh (IfaceRule a1 a2 a3 a4 a5 a6 a7) = do
1057 return (IfaceRule a1 a2 a3 a4 a5 a6 a7)