diff options
| -rw-r--r-- | compiler/basicTypes/Avail.hs | 17 | ||||
| -rw-r--r-- | compiler/iface/BinIface.hs | 1079 | ||||
| -rw-r--r-- | compiler/iface/IfaceSyn.lhs | 487 | ||||
| -rw-r--r-- | compiler/iface/IfaceType.lhs | 106 | ||||
| -rw-r--r-- | compiler/main/Annotations.hs | 14 | ||||
| -rw-r--r-- | compiler/main/HscTypes.lhs | 201 | ||||
| -rw-r--r-- | compiler/profiling/CostCentre.lhs | 39 | ||||
| -rw-r--r-- | compiler/types/Coercion.lhs | 10 | ||||
| -rw-r--r-- | compiler/utils/Binary.hs | 141 |
9 files changed, 1015 insertions, 1079 deletions
diff --git a/compiler/basicTypes/Avail.hs b/compiler/basicTypes/Avail.hs index afe93ff480..e22527c57a 100644 --- a/compiler/basicTypes/Avail.hs +++ b/compiler/basicTypes/Avail.hs @@ -18,6 +18,7 @@ import NameEnv import NameSet import RdrName +import Binary import Outputable import Util @@ -104,4 +105,20 @@ pprAvail :: AvailInfo -> SDoc pprAvail (Avail n) = ppr n pprAvail (AvailTC n ns) = ppr n <> braces (hsep (punctuate comma (map ppr ns))) +instance Binary AvailInfo where + put_ bh (Avail aa) = do + putByte bh 0 + put_ bh aa + put_ bh (AvailTC ab ac) = do + putByte bh 1 + put_ bh ab + put_ bh ac + get bh = do + h <- getByte bh + case h of + 0 -> do aa <- get bh + return (Avail aa) + _ -> do ab <- get bh + ac <- get bh + return (AvailTC ab ac) diff --git a/compiler/iface/BinIface.hs b/compiler/iface/BinIface.hs index ba1a7e28e2..0876d906ab 100644 --- a/compiler/iface/BinIface.hs +++ b/compiler/iface/BinIface.hs @@ -2,7 +2,6 @@ -- (c) The University of Glasgow 2002-2006 -- -{-# OPTIONS_GHC -fno-warn-orphans #-} {-# OPTIONS_GHC -O #-} -- We always optimise this, otherwise performance of a non-optimised -- compiler is severely affected @@ -24,20 +23,15 @@ import TyCon import DataCon (dataConName, dataConWorkId, dataConTyCon) import PrelInfo (wiredInThings, basicKnownKeyNames) import Id (idName, isDataConWorkId_maybe) -import Coercion (LeftOrRight(..)) import TysWiredIn import IfaceEnv import HscTypes import BasicTypes -import Annotations -import IfaceSyn import Module import Name -import Avail import DynFlags import UniqFM import UniqSupply -import CostCentre import Panic import Binary import SrcLoc @@ -413,153 +407,6 @@ data BinDictionary = BinDictionary { -- indexed by FastString } --- ----------------------------------------------------------------------------- --- All the binary instances - --- BasicTypes -{-! for Fixity derive: Binary !-} -{-! for FixityDirection derive: Binary !-} -{-! for Boxity derive: Binary !-} -{-! for StrictnessMark derive: Binary !-} -{-! for Activation derive: Binary !-} - --- Class -{-! for DefMeth derive: Binary !-} - --- HsTypes -{-! for HsPred derive: Binary !-} -{-! for HsType derive: Binary !-} -{-! for TupCon derive: Binary !-} -{-! for HsTyVarBndr derive: Binary !-} - --- HsCore -{-! for UfExpr derive: Binary !-} -{-! for UfConAlt derive: Binary !-} -{-! for UfBinding derive: Binary !-} -{-! for UfBinder derive: Binary !-} -{-! for HsIdInfo derive: Binary !-} -{-! for UfNote derive: Binary !-} - --- HsDecls -{-! for ConDetails derive: Binary !-} -{-! for BangType derive: Binary !-} - --- CostCentre -{-! for IsCafCC derive: Binary !-} -{-! for CostCentre derive: Binary !-} - - - --- --------------------------------------------------------------------------- --- Reading a binary interface into ParsedIface - -instance Binary ModIface where - put_ bh (ModIface { - mi_module = mod, - mi_boot = is_boot, - mi_iface_hash= iface_hash, - mi_mod_hash = mod_hash, - mi_flag_hash = flag_hash, - mi_orphan = orphan, - mi_finsts = hasFamInsts, - mi_deps = deps, - mi_usages = usages, - mi_exports = exports, - mi_exp_hash = exp_hash, - mi_used_th = used_th, - mi_fixities = fixities, - mi_warns = warns, - mi_anns = anns, - mi_decls = decls, - mi_insts = insts, - mi_fam_insts = fam_insts, - mi_rules = rules, - mi_orphan_hash = orphan_hash, - mi_vect_info = vect_info, - mi_hpc = hpc_info, - mi_trust = trust, - mi_trust_pkg = trust_pkg }) = do - put_ bh mod - put_ bh is_boot - put_ bh iface_hash - put_ bh mod_hash - put_ bh flag_hash - put_ bh orphan - put_ bh hasFamInsts - lazyPut bh deps - lazyPut bh usages - put_ bh exports - put_ bh exp_hash - put_ bh used_th - put_ bh fixities - lazyPut bh warns - lazyPut bh anns - put_ bh decls - put_ bh insts - put_ bh fam_insts - lazyPut bh rules - put_ bh orphan_hash - put_ bh vect_info - put_ bh hpc_info - put_ bh trust - put_ bh trust_pkg - - get bh = do - mod_name <- get bh - is_boot <- get bh - iface_hash <- get bh - mod_hash <- get bh - flag_hash <- get bh - orphan <- get bh - hasFamInsts <- get bh - deps <- lazyGet bh - usages <- {-# SCC "bin_usages" #-} lazyGet bh - exports <- {-# SCC "bin_exports" #-} get bh - exp_hash <- get bh - used_th <- get bh - fixities <- {-# SCC "bin_fixities" #-} get bh - warns <- {-# SCC "bin_warns" #-} lazyGet bh - anns <- {-# SCC "bin_anns" #-} lazyGet bh - decls <- {-# SCC "bin_tycldecls" #-} get bh - insts <- {-# SCC "bin_insts" #-} get bh - fam_insts <- {-# SCC "bin_fam_insts" #-} get bh - rules <- {-# SCC "bin_rules" #-} lazyGet bh - orphan_hash <- get bh - vect_info <- get bh - hpc_info <- get bh - trust <- get bh - trust_pkg <- get bh - return (ModIface { - mi_module = mod_name, - mi_boot = is_boot, - mi_iface_hash = iface_hash, - mi_mod_hash = mod_hash, - mi_flag_hash = flag_hash, - mi_orphan = orphan, - mi_finsts = hasFamInsts, - mi_deps = deps, - mi_usages = usages, - mi_exports = exports, - mi_exp_hash = exp_hash, - mi_used_th = used_th, - mi_anns = anns, - mi_fixities = fixities, - mi_warns = warns, - mi_decls = decls, - mi_globals = Nothing, - mi_insts = insts, - mi_fam_insts = fam_insts, - mi_rules = rules, - mi_orphan_hash = orphan_hash, - mi_vect_info = vect_info, - mi_hpc = hpc_info, - mi_trust = trust, - mi_trust_pkg = trust_pkg, - -- And build the cached values - mi_warn_fn = mkIfaceWarnCache warns, - mi_fix_fn = mkIfaceFixCache fixities, - mi_hash_fn = mkIfaceHashCache decls }) - getWayDescr :: DynFlags -> String getWayDescr dflags | platformUnregisterised (targetPlatform dflags) = 'u':tag @@ -568,929 +415,3 @@ getWayDescr dflags -- if this is an unregisterised build, make sure our interfaces -- can't be used by a registerised build. -------------------------------------------------------------------------- --- Types from: HscTypes -------------------------------------------------------------------------- - -instance Binary Dependencies where - put_ bh deps = do put_ bh (dep_mods deps) - put_ bh (dep_pkgs deps) - put_ bh (dep_orphs deps) - put_ bh (dep_finsts deps) - - get bh = do ms <- get bh - ps <- get bh - os <- get bh - fis <- get bh - return (Deps { dep_mods = ms, dep_pkgs = ps, dep_orphs = os, - dep_finsts = fis }) - -instance Binary AvailInfo where - put_ bh (Avail aa) = do - putByte bh 0 - put_ bh aa - put_ bh (AvailTC ab ac) = do - putByte bh 1 - put_ bh ab - put_ bh ac - get bh = do - h <- getByte bh - case h of - 0 -> do aa <- get bh - return (Avail aa) - _ -> do ab <- get bh - ac <- get bh - return (AvailTC ab ac) - -instance Binary Usage where - put_ bh usg@UsagePackageModule{} = do - putByte bh 0 - put_ bh (usg_mod usg) - put_ bh (usg_mod_hash usg) - put_ bh (usg_safe usg) - - put_ bh usg@UsageHomeModule{} = do - putByte bh 1 - put_ bh (usg_mod_name usg) - put_ bh (usg_mod_hash usg) - put_ bh (usg_exports usg) - put_ bh (usg_entities usg) - put_ bh (usg_safe usg) - - put_ bh usg@UsageFile{} = do - putByte bh 2 - put_ bh (usg_file_path usg) - put_ bh (usg_mtime usg) - - get bh = do - h <- getByte bh - case h of - 0 -> do - nm <- get bh - mod <- get bh - safe <- get bh - return UsagePackageModule { usg_mod = nm, usg_mod_hash = mod, usg_safe = safe } - 1 -> do - nm <- get bh - mod <- get bh - exps <- get bh - ents <- get bh - safe <- get bh - return UsageHomeModule { usg_mod_name = nm, usg_mod_hash = mod, - usg_exports = exps, usg_entities = ents, usg_safe = safe } - 2 -> do - fp <- get bh - mtime <- get bh - return UsageFile { usg_file_path = fp, usg_mtime = mtime } - i -> error ("Binary.get(Usage): " ++ show i) - -instance Binary Warnings where - put_ bh NoWarnings = putByte bh 0 - put_ bh (WarnAll t) = do - putByte bh 1 - put_ bh t - put_ bh (WarnSome ts) = do - putByte bh 2 - put_ bh ts - - get bh = do - h <- getByte bh - case h of - 0 -> return NoWarnings - 1 -> do aa <- get bh - return (WarnAll aa) - _ -> do aa <- get bh - return (WarnSome aa) - -instance Binary WarningTxt where - put_ bh (WarningTxt w) = do - putByte bh 0 - put_ bh w - put_ bh (DeprecatedTxt d) = do - putByte bh 1 - put_ bh d - - get bh = do - h <- getByte bh - case h of - 0 -> do w <- get bh - return (WarningTxt w) - _ -> do d <- get bh - return (DeprecatedTxt d) - -------------------------------------------------------------------------- --- Types from: BasicTypes -------------------------------------------------------------------------- - -instance Binary Activation where - put_ bh NeverActive = do - putByte bh 0 - put_ bh AlwaysActive = do - putByte bh 1 - put_ bh (ActiveBefore aa) = do - putByte bh 2 - put_ bh aa - put_ bh (ActiveAfter ab) = do - putByte bh 3 - put_ bh ab - get bh = do - h <- getByte bh - case h of - 0 -> do return NeverActive - 1 -> do return AlwaysActive - 2 -> do aa <- get bh - return (ActiveBefore aa) - _ -> do ab <- get bh - return (ActiveAfter ab) - -instance Binary RuleMatchInfo where - put_ bh FunLike = putByte bh 0 - put_ bh ConLike = putByte bh 1 - get bh = do - h <- getByte bh - if h == 1 then return ConLike - else return FunLike - -instance Binary InlinePragma where - put_ bh (InlinePragma a b c d) = do - put_ bh a - put_ bh b - put_ bh c - put_ bh d - - get bh = do - a <- get bh - b <- get bh - c <- get bh - d <- get bh - return (InlinePragma a b c d) - -instance Binary InlineSpec where - put_ bh EmptyInlineSpec = putByte bh 0 - put_ bh Inline = putByte bh 1 - put_ bh Inlinable = putByte bh 2 - put_ bh NoInline = putByte bh 3 - - get bh = do h <- getByte bh - case h of - 0 -> return EmptyInlineSpec - 1 -> return Inline - 2 -> return Inlinable - _ -> return NoInline - -instance Binary IfaceBang where - put_ bh IfNoBang = putByte bh 0 - put_ bh IfStrict = putByte bh 1 - put_ bh IfUnpack = putByte bh 2 - put_ bh (IfUnpackCo co) = putByte bh 3 >> put_ bh co - - get bh = do - h <- getByte bh - case h of - 0 -> do return IfNoBang - 1 -> do return IfStrict - 2 -> do return IfUnpack - _ -> do { a <- get bh; return (IfUnpackCo a) } - -instance Binary TupleSort where - put_ bh BoxedTuple = putByte bh 0 - put_ bh UnboxedTuple = putByte bh 1 - put_ bh ConstraintTuple = putByte bh 2 - get bh = do - h <- getByte bh - case h of - 0 -> do return BoxedTuple - 1 -> do return UnboxedTuple - _ -> do return ConstraintTuple - -instance Binary RecFlag where - put_ bh Recursive = do - putByte bh 0 - put_ bh NonRecursive = do - putByte bh 1 - get bh = do - h <- getByte bh - case h of - 0 -> do return Recursive - _ -> do return NonRecursive - -instance Binary DefMethSpec where - put_ bh NoDM = putByte bh 0 - put_ bh VanillaDM = putByte bh 1 - put_ bh GenericDM = putByte bh 2 - get bh = do - h <- getByte bh - case h of - 0 -> return NoDM - 1 -> return VanillaDM - _ -> return GenericDM - -instance Binary FixityDirection where - put_ bh InfixL = do - putByte bh 0 - put_ bh InfixR = do - putByte bh 1 - put_ bh InfixN = do - putByte bh 2 - get bh = do - h <- getByte bh - case h of - 0 -> do return InfixL - 1 -> do return InfixR - _ -> do return InfixN - -instance Binary Fixity where - put_ bh (Fixity aa ab) = do - put_ bh aa - put_ bh ab - get bh = do - aa <- get bh - ab <- get bh - return (Fixity aa ab) - - -------------------------------------------------------------------------- --- Types from: CostCentre -------------------------------------------------------------------------- - -instance Binary IsCafCC where - put_ bh CafCC = do - putByte bh 0 - put_ bh NotCafCC = do - putByte bh 1 - get bh = do - h <- getByte bh - case h of - 0 -> do return CafCC - _ -> do return NotCafCC - -instance Binary CostCentre where - put_ bh (NormalCC aa ab ac _ad ae) = do - putByte bh 0 - put_ bh aa - put_ bh ab - put_ bh ac - put_ bh ae - put_ bh (AllCafsCC ae _af) = do - putByte bh 1 - put_ bh ae - get bh = do - h <- getByte bh - case h of - 0 -> do aa <- get bh - ab <- get bh - ac <- get bh - ae <- get bh - return (NormalCC aa ab ac noSrcSpan ae) - _ -> do ae <- get bh - return (AllCafsCC ae noSrcSpan) - - -- We ignore the SrcSpans in CostCentres when we serialise them, - -- and set the SrcSpans to noSrcSpan when deserialising. This is - -- ok, because we only need the SrcSpan when declaring the - -- CostCentre in the original module, it is not used by importing - -- modules. - -------------------------------------------------------------------------- --- IfaceTypes and friends -------------------------------------------------------------------------- - -instance Binary IfaceBndr where - put_ bh (IfaceIdBndr aa) = do - putByte bh 0 - put_ bh aa - put_ bh (IfaceTvBndr ab) = do - putByte bh 1 - put_ bh ab - get bh = do - h <- getByte bh - case h of - 0 -> do aa <- get bh - return (IfaceIdBndr aa) - _ -> do ab <- get bh - return (IfaceTvBndr ab) - -instance Binary IfaceLetBndr where - put_ bh (IfLetBndr a b c) = do - put_ bh a - put_ bh b - put_ bh c - get bh = do a <- get bh - b <- get bh - c <- get bh - return (IfLetBndr a b c) - -instance Binary IfaceType where - put_ bh (IfaceForAllTy aa ab) = do - putByte bh 0 - put_ bh aa - put_ bh ab - put_ bh (IfaceTyVar ad) = do - putByte bh 1 - put_ bh ad - put_ bh (IfaceAppTy ae af) = do - putByte bh 2 - put_ bh ae - put_ bh af - put_ bh (IfaceFunTy ag ah) = do - putByte bh 3 - put_ bh ag - put_ bh ah - put_ bh (IfaceCoConApp cc tys) - = do { putByte bh 4; put_ bh cc; put_ bh tys } - put_ bh (IfaceTyConApp tc tys) - = do { putByte bh 5; put_ bh tc; put_ bh tys } - - put_ bh (IfaceLitTy n) - = do { putByte bh 30; put_ bh n } - - - get bh = do - h <- getByte bh - case h of - 0 -> do aa <- get bh - ab <- get bh - return (IfaceForAllTy aa ab) - 1 -> do ad <- get bh - return (IfaceTyVar ad) - 2 -> do ae <- get bh - af <- get bh - return (IfaceAppTy ae af) - 3 -> do ag <- get bh - ah <- get bh - return (IfaceFunTy ag ah) - 4 -> do { cc <- get bh; tys <- get bh - ; return (IfaceCoConApp cc tys) } - 5 -> do { tc <- get bh; tys <- get bh - ; return (IfaceTyConApp tc tys) } - - 30 -> do n <- get bh - return (IfaceLitTy n) - - _ -> panic ("get IfaceType " ++ show h) - -instance Binary IfaceTyLit where - put_ bh (IfaceNumTyLit n) = putByte bh 1 >> put_ bh n - put_ bh (IfaceStrTyLit n) = putByte bh 2 >> put_ bh n - - get bh = - do tag <- getByte bh - case tag of - 1 -> do { n <- get bh - ; return (IfaceNumTyLit n) } - 2 -> do { n <- get bh - ; return (IfaceStrTyLit n) } - _ -> panic ("get IfaceTyLit " ++ show tag) - -instance Binary IfaceTyCon where - put_ bh (IfaceTc ext) = put_ bh ext - get bh = liftM IfaceTc (get bh) - -instance Binary LeftOrRight where - put_ bh CLeft = putByte bh 0 - put_ bh CRight = putByte bh 1 - - get bh = do { h <- getByte bh - ; case h of - 0 -> return CLeft - _ -> return CRight } - -instance Binary IfaceCoCon where - put_ bh (IfaceCoAx n ind) = do { putByte bh 0; put_ bh n; put_ bh ind } - put_ bh IfaceReflCo = putByte bh 1 - put_ bh IfaceUnsafeCo = putByte bh 2 - put_ bh IfaceSymCo = putByte bh 3 - put_ bh IfaceTransCo = putByte bh 4 - put_ bh IfaceInstCo = putByte bh 5 - put_ bh (IfaceNthCo d) = do { putByte bh 6; put_ bh d } - put_ bh (IfaceLRCo lr) = do { putByte bh 7; put_ bh lr } - - get bh = do - h <- getByte bh - case h of - 0 -> do { n <- get bh; ind <- get bh; return (IfaceCoAx n ind) } - 1 -> return IfaceReflCo - 2 -> return IfaceUnsafeCo - 3 -> return IfaceSymCo - 4 -> return IfaceTransCo - 5 -> return IfaceInstCo - 6 -> do { d <- get bh; return (IfaceNthCo d) } - 7 -> do { lr <- get bh; return (IfaceLRCo lr) } - _ -> panic ("get IfaceCoCon " ++ show h) - -------------------------------------------------------------------------- --- IfaceExpr and friends -------------------------------------------------------------------------- - -instance Binary IfaceExpr where - put_ bh (IfaceLcl aa) = do - putByte bh 0 - put_ bh aa - put_ bh (IfaceType ab) = do - putByte bh 1 - put_ bh ab - put_ bh (IfaceCo ab) = do - putByte bh 2 - put_ bh ab - put_ bh (IfaceTuple ac ad) = do - putByte bh 3 - put_ bh ac - put_ bh ad - put_ bh (IfaceLam ae af) = do - putByte bh 4 - put_ bh ae - put_ bh af - put_ bh (IfaceApp ag ah) = do - putByte bh 5 - put_ bh ag - put_ bh ah - put_ bh (IfaceCase ai aj ak) = do - putByte bh 6 - put_ bh ai - put_ bh aj - put_ bh ak - put_ bh (IfaceLet al am) = do - putByte bh 7 - put_ bh al - put_ bh am - put_ bh (IfaceTick an ao) = do - putByte bh 8 - put_ bh an - put_ bh ao - put_ bh (IfaceLit ap) = do - putByte bh 9 - put_ bh ap - put_ bh (IfaceFCall as at) = do - putByte bh 10 - put_ bh as - put_ bh at - put_ bh (IfaceExt aa) = do - putByte bh 11 - put_ bh aa - put_ bh (IfaceCast ie ico) = do - putByte bh 12 - put_ bh ie - put_ bh ico - put_ bh (IfaceECase a b) = do - putByte bh 13 - put_ bh a - put_ bh b - get bh = do - h <- getByte bh - case h of - 0 -> do aa <- get bh - return (IfaceLcl aa) - 1 -> do ab <- get bh - return (IfaceType ab) - 2 -> do ab <- get bh - return (IfaceCo ab) - 3 -> do ac <- get bh - ad <- get bh - return (IfaceTuple ac ad) - 4 -> do ae <- get bh - af <- get bh - return (IfaceLam ae af) - 5 -> do ag <- get bh - ah <- get bh - return (IfaceApp ag ah) - 6 -> do ai <- get bh - aj <- get bh - ak <- get bh - return (IfaceCase ai aj ak) - 7 -> do al <- get bh - am <- get bh - return (IfaceLet al am) - 8 -> do an <- get bh - ao <- get bh - return (IfaceTick an ao) - 9 -> do ap <- get bh - return (IfaceLit ap) - 10 -> do as <- get bh - at <- get bh - return (IfaceFCall as at) - 11 -> do aa <- get bh - return (IfaceExt aa) - 12 -> do ie <- get bh - ico <- get bh - return (IfaceCast ie ico) - 13 -> do a <- get bh - b <- get bh - return (IfaceECase a b) - _ -> panic ("get IfaceExpr " ++ show h) - -instance Binary IfaceConAlt where - put_ bh IfaceDefault = putByte bh 0 - put_ bh (IfaceDataAlt aa) = putByte bh 1 >> put_ bh aa - put_ bh (IfaceLitAlt ac) = putByte bh 2 >> put_ bh ac - get bh = do - h <- getByte bh - case h of - 0 -> return IfaceDefault - 1 -> get bh >>= (return . IfaceDataAlt) - _ -> get bh >>= (return . IfaceLitAlt) - -instance Binary IfaceBinding where - put_ bh (IfaceNonRec aa ab) = putByte bh 0 >> put_ bh aa >> put_ bh ab - put_ bh (IfaceRec ac) = putByte bh 1 >> put_ bh ac - get bh = do - h <- getByte bh - case h of - 0 -> do { aa <- get bh; ab <- get bh; return (IfaceNonRec aa ab) } - _ -> do { ac <- get bh; return (IfaceRec ac) } - -instance Binary IfaceIdDetails where - put_ bh IfVanillaId = putByte bh 0 - put_ bh (IfRecSelId a b) = putByte bh 1 >> put_ bh a >> put_ bh b - put_ bh (IfDFunId n) = do { putByte bh 2; put_ bh n } - get bh = do - h <- getByte bh - case h of - 0 -> return IfVanillaId - 1 -> do { a <- get bh; b <- get bh; return (IfRecSelId a b) } - _ -> do { n <- get bh; return (IfDFunId n) } - -instance Binary IfaceIdInfo where - put_ bh NoInfo = putByte bh 0 - put_ bh (HasInfo i) = putByte bh 1 >> lazyPut bh i -- NB lazyPut - - get bh = do - h <- getByte bh - case h of - 0 -> return NoInfo - _ -> lazyGet bh >>= (return . HasInfo) -- NB lazyGet - -instance Binary IfaceInfoItem where - put_ bh (HsArity aa) = putByte bh 0 >> put_ bh aa - put_ bh (HsStrictness ab) = putByte bh 1 >> put_ bh ab - put_ bh (HsUnfold lb ad) = putByte bh 2 >> put_ bh lb >> put_ bh ad - put_ bh (HsInline ad) = putByte bh 3 >> put_ bh ad - put_ bh HsNoCafRefs = putByte bh 4 - get bh = do - h <- getByte bh - case h of - 0 -> get bh >>= (return . HsArity) - 1 -> get bh >>= (return . HsStrictness) - 2 -> do lb <- get bh - ad <- get bh - return (HsUnfold lb ad) - 3 -> get bh >>= (return . HsInline) - _ -> return HsNoCafRefs - -instance Binary IfaceUnfolding where - put_ bh (IfCoreUnfold s e) = do - putByte bh 0 - put_ bh s - put_ bh e - put_ bh (IfInlineRule a b c d) = do - putByte bh 1 - put_ bh a - put_ bh b - put_ bh c - put_ bh d - put_ bh (IfLclWrapper a n) = do - putByte bh 2 - put_ bh a - put_ bh n - put_ bh (IfExtWrapper a n) = do - putByte bh 3 - put_ bh a - put_ bh n - put_ bh (IfDFunUnfold as bs) = do - putByte bh 4 - put_ bh as - put_ bh bs - put_ bh (IfCompulsory e) = do - putByte bh 5 - put_ bh e - get bh = do - h <- getByte bh - case h of - 0 -> do s <- get bh - e <- get bh - return (IfCoreUnfold s e) - 1 -> do a <- get bh - b <- get bh - c <- get bh - d <- get bh - return (IfInlineRule a b c d) - 2 -> do a <- get bh - n <- get bh - return (IfLclWrapper a n) - 3 -> do a <- get bh - n <- get bh - return (IfExtWrapper a n) - 4 -> do as <- get bh - bs <- get bh - return (IfDFunUnfold as bs) - _ -> do e <- get bh - return (IfCompulsory e) - -instance Binary IfaceTickish where - put_ bh (IfaceHpcTick m ix) = do - putByte bh 0 - put_ bh m - put_ bh ix - put_ bh (IfaceSCC cc tick push) = do - putByte bh 1 - put_ bh cc - put_ bh tick - put_ bh push - - get bh = do - h <- getByte bh - case h of - 0 -> do m <- get bh - ix <- get bh - return (IfaceHpcTick m ix) - 1 -> do cc <- get bh - tick <- get bh - push <- get bh - return (IfaceSCC cc tick push) - _ -> panic ("get IfaceTickish " ++ show h) - -------------------------------------------------------------------------- --- IfaceDecl and friends -------------------------------------------------------------------------- - --- A bit of magic going on here: there's no need to store the OccName --- for a decl on the disk, since we can infer the namespace from the --- context; however it is useful to have the OccName in the IfaceDecl --- to avoid re-building it in various places. So we build the OccName --- when de-serialising. - -instance Binary IfaceDecl where - put_ bh (IfaceId name ty details idinfo) = do - putByte bh 0 - put_ bh (occNameFS name) - put_ bh ty - put_ bh details - put_ bh idinfo - - put_ _ (IfaceForeign _ _) = - error "Binary.put_(IfaceDecl): IfaceForeign" - - put_ bh (IfaceData a1 a2 a3 a4 a5 a6 a7 a8 a9) = do - putByte bh 2 - put_ bh (occNameFS a1) - put_ bh a2 - put_ bh a3 - put_ bh a4 - put_ bh a5 - put_ bh a6 - put_ bh a7 - put_ bh a8 - put_ bh a9 - - put_ bh (IfaceSyn a1 a2 a3 a4) = do - putByte bh 3 - put_ bh (occNameFS a1) - put_ bh a2 - put_ bh a3 - put_ bh a4 - - put_ bh (IfaceClass a1 a2 a3 a4 a5 a6 a7) = do - putByte bh 4 - put_ bh a1 - put_ bh (occNameFS a2) - put_ bh a3 - put_ bh a4 - put_ bh a5 - put_ bh a6 - put_ bh a7 - - put_ bh (IfaceAxiom a1 a2 a3) = do - putByte bh 5 - put_ bh (occNameFS a1) - put_ bh a2 - put_ bh a3 - - get bh = do - h <- getByte bh - case h of - 0 -> do name <- get bh - ty <- get bh - details <- get bh - idinfo <- get bh - occ <- return $! mkOccNameFS varName name - return (IfaceId occ ty details idinfo) - 1 -> error "Binary.get(TyClDecl): ForeignType" - 2 -> do a1 <- get bh - a2 <- get bh - a3 <- get bh - a4 <- get bh - a5 <- get bh - a6 <- get bh - a7 <- get bh - a8 <- get bh - a9 <- get bh - occ <- return $! mkOccNameFS tcName a1 - return (IfaceData occ a2 a3 a4 a5 a6 a7 a8 a9) - 3 -> do a1 <- get bh - a2 <- get bh - a3 <- get bh - a4 <- get bh - occ <- return $! mkOccNameFS tcName a1 - return (IfaceSyn occ a2 a3 a4) - 4 -> do a1 <- get bh - a2 <- get bh - a3 <- get bh - a4 <- get bh - a5 <- get bh - a6 <- get bh - a7 <- get bh - occ <- return $! mkOccNameFS clsName a2 - return (IfaceClass a1 occ a3 a4 a5 a6 a7) - _ -> do a1 <- get bh - a2 <- get bh - a3 <- get bh - occ <- return $! mkOccNameFS tcName a1 - return (IfaceAxiom occ a2 a3) - -instance Binary IfaceAxBranch where - put_ bh (IfaceAxBranch a1 a2 a3 a4) = do - put_ bh a1 - put_ bh a2 - put_ bh a3 - put_ bh a4 - get bh = do - a1 <- get bh - a2 <- get bh - a3 <- get bh - a4 <- get bh - return (IfaceAxBranch a1 a2 a3 a4) - -instance Binary IfaceSynTyConRhs where - put_ bh IfaceOpenSynFamilyTyCon = putByte bh 0 - put_ bh (IfaceClosedSynFamilyTyCon ax) = putByte bh 1 >> put_ bh ax - put_ bh (IfaceSynonymTyCon ty) = putByte bh 2 >> put_ bh ty - - get bh = do { h <- getByte bh - ; case h of - 0 -> do { return IfaceOpenSynFamilyTyCon } - 1 -> do { ax <- get bh - ; return (IfaceClosedSynFamilyTyCon ax) } - _ -> do { ty <- get bh - ; return (IfaceSynonymTyCon ty) } } - -instance Binary IfaceClsInst where - put_ bh (IfaceClsInst cls tys dfun flag orph) = do - put_ bh cls - put_ bh tys - put_ bh dfun - put_ bh flag - put_ bh orph - get bh = do - cls <- get bh - tys <- get bh - dfun <- get bh - flag <- get bh - orph <- get bh - return (IfaceClsInst cls tys dfun flag orph) - -instance Binary IfaceFamInst where - put_ bh (IfaceFamInst fam tys name orph) = do - put_ bh fam - put_ bh tys - put_ bh name - put_ bh orph - get bh = do - fam <- get bh - tys <- get bh - name <- get bh - orph <- get bh - return (IfaceFamInst fam tys name orph) - -instance Binary OverlapFlag where - put_ bh (NoOverlap b) = putByte bh 0 >> put_ bh b - put_ bh (OverlapOk b) = putByte bh 1 >> put_ bh b - put_ bh (Incoherent b) = putByte bh 2 >> put_ bh b - get bh = do - h <- getByte bh - b <- get bh - case h of - 0 -> return $ NoOverlap b - 1 -> return $ OverlapOk b - 2 -> return $ Incoherent b - _ -> panic ("get OverlapFlag " ++ show h) - -instance Binary IfaceConDecls where - put_ bh (IfAbstractTyCon d) = putByte bh 0 >> put_ bh d - put_ bh IfDataFamTyCon = putByte bh 1 - put_ bh (IfDataTyCon cs) = putByte bh 2 >> put_ bh cs - put_ bh (IfNewTyCon c) = putByte bh 3 >> put_ bh c - get bh = do - h <- getByte bh - case h of - 0 -> get bh >>= (return . IfAbstractTyCon) - 1 -> return IfDataFamTyCon - 2 -> get bh >>= (return . IfDataTyCon) - _ -> get bh >>= (return . IfNewTyCon) - -instance Binary IfaceConDecl where - put_ bh (IfCon a1 a2 a3 a4 a5 a6 a7 a8 a9 a10) = do - put_ bh a1 - put_ bh a2 - put_ bh a3 - put_ bh a4 - put_ bh a5 - put_ bh a6 - put_ bh a7 - put_ bh a8 - put_ bh a9 - put_ bh a10 - get bh = do - a1 <- get bh - a2 <- get bh - a3 <- get bh - a4 <- get bh - a5 <- get bh - a6 <- get bh - a7 <- get bh - a8 <- get bh - a9 <- get bh - a10 <- get bh - return (IfCon a1 a2 a3 a4 a5 a6 a7 a8 a9 a10) - -instance Binary IfaceAT where - put_ bh (IfaceAT dec defs) = do - put_ bh dec - put_ bh defs - get bh = do - dec <- get bh - defs <- get bh - return (IfaceAT dec defs) - -instance Binary IfaceClassOp where - put_ bh (IfaceClassOp n def ty) = do - put_ bh (occNameFS n) - put_ bh def - put_ bh ty - get bh = do - n <- get bh - def <- get bh - ty <- get bh - occ <- return $! mkOccNameFS varName n - return (IfaceClassOp occ def ty) - -instance Binary IfaceRule where - put_ bh (IfaceRule a1 a2 a3 a4 a5 a6 a7 a8) = do - put_ bh a1 - put_ bh a2 - put_ bh a3 - put_ bh a4 - put_ bh a5 - put_ bh a6 - put_ bh a7 - put_ bh a8 - get bh = do - a1 <- get bh - a2 <- get bh - a3 <- get bh - a4 <- get bh - a5 <- get bh - a6 <- get bh - a7 <- get bh - a8 <- get bh - return (IfaceRule a1 a2 a3 a4 a5 a6 a7 a8) - -instance Binary IfaceAnnotation where - put_ bh (IfaceAnnotation a1 a2) = do - put_ bh a1 - put_ bh a2 - get bh = do - a1 <- get bh - a2 <- get bh - return (IfaceAnnotation a1 a2) - -instance Binary name => Binary (AnnTarget name) where - put_ bh (NamedTarget a) = do - putByte bh 0 - put_ bh a - put_ bh (ModuleTarget a) = do - putByte bh 1 - put_ bh a - get bh = do - h <- getByte bh - case h of - 0 -> get bh >>= (return . NamedTarget) - _ -> get bh >>= (return . ModuleTarget) - -instance Binary IfaceVectInfo where - put_ bh (IfaceVectInfo a1 a2 a3 a4 a5) = do - put_ bh a1 - put_ bh a2 - put_ bh a3 - put_ bh a4 - put_ bh a5 - get bh = do - a1 <- get bh - a2 <- get bh - a3 <- get bh - a4 <- get bh - a5 <- get bh - return (IfaceVectInfo a1 a2 a3 a4 a5) - -instance Binary IfaceTrustInfo where - put_ bh iftrust = putByte bh $ trustInfoToNum iftrust - get bh = getByte bh >>= (return . numToTrustInfo) - diff --git a/compiler/iface/IfaceSyn.lhs b/compiler/iface/IfaceSyn.lhs index ad327d6428..0150d216b2 100644 --- a/compiler/iface/IfaceSyn.lhs +++ b/compiler/iface/IfaceSyn.lhs @@ -112,20 +112,148 @@ data IfaceDecl -- beyond .NET ifExtName :: Maybe FastString } +-- A bit of magic going on here: there's no need to store the OccName +-- for a decl on the disk, since we can infer the namespace from the +-- context; however it is useful to have the OccName in the IfaceDecl +-- to avoid re-building it in various places. So we build the OccName +-- when de-serialising. + +instance Binary IfaceDecl where + put_ bh (IfaceId name ty details idinfo) = do + putByte bh 0 + put_ bh (occNameFS name) + put_ bh ty + put_ bh details + put_ bh idinfo + + put_ _ (IfaceForeign _ _) = + error "Binary.put_(IfaceDecl): IfaceForeign" + + put_ bh (IfaceData a1 a2 a3 a4 a5 a6 a7 a8 a9) = do + putByte bh 2 + put_ bh (occNameFS a1) + put_ bh a2 + put_ bh a3 + put_ bh a4 + put_ bh a5 + put_ bh a6 + put_ bh a7 + put_ bh a8 + put_ bh a9 + + put_ bh (IfaceSyn a1 a2 a3 a4) = do + putByte bh 3 + put_ bh (occNameFS a1) + put_ bh a2 + put_ bh a3 + put_ bh a4 + + put_ bh (IfaceClass a1 a2 a3 a4 a5 a6 a7) = do + putByte bh 4 + put_ bh a1 + put_ bh (occNameFS a2) + put_ bh a3 + put_ bh a4 + put_ bh a5 + put_ bh a6 + put_ bh a7 + + put_ bh (IfaceAxiom a1 a2 a3) = do + putByte bh 5 + put_ bh (occNameFS a1) + put_ bh a2 + put_ bh a3 + + get bh = do + h <- getByte bh + case h of + 0 -> do name <- get bh + ty <- get bh + details <- get bh + idinfo <- get bh + occ <- return $! mkOccNameFS varName name + return (IfaceId occ ty details idinfo) + 1 -> error "Binary.get(TyClDecl): ForeignType" + 2 -> do a1 <- get bh + a2 <- get bh + a3 <- get bh + a4 <- get bh + a5 <- get bh + a6 <- get bh + a7 <- get bh + a8 <- get bh + a9 <- get bh + occ <- return $! mkOccNameFS tcName a1 + return (IfaceData occ a2 a3 a4 a5 a6 a7 a8 a9) + 3 -> do a1 <- get bh + a2 <- get bh + a3 <- get bh + a4 <- get bh + occ <- return $! mkOccNameFS tcName a1 + return (IfaceSyn occ a2 a3 a4) + 4 -> do a1 <- get bh + a2 <- get bh + a3 <- get bh + a4 <- get bh + a5 <- get bh + a6 <- get bh + a7 <- get bh + occ <- return $! mkOccNameFS clsName a2 + return (IfaceClass a1 occ a3 a4 a5 a6 a7) + _ -> do a1 <- get bh + a2 <- get bh + a3 <- get bh + occ <- return $! mkOccNameFS tcName a1 + return (IfaceAxiom occ a2 a3) + data IfaceSynTyConRhs = IfaceOpenSynFamilyTyCon | IfaceClosedSynFamilyTyCon IfExtName -- name of associated axiom | IfaceSynonymTyCon IfaceType +instance Binary IfaceSynTyConRhs where + put_ bh IfaceOpenSynFamilyTyCon = putByte bh 0 + put_ bh (IfaceClosedSynFamilyTyCon ax) = putByte bh 1 >> put_ bh ax + put_ bh (IfaceSynonymTyCon ty) = putByte bh 2 >> put_ bh ty + + get bh = do { h <- getByte bh + ; case h of + 0 -> do { return IfaceOpenSynFamilyTyCon } + 1 -> do { ax <- get bh + ; return (IfaceClosedSynFamilyTyCon ax) } + _ -> do { ty <- get bh + ; return (IfaceSynonymTyCon ty) } } + data IfaceClassOp = IfaceClassOp OccName DefMethSpec IfaceType -- Nothing => no default method -- Just False => ordinary polymorphic default method -- Just True => generic default method +instance Binary IfaceClassOp where + put_ bh (IfaceClassOp n def ty) = do + put_ bh (occNameFS n) + put_ bh def + put_ bh ty + get bh = do + n <- get bh + def <- get bh + ty <- get bh + occ <- return $! mkOccNameFS varName n + return (IfaceClassOp occ def ty) + data IfaceAT = IfaceAT IfaceDecl [IfaceAxBranch] -- Nothing => no default associated type instance -- Just ds => default associated type instance from these templates +instance Binary IfaceAT where + put_ bh (IfaceAT dec defs) = do + put_ bh dec + put_ bh defs + get bh = do + dec <- get bh + defs <- get bh + return (IfaceAT dec defs) + instance Outputable IfaceAxBranch where ppr = pprAxBranch Nothing @@ -157,12 +285,38 @@ data IfaceAxBranch = IfaceAxBranch { ifaxbTyVars :: [IfaceTvBndr] , ifaxbIncomps :: [BranchIndex] } -- See Note [Storing compatibility] in CoAxiom +instance Binary IfaceAxBranch where + put_ bh (IfaceAxBranch a1 a2 a3 a4) = do + put_ bh a1 + put_ bh a2 + put_ bh a3 + put_ bh a4 + get bh = do + a1 <- get bh + a2 <- get bh + a3 <- get bh + a4 <- get bh + return (IfaceAxBranch a1 a2 a3 a4) + data IfaceConDecls = IfAbstractTyCon Bool -- c.f TyCon.AbstractTyCon | IfDataFamTyCon -- Data family | IfDataTyCon [IfaceConDecl] -- Data type decls | IfNewTyCon IfaceConDecl -- Newtype decls +instance Binary IfaceConDecls where + put_ bh (IfAbstractTyCon d) = putByte bh 0 >> put_ bh d + put_ bh IfDataFamTyCon = putByte bh 1 + put_ bh (IfDataTyCon cs) = putByte bh 2 >> put_ bh cs + put_ bh (IfNewTyCon c) = putByte bh 3 >> put_ bh c + get bh = do + h <- getByte bh + case h of + 0 -> get bh >>= (return . IfAbstractTyCon) + 1 -> return IfDataFamTyCon + 2 -> get bh >>= (return . IfDataTyCon) + _ -> get bh >>= (return . IfNewTyCon) + visibleIfConDecls :: IfaceConDecls -> [IfaceConDecl] visibleIfConDecls (IfAbstractTyCon {}) = [] visibleIfConDecls IfDataFamTyCon = [] @@ -183,9 +337,48 @@ data IfaceConDecl ifConStricts :: [IfaceBang]} -- Empty (meaning all lazy), -- or 1-1 corresp with arg tys +instance Binary IfaceConDecl where + put_ bh (IfCon a1 a2 a3 a4 a5 a6 a7 a8 a9 a10) = do + put_ bh a1 + put_ bh a2 + put_ bh a3 + put_ bh a4 + put_ bh a5 + put_ bh a6 + put_ bh a7 + put_ bh a8 + put_ bh a9 + put_ bh a10 + get bh = do + a1 <- get bh + a2 <- get bh + a3 <- get bh + a4 <- get bh + a5 <- get bh + a6 <- get bh + a7 <- get bh + a8 <- get bh + a9 <- get bh + a10 <- get bh + return (IfCon a1 a2 a3 a4 a5 a6 a7 a8 a9 a10) + data IfaceBang = IfNoBang | IfStrict | IfUnpack | IfUnpackCo IfaceCoercion +instance Binary IfaceBang where + put_ bh IfNoBang = putByte bh 0 + put_ bh IfStrict = putByte bh 1 + put_ bh IfUnpack = putByte bh 2 + put_ bh (IfUnpackCo co) = putByte bh 3 >> put_ bh co + + get bh = do + h <- getByte bh + case h of + 0 -> do return IfNoBang + 1 -> do return IfStrict + 2 -> do return IfUnpack + _ -> do { a <- get bh; return (IfUnpackCo a) } + data IfaceClsInst = IfaceClsInst { ifInstCls :: IfExtName, -- See comments with ifInstTys :: [Maybe IfaceTyCon], -- the defn of ClsInst @@ -199,6 +392,21 @@ data IfaceClsInst -- If this instance decl is *used*, we'll record a usage on the dfun; -- and if the head does not change it won't be used if it wasn't before +instance Binary IfaceClsInst where + put_ bh (IfaceClsInst cls tys dfun flag orph) = do + put_ bh cls + put_ bh tys + put_ bh dfun + put_ bh flag + put_ bh orph + get bh = do + cls <- get bh + tys <- get bh + dfun <- get bh + flag <- get bh + orph <- get bh + return (IfaceClsInst cls tys dfun flag orph) + -- The ifFamInstTys field of IfaceFamInst contains a list of the rough -- match types data IfaceFamInst @@ -208,6 +416,19 @@ data IfaceFamInst , ifFamInstOrph :: Maybe OccName -- Just like IfaceClsInst } +instance Binary IfaceFamInst where + put_ bh (IfaceFamInst fam tys name orph) = do + put_ bh fam + put_ bh tys + put_ bh name + put_ bh orph + get bh = do + fam <- get bh + tys <- get bh + name <- get bh + orph <- get bh + return (IfaceFamInst fam tys name orph) + data IfaceRule = IfaceRule { ifRuleName :: RuleName, @@ -220,12 +441,42 @@ data IfaceRule ifRuleOrph :: Maybe OccName -- Just like IfaceClsInst } +instance Binary IfaceRule where + put_ bh (IfaceRule a1 a2 a3 a4 a5 a6 a7 a8) = do + put_ bh a1 + put_ bh a2 + put_ bh a3 + put_ bh a4 + put_ bh a5 + put_ bh a6 + put_ bh a7 + put_ bh a8 + get bh = do + a1 <- get bh + a2 <- get bh + a3 <- get bh + a4 <- get bh + a5 <- get bh + a6 <- get bh + a7 <- get bh + a8 <- get bh + return (IfaceRule a1 a2 a3 a4 a5 a6 a7 a8) + data IfaceAnnotation = IfaceAnnotation { ifAnnotatedTarget :: IfaceAnnTarget, ifAnnotatedValue :: Serialized } +instance Binary IfaceAnnotation where + put_ bh (IfaceAnnotation a1 a2) = do + put_ bh a1 + put_ bh a2 + get bh = do + a1 <- get bh + a2 <- get bh + return (IfaceAnnotation a1 a2) + type IfaceAnnTarget = AnnTarget OccName -- We only serialise the IdDetails of top-level Ids, and even then @@ -238,10 +489,31 @@ data IfaceIdDetails | IfRecSelId IfaceTyCon Bool | IfDFunId Int -- Number of silent args +instance Binary IfaceIdDetails where + put_ bh IfVanillaId = putByte bh 0 + put_ bh (IfRecSelId a b) = putByte bh 1 >> put_ bh a >> put_ bh b + put_ bh (IfDFunId n) = do { putByte bh 2; put_ bh n } + get bh = do + h <- getByte bh + case h of + 0 -> return IfVanillaId + 1 -> do { a <- get bh; b <- get bh; return (IfRecSelId a b) } + _ -> do { n <- get bh; return (IfDFunId n) } + data IfaceIdInfo = NoInfo -- When writing interface file without -O | HasInfo [IfaceInfoItem] -- Has info, and here it is +instance Binary IfaceIdInfo where + put_ bh NoInfo = putByte bh 0 + put_ bh (HasInfo i) = putByte bh 1 >> lazyPut bh i -- NB lazyPut + + get bh = do + h <- getByte bh + case h of + 0 -> return NoInfo + _ -> lazyGet bh >>= (return . HasInfo) -- NB lazyGet + -- Here's a tricky case: -- * Compile with -O module A, and B which imports A.f -- * Change function f in A, and recompile without -O @@ -260,6 +532,23 @@ data IfaceInfoItem IfaceUnfolding -- See Note [Expose recursive functions] | HsNoCafRefs +instance Binary IfaceInfoItem where + put_ bh (HsArity aa) = putByte bh 0 >> put_ bh aa + put_ bh (HsStrictness ab) = putByte bh 1 >> put_ bh ab + put_ bh (HsUnfold lb ad) = putByte bh 2 >> put_ bh lb >> put_ bh ad + put_ bh (HsInline ad) = putByte bh 3 >> put_ bh ad + put_ bh HsNoCafRefs = putByte bh 4 + get bh = do + h <- getByte bh + case h of + 0 -> get bh >>= (return . HsArity) + 1 -> get bh >>= (return . HsStrictness) + 2 -> do lb <- get bh + ad <- get bh + return (HsUnfold lb ad) + 3 -> get bh >>= (return . HsInline) + _ -> return HsNoCafRefs + -- NB: Specialisations and rules come in separately and are -- only later attached to the Id. Partial reason: some are orphans. @@ -281,6 +570,55 @@ data IfaceUnfolding | IfDFunUnfold [IfaceBndr] [IfaceExpr] +instance Binary IfaceUnfolding where + put_ bh (IfCoreUnfold s e) = do + putByte bh 0 + put_ bh s + put_ bh e + put_ bh (IfInlineRule a b c d) = do + putByte bh 1 + put_ bh a + put_ bh b + put_ bh c + put_ bh d + put_ bh (IfLclWrapper a n) = do + putByte bh 2 + put_ bh a + put_ bh n + put_ bh (IfExtWrapper a n) = do + putByte bh 3 + put_ bh a + put_ bh n + put_ bh (IfDFunUnfold as bs) = do + putByte bh 4 + put_ bh as + put_ bh bs + put_ bh (IfCompulsory e) = do + putByte bh 5 + put_ bh e + get bh = do + h <- getByte bh + case h of + 0 -> do s <- get bh + e <- get bh + return (IfCoreUnfold s e) + 1 -> do a <- get bh + b <- get bh + c <- get bh + d <- get bh + return (IfInlineRule a b c d) + 2 -> do a <- get bh + n <- get bh + return (IfLclWrapper a n) + 3 -> do a <- get bh + n <- get bh + return (IfExtWrapper a n) + 4 -> do as <- get bh + bs <- get bh + return (IfDFunUnfold as bs) + _ -> do e <- get bh + return (IfCompulsory e) + -------------------------------- data IfaceExpr = IfaceLcl IfLclName @@ -298,11 +636,130 @@ data IfaceExpr | IfaceFCall ForeignCall IfaceType | IfaceTick IfaceTickish IfaceExpr -- from Tick tickish E +instance Binary IfaceExpr where + put_ bh (IfaceLcl aa) = do + putByte bh 0 + put_ bh aa + put_ bh (IfaceType ab) = do + putByte bh 1 + put_ bh ab + put_ bh (IfaceCo ab) = do + putByte bh 2 + put_ bh ab + put_ bh (IfaceTuple ac ad) = do + putByte bh 3 + put_ bh ac + put_ bh ad + put_ bh (IfaceLam ae af) = do + putByte bh 4 + put_ bh ae + put_ bh af + put_ bh (IfaceApp ag ah) = do + putByte bh 5 + put_ bh ag + put_ bh ah + put_ bh (IfaceCase ai aj ak) = do + putByte bh 6 + put_ bh ai + put_ bh aj + put_ bh ak + put_ bh (IfaceLet al am) = do + putByte bh 7 + put_ bh al + put_ bh am + put_ bh (IfaceTick an ao) = do + putByte bh 8 + put_ bh an + put_ bh ao + put_ bh (IfaceLit ap) = do + putByte bh 9 + put_ bh ap + put_ bh (IfaceFCall as at) = do + putByte bh 10 + put_ bh as + put_ bh at + put_ bh (IfaceExt aa) = do + putByte bh 11 + put_ bh aa + put_ bh (IfaceCast ie ico) = do + putByte bh 12 + put_ bh ie + put_ bh ico + put_ bh (IfaceECase a b) = do + putByte bh 13 + put_ bh a + put_ bh b + get bh = do + h <- getByte bh + case h of + 0 -> do aa <- get bh + return (IfaceLcl aa) + 1 -> do ab <- get bh + return (IfaceType ab) + 2 -> do ab <- get bh + return (IfaceCo ab) + 3 -> do ac <- get bh + ad <- get bh + return (IfaceTuple ac ad) + 4 -> do ae <- get bh + af <- get bh + return (IfaceLam ae af) + 5 -> do ag <- get bh + ah <- get bh + return (IfaceApp ag ah) + 6 -> do ai <- get bh + aj <- get bh + ak <- get bh + return (IfaceCase ai aj ak) + 7 -> do al <- get bh + am <- get bh + return (IfaceLet al am) + 8 -> do an <- get bh + ao <- get bh + return (IfaceTick an ao) + 9 -> do ap <- get bh + return (IfaceLit ap) + 10 -> do as <- get bh + at <- get bh + return (IfaceFCall as at) + 11 -> do aa <- get bh + return (IfaceExt aa) + 12 -> do ie <- get bh + ico <- get bh + return (IfaceCast ie ico) + 13 -> do a <- get bh + b <- get bh + return (IfaceECase a b) + _ -> panic ("get IfaceExpr " ++ show h) + data IfaceTickish = IfaceHpcTick Module Int -- from HpcTick x | IfaceSCC CostCentre Bool Bool -- from ProfNote -- no breakpoints: we never export these into interface files +instance Binary IfaceTickish where + put_ bh (IfaceHpcTick m ix) = do + putByte bh 0 + put_ bh m + put_ bh ix + put_ bh (IfaceSCC cc tick push) = do + putByte bh 1 + put_ bh cc + put_ bh tick + put_ bh push + + get bh = do + h <- getByte bh + case h of + 0 -> do m <- get bh + ix <- get bh + return (IfaceHpcTick m ix) + 1 -> do cc <- get bh + tick <- get bh + push <- get bh + return (IfaceSCC cc tick push) + _ -> panic ("get IfaceTickish " ++ show h) + type IfaceAlt = (IfaceConAlt, [IfLclName], IfaceExpr) -- Note: IfLclName, not IfaceBndr (and same with the case binder) -- We reconstruct the kind/type of the thing from the context @@ -312,14 +769,44 @@ data IfaceConAlt = IfaceDefault | IfaceDataAlt IfExtName | IfaceLitAlt Literal +instance Binary IfaceConAlt where + put_ bh IfaceDefault = putByte bh 0 + put_ bh (IfaceDataAlt aa) = putByte bh 1 >> put_ bh aa + put_ bh (IfaceLitAlt ac) = putByte bh 2 >> put_ bh ac + get bh = do + h <- getByte bh + case h of + 0 -> return IfaceDefault + 1 -> get bh >>= (return . IfaceDataAlt) + _ -> get bh >>= (return . IfaceLitAlt) + data IfaceBinding = IfaceNonRec IfaceLetBndr IfaceExpr | IfaceRec [(IfaceLetBndr, IfaceExpr)] +instance Binary IfaceBinding where + put_ bh (IfaceNonRec aa ab) = putByte bh 0 >> put_ bh aa >> put_ bh ab + put_ bh (IfaceRec ac) = putByte bh 1 >> put_ bh ac + get bh = do + h <- getByte bh + case h of + 0 -> do { aa <- get bh; ab <- get bh; return (IfaceNonRec aa ab) } + _ -> do { ac <- get bh; return (IfaceRec ac) } + -- IfaceLetBndr is like IfaceIdBndr, but has IdInfo too -- It's used for *non-top-level* let/rec binders -- See Note [IdInfo on nested let-bindings] data IfaceLetBndr = IfLetBndr IfLclName IfaceType IfaceIdInfo + +instance Binary IfaceLetBndr where + put_ bh (IfLetBndr a b c) = do + put_ bh a + put_ bh b + put_ bh c + get bh = do a <- get bh + b <- get bh + c <- get bh + return (IfLetBndr a b c) \end{code} Note [Empty case alternatives] diff --git a/compiler/iface/IfaceType.lhs b/compiler/iface/IfaceType.lhs index 480eb7e0ba..c3b59b7be8 100644 --- a/compiler/iface/IfaceType.lhs +++ b/compiler/iface/IfaceType.lhs @@ -40,8 +40,11 @@ import TysPrim import PrelNames( funTyConKey ) import Name import BasicTypes +import Binary import Outputable import FastString + +import Control.Monad \end{code} %************************************************************************ @@ -173,6 +176,21 @@ pprIfaceTvBndr (tv, kind) = parens (ppr tv <> dcolon <> ppr kind) pprIfaceTvBndrs :: [IfaceTvBndr] -> SDoc pprIfaceTvBndrs tyvars = sep (map pprIfaceTvBndr tyvars) + +instance Binary IfaceBndr where + put_ bh (IfaceIdBndr aa) = do + putByte bh 0 + put_ bh aa + put_ bh (IfaceTvBndr ab) = do + putByte bh 1 + put_ bh ab + get bh = do + h <- getByte bh + case h of + 0 -> do aa <- get bh + return (IfaceIdBndr aa) + _ -> do ab <- get bh + return (IfaceTvBndr ab) \end{code} ----------------------------- Printing IfaceType ------------------------------------ @@ -264,6 +282,10 @@ ppr_tylit (IfaceStrTyLit n) = text (show n) instance Outputable IfaceTyCon where ppr = ppr . ifaceTyConName +instance Binary IfaceTyCon where + put_ bh (IfaceTc ext) = put_ bh ext + get bh = liftM IfaceTc (get bh) + instance Outputable IfaceCoCon where ppr (IfaceCoAx n i) = ppr n <> brackets (ppr i) ppr IfaceReflCo = ptext (sLit "Refl") @@ -274,9 +296,45 @@ instance Outputable IfaceCoCon where ppr (IfaceNthCo d) = ptext (sLit "Nth:") <> int d ppr (IfaceLRCo lr) = ppr lr +instance Binary IfaceCoCon where + put_ bh (IfaceCoAx n ind) = do { putByte bh 0; put_ bh n; put_ bh ind } + put_ bh IfaceReflCo = putByte bh 1 + put_ bh IfaceUnsafeCo = putByte bh 2 + put_ bh IfaceSymCo = putByte bh 3 + put_ bh IfaceTransCo = putByte bh 4 + put_ bh IfaceInstCo = putByte bh 5 + put_ bh (IfaceNthCo d) = do { putByte bh 6; put_ bh d } + put_ bh (IfaceLRCo lr) = do { putByte bh 7; put_ bh lr } + + get bh = do + h <- getByte bh + case h of + 0 -> do { n <- get bh; ind <- get bh; return (IfaceCoAx n ind) } + 1 -> return IfaceReflCo + 2 -> return IfaceUnsafeCo + 3 -> return IfaceSymCo + 4 -> return IfaceTransCo + 5 -> return IfaceInstCo + 6 -> do { d <- get bh; return (IfaceNthCo d) } + 7 -> do { lr <- get bh; return (IfaceLRCo lr) } + _ -> panic ("get IfaceCoCon " ++ show h) + instance Outputable IfaceTyLit where ppr = ppr_tylit +instance Binary IfaceTyLit where + put_ bh (IfaceNumTyLit n) = putByte bh 1 >> put_ bh n + put_ bh (IfaceStrTyLit n) = putByte bh 2 >> put_ bh n + + get bh = + do tag <- getByte bh + case tag of + 1 -> do { n <- get bh + ; return (IfaceNumTyLit n) } + 2 -> do { n <- get bh + ; return (IfaceStrTyLit n) } + _ -> panic ("get IfaceTyLit " ++ show tag) + ------------------- pprIfaceContext :: IfaceContext -> SDoc -- Prints "(C a, D b) =>", including the arrow @@ -286,6 +344,54 @@ pprIfaceContext theta = ppr_preds theta <+> darrow ppr_preds :: [IfacePredType] -> SDoc ppr_preds [pred] = ppr pred -- No parens ppr_preds preds = parens (sep (punctuate comma (map ppr preds))) + +instance Binary IfaceType where + put_ bh (IfaceForAllTy aa ab) = do + putByte bh 0 + put_ bh aa + put_ bh ab + put_ bh (IfaceTyVar ad) = do + putByte bh 1 + put_ bh ad + put_ bh (IfaceAppTy ae af) = do + putByte bh 2 + put_ bh ae + put_ bh af + put_ bh (IfaceFunTy ag ah) = do + putByte bh 3 + put_ bh ag + put_ bh ah + put_ bh (IfaceCoConApp cc tys) + = do { putByte bh 4; put_ bh cc; put_ bh tys } + put_ bh (IfaceTyConApp tc tys) + = do { putByte bh 5; put_ bh tc; put_ bh tys } + + put_ bh (IfaceLitTy n) + = do { putByte bh 30; put_ bh n } + + get bh = do + h <- getByte bh + case h of + 0 -> do aa <- get bh + ab <- get bh + return (IfaceForAllTy aa ab) + 1 -> do ad <- get bh + return (IfaceTyVar ad) + 2 -> do ae <- get bh + af <- get bh + return (IfaceAppTy ae af) + 3 -> do ag <- get bh + ah <- get bh + return (IfaceFunTy ag ah) + 4 -> do { cc <- get bh; tys <- get bh + ; return (IfaceCoConApp cc tys) } + 5 -> do { tc <- get bh; tys <- get bh + ; return (IfaceTyConApp tc tys) } + + 30 -> do n <- get bh + return (IfaceLitTy n) + + _ -> panic ("get IfaceType " ++ show h) \end{code} %************************************************************************ diff --git a/compiler/main/Annotations.hs b/compiler/main/Annotations.hs index 277c059b11..ec179d86e2 100644 --- a/compiler/main/Annotations.hs +++ b/compiler/main/Annotations.hs @@ -16,6 +16,7 @@ module Annotations ( deserializeAnns ) where +import Binary import Module ( Module ) import Name import Outputable @@ -64,6 +65,19 @@ instance Outputable name => Outputable (AnnTarget name) where ppr (NamedTarget nm) = text "Named target" <+> ppr nm ppr (ModuleTarget mod) = text "Module target" <+> ppr mod +instance Binary name => Binary (AnnTarget name) where + put_ bh (NamedTarget a) = do + putByte bh 0 + put_ bh a + put_ bh (ModuleTarget a) = do + putByte bh 1 + put_ bh a + get bh = do + h <- getByte bh + case h of + 0 -> get bh >>= (return . NamedTarget) + _ -> get bh >>= (return . ModuleTarget) + instance Outputable Annotation where ppr ann = ppr (ann_target ann) diff --git a/compiler/main/HscTypes.lhs b/compiler/main/HscTypes.lhs index 163af051e8..e022ae3eae 100644 --- a/compiler/main/HscTypes.lhs +++ b/compiler/main/HscTypes.lhs @@ -159,6 +159,7 @@ import StringBuffer ( StringBuffer ) import Fingerprint import MonadUtils import Bag +import Binary import ErrUtils import Platform import Util @@ -717,6 +718,113 @@ data ModIface -- See Note [RnNames . Trust Own Package] } +instance Binary ModIface where + put_ bh (ModIface { + mi_module = mod, + mi_boot = is_boot, + mi_iface_hash= iface_hash, + mi_mod_hash = mod_hash, + mi_flag_hash = flag_hash, + mi_orphan = orphan, + mi_finsts = hasFamInsts, + mi_deps = deps, + mi_usages = usages, + mi_exports = exports, + mi_exp_hash = exp_hash, + mi_used_th = used_th, + mi_fixities = fixities, + mi_warns = warns, + mi_anns = anns, + mi_decls = decls, + mi_insts = insts, + mi_fam_insts = fam_insts, + mi_rules = rules, + mi_orphan_hash = orphan_hash, + mi_vect_info = vect_info, + mi_hpc = hpc_info, + mi_trust = trust, + mi_trust_pkg = trust_pkg }) = do + put_ bh mod + put_ bh is_boot + put_ bh iface_hash + put_ bh mod_hash + put_ bh flag_hash + put_ bh orphan + put_ bh hasFamInsts + lazyPut bh deps + lazyPut bh usages + put_ bh exports + put_ bh exp_hash + put_ bh used_th + put_ bh fixities + lazyPut bh warns + lazyPut bh anns + put_ bh decls + put_ bh insts + put_ bh fam_insts + lazyPut bh rules + put_ bh orphan_hash + put_ bh vect_info + put_ bh hpc_info + put_ bh trust + put_ bh trust_pkg + + get bh = do + mod_name <- get bh + is_boot <- get bh + iface_hash <- get bh + mod_hash <- get bh + flag_hash <- get bh + orphan <- get bh + hasFamInsts <- get bh + deps <- lazyGet bh + usages <- {-# SCC "bin_usages" #-} lazyGet bh + exports <- {-# SCC "bin_exports" #-} get bh + exp_hash <- get bh + used_th <- get bh + fixities <- {-# SCC "bin_fixities" #-} get bh + warns <- {-# SCC "bin_warns" #-} lazyGet bh + anns <- {-# SCC "bin_anns" #-} lazyGet bh + decls <- {-# SCC "bin_tycldecls" #-} get bh + insts <- {-# SCC "bin_insts" #-} get bh + fam_insts <- {-# SCC "bin_fam_insts" #-} get bh + rules <- {-# SCC "bin_rules" #-} lazyGet bh + orphan_hash <- get bh + vect_info <- get bh + hpc_info <- get bh + trust <- get bh + trust_pkg <- get bh + return (ModIface { + mi_module = mod_name, + mi_boot = is_boot, + mi_iface_hash = iface_hash, + mi_mod_hash = mod_hash, + mi_flag_hash = flag_hash, + mi_orphan = orphan, + mi_finsts = hasFamInsts, + mi_deps = deps, + mi_usages = usages, + mi_exports = exports, + mi_exp_hash = exp_hash, + mi_used_th = used_th, + mi_anns = anns, + mi_fixities = fixities, + mi_warns = warns, + mi_decls = decls, + mi_globals = Nothing, + mi_insts = insts, + mi_fam_insts = fam_insts, + mi_rules = rules, + mi_orphan_hash = orphan_hash, + mi_vect_info = vect_info, + mi_hpc = hpc_info, + mi_trust = trust, + mi_trust_pkg = trust_pkg, + -- And build the cached values + mi_warn_fn = mkIfaceWarnCache warns, + mi_fix_fn = mkIfaceFixCache fixities, + mi_hash_fn = mkIfaceHashCache decls }) + -- | The original names declared of a certain module that are exported type IfaceExport = AvailInfo @@ -1527,6 +1635,24 @@ data Warnings -- a Name to its fixity declaration. deriving( Eq ) +instance Binary Warnings where + put_ bh NoWarnings = putByte bh 0 + put_ bh (WarnAll t) = do + putByte bh 1 + put_ bh t + put_ bh (WarnSome ts) = do + putByte bh 2 + put_ bh ts + + get bh = do + h <- getByte bh + case h of + 0 -> return NoWarnings + 1 -> do aa <- get bh + return (WarnAll aa) + _ -> do aa <- get bh + return (WarnSome aa) + -- | Constructs the cache for the 'mi_warn_fn' field of a 'ModIface' mkIfaceWarnCache :: Warnings -> Name -> Maybe WarningTxt mkIfaceWarnCache NoWarnings = \_ -> Nothing @@ -1625,6 +1751,19 @@ data Dependencies -- Equality used only for old/new comparison in MkIface.addFingerprints -- See 'TcRnTypes.ImportAvails' for details on dependencies. +instance Binary Dependencies where + put_ bh deps = do put_ bh (dep_mods deps) + put_ bh (dep_pkgs deps) + put_ bh (dep_orphs deps) + put_ bh (dep_finsts deps) + + get bh = do ms <- get bh + ps <- get bh + os <- get bh + fis <- get bh + return (Deps { dep_mods = ms, dep_pkgs = ps, dep_orphs = os, + dep_finsts = fis }) + noDependencies :: Dependencies noDependencies = Deps [] [] [] [] @@ -1673,6 +1812,49 @@ data Usage -- import M() -- And of course, for modules that aren't imported directly we don't -- depend on their export lists + +instance Binary Usage where + put_ bh usg@UsagePackageModule{} = do + putByte bh 0 + put_ bh (usg_mod usg) + put_ bh (usg_mod_hash usg) + put_ bh (usg_safe usg) + + put_ bh usg@UsageHomeModule{} = do + putByte bh 1 + put_ bh (usg_mod_name usg) + put_ bh (usg_mod_hash usg) + put_ bh (usg_exports usg) + put_ bh (usg_entities usg) + put_ bh (usg_safe usg) + + put_ bh usg@UsageFile{} = do + putByte bh 2 + put_ bh (usg_file_path usg) + put_ bh (usg_mtime usg) + + get bh = do + h <- getByte bh + case h of + 0 -> do + nm <- get bh + mod <- get bh + safe <- get bh + return UsagePackageModule { usg_mod = nm, usg_mod_hash = mod, usg_safe = safe } + 1 -> do + nm <- get bh + mod <- get bh + exps <- get bh + ents <- get bh + safe <- get bh + return UsageHomeModule { usg_mod_name = nm, usg_mod_hash = mod, + usg_exports = exps, usg_entities = ents, usg_safe = safe } + 2 -> do + fp <- get bh + mtime <- get bh + return UsageFile { usg_file_path = fp, usg_mtime = mtime } + i -> error ("Binary.get(Usage): " ++ show i) + \end{code} @@ -2060,6 +2242,21 @@ instance Outputable VectInfo where , ptext (sLit "parallel vars :") <+> ppr (vectInfoParallelVars info) , ptext (sLit "parallel tycons :") <+> ppr (vectInfoParallelTyCons info) ] + +instance Binary IfaceVectInfo where + put_ bh (IfaceVectInfo a1 a2 a3 a4 a5) = do + put_ bh a1 + put_ bh a2 + put_ bh a3 + put_ bh a4 + put_ bh a5 + get bh = do + a1 <- get bh + a2 <- get bh + a3 <- get bh + a4 <- get bh + a5 <- get bh + return (IfaceVectInfo a1 a2 a3 a4 a5) \end{code} %************************************************************************ @@ -2111,6 +2308,10 @@ instance Outputable IfaceTrustInfo where ppr (TrustInfo Sf_Trustworthy) = ptext $ sLit "trustworthy" ppr (TrustInfo Sf_Safe) = ptext $ sLit "safe" ppr (TrustInfo Sf_SafeInferred) = ptext $ sLit "safe-inferred" + +instance Binary IfaceTrustInfo where + put_ bh iftrust = putByte bh $ trustInfoToNum iftrust + get bh = getByte bh >>= (return . numToTrustInfo) \end{code} %************************************************************************ diff --git a/compiler/profiling/CostCentre.lhs b/compiler/profiling/CostCentre.lhs index 8d9c269305..7e6959baaa 100644 --- a/compiler/profiling/CostCentre.lhs +++ b/compiler/profiling/CostCentre.lhs @@ -29,6 +29,7 @@ module CostCentre ( cmpCostCentre -- used for removing dups in a list ) where +import Binary import Var import Name import Module @@ -294,4 +295,42 @@ costCentreUserNameFS (NormalCC {cc_name = name, cc_is_caf = is_caf}) costCentreSrcSpan :: CostCentre -> SrcSpan costCentreSrcSpan = cc_loc + +instance Binary IsCafCC where + put_ bh CafCC = do + putByte bh 0 + put_ bh NotCafCC = do + putByte bh 1 + get bh = do + h <- getByte bh + case h of + 0 -> do return CafCC + _ -> do return NotCafCC + +instance Binary CostCentre where + put_ bh (NormalCC aa ab ac _ad ae) = do + putByte bh 0 + put_ bh aa + put_ bh ab + put_ bh ac + put_ bh ae + put_ bh (AllCafsCC ae _af) = do + putByte bh 1 + put_ bh ae + get bh = do + h <- getByte bh + case h of + 0 -> do aa <- get bh + ab <- get bh + ac <- get bh + ae <- get bh + return (NormalCC aa ab ac noSrcSpan ae) + _ -> do ae <- get bh + return (AllCafsCC ae noSrcSpan) + + -- We ignore the SrcSpans in CostCentres when we serialise them, + -- and set the SrcSpans to noSrcSpan when deserialising. This is + -- ok, because we only need the SrcSpan when declaring the + -- CostCentre in the original module, it is not used by importing + -- modules. \end{code} diff --git a/compiler/types/Coercion.lhs b/compiler/types/Coercion.lhs index e1dec49380..0c85667e2f 100644 --- a/compiler/types/Coercion.lhs +++ b/compiler/types/Coercion.lhs @@ -91,6 +91,7 @@ import CoAxiom import Var import VarEnv import VarSet +import Binary import Maybes ( orElse ) import Name ( Name, NamedThing(..), nameUnique, nameModule, getSrcSpan ) import OccName ( parenSymOcc ) @@ -170,6 +171,15 @@ data Coercion data LeftOrRight = CLeft | CRight deriving( Eq, Data.Data, Data.Typeable ) +instance Binary LeftOrRight where + put_ bh CLeft = putByte bh 0 + put_ bh CRight = putByte bh 1 + + get bh = do { h <- getByte bh + ; case h of + 0 -> return CLeft + _ -> return CRight } + pickLR :: LeftOrRight -> (a,a) -> a pickLR CLeft (l,_) = l pickLR CRight (_,r) = r diff --git a/compiler/utils/Binary.hs b/compiler/utils/Binary.hs index e07577776a..d14c326d34 100644 --- a/compiler/utils/Binary.hs +++ b/compiler/utils/Binary.hs @@ -784,3 +784,144 @@ instance Binary FunctionOrData where 1 -> return IsData _ -> panic "Binary FunctionOrData" +instance Binary TupleSort where + put_ bh BoxedTuple = putByte bh 0 + put_ bh UnboxedTuple = putByte bh 1 + put_ bh ConstraintTuple = putByte bh 2 + get bh = do + h <- getByte bh + case h of + 0 -> do return BoxedTuple + 1 -> do return UnboxedTuple + _ -> do return ConstraintTuple + +instance Binary Activation where + put_ bh NeverActive = do + putByte bh 0 + put_ bh AlwaysActive = do + putByte bh 1 + put_ bh (ActiveBefore aa) = do + putByte bh 2 + put_ bh aa + put_ bh (ActiveAfter ab) = do + putByte bh 3 + put_ bh ab + get bh = do + h <- getByte bh + case h of + 0 -> do return NeverActive + 1 -> do return AlwaysActive + 2 -> do aa <- get bh + return (ActiveBefore aa) + _ -> do ab <- get bh + return (ActiveAfter ab) + +instance Binary InlinePragma where + put_ bh (InlinePragma a b c d) = do + put_ bh a + put_ bh b + put_ bh c + put_ bh d + + get bh = do + a <- get bh + b <- get bh + c <- get bh + d <- get bh + return (InlinePragma a b c d) + +instance Binary RuleMatchInfo where + put_ bh FunLike = putByte bh 0 + put_ bh ConLike = putByte bh 1 + get bh = do + h <- getByte bh + if h == 1 then return ConLike + else return FunLike + +instance Binary InlineSpec where + put_ bh EmptyInlineSpec = putByte bh 0 + put_ bh Inline = putByte bh 1 + put_ bh Inlinable = putByte bh 2 + put_ bh NoInline = putByte bh 3 + + get bh = do h <- getByte bh + case h of + 0 -> return EmptyInlineSpec + 1 -> return Inline + 2 -> return Inlinable + _ -> return NoInline + +instance Binary DefMethSpec where + put_ bh NoDM = putByte bh 0 + put_ bh VanillaDM = putByte bh 1 + put_ bh GenericDM = putByte bh 2 + get bh = do + h <- getByte bh + case h of + 0 -> return NoDM + 1 -> return VanillaDM + _ -> return GenericDM + +instance Binary RecFlag where + put_ bh Recursive = do + putByte bh 0 + put_ bh NonRecursive = do + putByte bh 1 + get bh = do + h <- getByte bh + case h of + 0 -> do return Recursive + _ -> do return NonRecursive + +instance Binary OverlapFlag where + put_ bh (NoOverlap b) = putByte bh 0 >> put_ bh b + put_ bh (OverlapOk b) = putByte bh 1 >> put_ bh b + put_ bh (Incoherent b) = putByte bh 2 >> put_ bh b + get bh = do + h <- getByte bh + b <- get bh + case h of + 0 -> return $ NoOverlap b + 1 -> return $ OverlapOk b + 2 -> return $ Incoherent b + _ -> panic ("get OverlapFlag " ++ show h) + +instance Binary FixityDirection where + put_ bh InfixL = do + putByte bh 0 + put_ bh InfixR = do + putByte bh 1 + put_ bh InfixN = do + putByte bh 2 + get bh = do + h <- getByte bh + case h of + 0 -> do return InfixL + 1 -> do return InfixR + _ -> do return InfixN + +instance Binary Fixity where + put_ bh (Fixity aa ab) = do + put_ bh aa + put_ bh ab + get bh = do + aa <- get bh + ab <- get bh + return (Fixity aa ab) + +instance Binary WarningTxt where + put_ bh (WarningTxt w) = do + putByte bh 0 + put_ bh w + put_ bh (DeprecatedTxt d) = do + putByte bh 1 + put_ bh d + + get bh = do + h <- getByte bh + case h of + 0 -> do w <- get bh + return (WarningTxt w) + _ -> do d <- get bh + return (DeprecatedTxt d) + |