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 )
22 isLiftedTypeKind, isUnliftedTypeKind, isOpenTypeKind,
23 isArgTypeKind, isUbxTupleKind, liftedTypeKind,
24 unliftedTypeKind, openTypeKind, argTypeKind,
25 ubxTupleKind, mkArrowKind, splitFunTy_maybe )
29 import Config ( cGhcUnregisterised )
32 import EXCEPTION ( throwDyn )
36 #include "HsVersions.h"
38 -- ---------------------------------------------------------------------------
39 writeBinIface :: FilePath -> ModIface -> IO ()
40 writeBinIface hi_path mod_iface
41 = putBinFileWithDict hi_path mod_iface
43 readBinIface :: FilePath -> IO ModIface
44 readBinIface hi_path = getBinFileWithDict hi_path
47 -- %*********************************************************
49 -- All the Binary instances
51 -- %*********************************************************
54 {-! for IPName derive: Binary !-}
55 {-! for Fixity derive: Binary !-}
56 {-! for FixityDirection derive: Binary !-}
57 {-! for Boxity derive: Binary !-}
58 {-! for StrictnessMark derive: Binary !-}
59 {-! for Activation derive: Binary !-}
62 {-! for Demand derive: Binary !-}
63 {-! for Demands derive: Binary !-}
64 {-! for DmdResult derive: Binary !-}
65 {-! for StrictSig derive: Binary !-}
68 {-! for DefMeth derive: Binary !-}
71 {-! for HsPred derive: Binary !-}
72 {-! for HsType derive: Binary !-}
73 {-! for TupCon derive: Binary !-}
74 {-! for HsTyVarBndr derive: Binary !-}
77 {-! for UfExpr derive: Binary !-}
78 {-! for UfConAlt derive: Binary !-}
79 {-! for UfBinding derive: Binary !-}
80 {-! for UfBinder derive: Binary !-}
81 {-! for HsIdInfo derive: Binary !-}
82 {-! for UfNote derive: Binary !-}
85 {-! for ConDetails derive: Binary !-}
86 {-! for BangType derive: Binary !-}
89 {-! for IsCafCC derive: Binary !-}
90 {-! for IsDupdCC derive: Binary !-}
91 {-! for CostCentre derive: Binary !-}
95 -- ---------------------------------------------------------------------------
96 -- Reading a binary interface into ParsedIface
98 instance Binary ModIface where
102 mi_mod_vers = mod_vers,
106 mi_exports = exports,
107 mi_exp_vers = exp_vers,
108 mi_fixities = fixities,
109 mi_deprecs = deprecs,
113 mi_rule_vers = rule_vers }) = do
114 put_ bh (show opt_HiVersion)
115 way_descr <- getWayDescr
134 let our_ver = show opt_HiVersion
135 when (check_ver /= our_ver) $
136 -- use userError because this will be caught by readIface
137 -- which will emit an error msg containing the iface module name.
138 throwDyn (ProgramError (
139 "mismatched interface file versions: expected "
140 ++ our_ver ++ ", found " ++ check_ver))
143 ignore_way <- readIORef v_IgnoreHiWay
144 way_descr <- getWayDescr
145 when (not ignore_way && check_way /= way_descr) $
146 -- use userError because this will be caught by readIface
147 -- which will emit an error msg containing the iface module name.
148 throwDyn (ProgramError (
149 "mismatched interface file ways: expected "
150 ++ way_descr ++ ", found " ++ check_way))
157 usages <- {-# SCC "bin_usages" #-} lazyGet bh
158 exports <- {-# SCC "bin_exports" #-} get bh
160 fixities <- {-# SCC "bin_fixities" #-} get bh
161 deprecs <- {-# SCC "bin_deprecs" #-} lazyGet bh
162 decls <- {-# SCC "bin_tycldecls" #-} get bh
163 insts <- {-# SCC "bin_insts" #-} get bh
164 rules <- {-# SCC "bin_rules" #-} lazyGet bh
167 mi_module = mod_name,
169 mi_mod_vers = mod_vers,
173 mi_exports = exports,
174 mi_exp_vers = exp_vers,
175 mi_fixities = fixities,
176 mi_deprecs = deprecs,
178 mi_globals = Nothing,
180 mi_fam_insts = mkIfaceFamInstsCache . map snd $ decls,
182 mi_rule_vers = rule_vers,
183 -- And build the cached values
184 mi_dep_fn = mkIfaceDepCache deprecs,
185 mi_fix_fn = mkIfaceFixCache fixities,
186 mi_ver_fn = mkIfaceVerCache decls })
188 GLOBAL_VAR(v_IgnoreHiWay, False, Bool)
190 getWayDescr :: IO String
192 tag <- readIORef v_Build_tag
193 if cGhcUnregisterised == "YES" then return ('u':tag) else return tag
194 -- if this is an unregisterised build, make sure our interfaces
195 -- can't be used by a registerised build.
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 IfaceType where
565 put_ bh (IfaceForAllTy aa ab) = do
569 put_ bh (IfaceTyVar ad) = do
572 put_ bh (IfaceAppTy ae af) = do
576 put_ bh (IfaceFunTy ag ah) = do
580 put_ bh (IfacePredTy aq) = do
584 -- Simple compression for common cases of TyConApp
585 put_ bh (IfaceTyConApp IfaceIntTc []) = putByte bh 6
586 put_ bh (IfaceTyConApp IfaceCharTc []) = putByte bh 7
587 put_ bh (IfaceTyConApp IfaceBoolTc []) = putByte bh 8
588 put_ bh (IfaceTyConApp IfaceListTc [ty]) = do { putByte bh 9; put_ bh ty }
589 -- Unit tuple and pairs
590 put_ bh (IfaceTyConApp (IfaceTupTc Boxed 0) []) = putByte bh 10
591 put_ bh (IfaceTyConApp (IfaceTupTc Boxed 2) [t1,t2]) = do { putByte bh 11; put_ bh t1; put_ bh t2 }
593 put_ bh (IfaceTyConApp IfaceLiftedTypeKindTc []) = putByte bh 12
594 put_ bh (IfaceTyConApp IfaceOpenTypeKindTc []) = putByte bh 13
595 put_ bh (IfaceTyConApp IfaceUnliftedTypeKindTc []) = putByte bh 14
596 put_ bh (IfaceTyConApp IfaceUbxTupleKindTc []) = putByte bh 15
597 put_ bh (IfaceTyConApp IfaceArgTypeKindTc []) = putByte bh 16
601 put_ bh (IfaceTyConApp (IfaceTc tc) tys) = do { putByte bh 18; put_ bh tc; put_ bh tys }
602 put_ bh (IfaceTyConApp tc tys) = do { putByte bh 19; put_ bh tc; put_ bh tys }
609 return (IfaceForAllTy aa ab)
611 return (IfaceTyVar ad)
614 return (IfaceAppTy ae af)
617 return (IfaceFunTy ag ah)
619 return (IfacePredTy ap)
621 -- Now the special cases for TyConApp
622 6 -> return (IfaceTyConApp IfaceIntTc [])
623 7 -> return (IfaceTyConApp IfaceCharTc [])
624 8 -> return (IfaceTyConApp IfaceBoolTc [])
625 9 -> do { ty <- get bh; return (IfaceTyConApp IfaceListTc [ty]) }
626 10 -> return (IfaceTyConApp (IfaceTupTc Boxed 0) [])
627 11 -> do { t1 <- get bh; t2 <- get bh; return (IfaceTyConApp (IfaceTupTc Boxed 2) [t1,t2]) }
628 12 -> return (IfaceTyConApp IfaceLiftedTypeKindTc [])
629 13 -> return (IfaceTyConApp IfaceOpenTypeKindTc [])
630 14 -> return (IfaceTyConApp IfaceUnliftedTypeKindTc [])
631 15 -> return (IfaceTyConApp IfaceUbxTupleKindTc [])
632 16 -> return (IfaceTyConApp IfaceArgTypeKindTc [])
634 18 -> do { tc <- get bh; tys <- get bh; return (IfaceTyConApp (IfaceTc tc) tys) }
635 _ -> do { tc <- get bh; tys <- get bh; return (IfaceTyConApp tc tys) }
637 instance Binary IfaceTyCon where
638 -- Int,Char,Bool can't show up here because they can't not be saturated
640 put_ bh IfaceIntTc = putByte bh 1
641 put_ bh IfaceBoolTc = putByte bh 2
642 put_ bh IfaceCharTc = putByte bh 3
643 put_ bh IfaceListTc = putByte bh 4
644 put_ bh IfacePArrTc = putByte bh 5
645 put_ bh IfaceLiftedTypeKindTc = putByte bh 6
646 put_ bh IfaceOpenTypeKindTc = putByte bh 7
647 put_ bh IfaceUnliftedTypeKindTc = putByte bh 8
648 put_ bh IfaceUbxTupleKindTc = putByte bh 9
649 put_ bh IfaceArgTypeKindTc = putByte bh 10
650 put_ bh (IfaceTupTc bx ar) = do { putByte bh 11; put_ bh bx; put_ bh ar }
651 put_ bh (IfaceTc ext) = do { putByte bh 12; put_ bh ext }
656 1 -> return IfaceIntTc
657 2 -> return IfaceBoolTc
658 3 -> return IfaceCharTc
659 4 -> return IfaceListTc
660 5 -> return IfacePArrTc
661 6 -> return IfaceLiftedTypeKindTc
662 7 -> return IfaceOpenTypeKindTc
663 8 -> return IfaceUnliftedTypeKindTc
664 9 -> return IfaceUbxTupleKindTc
665 10 -> return IfaceArgTypeKindTc
666 11 -> do { bx <- get bh; ar <- get bh; return (IfaceTupTc bx ar) }
667 _ -> do { ext <- get bh; return (IfaceTc ext) }
669 instance Binary IfacePredType where
670 put_ bh (IfaceClassP aa ab) = do
674 put_ bh (IfaceIParam ac ad) = do
678 put_ bh (IfaceEqPred ac ad) = do
687 return (IfaceClassP aa ab)
690 return (IfaceIParam ac ad)
693 return (IfaceEqPred ac ad)
695 -------------------------------------------------------------------------
696 -- IfaceExpr and friends
697 -------------------------------------------------------------------------
699 instance Binary IfaceExpr where
700 put_ bh (IfaceLcl aa) = do
703 put_ bh (IfaceType ab) = do
706 put_ bh (IfaceTuple ac ad) = do
710 put_ bh (IfaceLam ae af) = do
714 put_ bh (IfaceApp ag ah) = do
719 put_ bh (IfaceCase ai aj al ak) = do
726 put_ bh (IfaceLet al am) = do
730 put_ bh (IfaceNote an ao) = do
734 put_ bh (IfaceLit ap) = do
737 put_ bh (IfaceFCall as at) = do
741 put_ bh (IfaceExt aa) = do
744 put_ bh (IfaceCast ie ico) = do
754 return (IfaceType ab)
757 return (IfaceTuple ac ad)
760 return (IfaceLam ae af)
763 return (IfaceApp ag ah)
770 return (IfaceCase ai aj al ak)
773 return (IfaceLet al am)
776 return (IfaceNote an ao)
781 return (IfaceFCall as at)
782 10 -> do aa <- get bh
784 11 -> do ie <- get bh
786 return (IfaceCast ie ico)
788 instance Binary IfaceConAlt where
789 put_ bh IfaceDefault = do
791 put_ bh (IfaceDataAlt aa) = do
794 put_ bh (IfaceTupleAlt ab) = do
797 put_ bh (IfaceLitAlt ac) = do
803 0 -> do return IfaceDefault
805 return (IfaceDataAlt aa)
807 return (IfaceTupleAlt ab)
809 return (IfaceLitAlt ac)
811 instance Binary IfaceBinding where
812 put_ bh (IfaceNonRec aa ab) = do
816 put_ bh (IfaceRec ac) = do
824 return (IfaceNonRec aa ab)
828 instance Binary IfaceIdInfo where
829 put_ bh NoInfo = putByte bh 0
830 put_ bh (HasInfo i) = do
832 lazyPut bh i -- NB lazyPut
838 _ -> do info <- lazyGet bh -- NB lazyGet
839 return (HasInfo info)
841 instance Binary IfaceInfoItem where
842 put_ bh (HsArity aa) = do
845 put_ bh (HsStrictness ab) = do
848 put_ bh (HsUnfold ad) = do
851 put_ bh (HsInline ad) = do
854 put_ bh HsNoCafRefs = do
856 put_ bh (HsWorker ae af) = do
866 return (HsStrictness ab)
871 4 -> do return HsNoCafRefs
874 return (HsWorker ae af)
876 instance Binary IfaceNote where
877 put_ bh (IfaceSCC aa) = do
880 put_ bh IfaceInlineMe = do
882 put_ bh (IfaceCoreNote s) = do
890 3 -> do return IfaceInlineMe
892 return (IfaceCoreNote ac)
895 -------------------------------------------------------------------------
896 -- IfaceDecl and friends
897 -------------------------------------------------------------------------
899 instance Binary IfaceDecl where
900 put_ bh (IfaceId name ty idinfo) = do
905 put_ bh (IfaceForeign ae af) =
906 error "Binary.put_(IfaceDecl): IfaceForeign"
907 put_ bh (IfaceData a1 a2 a3 a4 a5 a6 a7 a8) = do
917 put_ bh (IfaceSyn aq ar as at) = do
923 put_ bh (IfaceClass a1 a2 a3 a4 a5 a6 a7) = do
935 0 -> do name <- get bh
938 return (IfaceId name ty idinfo)
939 1 -> error "Binary.get(TyClDecl): ForeignType"
949 return (IfaceData a1 a2 a3 a4 a5 a6 a7 a8)
955 return (IfaceSyn aq ar as at)
964 return (IfaceClass a1 a2 a3 a4 a5 a6 a7)
966 instance Binary IfaceInst where
967 put_ bh (IfaceInst cls tys dfun flag orph) = do
973 get bh = do cls <- get bh
978 return (IfaceInst cls tys dfun flag orph)
980 instance Binary IfaceFamInst where
981 put_ bh (IfaceFamInst tycon tys) = do
984 get bh = do tycon <- get bh
986 return (IfaceFamInst tycon tys)
988 instance Binary OverlapFlag where
989 put_ bh NoOverlap = putByte bh 0
990 put_ bh OverlapOk = putByte bh 1
991 put_ bh Incoherent = putByte bh 2
992 get bh = do h <- getByte bh
994 0 -> return NoOverlap
995 1 -> return OverlapOk
996 2 -> return Incoherent
998 instance Binary IfaceConDecls where
999 put_ bh IfAbstractTyCon = putByte bh 0
1000 put_ bh IfOpenDataTyCon = putByte bh 1
1001 put_ bh IfOpenNewTyCon = putByte bh 2
1002 put_ bh (IfDataTyCon cs) = do { putByte bh 3
1004 put_ bh (IfNewTyCon c) = do { putByte bh 4
1009 0 -> return IfAbstractTyCon
1010 1 -> return IfOpenDataTyCon
1011 2 -> return IfOpenNewTyCon
1012 3 -> do cs <- get bh
1013 return (IfDataTyCon cs)
1014 _ -> do aa <- get bh
1015 return (IfNewTyCon aa)
1017 instance Binary IfaceConDecl where
1018 put_ bh (IfCon a1 a2 a3 a4 a5 a6 a7 a8 a9) = do
1028 get bh = do a1 <- get bh
1037 return (IfCon a1 a2 a3 a4 a5 a6 a7 a8 a9)
1039 instance Binary IfaceClassOp where
1040 put_ bh (IfaceClassOp n def ty) = do
1048 return (IfaceClassOp n def ty)
1050 instance Binary IfaceRule where
1051 put_ bh (IfaceRule a1 a2 a3 a4 a5 a6 a7) = do
1067 return (IfaceRule a1 a2 a3 a4 a5 a6 a7)