-- Equality
IfaceEq(..), (&&&), bool, eqListBy, eqMaybeBy,
- eqIfDecl, eqIfInst, eqIfRule,
+ eqIfDecl, eqIfInst, eqIfRule, checkBootDecl,
-- Pretty printing
pprIfaceExpr, pprIfaceDecl, pprIfaceDeclHead
import DataCon ( dataConName, dataConSig, dataConFieldLabels, dataConStrictMarks,
dataConTyCon, dataConIsInfix, isVanillaDataCon )
import Class ( FunDep, DefMeth, classExtraBigSig, classTyCon )
-import OccName ( OccName, OccEnv, emptyOccEnv,
- lookupOccEnv, extendOccEnv, parenSymOcc,
+import OccName ( OccName, parenSymOcc, occNameFS,
OccSet, unionOccSets, unitOccSet )
+import UniqFM ( UniqFM, emptyUFM, addToUFM, lookupUFM )
import Name ( Name, NamedThing(..), nameOccName, isExternalName )
import CostCentre ( CostCentre, pprCostCentreCore )
import Literal ( Literal )
| IfaceClass { ifCtxt :: IfaceContext, -- Context...
ifName :: OccName, -- Name of the class
ifTyVars :: [IfaceTvBndr], -- Type variables
- ifFDs :: [FunDep OccName], -- Functional dependencies
+ ifFDs :: [FunDep FastString], -- Functional dependencies
ifSigs :: [IfaceClassOp], -- Method signatures
ifRec :: RecFlag, -- Is newtype/datatype associated with the class recursive?
ifVrcs :: ArgVrcs -- ... and what are its argument variances ...
--------------------------------
data IfaceExpr
- = IfaceLcl OccName
+ = IfaceLcl FastString
| IfaceExt IfaceExtName
| IfaceType IfaceType
| IfaceTuple Boxity [IfaceExpr] -- Saturated; type arguments omitted
| IfaceLam IfaceBndr IfaceExpr
| IfaceApp IfaceExpr IfaceExpr
- | IfaceCase IfaceExpr OccName IfaceType [IfaceAlt]
+ | IfaceCase IfaceExpr FastString IfaceType [IfaceAlt]
| IfaceLet IfaceBinding IfaceExpr
| IfaceNote IfaceNote IfaceExpr
| IfaceLit Literal
data IfaceNote = IfaceSCC CostCentre
| IfaceCoerce IfaceType
- | IfaceInlineCall
| IfaceInlineMe
| IfaceCoreNote String
-type IfaceAlt = (IfaceConAlt, [OccName], IfaceExpr)
+type IfaceAlt = (IfaceConAlt, [FastString], IfaceExpr)
-- Note: OccName, not IfaceBndr (and same with the case binder)
-- We reconstruct the kind/type of the thing from the context
-- thus saving bulk in interface files
instance Outputable IfaceNote where
ppr (IfaceSCC cc) = pprCostCentreCore cc
ppr (IfaceCoerce ty) = ptext SLIT("__coerce") <+> pprParendIfaceType ty
- ppr IfaceInlineCall = ptext SLIT("__inline_call")
ppr IfaceInlineMe = ptext SLIT("__inline_me")
ppr (IfaceCoreNote s) = ptext SLIT("__core_note") <+> pprHsString (mkFastString s)
(sel_tyvars, rho_ty) = splitForAllTys (idType sel_id)
op_ty = funResultTy rho_ty
- toIfaceFD (tvs1, tvs2) = (map getOccName tvs1, map getOccName tvs2)
+ toIfaceFD (tvs1, tvs2) = (map (occNameFS.getOccName) tvs1, map (occNameFS.getOccName) tvs2)
tyThingToIfaceDecl ext (ATyCon tycon)
| isSynTyCon tycon
toIfaceExpr ext (Type ty) = IfaceType (toIfaceType ext ty)
toIfaceExpr ext (Lam x b) = IfaceLam (toIfaceBndr ext x) (toIfaceExpr ext b)
toIfaceExpr ext (App f a) = toIfaceApp ext f [a]
-toIfaceExpr ext (Case s x ty as) = IfaceCase (toIfaceExpr ext s) (getOccName x) (toIfaceType ext ty) (map (toIfaceAlt ext) as)
+toIfaceExpr ext (Case s x ty as) = IfaceCase (toIfaceExpr ext s) (occNameFS (getOccName x)) (toIfaceType ext ty) (map (toIfaceAlt ext) as)
toIfaceExpr ext (Let b e) = IfaceLet (toIfaceBind ext b) (toIfaceExpr ext e)
toIfaceExpr ext (Note n e) = IfaceNote (toIfaceNote ext n) (toIfaceExpr ext e)
---------------------
toIfaceNote ext (SCC cc) = IfaceSCC cc
toIfaceNote ext (Coerce t1 _) = IfaceCoerce (toIfaceType ext t1)
-toIfaceNote ext InlineCall = IfaceInlineCall
toIfaceNote ext InlineMe = IfaceInlineMe
toIfaceNote ext (CoreNote s) = IfaceCoreNote s
toIfaceBind ext (Rec prs) = IfaceRec [(toIfaceIdBndr ext b, toIfaceExpr ext r) | (b,r) <- prs]
---------------------
-toIfaceAlt ext (c,bs,r) = (toIfaceCon c, map getOccName bs, toIfaceExpr ext r)
+toIfaceAlt ext (c,bs,r) = (toIfaceCon c, map (occNameFS.getOccName) bs, toIfaceExpr ext r)
---------------------
toIfaceCon (DataAlt dc) | isTupleTyCon tc = IfaceTupleAlt (tupleTyConBoxity tc)
| Just fcall <- isFCallId_maybe v = IfaceFCall fcall (toIfaceType ext (idType v))
-- Foreign calls have special syntax
| isExternalName name = IfaceExt (ext name)
- | otherwise = IfaceLcl (nameOccName name)
+ | otherwise = IfaceLcl (occNameFS (nameOccName name))
where
name = idName v
\end{code}
bool True = Equal
bool False = NotEqual
+toBool :: IfaceEq -> Bool
+toBool Equal = True
+toBool (EqBut _) = True
+toBool NotEqual = False
+
zapEq :: IfaceEq -> IfaceEq -- Used to forget EqBut information
zapEq (EqBut _) = Equal
zapEq other = other
\begin{code}
---------------------
+checkBootDecl :: IfaceDecl -- The boot decl
+ -> IfaceDecl -- The real decl
+ -> Bool -- True <=> compatible
+checkBootDecl (IfaceId s1 t1 _) (IfaceId s2 t2 _)
+ = ASSERT( s1==s2 ) toBool (t1 `eqIfType` t2)
+
+checkBootDecl d1@(IfaceForeign {}) d2@(IfaceForeign {})
+ = ASSERT (ifName d1 == ifName d2 ) ifExtName d1 == ifExtName d2
+
+checkBootDecl d1@(IfaceSyn {}) d2@(IfaceSyn {})
+ = ASSERT( ifName d1 == ifName d2 )
+ toBool $ eqWith (ifTyVars d1) (ifTyVars d2) $ \ env ->
+ eq_ifType env (ifSynRhs d1) (ifSynRhs d2)
+
+checkBootDecl d1@(IfaceData {}) d2@(IfaceData {})
+-- We don't check the recursion flags because the boot-one is
+-- recursive, to be conservative, but the real one may not be.
+-- I'm not happy with the way recursive flags are dealt with.
+ = ASSERT( ifName d1 == ifName d2 )
+ toBool $ eqWith (ifTyVars d1) (ifTyVars d2) $ \ env ->
+ eq_ifContext env (ifCtxt d1) (ifCtxt d2) &&&
+ case ifCons d1 of
+ IfAbstractTyCon -> Equal
+ cons1 -> eq_hsCD env cons1 (ifCons d2)
+
+checkBootDecl d1@(IfaceClass {}) d2@(IfaceClass {})
+ = ASSERT( ifName d1 == ifName d2 )
+ toBool $ eqWith (ifTyVars d1) (ifTyVars d2) $ \ env ->
+ eqListBy (eq_hsFD env) (ifFDs d1) (ifFDs d2) &&&
+ case (ifCtxt d1, ifSigs d1) of
+ ([], []) -> Equal
+ (cxt1, sigs1) -> eq_ifContext env cxt1 (ifCtxt d2) &&&
+ eqListBy (eq_cls_sig env) sigs1 (ifSigs d2)
+
+checkBootDecl _ _ = False -- default case
+
+---------------------
eqIfDecl :: IfaceDecl -> IfaceDecl -> IfaceEq
eqIfDecl (IfaceId s1 t1 i1) (IfaceId s2 t2 i2)
= bool (s1 == s2) &&& (t1 `eqIfType` t2) &&& (i1 `eqIfIdInfo` i2)
eqWith = eq_ifTvBndrs emptyEqEnv
-----------------------
-eqIfInst d1 d2 = bool (ifDFun d1 == ifDFun d2)
+eqIfInst d1 d2 = bool (ifDFun d1 == ifDFun d2 && ifOFlag d1 == ifOFlag d2)
-- All other changes are handled via the version info on the dfun
eqIfRule (IfaceRule n1 a1 bs1 f1 es1 rhs1 o1)
eq_ifaceNote :: EqEnv -> IfaceNote -> IfaceNote -> IfaceEq
eq_ifaceNote env (IfaceSCC c1) (IfaceSCC c2) = bool (c1==c2)
eq_ifaceNote env (IfaceCoerce t1) (IfaceCoerce t2) = eq_ifType env t1 t2
-eq_ifaceNote env IfaceInlineCall IfaceInlineCall = Equal
eq_ifaceNote env IfaceInlineMe IfaceInlineMe = Equal
eq_ifaceNote env (IfaceCoreNote s1) (IfaceCoreNote s2) = bool (s1==s2)
eq_ifaceNote env _ _ = NotEqual
\begin{code}
------------------------------------
-type EqEnv = OccEnv OccName -- Tracks the mapping from L-variables to R-variables
+type EqEnv = UniqFM FastString -- Tracks the mapping from L-variables to R-variables
-eqIfOcc :: EqEnv -> OccName -> OccName -> IfaceEq
-eqIfOcc env n1 n2 = case lookupOccEnv env n1 of
+eqIfOcc :: EqEnv -> FastString -> FastString -> IfaceEq
+eqIfOcc env n1 n2 = case lookupUFM env n1 of
Just n1 -> bool (n1 == n2)
Nothing -> bool (n1 == n2)
-extendEqEnv :: EqEnv -> OccName -> OccName -> EqEnv
+extendEqEnv :: EqEnv -> FastString -> FastString -> EqEnv
extendEqEnv env n1 n2 | n1 == n2 = env
- | otherwise = extendOccEnv env n1 n2
+ | otherwise = addToUFM env n1 n2
emptyEqEnv :: EqEnv
-emptyEqEnv = emptyOccEnv
+emptyEqEnv = emptyUFM
------------------------------------
type ExtEnv bndr = EqEnv -> bndr -> bndr -> (EqEnv -> IfaceEq) -> IfaceEq
-eq_ifNakedBndr :: ExtEnv OccName
+eq_ifNakedBndr :: ExtEnv FastString
eq_ifBndr :: ExtEnv IfaceBndr
eq_ifTvBndr :: ExtEnv IfaceTvBndr
eq_ifIdBndr :: ExtEnv IfaceIdBndr
eq_ifBndrs :: ExtEnv [IfaceBndr]
eq_ifIdBndrs :: ExtEnv [IfaceIdBndr]
eq_ifTvBndrs :: ExtEnv [IfaceTvBndr]
-eq_ifNakedBndrs :: ExtEnv [OccName]
+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
projects / ghc-hetmet.git / blobdiff