summaryrefslogtreecommitdiff
path: root/compiler/iface/BinIface.hs
diff options
context:
space:
mode:
Diffstat (limited to 'compiler/iface/BinIface.hs')
-rw-r--r--compiler/iface/BinIface.hs1077
1 files changed, 0 insertions, 1077 deletions
diff --git a/compiler/iface/BinIface.hs b/compiler/iface/BinIface.hs
index 69e702bb20..c4c1bcd69e 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,21 +23,15 @@ import TyCon
import DataCon (dataConName, dataConWorkId, dataConTyCon)
import PrelInfo (wiredInThings, basicKnownKeyNames)
import Id (idName, isDataConWorkId_maybe)
-import CoreSyn (DFunArg(..))
-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
@@ -414,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,926 +414,3 @@ getWayDescr dflags
where tag = buildTag 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 (DFunArg IfaceExpr) where
- put_ bh (DFunPolyArg e) = putByte bh 0 >> put_ bh e
- put_ bh (DFunLamArg i) = putByte bh 1 >> put_ bh i
- get bh = do { h <- getByte bh
- ; case h of
- 0 -> do { a <- get bh; return (DFunPolyArg a) }
- _ -> do { a <- get bh; return (DFunLamArg a) } }
-
-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 (IfWrapper e) = do
- putByte bh 2
- put_ bh e
- put_ bh (IfDFunUnfold as) = do
- putByte bh 3
- put_ bh as
- put_ bh (IfCompulsory e) = do
- putByte bh 4
- 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 e <- get bh
- return (IfWrapper e)
- 3 -> do as <- get bh
- return (IfDFunUnfold as)
- _ -> 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) = do
- put_ bh a1
- put_ bh a2
- put_ bh a3
- get bh = do
- a1 <- get bh
- a2 <- get bh
- a3 <- get bh
- return (IfaceAxBranch a1 a2 a3)
-
-instance Binary ty => Binary (SynTyConRhs ty) where
- put_ bh (SynFamilyTyCon a b) = putByte bh 0 >> put_ bh a >> put_ bh b
- put_ bh (SynonymTyCon ty) = putByte bh 1 >> put_ bh ty
-
- get bh = do { h <- getByte bh
- ; case h of
- 0 -> do { a <- get bh
- ; b <- get bh
- ; return (SynFamilyTyCon a b) }
- _ -> do { ty <- get bh
- ; return (SynonymTyCon 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 group tys name orph) = do
- put_ bh fam
- put_ bh group
- put_ bh tys
- put_ bh name
- put_ bh orph
- get bh = do
- fam <- get bh
- group <- get bh
- tys <- get bh
- name <- get bh
- orph <- get bh
- return (IfaceFamInst fam group 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)
-
View Lorry Controller Status