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 Class ( DefMeth(..) )
19 import DriverState ( v_Build_tag )
20 import CmdLineOpts ( opt_HiVersion )
21 import Kind ( Kind(..) )
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
96 mi_mod_vers = mod_vers,
97 mi_package = _, -- we ignore the package on output
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 build_tag <- readIORef v_Build_tag
128 let our_ver = show opt_HiVersion
129 when (check_ver /= our_ver) $
130 -- use userError because this will be caught by readIface
131 -- which will emit an error msg containing the iface module name.
132 throwDyn (ProgramError (
133 "mismatched interface file versions: expected "
134 ++ our_ver ++ ", found " ++ check_ver))
137 ignore_way <- readIORef v_IgnoreHiWay
138 build_tag <- readIORef v_Build_tag
139 when (not ignore_way && check_way /= build_tag) $
140 -- use userError because this will be caught by readIface
141 -- which will emit an error msg containing the iface module name.
142 throwDyn (ProgramError (
143 "mismatched interface file ways: expected "
144 ++ build_tag ++ ", found " ++ check_way))
151 usages <- {-# SCC "bin_usages" #-} lazyGet bh
152 exports <- {-# SCC "bin_exports" #-} get bh
154 fixities <- {-# SCC "bin_fixities" #-} get bh
155 deprecs <- {-# SCC "bin_deprecs" #-} lazyGet bh
156 decls <- {-# SCC "bin_tycldecls" #-} get bh
157 insts <- {-# SCC "bin_insts" #-} get bh
158 rules <- {-# SCC "bin_rules" #-} lazyGet bh
161 mi_package = ThisPackage, -- to be filled in properly later
162 mi_module = mod_name,
163 mi_mod_vers = mod_vers,
164 mi_boot = False, -- Binary interfaces are never .hi-boot files!
168 mi_exports = exports,
169 mi_exp_vers = exp_vers,
170 mi_fixities = fixities,
171 mi_deprecs = deprecs,
175 mi_rule_vers = rule_vers,
176 -- And build the cached values
177 mi_dep_fn = mkIfaceDepCache deprecs,
178 mi_fix_fn = mkIfaceFixCache fixities,
179 mi_ver_fn = mkIfaceVerCache decls })
181 GLOBAL_VAR(v_IgnoreHiWay, False, Bool)
183 -------------------------------------------------------------------------
184 -- Types from: HscTypes
185 -------------------------------------------------------------------------
187 instance Binary Dependencies where
188 put_ bh deps = do put_ bh (dep_mods deps)
189 put_ bh (dep_pkgs deps)
190 put_ bh (dep_orphs deps)
192 get bh = do ms <- get bh
195 return (Deps { dep_mods = ms, dep_pkgs = ps, dep_orphs = os })
197 instance (Binary name) => Binary (GenAvailInfo name) where
198 put_ bh (Avail aa) = do
201 put_ bh (AvailTC ab ac) = do
212 return (AvailTC ab ac)
214 instance Binary Usage where
216 put_ bh (usg_name usg)
217 put_ bh (usg_mod usg)
218 put_ bh (usg_exports usg)
219 put_ bh (usg_entities usg)
220 put_ bh (usg_rules usg)
228 return (Usage { usg_name = nm, usg_mod = mod,
229 usg_exports = exps, usg_entities = ents,
232 instance Binary a => Binary (Deprecs a) where
233 put_ bh NoDeprecs = putByte bh 0
234 put_ bh (DeprecAll t) = do
237 put_ bh (DeprecSome ts) = do
244 0 -> return NoDeprecs
246 return (DeprecAll aa)
248 return (DeprecSome aa)
250 -------------------------------------------------------------------------
251 -- Types from: BasicTypes
252 -------------------------------------------------------------------------
254 instance Binary Activation where
255 put_ bh NeverActive = do
257 put_ bh AlwaysActive = do
259 put_ bh (ActiveBefore aa) = do
262 put_ bh (ActiveAfter ab) = do
268 0 -> do return NeverActive
269 1 -> do return AlwaysActive
271 return (ActiveBefore aa)
273 return (ActiveAfter ab)
275 instance Binary StrictnessMark where
276 put_ bh MarkedStrict = do
278 put_ bh MarkedUnboxed = do
280 put_ bh NotMarkedStrict = do
285 0 -> do return MarkedStrict
286 1 -> do return MarkedUnboxed
287 _ -> do return NotMarkedStrict
289 instance Binary Boxity where
298 _ -> do return Unboxed
300 instance Binary TupCon where
301 put_ bh (TupCon ab ac) = do
307 return (TupCon ab ac)
309 instance Binary RecFlag where
310 put_ bh Recursive = do
312 put_ bh NonRecursive = do
317 0 -> do return Recursive
318 _ -> do return NonRecursive
320 instance Binary DefMeth where
321 put_ bh NoDefMeth = putByte bh 0
322 put_ bh DefMeth = putByte bh 1
323 put_ bh GenDefMeth = putByte bh 2
327 0 -> return NoDefMeth
329 _ -> return GenDefMeth
331 instance Binary FixityDirection where
341 0 -> do return InfixL
342 1 -> do return InfixR
343 _ -> do return InfixN
345 instance Binary Fixity where
346 put_ bh (Fixity aa ab) = do
352 return (Fixity aa ab)
354 instance (Binary name) => Binary (IPName name) where
355 put_ bh (Dupable aa) = do
358 put_ bh (Linear ab) = do
369 -------------------------------------------------------------------------
370 -- Types from: Demand
371 -------------------------------------------------------------------------
373 instance Binary DmdType where
374 -- Ignore DmdEnv when spitting out the DmdType
375 put bh (DmdType _ ds dr) = do p <- put bh ds; put bh dr; return (castBin p)
376 get bh = do ds <- get bh; dr <- get bh; return (DmdType emptyVarEnv ds dr)
378 instance Binary Demand where
383 put_ bh (Call aa) = do
386 put_ bh (Eval ab) = do
389 put_ bh (Defer ac) = do
392 put_ bh (Box ad) = do
412 instance Binary Demands where
413 put_ bh (Poly aa) = do
416 put_ bh (Prod ab) = do
427 instance Binary DmdResult where
437 0 -> do return TopRes
438 1 -> do return RetCPR -- Really use RetCPR even if -fcpr-off
439 -- The wrapper was generated for CPR in
440 -- the imported module!
441 _ -> do return BotRes
443 instance Binary StrictSig where
444 put_ bh (StrictSig aa) = do
448 return (StrictSig aa)
451 -------------------------------------------------------------------------
452 -- Types from: CostCentre
453 -------------------------------------------------------------------------
455 instance Binary IsCafCC where
458 put_ bh NotCafCC = do
464 _ -> do return NotCafCC
466 instance Binary IsDupdCC where
467 put_ bh OriginalCC = do
474 0 -> do return OriginalCC
475 _ -> do return DupdCC
477 instance Binary CostCentre where
478 put_ bh NoCostCentre = do
480 put_ bh (NormalCC aa ab ac ad) = do
486 put_ bh (AllCafsCC ae) = do
492 0 -> do return NoCostCentre
497 return (NormalCC aa ab ac ad)
499 return (AllCafsCC ae)
501 -------------------------------------------------------------------------
502 -- IfaceTypes and friends
503 -------------------------------------------------------------------------
505 instance Binary IfaceExtName where
506 put_ bh (ExtPkg mod occ) = do
510 put_ bh (HomePkg mod occ vers) = do
515 put_ bh (LocalTop occ) = do
518 put_ bh (LocalTopSub occ _) = do -- Write LocalTopSub just like LocalTop
525 0 -> do mod <- get bh
527 return (ExtPkg mod occ)
528 1 -> do mod <- get bh
531 return (HomePkg mod occ vers)
532 _ -> do occ <- get bh
533 return (LocalTop occ)
535 instance Binary IfaceBndr where
536 put_ bh (IfaceIdBndr aa) = do
539 put_ bh (IfaceTvBndr ab) = do
546 return (IfaceIdBndr aa)
548 return (IfaceTvBndr ab)
550 instance Binary Kind where
551 put_ bh LiftedTypeKind = putByte bh 0
552 put_ bh UnliftedTypeKind = putByte bh 1
553 put_ bh OpenTypeKind = putByte bh 2
554 put_ bh ArgTypeKind = putByte bh 3
555 put_ bh UbxTupleKind = putByte bh 4
556 put_ bh (FunKind k1 k2) = do
560 put_ bh (KindVar kv) = pprPanic "BinIface.put_: kind var" (ppr kv)
565 0 -> return LiftedTypeKind
566 1 -> return UnliftedTypeKind
567 2 -> return OpenTypeKind
568 3 -> return ArgTypeKind
569 4 -> return UbxTupleKind
572 return (FunKind k1 k2)
574 instance Binary IfaceType where
575 put_ bh (IfaceForAllTy aa ab) = do
579 put_ bh (IfaceTyVar ad) = do
582 put_ bh (IfaceAppTy ae af) = do
586 put_ bh (IfaceFunTy ag ah) = do
590 put_ bh (IfacePredTy aq) = do
594 -- Simple compression for common cases of TyConApp
595 put_ bh (IfaceTyConApp IfaceIntTc []) = putByte bh 6
596 put_ bh (IfaceTyConApp IfaceCharTc []) = putByte bh 7
597 put_ bh (IfaceTyConApp IfaceBoolTc []) = putByte bh 8
598 put_ bh (IfaceTyConApp IfaceListTc [ty]) = do { putByte bh 9; put_ bh ty }
599 -- Unit tuple and pairs
600 put_ bh (IfaceTyConApp (IfaceTupTc Boxed 0) []) = putByte bh 10
601 put_ bh (IfaceTyConApp (IfaceTupTc Boxed 2) [t1,t2]) = do { putByte bh 11; put_ bh t1; put_ bh t2 }
603 put_ bh (IfaceTyConApp (IfaceTc tc) tys) = do { putByte bh 12; put_ bh tc; put_ bh tys }
604 put_ bh (IfaceTyConApp tc tys) = do { putByte bh 13; put_ bh tc; put_ bh tys }
611 return (IfaceForAllTy aa ab)
613 return (IfaceTyVar ad)
616 return (IfaceAppTy ae af)
619 return (IfaceFunTy ag ah)
621 return (IfacePredTy ap)
623 -- Now the special cases for TyConApp
624 6 -> return (IfaceTyConApp IfaceIntTc [])
625 7 -> return (IfaceTyConApp IfaceCharTc [])
626 8 -> return (IfaceTyConApp IfaceBoolTc [])
627 9 -> do { ty <- get bh; return (IfaceTyConApp IfaceListTc [ty]) }
628 10 -> return (IfaceTyConApp (IfaceTupTc Boxed 0) [])
629 11 -> do { t1 <- get bh; t2 <- get bh; return (IfaceTyConApp (IfaceTupTc Boxed 2) [t1,t2]) }
630 12 -> do { tc <- get bh; tys <- get bh; return (IfaceTyConApp (IfaceTc tc) tys) }
631 _ -> do { tc <- get bh; tys <- get bh; return (IfaceTyConApp tc tys) }
633 instance Binary IfaceTyCon where
634 -- Int,Char,Bool can't show up here because they can't not be saturated
635 put_ bh IfaceListTc = putByte bh 1
636 put_ bh IfacePArrTc = putByte bh 2
637 put_ bh (IfaceTupTc bx ar) = do { putByte bh 3; put_ bh bx; put_ bh ar }
638 put_ bh tc = pprPanic "BinIface.put:" (ppr tc) -- Dealt with by the IfaceType instance
643 1 -> return IfaceListTc
644 2 -> return IfacePArrTc
645 _ -> do { bx <- get bh; ar <- get bh; return (IfaceTupTc bx ar) }
647 instance Binary IfacePredType where
648 put_ bh (IfaceClassP aa ab) = do
652 put_ bh (IfaceIParam ac ad) = do
661 return (IfaceClassP aa ab)
664 return (IfaceIParam ac ad)
666 -------------------------------------------------------------------------
667 -- IfaceExpr and friends
668 -------------------------------------------------------------------------
670 instance Binary IfaceExpr where
671 put_ bh (IfaceLcl aa) = do
674 put_ bh (IfaceType ab) = do
677 put_ bh (IfaceTuple ac ad) = do
681 put_ bh (IfaceLam ae af) = do
685 put_ bh (IfaceApp ag ah) = do
690 put_ bh (IfaceCase ai aj al ak) = do
697 put_ bh (IfaceLet al am) = do
701 put_ bh (IfaceNote an ao) = do
705 put_ bh (IfaceLit ap) = do
708 put_ bh (IfaceFCall as at) = do
712 put_ bh (IfaceExt aa) = do
721 return (IfaceType ab)
724 return (IfaceTuple ac ad)
727 return (IfaceLam ae af)
730 return (IfaceApp ag ah)
737 return (IfaceCase ai aj al ak)
740 return (IfaceLet al am)
743 return (IfaceNote an ao)
748 return (IfaceFCall as at)
752 instance Binary IfaceConAlt where
753 put_ bh IfaceDefault = do
755 put_ bh (IfaceDataAlt aa) = do
758 put_ bh (IfaceTupleAlt ab) = do
761 put_ bh (IfaceLitAlt ac) = do
767 0 -> do return IfaceDefault
769 return (IfaceDataAlt aa)
771 return (IfaceTupleAlt ab)
773 return (IfaceLitAlt ac)
775 instance Binary IfaceBinding where
776 put_ bh (IfaceNonRec aa ab) = do
780 put_ bh (IfaceRec ac) = do
788 return (IfaceNonRec aa ab)
792 instance Binary IfaceIdInfo where
793 put_ bh NoInfo = putByte bh 0
794 put_ bh (HasInfo i) = do
802 _ -> do info <- lazyGet bh
803 return (HasInfo info)
805 instance Binary IfaceInfoItem where
806 put_ bh (HsArity aa) = do
809 put_ bh (HsStrictness ab) = do
812 put_ bh (HsUnfold ac ad) = do
816 put_ bh HsNoCafRefs = do
818 put_ bh (HsWorker ae af) = do
828 return (HsStrictness ab)
831 return (HsUnfold ac ad)
832 3 -> do return HsNoCafRefs
835 return (HsWorker ae af)
837 instance Binary IfaceNote where
838 put_ bh (IfaceSCC aa) = do
841 put_ bh (IfaceCoerce ab) = do
844 put_ bh IfaceInlineCall = do
846 put_ bh IfaceInlineMe = do
848 put_ bh (IfaceCoreNote s) = do
857 return (IfaceCoerce ab)
858 2 -> do return IfaceInlineCall
859 3 -> do return IfaceInlineMe
861 return (IfaceCoreNote ac)
864 -------------------------------------------------------------------------
865 -- IfaceDecl and friends
866 -------------------------------------------------------------------------
868 instance Binary IfaceDecl where
869 put_ bh (IfaceId name ty idinfo) = do
874 put_ bh (IfaceForeign ae af) =
875 error "Binary.put_(IfaceDecl): IfaceForeign"
876 put_ bh (IfaceData a1 a2 a3 a4 a5 a6) = do
885 put_ bh (IfaceSyn aq ar as at) = do
891 put_ bh (IfaceClass a1 a2 a3 a4 a5 a6 a7) = do
903 0 -> do name <- get bh
906 return (IfaceId name ty idinfo)
907 1 -> error "Binary.get(TyClDecl): ForeignType"
915 return (IfaceData a1 a2 a3 a4 a5 a6)
921 return (IfaceSyn aq ar as at)
930 return (IfaceClass a1 a2 a3 a4 a5 a6 a7)
932 instance Binary IfaceInst where
933 put_ bh (IfaceInst ty dfun) = do
936 get bh = do ty <- get bh
938 return (IfaceInst ty dfun)
940 instance Binary IfaceConDecls where
941 put_ bh IfAbstractTyCon = putByte bh 0
942 put_ bh (IfDataTyCon st cs) = do { putByte bh 1
945 put_ bh (IfNewTyCon c) = do { putByte bh 2
950 0 -> return IfAbstractTyCon
953 return (IfDataTyCon st cs)
955 return (IfNewTyCon aa)
957 instance Binary IfaceConDecl where
958 put_ bh (IfVanillaCon a1 a2 a3 a4 a5) = do
965 put_ bh (IfGadtCon a1 a2 a3 a4 a5 a6) = do
981 return (IfVanillaCon a1 a2 a3 a4 a5)
988 return (IfGadtCon a1 a2 a3 a4 a5 a6)
990 instance Binary IfaceClassOp where
991 put_ bh (IfaceClassOp n def ty) = do
999 return (IfaceClassOp n def ty)
1001 instance Binary IfaceRule where
1002 -- IfaceBuiltinRule should not happen here
1003 put_ bh (IfaceRule a1 a2 a3 a4 a5 a6) = do
1017 return (IfaceRule a1 a2 a3 a4 a5 a6)