Commit e28816f0 authored by simonpj@microsoft.com's avatar simonpj@microsoft.com
Browse files

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.
parent 4dc71b4b
......@@ -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}
%************************************************************************
......
......@@ -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)
......
......@@ -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!
......
......@@ -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 []
......
......@@ -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}
......
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment