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,
181 mi_rule_vers = rule_vers,
182 -- And build the cached values
183 mi_dep_fn = mkIfaceDepCache deprecs,
184 mi_fix_fn = mkIfaceFixCache fixities,
185 mi_ver_fn = mkIfaceVerCache decls })
187 GLOBAL_VAR(v_IgnoreHiWay, False, Bool)
189 getWayDescr :: IO String
191 tag <- readIORef v_Build_tag
192 if cGhcUnregisterised == "YES" then return ('u':tag) else return tag
193 -- if this is an unregisterised build, make sure our interfaces
194 -- can't be used by a registerised build.
196 -------------------------------------------------------------------------
197 -- Types from: HscTypes
198 -------------------------------------------------------------------------
200 instance Binary Dependencies where
201 put_ bh deps = do put_ bh (dep_mods deps)
202 put_ bh (dep_pkgs deps)
203 put_ bh (dep_orphs deps)
205 get bh = do ms <- get bh
208 return (Deps { dep_mods = ms, dep_pkgs = ps, dep_orphs = os })
210 instance (Binary name) => Binary (GenAvailInfo name) where
211 put_ bh (Avail aa) = do
214 put_ bh (AvailTC ab ac) = do
225 return (AvailTC ab ac)
227 instance Binary Usage where
229 put_ bh (usg_name usg)
230 put_ bh (usg_mod usg)
231 put_ bh (usg_exports usg)
232 put_ bh (usg_entities usg)
233 put_ bh (usg_rules usg)
241 return (Usage { usg_name = nm, usg_mod = mod,
242 usg_exports = exps, usg_entities = ents,
245 instance Binary a => Binary (Deprecs a) where
246 put_ bh NoDeprecs = putByte bh 0
247 put_ bh (DeprecAll t) = do
250 put_ bh (DeprecSome ts) = do
257 0 -> return NoDeprecs
259 return (DeprecAll aa)
261 return (DeprecSome aa)
263 -------------------------------------------------------------------------
264 -- Types from: BasicTypes
265 -------------------------------------------------------------------------
267 instance Binary Activation where
268 put_ bh NeverActive = do
270 put_ bh AlwaysActive = do
272 put_ bh (ActiveBefore aa) = do
275 put_ bh (ActiveAfter ab) = do
281 0 -> do return NeverActive
282 1 -> do return AlwaysActive
284 return (ActiveBefore aa)
286 return (ActiveAfter ab)
288 instance Binary StrictnessMark where
289 put_ bh MarkedStrict = do
291 put_ bh MarkedUnboxed = do
293 put_ bh NotMarkedStrict = do
298 0 -> do return MarkedStrict
299 1 -> do return MarkedUnboxed
300 _ -> do return NotMarkedStrict
302 instance Binary Boxity where
311 _ -> do return Unboxed
313 instance Binary TupCon where
314 put_ bh (TupCon ab ac) = do
320 return (TupCon ab ac)
322 instance Binary RecFlag where
323 put_ bh Recursive = do
325 put_ bh NonRecursive = do
330 0 -> do return Recursive
331 _ -> do return NonRecursive
333 instance Binary DefMeth where
334 put_ bh NoDefMeth = putByte bh 0
335 put_ bh DefMeth = putByte bh 1
336 put_ bh GenDefMeth = putByte bh 2
340 0 -> return NoDefMeth
342 _ -> return GenDefMeth
344 instance Binary FixityDirection where
354 0 -> do return InfixL
355 1 -> do return InfixR
356 _ -> do return InfixN
358 instance Binary Fixity where
359 put_ bh (Fixity aa ab) = do
365 return (Fixity aa ab)
367 instance (Binary name) => Binary (IPName name) where
368 put_ bh (Dupable aa) = do
371 put_ bh (Linear ab) = do
382 -------------------------------------------------------------------------
383 -- Types from: Demand
384 -------------------------------------------------------------------------
386 instance Binary DmdType where
387 -- Ignore DmdEnv when spitting out the DmdType
388 put bh (DmdType _ ds dr) = do p <- put bh ds; put bh dr; return (castBin p)
389 get bh = do ds <- get bh; dr <- get bh; return (DmdType emptyVarEnv ds dr)
391 instance Binary Demand where
396 put_ bh (Call aa) = do
399 put_ bh (Eval ab) = do
402 put_ bh (Defer ac) = do
405 put_ bh (Box ad) = do
425 instance Binary Demands where
426 put_ bh (Poly aa) = do
429 put_ bh (Prod ab) = do
440 instance Binary DmdResult where
450 0 -> do return TopRes
451 1 -> do return RetCPR -- Really use RetCPR even if -fcpr-off
452 -- The wrapper was generated for CPR in
453 -- the imported module!
454 _ -> do return BotRes
456 instance Binary StrictSig where
457 put_ bh (StrictSig aa) = do
461 return (StrictSig aa)
464 -------------------------------------------------------------------------
465 -- Types from: CostCentre
466 -------------------------------------------------------------------------
468 instance Binary IsCafCC where
471 put_ bh NotCafCC = do
477 _ -> do return NotCafCC
479 instance Binary IsDupdCC where
480 put_ bh OriginalCC = do
487 0 -> do return OriginalCC
488 _ -> do return DupdCC
490 instance Binary CostCentre where
491 put_ bh NoCostCentre = do
493 put_ bh (NormalCC aa ab ac ad) = do
499 put_ bh (AllCafsCC ae) = do
505 0 -> do return NoCostCentre
510 return (NormalCC aa ab ac ad)
512 return (AllCafsCC ae)
514 -------------------------------------------------------------------------
515 -- IfaceTypes and friends
516 -------------------------------------------------------------------------
518 instance Binary IfaceExtName where
519 put_ bh (ExtPkg mod occ) = do
523 put_ bh (HomePkg mod occ vers) = do
528 put_ bh (LocalTop occ) = do
531 put_ bh (LocalTopSub occ _) = do -- Write LocalTopSub just like LocalTop
538 0 -> do mod <- get bh
540 return (ExtPkg mod occ)
541 1 -> do mod <- get bh
544 return (HomePkg mod occ vers)
545 _ -> do occ <- get bh
546 return (LocalTop occ)
548 instance Binary IfaceBndr where
549 put_ bh (IfaceIdBndr aa) = do
552 put_ bh (IfaceTvBndr ab) = do
559 return (IfaceIdBndr aa)
561 return (IfaceTvBndr ab)
563 instance Binary IfaceType where
564 put_ bh (IfaceForAllTy aa ab) = do
568 put_ bh (IfaceTyVar ad) = do
571 put_ bh (IfaceAppTy ae af) = do
575 put_ bh (IfaceFunTy ag ah) = do
579 put_ bh (IfacePredTy aq) = do
583 -- Simple compression for common cases of TyConApp
584 put_ bh (IfaceTyConApp IfaceIntTc []) = putByte bh 6
585 put_ bh (IfaceTyConApp IfaceCharTc []) = putByte bh 7
586 put_ bh (IfaceTyConApp IfaceBoolTc []) = putByte bh 8
587 put_ bh (IfaceTyConApp IfaceListTc [ty]) = do { putByte bh 9; put_ bh ty }
588 -- Unit tuple and pairs
589 put_ bh (IfaceTyConApp (IfaceTupTc Boxed 0) []) = putByte bh 10
590 put_ bh (IfaceTyConApp (IfaceTupTc Boxed 2) [t1,t2]) = do { putByte bh 11; put_ bh t1; put_ bh t2 }
592 put_ bh (IfaceTyConApp IfaceLiftedTypeKindTc []) = putByte bh 12
593 put_ bh (IfaceTyConApp IfaceOpenTypeKindTc []) = putByte bh 13
594 put_ bh (IfaceTyConApp IfaceUnliftedTypeKindTc []) = putByte bh 14
595 put_ bh (IfaceTyConApp IfaceUbxTupleKindTc []) = putByte bh 15
596 put_ bh (IfaceTyConApp IfaceArgTypeKindTc []) = putByte bh 16
600 put_ bh (IfaceTyConApp (IfaceTc tc) tys) = do { putByte bh 18; put_ bh tc; put_ bh tys }
601 put_ bh (IfaceTyConApp tc tys) = do { putByte bh 19; put_ bh tc; put_ bh tys }
608 return (IfaceForAllTy aa ab)
610 return (IfaceTyVar ad)
613 return (IfaceAppTy ae af)
616 return (IfaceFunTy ag ah)
618 return (IfacePredTy ap)
620 -- Now the special cases for TyConApp
621 6 -> return (IfaceTyConApp IfaceIntTc [])
622 7 -> return (IfaceTyConApp IfaceCharTc [])
623 8 -> return (IfaceTyConApp IfaceBoolTc [])
624 9 -> do { ty <- get bh; return (IfaceTyConApp IfaceListTc [ty]) }
625 10 -> return (IfaceTyConApp (IfaceTupTc Boxed 0) [])
626 11 -> do { t1 <- get bh; t2 <- get bh; return (IfaceTyConApp (IfaceTupTc Boxed 2) [t1,t2]) }
627 12 -> return (IfaceTyConApp IfaceLiftedTypeKindTc [])
628 13 -> return (IfaceTyConApp IfaceOpenTypeKindTc [])
629 14 -> return (IfaceTyConApp IfaceUnliftedTypeKindTc [])
630 15 -> return (IfaceTyConApp IfaceUbxTupleKindTc [])
631 16 -> return (IfaceTyConApp IfaceArgTypeKindTc [])
633 18 -> do { tc <- get bh; tys <- get bh; return (IfaceTyConApp (IfaceTc tc) tys) }
634 _ -> do { tc <- get bh; tys <- get bh; return (IfaceTyConApp tc tys) }
636 instance Binary IfaceTyCon where
637 -- Int,Char,Bool can't show up here because they can't not be saturated
639 put_ bh IfaceIntTc = putByte bh 1
640 put_ bh IfaceBoolTc = putByte bh 2
641 put_ bh IfaceCharTc = putByte bh 3
642 put_ bh IfaceListTc = putByte bh 4
643 put_ bh IfacePArrTc = putByte bh 5
644 put_ bh IfaceLiftedTypeKindTc = putByte bh 6
645 put_ bh IfaceOpenTypeKindTc = putByte bh 7
646 put_ bh IfaceUnliftedTypeKindTc = putByte bh 8
647 put_ bh IfaceUbxTupleKindTc = putByte bh 9
648 put_ bh IfaceArgTypeKindTc = putByte bh 10
649 put_ bh (IfaceTupTc bx ar) = do { putByte bh 11; put_ bh bx; put_ bh ar }
650 put_ bh (IfaceTc ext) = do { putByte bh 12; put_ bh ext }
655 1 -> return IfaceIntTc
656 2 -> return IfaceBoolTc
657 3 -> return IfaceCharTc
658 4 -> return IfaceListTc
659 5 -> return IfacePArrTc
660 6 -> return IfaceLiftedTypeKindTc
661 7 -> return IfaceOpenTypeKindTc
662 8 -> return IfaceUnliftedTypeKindTc
663 9 -> return IfaceUbxTupleKindTc
664 10 -> return IfaceArgTypeKindTc
665 11 -> do { bx <- get bh; ar <- get bh; return (IfaceTupTc bx ar) }
666 _ -> do { ext <- get bh; return (IfaceTc ext) }
668 instance Binary IfacePredType where
669 put_ bh (IfaceClassP aa ab) = do
673 put_ bh (IfaceIParam ac ad) = do
677 put_ bh (IfaceEqPred ac ad) = do
686 return (IfaceClassP aa ab)
689 return (IfaceIParam ac ad)
692 return (IfaceEqPred ac ad)
694 -------------------------------------------------------------------------
695 -- IfaceExpr and friends
696 -------------------------------------------------------------------------
698 instance Binary IfaceExpr where
699 put_ bh (IfaceLcl aa) = do
702 put_ bh (IfaceType ab) = do
705 put_ bh (IfaceTuple ac ad) = do
709 put_ bh (IfaceLam ae af) = do
713 put_ bh (IfaceApp ag ah) = do
718 put_ bh (IfaceCase ai aj al ak) = do
725 put_ bh (IfaceLet al am) = do
729 put_ bh (IfaceNote an ao) = do
733 put_ bh (IfaceLit ap) = do
736 put_ bh (IfaceFCall as at) = do
740 put_ bh (IfaceExt aa) = do
743 put_ bh (IfaceCast ie ico) = do
753 return (IfaceType ab)
756 return (IfaceTuple ac ad)
759 return (IfaceLam ae af)
762 return (IfaceApp ag ah)
769 return (IfaceCase ai aj al ak)
772 return (IfaceLet al am)
775 return (IfaceNote an ao)
780 return (IfaceFCall as at)
781 10 -> do aa <- get bh
783 11 -> do ie <- get bh
785 return (IfaceCast ie ico)
787 instance Binary IfaceConAlt where
788 put_ bh IfaceDefault = do
790 put_ bh (IfaceDataAlt aa) = do
793 put_ bh (IfaceTupleAlt ab) = do
796 put_ bh (IfaceLitAlt ac) = do
802 0 -> do return IfaceDefault
804 return (IfaceDataAlt aa)
806 return (IfaceTupleAlt ab)
808 return (IfaceLitAlt ac)
810 instance Binary IfaceBinding where
811 put_ bh (IfaceNonRec aa ab) = do
815 put_ bh (IfaceRec ac) = do
823 return (IfaceNonRec aa ab)
827 instance Binary IfaceIdInfo where
828 put_ bh NoInfo = putByte bh 0
829 put_ bh (HasInfo i) = do
831 lazyPut bh i -- NB lazyPut
837 _ -> do info <- lazyGet bh -- NB lazyGet
838 return (HasInfo info)
840 instance Binary IfaceInfoItem where
841 put_ bh (HsArity aa) = do
844 put_ bh (HsStrictness ab) = do
847 put_ bh (HsUnfold ad) = do
850 put_ bh (HsInline ad) = do
853 put_ bh HsNoCafRefs = do
855 put_ bh (HsWorker ae af) = do
865 return (HsStrictness ab)
870 4 -> do return HsNoCafRefs
873 return (HsWorker ae af)
875 instance Binary IfaceNote where
876 put_ bh (IfaceSCC aa) = do
879 put_ bh IfaceInlineMe = do
881 put_ bh (IfaceCoreNote s) = do
889 3 -> do return IfaceInlineMe
891 return (IfaceCoreNote ac)
894 -------------------------------------------------------------------------
895 -- IfaceDecl and friends
896 -------------------------------------------------------------------------
898 instance Binary IfaceDecl where
899 put_ bh (IfaceId name ty idinfo) = do
904 put_ bh (IfaceForeign ae af) =
905 error "Binary.put_(IfaceDecl): IfaceForeign"
906 put_ bh (IfaceData a1 a2 a3 a4 a5 a6 a7) = do
916 put_ bh (IfaceSyn aq ar as at) = do
922 put_ bh (IfaceClass a1 a2 a3 a4 a5 a6 a7) = do
934 0 -> do name <- get bh
937 return (IfaceId name ty idinfo)
938 1 -> error "Binary.get(TyClDecl): ForeignType"
947 return (IfaceData a1 a2 a3 a4 a5 a6 a7)
953 return (IfaceSyn aq ar as at)
962 return (IfaceClass a1 a2 a3 a4 a5 a6 a7)
964 instance Binary IfaceInst where
965 put_ bh (IfaceInst cls tys dfun flag orph) = do
971 get bh = do cls <- get bh
976 return (IfaceInst cls tys dfun flag orph)
978 instance Binary OverlapFlag where
979 put_ bh NoOverlap = putByte bh 0
980 put_ bh OverlapOk = putByte bh 1
981 put_ bh Incoherent = putByte bh 2
982 get bh = do h <- getByte bh
984 0 -> return NoOverlap
985 1 -> return OverlapOk
986 2 -> return Incoherent
988 instance Binary IfaceConDecls where
989 put_ bh IfAbstractTyCon = putByte bh 0
990 put_ bh IfOpenDataTyCon = putByte bh 1
991 put_ bh IfOpenNewTyCon = putByte bh 2
992 put_ bh (IfDataTyCon cs) = do { putByte bh 3
994 put_ bh (IfNewTyCon c) = do { putByte bh 4
999 0 -> return IfAbstractTyCon
1000 1 -> return IfOpenDataTyCon
1001 2 -> return IfOpenNewTyCon
1002 3 -> do cs <- get bh
1003 return (IfDataTyCon cs)
1004 _ -> do aa <- get bh
1005 return (IfNewTyCon aa)
1007 instance Binary IfaceConDecl where
1008 put_ bh (IfCon a1 a2 a3 a4 a5 a6 a7 a8 a9) = do
1018 get bh = do a1 <- get bh
1027 return (IfCon a1 a2 a3 a4 a5 a6 a7 a8 a9)
1029 instance Binary IfaceClassOp where
1030 put_ bh (IfaceClassOp n def ty) = do
1038 return (IfaceClassOp n def ty)
1040 instance Binary IfaceRule where
1041 put_ bh (IfaceRule a1 a2 a3 a4 a5 a6 a7) = do
1057 return (IfaceRule a1 a2 a3 a4 a5 a6 a7)