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,
108 mi_rule_vers = rule_vers }) = do
109 put_ bh (show opt_HiVersion)
110 way_descr <- getWayDescr
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 way_descr <- getWayDescr
140 when (not ignore_way && check_way /= way_descr) $
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 ++ way_descr ++ ", 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_module = mod_name,
164 mi_mod_vers = mod_vers,
168 mi_exports = exports,
169 mi_exp_vers = exp_vers,
170 mi_fixities = fixities,
171 mi_deprecs = deprecs,
173 mi_globals = Nothing,
175 mi_fam_insts = mkIfaceFamInstsCache . map snd $ decls,
177 mi_rule_vers = rule_vers,
178 -- And build the cached values
179 mi_dep_fn = mkIfaceDepCache deprecs,
180 mi_fix_fn = mkIfaceFixCache fixities,
181 mi_ver_fn = mkIfaceVerCache decls })
183 GLOBAL_VAR(v_IgnoreHiWay, False, Bool)
185 getWayDescr :: IO String
187 tag <- readIORef v_Build_tag
188 if cGhcUnregisterised == "YES" then return ('u':tag) else return tag
189 -- if this is an unregisterised build, make sure our interfaces
190 -- can't be used by a registerised build.
192 -------------------------------------------------------------------------
193 -- Types from: HscTypes
194 -------------------------------------------------------------------------
196 instance Binary Dependencies where
197 put_ bh deps = do put_ bh (dep_mods deps)
198 put_ bh (dep_pkgs deps)
199 put_ bh (dep_orphs deps)
201 get bh = do ms <- get bh
204 return (Deps { dep_mods = ms, dep_pkgs = ps, dep_orphs = os })
206 instance (Binary name) => Binary (GenAvailInfo name) where
207 put_ bh (Avail aa) = do
210 put_ bh (AvailTC ab ac) = do
221 return (AvailTC ab ac)
223 instance Binary Usage where
225 put_ bh (usg_name usg)
226 put_ bh (usg_mod usg)
227 put_ bh (usg_exports usg)
228 put_ bh (usg_entities usg)
229 put_ bh (usg_rules usg)
237 return (Usage { usg_name = nm, usg_mod = mod,
238 usg_exports = exps, usg_entities = ents,
241 instance Binary a => Binary (Deprecs a) where
242 put_ bh NoDeprecs = putByte bh 0
243 put_ bh (DeprecAll t) = do
246 put_ bh (DeprecSome ts) = do
253 0 -> return NoDeprecs
255 return (DeprecAll aa)
257 return (DeprecSome aa)
259 -------------------------------------------------------------------------
260 -- Types from: BasicTypes
261 -------------------------------------------------------------------------
263 instance Binary Activation where
264 put_ bh NeverActive = do
266 put_ bh AlwaysActive = do
268 put_ bh (ActiveBefore aa) = do
271 put_ bh (ActiveAfter ab) = do
277 0 -> do return NeverActive
278 1 -> do return AlwaysActive
280 return (ActiveBefore aa)
282 return (ActiveAfter ab)
284 instance Binary StrictnessMark where
285 put_ bh MarkedStrict = do
287 put_ bh MarkedUnboxed = do
289 put_ bh NotMarkedStrict = do
294 0 -> do return MarkedStrict
295 1 -> do return MarkedUnboxed
296 _ -> do return NotMarkedStrict
298 instance Binary Boxity where
307 _ -> do return Unboxed
309 instance Binary TupCon where
310 put_ bh (TupCon ab ac) = do
316 return (TupCon ab ac)
318 instance Binary RecFlag where
319 put_ bh Recursive = do
321 put_ bh NonRecursive = do
326 0 -> do return Recursive
327 _ -> do return NonRecursive
329 instance Binary DefMeth where
330 put_ bh NoDefMeth = putByte bh 0
331 put_ bh DefMeth = putByte bh 1
332 put_ bh GenDefMeth = putByte bh 2
336 0 -> return NoDefMeth
338 _ -> return GenDefMeth
340 instance Binary FixityDirection where
350 0 -> do return InfixL
351 1 -> do return InfixR
352 _ -> do return InfixN
354 instance Binary Fixity where
355 put_ bh (Fixity aa ab) = do
361 return (Fixity aa ab)
363 instance (Binary name) => Binary (IPName name) where
364 put_ bh (IPName aa) = put_ bh aa
365 get bh = do aa <- get bh
368 -------------------------------------------------------------------------
369 -- Types from: Demand
370 -------------------------------------------------------------------------
372 instance Binary DmdType where
373 -- Ignore DmdEnv when spitting out the DmdType
374 put bh (DmdType _ ds dr) = do p <- put bh ds; put bh dr; return (castBin p)
375 get bh = do ds <- get bh; dr <- get bh; return (DmdType emptyVarEnv ds dr)
377 instance Binary Demand where
382 put_ bh (Call aa) = do
385 put_ bh (Eval ab) = do
388 put_ bh (Defer ac) = do
391 put_ bh (Box ad) = do
411 instance Binary Demands where
412 put_ bh (Poly aa) = do
415 put_ bh (Prod ab) = do
426 instance Binary DmdResult where
436 0 -> do return TopRes
437 1 -> do return RetCPR -- Really use RetCPR even if -fcpr-off
438 -- The wrapper was generated for CPR in
439 -- the imported module!
440 _ -> do return BotRes
442 instance Binary StrictSig where
443 put_ bh (StrictSig aa) = do
447 return (StrictSig aa)
450 -------------------------------------------------------------------------
451 -- Types from: CostCentre
452 -------------------------------------------------------------------------
454 instance Binary IsCafCC where
457 put_ bh NotCafCC = do
463 _ -> do return NotCafCC
465 instance Binary IsDupdCC where
466 put_ bh OriginalCC = do
473 0 -> do return OriginalCC
474 _ -> do return DupdCC
476 instance Binary CostCentre where
477 put_ bh NoCostCentre = do
479 put_ bh (NormalCC aa ab ac ad) = do
485 put_ bh (AllCafsCC ae) = do
491 0 -> do return NoCostCentre
496 return (NormalCC aa ab ac ad)
498 return (AllCafsCC ae)
500 -------------------------------------------------------------------------
501 -- IfaceTypes and friends
502 -------------------------------------------------------------------------
504 instance Binary IfaceExtName where
505 put_ bh (ExtPkg mod occ) = do
509 put_ bh (HomePkg mod occ vers) = do
514 put_ bh (LocalTop occ) = do
517 put_ bh (LocalTopSub occ _) = do -- Write LocalTopSub just like LocalTop
524 0 -> do mod <- get bh
526 return (ExtPkg mod occ)
527 1 -> do mod <- get bh
530 return (HomePkg mod occ vers)
531 _ -> do occ <- get bh
532 return (LocalTop occ)
534 instance Binary IfaceBndr where
535 put_ bh (IfaceIdBndr aa) = do
538 put_ bh (IfaceTvBndr ab) = do
545 return (IfaceIdBndr aa)
547 return (IfaceTvBndr ab)
549 instance Binary IfaceType where
550 put_ bh (IfaceForAllTy aa ab) = do
554 put_ bh (IfaceTyVar ad) = do
557 put_ bh (IfaceAppTy ae af) = do
561 put_ bh (IfaceFunTy ag ah) = do
565 put_ bh (IfacePredTy aq) = do
569 -- Simple compression for common cases of TyConApp
570 put_ bh (IfaceTyConApp IfaceIntTc []) = putByte bh 6
571 put_ bh (IfaceTyConApp IfaceCharTc []) = putByte bh 7
572 put_ bh (IfaceTyConApp IfaceBoolTc []) = putByte bh 8
573 put_ bh (IfaceTyConApp IfaceListTc [ty]) = do { putByte bh 9; put_ bh ty }
574 -- Unit tuple and pairs
575 put_ bh (IfaceTyConApp (IfaceTupTc Boxed 0) []) = putByte bh 10
576 put_ bh (IfaceTyConApp (IfaceTupTc Boxed 2) [t1,t2]) = do { putByte bh 11; put_ bh t1; put_ bh t2 }
578 put_ bh (IfaceTyConApp IfaceLiftedTypeKindTc []) = putByte bh 12
579 put_ bh (IfaceTyConApp IfaceOpenTypeKindTc []) = putByte bh 13
580 put_ bh (IfaceTyConApp IfaceUnliftedTypeKindTc []) = putByte bh 14
581 put_ bh (IfaceTyConApp IfaceUbxTupleKindTc []) = putByte bh 15
582 put_ bh (IfaceTyConApp IfaceArgTypeKindTc []) = putByte bh 16
586 put_ bh (IfaceTyConApp (IfaceTc tc) tys) = do { putByte bh 18; put_ bh tc; put_ bh tys }
587 put_ bh (IfaceTyConApp tc tys) = do { putByte bh 19; put_ bh tc; put_ bh tys }
594 return (IfaceForAllTy aa ab)
596 return (IfaceTyVar ad)
599 return (IfaceAppTy ae af)
602 return (IfaceFunTy ag ah)
604 return (IfacePredTy ap)
606 -- Now the special cases for TyConApp
607 6 -> return (IfaceTyConApp IfaceIntTc [])
608 7 -> return (IfaceTyConApp IfaceCharTc [])
609 8 -> return (IfaceTyConApp IfaceBoolTc [])
610 9 -> do { ty <- get bh; return (IfaceTyConApp IfaceListTc [ty]) }
611 10 -> return (IfaceTyConApp (IfaceTupTc Boxed 0) [])
612 11 -> do { t1 <- get bh; t2 <- get bh; return (IfaceTyConApp (IfaceTupTc Boxed 2) [t1,t2]) }
613 12 -> return (IfaceTyConApp IfaceLiftedTypeKindTc [])
614 13 -> return (IfaceTyConApp IfaceOpenTypeKindTc [])
615 14 -> return (IfaceTyConApp IfaceUnliftedTypeKindTc [])
616 15 -> return (IfaceTyConApp IfaceUbxTupleKindTc [])
617 16 -> return (IfaceTyConApp IfaceArgTypeKindTc [])
619 18 -> do { tc <- get bh; tys <- get bh; return (IfaceTyConApp (IfaceTc tc) tys) }
620 _ -> do { tc <- get bh; tys <- get bh; return (IfaceTyConApp tc tys) }
622 instance Binary IfaceTyCon where
623 -- Int,Char,Bool can't show up here because they can't not be saturated
625 put_ bh IfaceIntTc = putByte bh 1
626 put_ bh IfaceBoolTc = putByte bh 2
627 put_ bh IfaceCharTc = putByte bh 3
628 put_ bh IfaceListTc = putByte bh 4
629 put_ bh IfacePArrTc = putByte bh 5
630 put_ bh IfaceLiftedTypeKindTc = putByte bh 6
631 put_ bh IfaceOpenTypeKindTc = putByte bh 7
632 put_ bh IfaceUnliftedTypeKindTc = putByte bh 8
633 put_ bh IfaceUbxTupleKindTc = putByte bh 9
634 put_ bh IfaceArgTypeKindTc = putByte bh 10
635 put_ bh (IfaceTupTc bx ar) = do { putByte bh 11; put_ bh bx; put_ bh ar }
636 put_ bh (IfaceTc ext) = do { putByte bh 12; put_ bh ext }
641 1 -> return IfaceIntTc
642 2 -> return IfaceBoolTc
643 3 -> return IfaceCharTc
644 4 -> return IfaceListTc
645 5 -> return IfacePArrTc
646 6 -> return IfaceLiftedTypeKindTc
647 7 -> return IfaceOpenTypeKindTc
648 8 -> return IfaceUnliftedTypeKindTc
649 9 -> return IfaceUbxTupleKindTc
650 10 -> return IfaceArgTypeKindTc
651 11 -> do { bx <- get bh; ar <- get bh; return (IfaceTupTc bx ar) }
652 _ -> do { ext <- get bh; return (IfaceTc ext) }
654 instance Binary IfacePredType where
655 put_ bh (IfaceClassP aa ab) = do
659 put_ bh (IfaceIParam ac ad) = do
663 put_ bh (IfaceEqPred ac ad) = do
672 return (IfaceClassP aa ab)
675 return (IfaceIParam ac ad)
678 return (IfaceEqPred ac ad)
680 -------------------------------------------------------------------------
681 -- IfaceExpr and friends
682 -------------------------------------------------------------------------
684 instance Binary IfaceExpr where
685 put_ bh (IfaceLcl aa) = do
688 put_ bh (IfaceType ab) = do
691 put_ bh (IfaceTuple ac ad) = do
695 put_ bh (IfaceLam ae af) = do
699 put_ bh (IfaceApp ag ah) = do
704 put_ bh (IfaceCase ai aj al ak) = do
711 put_ bh (IfaceLet al am) = do
715 put_ bh (IfaceNote an ao) = do
719 put_ bh (IfaceLit ap) = do
722 put_ bh (IfaceFCall as at) = do
726 put_ bh (IfaceExt aa) = do
729 put_ bh (IfaceCast ie ico) = do
739 return (IfaceType ab)
742 return (IfaceTuple ac ad)
745 return (IfaceLam ae af)
748 return (IfaceApp ag ah)
755 return (IfaceCase ai aj al ak)
758 return (IfaceLet al am)
761 return (IfaceNote an ao)
766 return (IfaceFCall as at)
767 10 -> do aa <- get bh
769 11 -> do ie <- get bh
771 return (IfaceCast ie ico)
773 instance Binary IfaceConAlt where
774 put_ bh IfaceDefault = do
776 put_ bh (IfaceDataAlt aa) = do
779 put_ bh (IfaceTupleAlt ab) = do
782 put_ bh (IfaceLitAlt ac) = do
788 0 -> do return IfaceDefault
790 return (IfaceDataAlt aa)
792 return (IfaceTupleAlt ab)
794 return (IfaceLitAlt ac)
796 instance Binary IfaceBinding where
797 put_ bh (IfaceNonRec aa ab) = do
801 put_ bh (IfaceRec ac) = do
809 return (IfaceNonRec aa ab)
813 instance Binary IfaceIdInfo where
814 put_ bh NoInfo = putByte bh 0
815 put_ bh (HasInfo i) = do
817 lazyPut bh i -- NB lazyPut
823 _ -> do info <- lazyGet bh -- NB lazyGet
824 return (HasInfo info)
826 instance Binary IfaceInfoItem where
827 put_ bh (HsArity aa) = do
830 put_ bh (HsStrictness ab) = do
833 put_ bh (HsUnfold ad) = do
836 put_ bh (HsInline ad) = do
839 put_ bh HsNoCafRefs = do
841 put_ bh (HsWorker ae af) = do
851 return (HsStrictness ab)
856 4 -> do return HsNoCafRefs
859 return (HsWorker ae af)
861 instance Binary IfaceNote where
862 put_ bh (IfaceSCC aa) = do
865 put_ bh IfaceInlineMe = do
867 put_ bh (IfaceCoreNote s) = do
875 3 -> do return IfaceInlineMe
877 return (IfaceCoreNote ac)
880 -------------------------------------------------------------------------
881 -- IfaceDecl and friends
882 -------------------------------------------------------------------------
884 instance Binary IfaceDecl where
885 put_ bh (IfaceId name ty idinfo) = do
890 put_ bh (IfaceForeign ae af) =
891 error "Binary.put_(IfaceDecl): IfaceForeign"
892 put_ bh (IfaceData a1 a2 a3 a4 a5 a6 a7 a8) = do
902 put_ bh (IfaceSyn aq ar as at) = do
908 put_ bh (IfaceClass a1 a2 a3 a4 a5 a6 a7) = do
920 0 -> do name <- get bh
923 return (IfaceId name ty idinfo)
924 1 -> error "Binary.get(TyClDecl): ForeignType"
934 return (IfaceData a1 a2 a3 a4 a5 a6 a7 a8)
940 return (IfaceSyn aq ar as at)
949 return (IfaceClass a1 a2 a3 a4 a5 a6 a7)
951 instance Binary IfaceInst where
952 put_ bh (IfaceInst cls tys dfun flag orph) = do
958 get bh = do cls <- get bh
963 return (IfaceInst cls tys dfun flag orph)
965 instance Binary IfaceFamInst where
966 put_ bh (IfaceFamInst tycon tys) = do
969 get bh = do tycon <- get bh
971 return (IfaceFamInst tycon tys)
973 instance Binary OverlapFlag where
974 put_ bh NoOverlap = putByte bh 0
975 put_ bh OverlapOk = putByte bh 1
976 put_ bh Incoherent = putByte bh 2
977 get bh = do h <- getByte bh
979 0 -> return NoOverlap
980 1 -> return OverlapOk
981 2 -> return Incoherent
983 instance Binary IfaceConDecls where
984 put_ bh IfAbstractTyCon = putByte bh 0
985 put_ bh IfOpenDataTyCon = putByte bh 1
986 put_ bh IfOpenNewTyCon = putByte bh 2
987 put_ bh (IfDataTyCon cs) = do { putByte bh 3
989 put_ bh (IfNewTyCon c) = do { putByte bh 4
994 0 -> return IfAbstractTyCon
995 1 -> return IfOpenDataTyCon
996 2 -> return IfOpenNewTyCon
998 return (IfDataTyCon cs)
1000 return (IfNewTyCon aa)
1002 instance Binary IfaceConDecl where
1003 put_ bh (IfCon a1 a2 a3 a4 a5 a6 a7 a8 a9) = do
1013 get bh = do a1 <- get bh
1022 return (IfCon a1 a2 a3 a4 a5 a6 a7 a8 a9)
1024 instance Binary IfaceClassOp where
1025 put_ bh (IfaceClassOp n def ty) = do
1033 return (IfaceClassOp n def ty)
1035 instance Binary IfaceRule where
1036 put_ bh (IfaceRule a1 a2 a3 a4 a5 a6 a7) = do
1052 return (IfaceRule a1 a2 a3 a4 a5 a6 a7)