From: simonpj@microsoft.com Date: Wed, 26 Jan 2011 17:12:29 +0000 (+0000) Subject: Look through type synonyms when computing orphans X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=commitdiff_plain;h=e28816f0b0451c29acb6e7651783a6373dbb241b Look through type synonyms when computing orphans I renamed functions tyClsNamesOfTypes to oprhNamesOfType, because it's only used in that capacity, and we therefore want to look through type synonyms. Similarly exprOrphNames. This fixes Trac #4912. --- diff --git a/compiler/coreSyn/CoreFVs.lhs b/compiler/coreSyn/CoreFVs.lhs index 9abf11f..af414f7 100644 --- a/compiler/coreSyn/CoreFVs.lhs +++ b/compiler/coreSyn/CoreFVs.lhs @@ -23,14 +23,13 @@ module CoreFVs ( -- * Selective free variables of expressions InterestingVarFun, exprSomeFreeVars, exprsSomeFreeVars, - exprFreeNames, exprsFreeNames, -- * Free variables of Rules, Vars and Ids varTypeTyVars, varTypeTcTyVars, idUnfoldingVars, idFreeVars, idRuleAndUnfoldingVars, idRuleVars, idRuleRhsVars, stableUnfoldingVars, ruleRhsFreeVars, rulesFreeVars, - ruleLhsFreeNames, ruleLhsFreeIds, + ruleLhsOrphNames, ruleLhsFreeIds, -- * Core syntax tree annotation with free variables CoreExprWithFVs, -- = AnnExpr Id VarSet @@ -219,7 +218,7 @@ exprs_fvs exprs = foldr (union . expr_fvs) noVars exprs %************************************************************************ \begin{code} --- | Similar to 'exprFreeNames'. However, this is used when deciding whether +-- | ruleLhsOrphNames is used when deciding whether -- a rule is an orphan. In particular, suppose that T is defined in this -- module; we want to avoid declaring that a rule like: -- @@ -227,18 +226,20 @@ exprs_fvs exprs = foldr (union . expr_fvs) noVars exprs -- -- is an orphan. Of course it isn't, and declaring it an orphan would -- make the whole module an orphan module, which is bad. -ruleLhsFreeNames :: CoreRule -> NameSet -ruleLhsFreeNames (BuiltinRule { ru_fn = fn }) = unitNameSet fn -ruleLhsFreeNames (Rule { ru_fn = fn, ru_args = tpl_args }) - = addOneToNameSet (exprsFreeNames tpl_args) fn +ruleLhsOrphNames :: CoreRule -> NameSet +ruleLhsOrphNames (BuiltinRule { ru_fn = fn }) = unitNameSet fn +ruleLhsOrphNames (Rule { ru_fn = fn, ru_args = tpl_args }) + = addOneToNameSet (exprsOrphNames tpl_args) fn + -- No need to delete bndrs, because + -- exprsOrphNames finds only External names -- | Finds the free /external/ names of an expression, notably -- including the names of type constructors (which of course do not show -- up in 'exprFreeVars'). -exprFreeNames :: CoreExpr -> NameSet +exprOrphNames :: CoreExpr -> NameSet -- There's no need to delete local binders, because they will all -- be /internal/ names. -exprFreeNames e +exprOrphNames e = go e where go (Var v) @@ -246,21 +247,21 @@ exprFreeNames e | otherwise = emptyNameSet where n = idName v go (Lit _) = emptyNameSet - go (Type ty) = tyClsNamesOfType ty -- Don't need free tyvars + go (Type ty) = orphNamesOfType ty -- Don't need free tyvars go (App e1 e2) = go e1 `unionNameSets` go e2 go (Lam v e) = go e `delFromNameSet` idName v go (Note _ e) = go e - go (Cast e co) = go e `unionNameSets` tyClsNamesOfType co + go (Cast e co) = go e `unionNameSets` orphNamesOfType co go (Let (NonRec _ r) e) = go e `unionNameSets` go r - go (Let (Rec prs) e) = exprsFreeNames (map snd prs) `unionNameSets` go e - go (Case e _ ty as) = go e `unionNameSets` tyClsNamesOfType ty + go (Let (Rec prs) e) = exprsOrphNames (map snd prs) `unionNameSets` go e + go (Case e _ ty as) = go e `unionNameSets` orphNamesOfType ty `unionNameSets` unionManyNameSets (map go_alt as) go_alt (_,_,r) = go r --- | Finds the free /external/ names of several expressions: see 'exprFreeNames' for details -exprsFreeNames :: [CoreExpr] -> NameSet -exprsFreeNames es = foldr (unionNameSets . exprFreeNames) emptyNameSet es +-- | Finds the free /external/ names of several expressions: see 'exprOrphNames' for details +exprsOrphNames :: [CoreExpr] -> NameSet +exprsOrphNames es = foldr (unionNameSets . exprOrphNames) emptyNameSet es \end{code} %************************************************************************ diff --git a/compiler/iface/MkIface.lhs b/compiler/iface/MkIface.lhs index c0d49a3..b940cb1 100644 --- a/compiler/iface/MkIface.lhs +++ b/compiler/iface/MkIface.lhs @@ -1431,7 +1431,7 @@ instanceToIfaceInst (Instance { is_dfun = dfun_id, is_flag = oflag, (_, _, cls, tys) = tcSplitDFunTy (idType dfun_id) -- Slightly awkward: we need the Class to get the fundeps (tvs, fds) = classTvsFds cls - arg_names = [filterNameSet is_local (tyClsNamesOfType ty) | ty <- tys] + arg_names = [filterNameSet is_local (orphNamesOfType ty) | ty <- tys] orph | is_local cls_name = Just (nameOccName cls_name) | all isJust mb_ns = ASSERT( not (null mb_ns) ) head mb_ns | otherwise = Nothing @@ -1549,10 +1549,10 @@ coreRuleToIfaceRule _ (BuiltinRule { ru_fn = fn}) = pprTrace "toHsRule: builtin" (ppr fn) $ bogusIfaceRule fn -coreRuleToIfaceRule mod (Rule { ru_name = name, ru_fn = fn, - ru_act = act, ru_bndrs = bndrs, - ru_args = args, ru_rhs = rhs, - ru_auto = auto }) +coreRuleToIfaceRule mod rule@(Rule { ru_name = name, ru_fn = fn, + ru_act = act, ru_bndrs = bndrs, + ru_args = args, ru_rhs = rhs, + ru_auto = auto }) = IfaceRule { ifRuleName = name, ifActivation = act, ifRuleBndrs = map toIfaceBndr bndrs, ifRuleHead = fn, @@ -1571,9 +1571,7 @@ coreRuleToIfaceRule mod (Rule { ru_name = name, ru_fn = fn, -- Compute orphanhood. See Note [Orphans] in IfaceSyn -- A rule is an orphan only if none of the variables -- mentioned on its left-hand side are locally defined - lhs_names = fn : nameSetToList (exprsFreeNames args) - -- No need to delete bndrs, because - -- exprsFreeNames finds only External names + lhs_names = nameSetToList (ruleLhsOrphNames rule) orph = case filter (nameIsLocalOrFrom mod) lhs_names of (n : _) -> Just (nameOccName n) diff --git a/compiler/main/InteractiveEval.hs b/compiler/main/InteractiveEval.hs index 8967c17..43f6aa2 100644 --- a/compiler/main/InteractiveEval.hs +++ b/compiler/main/InteractiveEval.hs @@ -860,7 +860,7 @@ getInfo name return (Just (thing, fixity, filter (plausible rdr_env) ispecs)) where plausible rdr_env ispec -- Dfun involving only names that are in ic_rn_glb_env - = all ok $ nameSetToList $ tyClsNamesOfType $ idType $ instanceDFunId ispec + = all ok $ nameSetToList $ orphNamesOfType $ idType $ instanceDFunId ispec where -- A name is ok if it's in the rdr_env, -- whether qualified or not ok n | n == name = True -- The one we looked for in the first place! diff --git a/compiler/typecheck/TcRnDriver.lhs b/compiler/typecheck/TcRnDriver.lhs index ae3e2fa..38c4d7a 100644 --- a/compiler/typecheck/TcRnDriver.lhs +++ b/compiler/typecheck/TcRnDriver.lhs @@ -72,7 +72,7 @@ import Outputable import DataCon import Type import Class -import TcType ( tyClsNamesOfDFunHead ) +import TcType ( orphNamesOfDFunHead ) import Inst ( tcGetInstEnvs ) import Data.List ( sortBy ) @@ -1499,7 +1499,7 @@ lookupInsts (ATyCon tc) , let dfun = instanceDFunId ispec , relevant dfun ] } where - relevant df = tc_name `elemNameSet` tyClsNamesOfDFunHead (idType df) + relevant df = tc_name `elemNameSet` orphNamesOfDFunHead (idType df) tc_name = tyConName tc lookupInsts _ = return [] diff --git a/compiler/typecheck/TcType.lhs b/compiler/typecheck/TcType.lhs index 3ea53e8..eab0732 100644 --- a/compiler/typecheck/TcType.lhs +++ b/compiler/typecheck/TcType.lhs @@ -61,7 +61,7 @@ module TcType ( --------------------------------- -- Misc type manipulators deNoteType, - tyClsNamesOfType, tyClsNamesOfDFunHead, + orphNamesOfType, orphNamesOfDFunHead, getDFunTyKey, --------------------------------- @@ -1162,13 +1162,13 @@ exactTyVarsOfType ty = go ty where go ty | Just ty' <- tcView ty = go ty' -- This is the key line - go (TyVarTy tv) = unitVarSet tv - go (TyConApp _ tys) = exactTyVarsOfTypes tys - go (PredTy ty) = go_pred ty - go (FunTy arg res) = go arg `unionVarSet` go res - go (AppTy fun arg) = go fun `unionVarSet` go arg - go (ForAllTy tyvar ty) = delVarSet (go ty) tyvar - `unionVarSet` go_tv tyvar + go (TyVarTy tv) = unitVarSet tv + go (TyConApp _ tys) = exactTyVarsOfTypes tys + go (PredTy ty) = go_pred ty + go (FunTy arg res) = go arg `unionVarSet` go res + go (AppTy fun arg) = go fun `unionVarSet` go arg + go (ForAllTy tyvar ty) = delVarSet (go ty) tyvar + `unionVarSet` go_tv tyvar go_pred (IParam _ ty) = go ty go_pred (ClassP _ tys) = exactTyVarsOfTypes tys @@ -1185,29 +1185,34 @@ Find the free tycons and classes of a type. This is used in the front end of the compiler. \begin{code} -tyClsNamesOfType :: Type -> NameSet -tyClsNamesOfType (TyVarTy _) = emptyNameSet -tyClsNamesOfType (TyConApp tycon tys) = unitNameSet (getName tycon) `unionNameSets` tyClsNamesOfTypes tys -tyClsNamesOfType (PredTy (IParam _ ty)) = tyClsNamesOfType ty -tyClsNamesOfType (PredTy (ClassP cl tys)) = unitNameSet (getName cl) `unionNameSets` tyClsNamesOfTypes tys -tyClsNamesOfType (PredTy (EqPred ty1 ty2)) = tyClsNamesOfType ty1 `unionNameSets` tyClsNamesOfType ty2 -tyClsNamesOfType (FunTy arg res) = tyClsNamesOfType arg `unionNameSets` tyClsNamesOfType res -tyClsNamesOfType (AppTy fun arg) = tyClsNamesOfType fun `unionNameSets` tyClsNamesOfType arg -tyClsNamesOfType (ForAllTy _ ty) = tyClsNamesOfType ty - -tyClsNamesOfTypes :: [Type] -> NameSet -tyClsNamesOfTypes tys = foldr (unionNameSets . tyClsNamesOfType) emptyNameSet tys - -tyClsNamesOfDFunHead :: Type -> NameSet +orphNamesOfType :: Type -> NameSet +orphNamesOfType ty | Just ty' <- tcView ty = orphNamesOfType ty' + -- Look through type synonyms (Trac #4912) +orphNamesOfType (TyVarTy _) = emptyNameSet +orphNamesOfType (TyConApp tycon tys) = unitNameSet (getName tycon) + `unionNameSets` orphNamesOfTypes tys +orphNamesOfType (PredTy (IParam _ ty)) = orphNamesOfType ty +orphNamesOfType (PredTy (ClassP cl tys)) = unitNameSet (getName cl) + `unionNameSets` orphNamesOfTypes tys +orphNamesOfType (PredTy (EqPred ty1 ty2)) = orphNamesOfType ty1 + `unionNameSets` orphNamesOfType ty2 +orphNamesOfType (FunTy arg res) = orphNamesOfType arg `unionNameSets` orphNamesOfType res +orphNamesOfType (AppTy fun arg) = orphNamesOfType fun `unionNameSets` orphNamesOfType arg +orphNamesOfType (ForAllTy _ ty) = orphNamesOfType ty + +orphNamesOfTypes :: [Type] -> NameSet +orphNamesOfTypes tys = foldr (unionNameSets . orphNamesOfType) emptyNameSet tys + +orphNamesOfDFunHead :: Type -> NameSet -- Find the free type constructors and classes -- of the head of the dfun instance type -- The 'dfun_head_type' is because of -- instance Foo a => Baz T where ... -- The decl is an orphan if Baz and T are both not locally defined, -- even if Foo *is* locally defined -tyClsNamesOfDFunHead dfun_ty +orphNamesOfDFunHead dfun_ty = case tcSplitSigmaTy dfun_ty of - (_, _, head_ty) -> tyClsNamesOfType head_ty + (_, _, head_ty) -> orphNamesOfType head_ty \end{code}