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 )
21 import Kind ( Kind(..) )
25 import Config ( cGhcUnregisterised )
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,
102 mi_exports = exports,
103 mi_exp_vers = exp_vers,
104 mi_fixities = fixities,
105 mi_deprecs = deprecs,
109 mi_rule_vers = rule_vers }) = do
110 put_ bh (show opt_HiVersion)
111 way_descr <- getWayDescr
130 let our_ver = show opt_HiVersion
131 when (check_ver /= our_ver) $
132 -- use userError because this will be caught by readIface
133 -- which will emit an error msg containing the iface module name.
134 throwDyn (ProgramError (
135 "mismatched interface file versions: expected "
136 ++ our_ver ++ ", found " ++ check_ver))
139 ignore_way <- readIORef v_IgnoreHiWay
140 way_descr <- getWayDescr
141 when (not ignore_way && check_way /= way_descr) $
142 -- use userError because this will be caught by readIface
143 -- which will emit an error msg containing the iface module name.
144 throwDyn (ProgramError (
145 "mismatched interface file ways: expected "
146 ++ way_descr ++ ", found " ++ check_way))
153 usages <- {-# SCC "bin_usages" #-} lazyGet bh
154 exports <- {-# SCC "bin_exports" #-} get bh
156 fixities <- {-# SCC "bin_fixities" #-} get bh
157 deprecs <- {-# SCC "bin_deprecs" #-} lazyGet bh
158 decls <- {-# SCC "bin_tycldecls" #-} get bh
159 insts <- {-# SCC "bin_insts" #-} get bh
160 rules <- {-# SCC "bin_rules" #-} lazyGet bh
163 mi_module = mod_name,
165 mi_mod_vers = mod_vers,
169 mi_exports = exports,
170 mi_exp_vers = exp_vers,
171 mi_fixities = fixities,
172 mi_deprecs = deprecs,
174 mi_globals = Nothing,
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 (Dupable aa) = do
367 put_ bh (Linear ab) = do
378 -------------------------------------------------------------------------
379 -- Types from: Demand
380 -------------------------------------------------------------------------
382 instance Binary DmdType where
383 -- Ignore DmdEnv when spitting out the DmdType
384 put bh (DmdType _ ds dr) = do p <- put bh ds; put bh dr; return (castBin p)
385 get bh = do ds <- get bh; dr <- get bh; return (DmdType emptyVarEnv ds dr)
387 instance Binary Demand where
392 put_ bh (Call aa) = do
395 put_ bh (Eval ab) = do
398 put_ bh (Defer ac) = do
401 put_ bh (Box ad) = do
421 instance Binary Demands where
422 put_ bh (Poly aa) = do
425 put_ bh (Prod ab) = do
436 instance Binary DmdResult where
446 0 -> do return TopRes
447 1 -> do return RetCPR -- Really use RetCPR even if -fcpr-off
448 -- The wrapper was generated for CPR in
449 -- the imported module!
450 _ -> do return BotRes
452 instance Binary StrictSig where
453 put_ bh (StrictSig aa) = do
457 return (StrictSig aa)
460 -------------------------------------------------------------------------
461 -- Types from: CostCentre
462 -------------------------------------------------------------------------
464 instance Binary IsCafCC where
467 put_ bh NotCafCC = do
473 _ -> do return NotCafCC
475 instance Binary IsDupdCC where
476 put_ bh OriginalCC = do
483 0 -> do return OriginalCC
484 _ -> do return DupdCC
486 instance Binary CostCentre where
487 put_ bh NoCostCentre = do
489 put_ bh (NormalCC aa ab ac ad) = do
495 put_ bh (AllCafsCC ae) = do
501 0 -> do return NoCostCentre
506 return (NormalCC aa ab ac ad)
508 return (AllCafsCC ae)
510 -------------------------------------------------------------------------
511 -- IfaceTypes and friends
512 -------------------------------------------------------------------------
514 instance Binary IfaceExtName where
515 put_ bh (ExtPkg mod occ) = do
519 put_ bh (HomePkg mod occ vers) = do
524 put_ bh (LocalTop occ) = do
527 put_ bh (LocalTopSub occ _) = do -- Write LocalTopSub just like LocalTop
534 0 -> do mod <- get bh
536 return (ExtPkg mod occ)
537 1 -> do mod <- get bh
540 return (HomePkg mod occ vers)
541 _ -> do occ <- get bh
542 return (LocalTop occ)
544 instance Binary IfaceBndr where
545 put_ bh (IfaceIdBndr aa) = do
548 put_ bh (IfaceTvBndr ab) = do
555 return (IfaceIdBndr aa)
557 return (IfaceTvBndr ab)
559 instance Binary Kind where
560 put_ bh LiftedTypeKind = putByte bh 0
561 put_ bh UnliftedTypeKind = putByte bh 1
562 put_ bh UnboxedTypeKind = putByte bh 2
563 put_ bh OpenTypeKind = putByte bh 3
564 put_ bh ArgTypeKind = putByte bh 4
565 put_ bh UbxTupleKind = putByte bh 5
566 put_ bh (FunKind k1 k2) = do
570 put_ bh (KindVar kv) = pprPanic "BinIface.put_: kind var" (ppr kv)
575 0 -> return LiftedTypeKind
576 1 -> return UnliftedTypeKind
577 2 -> return UnboxedTypeKind
578 3 -> return OpenTypeKind
579 4 -> return ArgTypeKind
580 5 -> return UbxTupleKind
583 return (FunKind k1 k2)
585 instance Binary IfaceType where
586 put_ bh (IfaceForAllTy aa ab) = do
590 put_ bh (IfaceTyVar ad) = do
593 put_ bh (IfaceAppTy ae af) = do
597 put_ bh (IfaceFunTy ag ah) = do
601 put_ bh (IfacePredTy aq) = do
605 -- Simple compression for common cases of TyConApp
606 put_ bh (IfaceTyConApp IfaceIntTc []) = putByte bh 6
607 put_ bh (IfaceTyConApp IfaceCharTc []) = putByte bh 7
608 put_ bh (IfaceTyConApp IfaceBoolTc []) = putByte bh 8
609 put_ bh (IfaceTyConApp IfaceListTc [ty]) = do { putByte bh 9; put_ bh ty }
610 -- Unit tuple and pairs
611 put_ bh (IfaceTyConApp (IfaceTupTc Boxed 0) []) = putByte bh 10
612 put_ bh (IfaceTyConApp (IfaceTupTc Boxed 2) [t1,t2]) = do { putByte bh 11; put_ bh t1; put_ bh t2 }
614 put_ bh (IfaceTyConApp (IfaceTc tc) tys) = do { putByte bh 12; put_ bh tc; put_ bh tys }
615 put_ bh (IfaceTyConApp tc tys) = do { putByte bh 13; put_ bh tc; put_ bh tys }
622 return (IfaceForAllTy aa ab)
624 return (IfaceTyVar ad)
627 return (IfaceAppTy ae af)
630 return (IfaceFunTy ag ah)
632 return (IfacePredTy ap)
634 -- Now the special cases for TyConApp
635 6 -> return (IfaceTyConApp IfaceIntTc [])
636 7 -> return (IfaceTyConApp IfaceCharTc [])
637 8 -> return (IfaceTyConApp IfaceBoolTc [])
638 9 -> do { ty <- get bh; return (IfaceTyConApp IfaceListTc [ty]) }
639 10 -> return (IfaceTyConApp (IfaceTupTc Boxed 0) [])
640 11 -> do { t1 <- get bh; t2 <- get bh; return (IfaceTyConApp (IfaceTupTc Boxed 2) [t1,t2]) }
641 12 -> do { tc <- get bh; tys <- get bh; return (IfaceTyConApp (IfaceTc tc) tys) }
642 _ -> do { tc <- get bh; tys <- get bh; return (IfaceTyConApp tc tys) }
644 instance Binary IfaceTyCon where
645 -- Int,Char,Bool can't show up here because they can't not be saturated
647 put_ bh IfaceIntTc = putByte bh 1
648 put_ bh IfaceBoolTc = putByte bh 2
649 put_ bh IfaceCharTc = putByte bh 3
650 put_ bh IfaceListTc = putByte bh 4
651 put_ bh IfacePArrTc = putByte bh 5
652 put_ bh (IfaceTupTc bx ar) = do { putByte bh 6; put_ bh bx; put_ bh ar }
653 put_ bh (IfaceTc ext) = do { putByte bh 7; put_ bh ext }
658 1 -> return IfaceIntTc
659 2 -> return IfaceBoolTc
660 3 -> return IfaceCharTc
661 4 -> return IfaceListTc
662 5 -> return IfacePArrTc
663 6 -> do { bx <- get bh; ar <- get bh; return (IfaceTupTc bx ar) }
664 _ -> do { ext <- get bh; return (IfaceTc ext) }
666 instance Binary IfacePredType where
667 put_ bh (IfaceClassP aa ab) = do
671 put_ bh (IfaceIParam ac ad) = do
680 return (IfaceClassP aa ab)
683 return (IfaceIParam ac ad)
685 -------------------------------------------------------------------------
686 -- IfaceExpr and friends
687 -------------------------------------------------------------------------
689 instance Binary IfaceExpr where
690 put_ bh (IfaceLcl aa) = do
693 put_ bh (IfaceType ab) = do
696 put_ bh (IfaceTuple ac ad) = do
700 put_ bh (IfaceLam ae af) = do
704 put_ bh (IfaceApp ag ah) = do
709 put_ bh (IfaceCase ai aj al ak) = do
716 put_ bh (IfaceLet al am) = do
720 put_ bh (IfaceNote an ao) = do
724 put_ bh (IfaceLit ap) = do
727 put_ bh (IfaceFCall as at) = do
731 put_ bh (IfaceExt aa) = do
740 return (IfaceType ab)
743 return (IfaceTuple ac ad)
746 return (IfaceLam ae af)
749 return (IfaceApp ag ah)
756 return (IfaceCase ai aj al ak)
759 return (IfaceLet al am)
762 return (IfaceNote an ao)
767 return (IfaceFCall as at)
771 instance Binary IfaceConAlt where
772 put_ bh IfaceDefault = do
774 put_ bh (IfaceDataAlt aa) = do
777 put_ bh (IfaceTupleAlt ab) = do
780 put_ bh (IfaceLitAlt ac) = do
786 0 -> do return IfaceDefault
788 return (IfaceDataAlt aa)
790 return (IfaceTupleAlt ab)
792 return (IfaceLitAlt ac)
794 instance Binary IfaceBinding where
795 put_ bh (IfaceNonRec aa ab) = do
799 put_ bh (IfaceRec ac) = do
807 return (IfaceNonRec aa ab)
811 instance Binary IfaceIdInfo where
812 put_ bh NoInfo = putByte bh 0
813 put_ bh (HasInfo i) = do
815 lazyPut bh i -- NB lazyPut
821 _ -> do info <- lazyGet bh -- NB lazyGet
822 return (HasInfo info)
824 instance Binary IfaceInfoItem where
825 put_ bh (HsArity aa) = do
828 put_ bh (HsStrictness ab) = do
831 put_ bh (HsUnfold ad) = do
834 put_ bh (HsInline ad) = do
837 put_ bh HsNoCafRefs = do
839 put_ bh (HsWorker ae af) = do
849 return (HsStrictness ab)
854 4 -> do return HsNoCafRefs
857 return (HsWorker ae af)
859 instance Binary IfaceNote where
860 put_ bh (IfaceSCC aa) = do
863 put_ bh (IfaceCoerce ab) = do
866 put_ bh IfaceInlineMe = do
868 put_ bh (IfaceCoreNote s) = do
877 return (IfaceCoerce ab)
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) = 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"
936 return (IfaceData a1 a2 a3 a4 a5 a6 a7)
942 return (IfaceSyn aq ar as at)
951 return (IfaceClass a1 a2 a3 a4 a5 a6 a7)
953 instance Binary IfaceInst where
954 put_ bh (IfaceInst cls tys dfun flag orph) = do
960 get bh = do cls <- get bh
965 return (IfaceInst cls tys dfun flag orph)
967 instance Binary OverlapFlag where
968 put_ bh NoOverlap = putByte bh 0
969 put_ bh OverlapOk = putByte bh 1
970 put_ bh Incoherent = putByte bh 2
971 get bh = do h <- getByte bh
973 0 -> return NoOverlap
974 1 -> return OverlapOk
975 2 -> return Incoherent
977 instance Binary IfaceConDecls where
978 put_ bh IfAbstractTyCon = putByte bh 0
979 put_ bh (IfDataTyCon cs) = do { putByte bh 1
981 put_ bh (IfNewTyCon c) = do { putByte bh 2
986 0 -> return IfAbstractTyCon
988 return (IfDataTyCon cs)
990 return (IfNewTyCon aa)
992 instance Binary IfaceConDecl where
993 put_ bh (IfVanillaCon a1 a2 a3 a4 a5) = do
1000 put_ bh (IfGadtCon a1 a2 a3 a4 a5 a6) = do
1011 0 -> do a1 <- get bh
1016 return (IfVanillaCon a1 a2 a3 a4 a5)
1017 _ -> do a1 <- get bh
1023 return (IfGadtCon a1 a2 a3 a4 a5 a6)
1025 instance Binary IfaceClassOp where
1026 put_ bh (IfaceClassOp n def ty) = do
1034 return (IfaceClassOp n def ty)
1036 instance Binary IfaceRule where
1037 put_ bh (IfaceRule a1 a2 a3 a4 a5 a6 a7) = do
1053 return (IfaceRule a1 a2 a3 a4 a5 a6 a7)