%
\begin{code}
+{-# OPTIONS_GHC -w #-}
+-- The above warning supression flag is a temporary kludge.
+-- While working on this module you are encouraged to remove it and fix
+-- any warnings in the module. See
+-- http://hackage.haskell.org/trac/ghc/wiki/WorkingConventions#Warnings
+-- for details
+
module IfaceSyn (
module IfaceType, -- Re-export all this
IfaceDecl(..), IfaceClassOp(..), IfaceConDecl(..), IfaceConDecls(..),
- IfaceExpr(..), IfaceAlt, IfaceNote(..),
+ IfaceExpr(..), IfaceAlt, IfaceNote(..), IfaceLetBndr(..),
IfaceBinding(..), IfaceConAlt(..), IfaceIdInfo(..),
IfaceInfoItem(..), IfaceRule(..), IfaceInst(..), IfaceFamInst(..),
import NewDemand
import Class
import UniqFM
-import Unique
import NameSet
import Name
import CostCentre
import Literal
import ForeignCall
-import SrcLoc
import BasicTypes
import Outputable
import FastString
-- current compilation unit
ifFamInst :: Maybe (IfaceTyCon, [IfaceType])
-- Just <=> instance of family
+ -- Invariant:
+ -- ifCons /= IfOpenDataTyCon
+ -- for family instances
}
| IfaceSyn { ifName :: OccName, -- Type constructor
ifTyVars :: [IfaceTvBndr], -- Type variables
ifOpenSyn :: Bool, -- Is an open family?
- ifSynRhs :: IfaceType -- Type for an ordinary
+ ifSynRhs :: IfaceType, -- Type for an ordinary
-- synonym and kind for an
-- open family
+ ifFamInst :: Maybe (IfaceTyCon, [IfaceType])
+ -- Just <=> instance of family
+ -- Invariant: ifOpenSyn == False
+ -- for family instances
}
| IfaceClass { ifCtxt :: IfaceContext, -- Context...
data IfaceConDecls
= IfAbstractTyCon -- No info
| IfOpenDataTyCon -- Open data family
- | IfOpenNewTyCon -- Open newtype family
| IfDataTyCon [IfaceConDecl] -- data type decls
| IfNewTyCon IfaceConDecl -- newtype decls
visibleIfConDecls :: IfaceConDecls -> [IfaceConDecl]
visibleIfConDecls IfAbstractTyCon = []
visibleIfConDecls IfOpenDataTyCon = []
-visibleIfConDecls IfOpenNewTyCon = []
visibleIfConDecls (IfDataTyCon cs) = cs
visibleIfConDecls (IfNewTyCon c) = [c]
ifInstTys :: [Maybe IfaceTyCon], -- the defn of Instance
ifDFun :: Name, -- The dfun
ifOFlag :: OverlapFlag, -- Overlap flag
- ifInstOrph :: Maybe OccName } -- See is_orph in defn of Instance
+ ifInstOrph :: Maybe OccName } -- See Note [Orphans]
-- There's always a separate IfaceDecl for the DFun, which gives
-- its IdInfo with its full type and version number.
-- The instance declarations taken together have a version number,
| IfaceCast IfaceExpr IfaceCoercion
| IfaceLit Literal
| IfaceFCall ForeignCall IfaceType
+ | IfaceTick Module Int
data IfaceNote = IfaceSCC CostCentre
| IfaceInlineMe
| IfaceCoreNote String
- | IfaceTickBox Module Int
- | IfaceBinaryTickBox Module Int Int
type IfaceAlt = (IfaceConAlt, [FastString], IfaceExpr)
-- Note: FastString, not IfaceBndr (and same with the case binder)
| IfaceLitAlt Literal
data IfaceBinding
- = IfaceNonRec IfaceIdBndr IfaceExpr
- | IfaceRec [(IfaceIdBndr, IfaceExpr)]
+ = IfaceNonRec IfaceLetBndr IfaceExpr
+ | IfaceRec [(IfaceLetBndr, IfaceExpr)]
+
+-- 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 FastString IfaceType IfaceIdInfo
+\end{code}
+
+Note [IdInfo on nested let-bindings]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Occasionally we want to preserve IdInfo on nested let bindings The one
+that came up was a NOINLINE pragma on a let-binding inside an INLINE
+function. The user (Duncan Coutts) really wanted the NOINLINE control
+to cross the separate compilation boundary.
+
+So a IfaceLetBndr keeps a trimmed-down list of IfaceIdInfo stuff.
+Currently we only actually retain InlinePragInfo, but in principle we could
+add strictness etc.
+
+
+Note [Orphans]: the ifInstOrph and ifRuleOrph fields
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+If a module contains any "orphans", then its interface file is read
+regardless, so that its instances are not missed.
+
+Roughly speaking, an instance is an orphan if its head (after the =>)
+mentions nothing defined in this module. Functional dependencies
+complicate the situation though. Consider
+
+ module M where { class C a b | a -> b }
+
+and suppose we are compiling module X:
+
+ module X where
+ import M
+ data T = ...
+ instance C Int T where ...
+
+This instance is an orphan, because when compiling a third module Y we
+might get a constraint (C Int v), and we'd want to improve v to T. So
+we must make sure X's instances are loaded, even if we do not directly
+use anything from X.
+
+More precisely, an instance is an orphan iff
+
+ If there are no fundeps, then at least of the names in
+ the instance head is locally defined.
+
+ If there are fundeps, then for every fundep, at least one of the
+ names free in a *non-determined* part of the instance head is
+ defined in this module.
+
+(Note that these conditions hold trivially if the class is locally
+defined.)
+Note [Versioning of instances]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Now consider versioning. If we *use* an instance decl in one compilation,
+we'll depend on the dfun id for that instance, so we'll recompile if it changes.
+But suppose we *don't* (currently) use an instance! We must recompile if
+the instance is changed in such a way that it becomes important. (This would
+only matter with overlapping instances, else the importing module wouldn't have
+compiled before and the recompilation check is irrelevant.)
+
+The is_orph field is set to (Just n) if the instance is not an orphan.
+The 'n' is *any* of the locally-defined names mentioned anywhere in the
+instance head. This name is used for versioning; the instance decl is
+considered part of the defn of this 'n'.
+
+I'm worried about whether this works right if we pick a name from
+a functionally-dependent part of the instance decl. E.g.
+
+ module M where { class C a b | a -> b }
+
+and suppose we are compiling module X:
+
+ module X where
+ import M
+ data S = ...
+ data T = ...
+ instance C S T where ...
+
+If we base the instance verion on T, I'm worried that changing S to S'
+would change T's version, but not S or S'. But an importing module might
+not depend on T, and so might not be recompiled even though the new instance
+(C S' T) might be relevant. I have not been able to make a concrete example,
+and it seems deeply obscure, so I'm going to leave it for now.
+
+
+Note [Versioning of rules]
+~~~~~~~~~~~~~~~~~~~~~~~~~~
+A rule that is not an orphan has an ifRuleOrph field of (Just n), where
+n appears on the LHS of the rule; any change in the rule changes the version of n.
+
+
+\begin{code}
-- -----------------------------------------------------------------------------
-- Utils on IfaceSyn
= hsep [ptext SLIT("foreign import type dotnet"), ppr tycon]
pprIfaceDecl (IfaceSyn {ifName = tycon, ifTyVars = tyvars,
- ifOpenSyn = False, ifSynRhs = mono_ty})
+ ifOpenSyn = False, ifSynRhs = mono_ty,
+ ifFamInst = mbFamInst})
= hang (ptext SLIT("type") <+> pprIfaceDeclHead [] tycon tyvars)
- 4 (equals <+> ppr mono_ty)
+ 4 (vcat [equals <+> ppr mono_ty, pprFamily mbFamInst])
pprIfaceDecl (IfaceSyn {ifName = tycon, ifTyVars = tyvars,
ifOpenSyn = True, ifSynRhs = mono_ty})
IfOpenDataTyCon -> ptext SLIT("data family")
IfDataTyCon _ -> ptext SLIT("data")
IfNewTyCon _ -> ptext SLIT("newtype")
- IfOpenNewTyCon -> ptext SLIT("newtype family")
pprIfaceDecl (IfaceClass {ifCtxt = context, ifName = clas, ifTyVars = tyvars,
ifFDs = fds, ifATs = ats, ifSigs = sigs,
pprIfaceTvBndrs tyvars]
pp_condecls tc IfAbstractTyCon = ptext SLIT("{- abstract -}")
-pp_condecls tc IfOpenNewTyCon = empty
pp_condecls tc (IfNewTyCon c) = equals <+> pprIfaceConDecl tc c
pp_condecls tc IfOpenDataTyCon = empty
pp_condecls tc (IfDataTyCon cs) = equals <+> sep (punctuate (ptext SLIT(" |"))
(map (pprIfaceConDecl tc) cs))
+pprIfaceConDecl :: OccName -> IfaceConDecl -> SDoc
pprIfaceConDecl tc
(IfCon { ifConOcc = name, ifConInfix = is_infix,
ifConUnivTvs = univ_tvs, ifConExTvs = ex_tvs,
else nest 4 (ptext SLIT("Fields:") <+> hsep (map ppr fields))]
where
main_payload = ppr name <+> dcolon <+>
- pprIfaceForAllPart (univ_tvs ++ ex_tvs) (eq_ctxt ++ ctxt) (ppr con_tau)
+ pprIfaceForAllPart (univ_tvs ++ ex_tvs) (eq_ctxt ++ ctxt) pp_tau
eq_ctxt = [(IfaceEqPred (IfaceTyVar (occNameFS tv)) ty)
| (tv,ty) <- eq_spec]
- con_tau = foldr1 IfaceFunTy (arg_tys ++ [tc_app])
- tc_app = IfaceTyConApp (IfaceTc tc_name)
- [IfaceTyVar tv | (tv,_) <- univ_tvs]
- tc_name = mkInternalName (mkBuiltinUnique 1) tc noSrcLoc
- -- Really Gruesome, but just for debug print
+
+ -- A bit gruesome this, but we can't form the full con_tau, and ppr it,
+ -- because we don't have a Name for the tycon, only an OccName
+ pp_tau = case map pprParendIfaceType arg_tys ++ [pp_res_ty] of
+ (t:ts) -> fsep (t : map (arrow <+>) ts)
+ [] -> panic "pp_con_taus"
+
+ pp_res_ty = ppr tc <+> fsep [ppr tv | (tv,_) <- univ_tvs]
instance Outputable IfaceRule where
ppr (IfaceRule { ifRuleName = name, ifActivation = act, ifRuleBndrs = bndrs,
pprIfaceExpr add_par (IfaceExt v) = ppr v
pprIfaceExpr add_par (IfaceLit l) = ppr l
pprIfaceExpr add_par (IfaceFCall cc ty) = braces (ppr cc <+> ppr ty)
+pprIfaceExpr add_par (IfaceTick m ix) = braces (text "tick" <+> ppr m <+> ppr ix)
pprIfaceExpr add_par (IfaceType ty) = char '@' <+> pprParendIfaceType ty
pprIfaceExpr add_par app@(IfaceApp _ _) = add_par (pprIfaceApp app [])
ppr_con_bs (IfaceTupleAlt tup_con) bs = tupleParens tup_con (interpp'SP bs)
ppr_con_bs con bs = ppr con <+> hsep (map ppr bs)
-ppr_bind ((b,ty),rhs) = sep [ppr b <+> dcolon <+> ppr ty,
- equals <+> pprIfaceExpr noParens rhs]
+ppr_bind (IfLetBndr b ty info, rhs)
+ = sep [hang (ppr b <+> dcolon <+> ppr ty) 2 (ppr info),
+ equals <+> pprIfaceExpr noParens rhs]
------------------
pprIfaceApp (IfaceApp fun arg) args = pprIfaceApp fun (nest 2 (pprIfaceExpr parens arg) : args)
ppr (IfaceSCC cc) = pprCostCentreCore cc
ppr IfaceInlineMe = ptext SLIT("__inline_me")
ppr (IfaceCoreNote s) = ptext SLIT("__core_note") <+> pprHsString (mkFastString s)
- ppr (IfaceTickBox m n) = ptext SLIT("__tick_box") <+> pprModule m <+> text (show n)
- ppr (IfaceBinaryTickBox m t e)
- = ptext SLIT("__binary_tick_box")
- <+> pprModule m
- <+> text (show t)
- <+> text (show e)
instance Outputable IfaceConAlt where
------------------
instance Outputable IfaceIdInfo where
- ppr NoInfo = empty
- ppr (HasInfo is) = ptext SLIT("{-") <+> fsep (map ppr_hs_info is) <+> ptext SLIT("-}")
+ ppr NoInfo = empty
+ ppr (HasInfo is) = ptext SLIT("{-") <+> fsep (map ppr is) <+> ptext SLIT("-}")
-ppr_hs_info (HsUnfold unf) = ptext SLIT("Unfolding:") <+>
+instance Outputable IfaceInfoItem where
+ ppr (HsUnfold unf) = ptext SLIT("Unfolding:") <+>
parens (pprIfaceExpr noParens unf)
-ppr_hs_info (HsInline act) = ptext SLIT("Inline:") <+> ppr act
-ppr_hs_info (HsArity arity) = ptext SLIT("Arity:") <+> int arity
-ppr_hs_info (HsStrictness str) = ptext SLIT("Strictness:") <+> pprIfaceStrictSig str
-ppr_hs_info HsNoCafRefs = ptext SLIT("HasNoCafRefs")
-ppr_hs_info (HsWorker w a) = ptext SLIT("Worker:") <+> ppr w <+> int a
+ ppr (HsInline act) = ptext SLIT("Inline:") <+> ppr act
+ ppr (HsArity arity) = ptext SLIT("Arity:") <+> int arity
+ ppr (HsStrictness str) = ptext SLIT("Strictness:") <+> pprIfaceStrictSig str
+ ppr HsNoCafRefs = ptext SLIT("HasNoCafRefs")
+ ppr (HsWorker w a) = ptext SLIT("Worker:") <+> ppr w <+> int a
\end{code}
-- The type variables of the data type do not scope
-- over the constructors (any more), but they do scope
-- over the stupid context in the IfaceConDecls
- where
- Nothing `eqIfTc_fam` Nothing = Equal
- (Just (fam1, tys1)) `eqIfTc_fam` (Just (fam2, tys2)) =
- fam1 `eqIfTc` fam2 &&& eqListBy eqIfType tys1 tys2
- _ `eqIfTc_fam` _ = NotEqual
eqIfDecl d1@(IfaceSyn {}) d2@(IfaceSyn {})
= bool (ifName d1 == ifName d2) &&&
+ ifFamInst d1 `eqIfTc_fam` ifFamInst d2 &&&
eqWith (ifTyVars d1) (ifTyVars d2) (\ env ->
eq_ifType env (ifSynRhs d1) (ifSynRhs d2)
)
eqWith :: [IfaceTvBndr] -> [IfaceTvBndr] -> (EqEnv -> IfaceEq) -> IfaceEq
eqWith = eq_ifTvBndrs emptyEqEnv
+eqIfTc_fam :: Maybe (IfaceTyCon, [IfaceType])
+ -> Maybe (IfaceTyCon, [IfaceType])
+ -> IfaceEq
+Nothing `eqIfTc_fam` Nothing = Equal
+(Just (fam1, tys1)) `eqIfTc_fam` (Just (fam2, tys2)) =
+ fam1 `eqIfTc` fam2 &&& eqListBy eqIfType tys1 tys2
+_ `eqIfTc_fam` _ = NotEqual
+
+
-----------------------
eqIfInst d1 d2 = bool (ifDFun d1 == ifDFun d2 && ifOFlag d1 == ifOFlag d2)
-- All other changes are handled via the version info on the dfun
eq_hsCD env (IfNewTyCon c1) (IfNewTyCon c2) = eq_ConDecl env c1 c2
eq_hsCD env IfAbstractTyCon IfAbstractTyCon = Equal
eq_hsCD env IfOpenDataTyCon IfOpenDataTyCon = Equal
-eq_hsCD env IfOpenNewTyCon IfOpenNewTyCon = Equal
eq_hsCD env d1 d2 = NotEqual
eq_ConDecl env c1 c2
eq_ifaceExpr env (IfaceExt v1) (IfaceExt v2) = eqIfExt v1 v2
eq_ifaceExpr env (IfaceLit l1) (IfaceLit l2) = bool (l1 == l2)
eq_ifaceExpr env (IfaceFCall c1 ty1) (IfaceFCall c2 ty2) = bool (c1==c2) &&& eq_ifType env ty1 ty2
+eq_ifaceExpr env (IfaceTick m1 ix1) (IfaceTick m2 ix2) = bool (m1==m2) &&& bool (ix1 == ix2)
eq_ifaceExpr env (IfaceType ty1) (IfaceType ty2) = eq_ifType env ty1 ty2
eq_ifaceExpr env (IfaceTuple n1 as1) (IfaceTuple n2 as2) = bool (n1==n2) &&& eqListBy (eq_ifaceExpr env) as1 as2
eq_ifaceExpr env (IfaceLam b1 body1) (IfaceLam b2 body2) = eq_ifBndr env b1 b2 (\env -> eq_ifaceExpr env body1 body2)
eq_ifNakedBndrs env bs1 bs2 (\env -> eq_ifaceExpr env r1 r2)
eq_ifaceExpr env (IfaceLet (IfaceNonRec b1 r1) x1) (IfaceLet (IfaceNonRec b2 r2) x2)
- = eq_ifaceExpr env r1 r2 &&& eq_ifIdBndr env b1 b2 (\env -> eq_ifaceExpr env x1 x2)
+ = eq_ifaceExpr env r1 r2 &&& eq_ifLetBndr env b1 b2 (\env -> eq_ifaceExpr env x1 x2)
eq_ifaceExpr env (IfaceLet (IfaceRec as1) x1) (IfaceLet (IfaceRec as2) x2)
- = eq_ifIdBndrs env bs1 bs2 (\env -> eqListBy (eq_ifaceExpr env) rs1 rs2 &&& eq_ifaceExpr env x1 x2)
+ = eq_ifLetBndrs env bs1 bs2 (\env -> eqListBy (eq_ifaceExpr env) rs1 rs2 &&& eq_ifaceExpr env x1 x2)
where
(bs1,rs1) = unzip as1
(bs2,rs2) = unzip as2
eq_ifaceNote env (IfaceSCC c1) (IfaceSCC c2) = bool (c1==c2)
eq_ifaceNote env IfaceInlineMe IfaceInlineMe = Equal
eq_ifaceNote env (IfaceCoreNote s1) (IfaceCoreNote s2) = bool (s1==s2)
-eq_ifaceNote env (IfaceTickBox m1 n1) (IfaceTickBox m2 n2) = bool (m1==m2 && n1==n2)
-eq_ifaceNote env (IfaceBinaryTickBox m1 t1 e1) (IfaceBinaryTickBox m2 t2 e2) = bool (m1==m2 && t1==t2 && e1 == e2)
eq_ifaceNote env _ _ = NotEqual
\end{code}
eq_ifTvBndr env (v1, k1) (v2, k2) k = eq_ifType env k1 k2 &&& k (extendEqEnv env v1 v2)
eq_ifIdBndr env (v1, t1) (v2, t2) k = eq_ifType env t1 t2 &&& k (extendEqEnv env v1 v2)
+eq_ifLetBndr env (IfLetBndr v1 t1 i1) (IfLetBndr v2 t2 i2) k
+ = eq_ifType env t1 t2 &&& eqIfIdInfo i1 i2 &&& k (extendEqEnv env v1 v2)
+
eq_ifBndrs :: ExtEnv [IfaceBndr]
-eq_ifIdBndrs :: ExtEnv [IfaceIdBndr]
+eq_ifLetBndrs :: ExtEnv [IfaceLetBndr]
eq_ifTvBndrs :: ExtEnv [IfaceTvBndr]
eq_ifNakedBndrs :: ExtEnv [FastString]
eq_ifBndrs = eq_bndrs_with eq_ifBndr
-eq_ifIdBndrs = eq_bndrs_with eq_ifIdBndr
eq_ifTvBndrs = eq_bndrs_with eq_ifTvBndr
eq_ifNakedBndrs = eq_bndrs_with eq_ifNakedBndr
+eq_ifLetBndrs = eq_bndrs_with eq_ifLetBndr
eq_bndrs_with eq env [] [] k = k env
eq_bndrs_with eq env (b1:bs1) (b2:bs2) k = eq env b1 b2 (\env -> eq_bndrs_with eq env bs1 bs2 k)
projects / ghc-hetmet.git / blobdiff