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"
18 import Packages ( PackageIdH(..) )
19 import Class ( DefMeth(..) )
21 import DriverState ( v_Build_tag )
22 import CmdLineOpts ( opt_HiVersion )
23 import Kind ( Kind(..) )
29 import DATA_WORD ( Word8 )
30 import EXCEPTION ( throwDyn )
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,
99 mi_package = _, -- we ignore the package on output
103 mi_exports = exports,
104 mi_exp_vers = exp_vers,
105 mi_fixities = fixities,
106 mi_deprecs = deprecs,
110 mi_rule_vers = rule_vers }) = do
111 put_ bh (show opt_HiVersion)
112 build_tag <- readIORef v_Build_tag
114 put_ bh (WORD_SIZE_IN_BITS :: Word8)
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 build_tag <- readIORef v_Build_tag
143 when (not ignore_way && check_way /= build_tag) $
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 ++ build_tag ++ ", found " ++ check_way))
151 let our_ws = WORD_SIZE_IN_BITS :: Word8
152 when (check_ws /= our_ws) $
153 -- use userError because this will be caught by readIface
154 -- which will emit an error msg containing the iface module name.
155 throwDyn (ProgramError (
156 "mismatched word size: expected "
157 ++ show our_ws ++ ", found " ++ show check_ws))
164 usages <- {-# SCC "bin_usages" #-} lazyGet bh
165 exports <- {-# SCC "bin_exports" #-} get bh
167 fixities <- {-# SCC "bin_fixities" #-} get bh
168 deprecs <- {-# SCC "bin_deprecs" #-} lazyGet bh
169 decls <- {-# SCC "bin_tycldecls" #-} get bh
170 insts <- {-# SCC "bin_insts" #-} get bh
171 rules <- {-# SCC "bin_rules" #-} lazyGet bh
174 mi_package = HomePackage, -- to be filled in properly later
175 mi_module = mod_name,
177 mi_mod_vers = mod_vers,
181 mi_exports = exports,
182 mi_exp_vers = exp_vers,
183 mi_fixities = fixities,
184 mi_deprecs = deprecs,
186 mi_globals = Nothing,
189 mi_rule_vers = rule_vers,
190 -- And build the cached values
191 mi_dep_fn = mkIfaceDepCache deprecs,
192 mi_fix_fn = mkIfaceFixCache fixities,
193 mi_ver_fn = mkIfaceVerCache decls })
195 GLOBAL_VAR(v_IgnoreHiWay, False, Bool)
197 -------------------------------------------------------------------------
198 -- Types from: HscTypes
199 -------------------------------------------------------------------------
201 instance Binary Dependencies where
202 put_ bh deps = do put_ bh (dep_mods deps)
203 put_ bh (dep_pkgs deps)
204 put_ bh (dep_orphs deps)
206 get bh = do ms <- get bh
209 return (Deps { dep_mods = ms, dep_pkgs = ps, dep_orphs = os })
211 instance (Binary name) => Binary (GenAvailInfo name) where
212 put_ bh (Avail aa) = do
215 put_ bh (AvailTC ab ac) = do
226 return (AvailTC ab ac)
228 instance Binary Usage where
230 put_ bh (usg_name usg)
231 put_ bh (usg_mod usg)
232 put_ bh (usg_exports usg)
233 put_ bh (usg_entities usg)
234 put_ bh (usg_rules usg)
242 return (Usage { usg_name = nm, usg_mod = mod,
243 usg_exports = exps, usg_entities = ents,
246 instance Binary a => Binary (Deprecs a) where
247 put_ bh NoDeprecs = putByte bh 0
248 put_ bh (DeprecAll t) = do
251 put_ bh (DeprecSome ts) = do
258 0 -> return NoDeprecs
260 return (DeprecAll aa)
262 return (DeprecSome aa)
264 -------------------------------------------------------------------------
265 -- Types from: BasicTypes
266 -------------------------------------------------------------------------
268 instance Binary Activation where
269 put_ bh NeverActive = do
271 put_ bh AlwaysActive = do
273 put_ bh (ActiveBefore aa) = do
276 put_ bh (ActiveAfter ab) = do
282 0 -> do return NeverActive
283 1 -> do return AlwaysActive
285 return (ActiveBefore aa)
287 return (ActiveAfter ab)
289 instance Binary StrictnessMark where
290 put_ bh MarkedStrict = do
292 put_ bh MarkedUnboxed = do
294 put_ bh NotMarkedStrict = do
299 0 -> do return MarkedStrict
300 1 -> do return MarkedUnboxed
301 _ -> do return NotMarkedStrict
303 instance Binary Boxity where
312 _ -> do return Unboxed
314 instance Binary TupCon where
315 put_ bh (TupCon ab ac) = do
321 return (TupCon ab ac)
323 instance Binary RecFlag where
324 put_ bh Recursive = do
326 put_ bh NonRecursive = do
331 0 -> do return Recursive
332 _ -> do return NonRecursive
334 instance Binary DefMeth where
335 put_ bh NoDefMeth = putByte bh 0
336 put_ bh DefMeth = putByte bh 1
337 put_ bh GenDefMeth = putByte bh 2
341 0 -> return NoDefMeth
343 _ -> return GenDefMeth
345 instance Binary FixityDirection where
355 0 -> do return InfixL
356 1 -> do return InfixR
357 _ -> do return InfixN
359 instance Binary Fixity where
360 put_ bh (Fixity aa ab) = do
366 return (Fixity aa ab)
368 instance (Binary name) => Binary (IPName name) where
369 put_ bh (Dupable aa) = do
372 put_ bh (Linear ab) = do
383 -------------------------------------------------------------------------
384 -- Types from: Demand
385 -------------------------------------------------------------------------
387 instance Binary DmdType where
388 -- Ignore DmdEnv when spitting out the DmdType
389 put bh (DmdType _ ds dr) = do p <- put bh ds; put bh dr; return (castBin p)
390 get bh = do ds <- get bh; dr <- get bh; return (DmdType emptyVarEnv ds dr)
392 instance Binary Demand where
397 put_ bh (Call aa) = do
400 put_ bh (Eval ab) = do
403 put_ bh (Defer ac) = do
406 put_ bh (Box ad) = do
426 instance Binary Demands where
427 put_ bh (Poly aa) = do
430 put_ bh (Prod ab) = do
441 instance Binary DmdResult where
451 0 -> do return TopRes
452 1 -> do return RetCPR -- Really use RetCPR even if -fcpr-off
453 -- The wrapper was generated for CPR in
454 -- the imported module!
455 _ -> do return BotRes
457 instance Binary StrictSig where
458 put_ bh (StrictSig aa) = do
462 return (StrictSig aa)
465 -------------------------------------------------------------------------
466 -- Types from: CostCentre
467 -------------------------------------------------------------------------
469 instance Binary IsCafCC where
472 put_ bh NotCafCC = do
478 _ -> do return NotCafCC
480 instance Binary IsDupdCC where
481 put_ bh OriginalCC = do
488 0 -> do return OriginalCC
489 _ -> do return DupdCC
491 instance Binary CostCentre where
492 put_ bh NoCostCentre = do
494 put_ bh (NormalCC aa ab ac ad) = do
500 put_ bh (AllCafsCC ae) = do
506 0 -> do return NoCostCentre
511 return (NormalCC aa ab ac ad)
513 return (AllCafsCC ae)
515 -------------------------------------------------------------------------
516 -- IfaceTypes and friends
517 -------------------------------------------------------------------------
519 instance Binary IfaceExtName where
520 put_ bh (ExtPkg mod occ) = do
524 put_ bh (HomePkg mod occ vers) = do
529 put_ bh (LocalTop occ) = do
532 put_ bh (LocalTopSub occ _) = do -- Write LocalTopSub just like LocalTop
539 0 -> do mod <- get bh
541 return (ExtPkg mod occ)
542 1 -> do mod <- get bh
545 return (HomePkg mod occ vers)
546 _ -> do occ <- get bh
547 return (LocalTop occ)
549 instance Binary IfaceBndr where
550 put_ bh (IfaceIdBndr aa) = do
553 put_ bh (IfaceTvBndr ab) = do
560 return (IfaceIdBndr aa)
562 return (IfaceTvBndr ab)
564 instance Binary Kind where
565 put_ bh LiftedTypeKind = putByte bh 0
566 put_ bh UnliftedTypeKind = putByte bh 1
567 put_ bh OpenTypeKind = putByte bh 2
568 put_ bh ArgTypeKind = putByte bh 3
569 put_ bh UbxTupleKind = putByte bh 4
570 put_ bh (FunKind k1 k2) = do
574 put_ bh (KindVar kv) = pprPanic "BinIface.put_: kind var" (ppr kv)
579 0 -> return LiftedTypeKind
580 1 -> return UnliftedTypeKind
581 2 -> return OpenTypeKind
582 3 -> return ArgTypeKind
583 4 -> 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
649 put_ bh IfaceListTc = putByte bh 1
650 put_ bh IfacePArrTc = putByte bh 2
651 put_ bh (IfaceTupTc bx ar) = do { putByte bh 3; put_ bh bx; put_ bh ar }
652 put_ bh tc = pprPanic "BinIface.put:" (ppr tc) -- Dealt with by the IfaceType instance
657 1 -> return IfaceListTc
658 2 -> return IfacePArrTc
659 _ -> do { bx <- get bh; ar <- get bh; return (IfaceTupTc bx ar) }
661 instance Binary IfacePredType where
662 put_ bh (IfaceClassP aa ab) = do
666 put_ bh (IfaceIParam ac ad) = do
675 return (IfaceClassP aa ab)
678 return (IfaceIParam 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
735 return (IfaceType ab)
738 return (IfaceTuple ac ad)
741 return (IfaceLam ae af)
744 return (IfaceApp ag ah)
751 return (IfaceCase ai aj al ak)
754 return (IfaceLet al am)
757 return (IfaceNote an ao)
762 return (IfaceFCall as at)
766 instance Binary IfaceConAlt where
767 put_ bh IfaceDefault = do
769 put_ bh (IfaceDataAlt aa) = do
772 put_ bh (IfaceTupleAlt ab) = do
775 put_ bh (IfaceLitAlt ac) = do
781 0 -> do return IfaceDefault
783 return (IfaceDataAlt aa)
785 return (IfaceTupleAlt ab)
787 return (IfaceLitAlt ac)
789 instance Binary IfaceBinding where
790 put_ bh (IfaceNonRec aa ab) = do
794 put_ bh (IfaceRec ac) = do
802 return (IfaceNonRec aa ab)
806 instance Binary IfaceIdInfo where
807 put_ bh NoInfo = putByte bh 0
808 put_ bh (HasInfo i) = do
816 _ -> do info <- lazyGet bh
817 return (HasInfo info)
819 instance Binary IfaceInfoItem where
820 put_ bh (HsArity aa) = do
823 put_ bh (HsStrictness ab) = do
826 put_ bh (HsUnfold ac ad) = do
830 put_ bh HsNoCafRefs = do
832 put_ bh (HsWorker ae af) = do
842 return (HsStrictness ab)
845 return (HsUnfold ac ad)
846 3 -> do return HsNoCafRefs
849 return (HsWorker ae af)
851 instance Binary IfaceNote where
852 put_ bh (IfaceSCC aa) = do
855 put_ bh (IfaceCoerce ab) = do
858 put_ bh IfaceInlineCall = do
860 put_ bh IfaceInlineMe = do
862 put_ bh (IfaceCoreNote s) = do
871 return (IfaceCoerce ab)
872 2 -> do return IfaceInlineCall
873 3 -> do return IfaceInlineMe
875 return (IfaceCoreNote ac)
878 -------------------------------------------------------------------------
879 -- IfaceDecl and friends
880 -------------------------------------------------------------------------
882 instance Binary IfaceDecl where
883 put_ bh (IfaceId name ty idinfo) = do
888 put_ bh (IfaceForeign ae af) =
889 error "Binary.put_(IfaceDecl): IfaceForeign"
890 put_ bh (IfaceData a1 a2 a3 a4 a5 a6) = do
899 put_ bh (IfaceSyn aq ar as at) = do
905 put_ bh (IfaceClass a1 a2 a3 a4 a5 a6 a7) = do
917 0 -> do name <- get bh
920 return (IfaceId name ty idinfo)
921 1 -> error "Binary.get(TyClDecl): ForeignType"
929 return (IfaceData a1 a2 a3 a4 a5 a6)
935 return (IfaceSyn aq ar as at)
944 return (IfaceClass a1 a2 a3 a4 a5 a6 a7)
946 instance Binary IfaceInst where
947 put_ bh (IfaceInst ty dfun) = do
950 get bh = do ty <- get bh
952 return (IfaceInst ty dfun)
954 instance Binary IfaceConDecls where
955 put_ bh IfAbstractTyCon = putByte bh 0
956 put_ bh (IfDataTyCon st cs) = do { putByte bh 1
959 put_ bh (IfNewTyCon c) = do { putByte bh 2
964 0 -> return IfAbstractTyCon
967 return (IfDataTyCon st cs)
969 return (IfNewTyCon aa)
971 instance Binary IfaceConDecl where
972 put_ bh (IfVanillaCon a1 a2 a3 a4 a5) = do
979 put_ bh (IfGadtCon a1 a2 a3 a4 a5 a6) = do
995 return (IfVanillaCon a1 a2 a3 a4 a5)
1002 return (IfGadtCon a1 a2 a3 a4 a5 a6)
1004 instance Binary IfaceClassOp where
1005 put_ bh (IfaceClassOp n def ty) = do
1013 return (IfaceClassOp n def ty)
1015 instance Binary IfaceRule where
1016 -- IfaceBuiltinRule should not happen here
1017 put_ bh (IfaceRule a1 a2 a3 a4 a5 a6) = do
1031 return (IfaceRule a1 a2 a3 a4 a5 a6)