Commit fb520bb6 authored by ian@well-typed.com's avatar ian@well-typed.com

De-orphan a load of Binary instances

parent 0fa7cc97
......@@ -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)
This diff is collapsed.
......@@ -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]
......
......@@ -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