Commit dfc9d309 authored by Simon Peyton Jones's avatar Simon Peyton Jones

Define mapUnionVarSet, and use it

Call sites are much easier to understand than before
parent 2da63c60
......@@ -15,12 +15,12 @@
module VarSet (
-- * Var, Id and TyVar set types
VarSet, IdSet, TyVarSet, CoVarSet,
-- ** Manipulating these sets
emptyVarSet, unitVarSet, mkVarSet,
extendVarSet, extendVarSetList, extendVarSet_C,
elemVarSet, varSetElems, subVarSet,
unionVarSet, unionVarSets,
unionVarSet, unionVarSets, mapUnionVarSet,
intersectVarSet, intersectsVarSet, disjointVarSet,
isEmptyVarSet, delVarSet, delVarSetList, delVarSetByKey,
minusVarSet, foldVarSet, filterVarSet, fixVarSet,
......@@ -51,6 +51,10 @@ emptyVarSet :: VarSet
intersectVarSet :: VarSet -> VarSet -> VarSet
unionVarSet :: VarSet -> VarSet -> VarSet
unionVarSets :: [VarSet] -> VarSet
mapUnionVarSet :: (a -> VarSet) -> [a] -> VarSet
-- ^ map the function oer the list, and union the results
varSetElems :: VarSet -> [Var]
unitVarSet :: Var -> VarSet
extendVarSet :: VarSet -> Var -> VarSet
......@@ -108,6 +112,8 @@ partitionVarSet = partitionUniqSet
\end{code}
\begin{code}
mapUnionVarSet get_set xs = foldr (unionVarSet . get_set) emptyVarSet xs
-- See comments with type signatures
intersectsVarSet s1 s2 = not (s1 `disjointVarSet` s2)
disjointVarSet s1 s2 = isEmptyVarSet (s1 `intersectVarSet` s2)
......
......@@ -78,7 +78,7 @@ exprFreeIds = exprSomeFreeVars isLocalId
-- | Find all locally-defined free Ids or type variables in several expressions
exprsFreeVars :: [CoreExpr] -> VarSet
exprsFreeVars = foldr (unionVarSet . exprFreeVars) emptyVarSet
exprsFreeVars = mapUnionVarSet exprFreeVars
-- | Find all locally defined free Ids in a binding group
bindFreeVars :: CoreBind -> VarSet
......@@ -97,7 +97,7 @@ exprSomeFreeVars fv_cand e = expr_fvs e fv_cand emptyVarSet
exprsSomeFreeVars :: InterestingVarFun -- Says which 'Var's are interesting
-> [CoreExpr]
-> VarSet
exprsSomeFreeVars fv_cand = foldr (unionVarSet . exprSomeFreeVars fv_cand) emptyVarSet
exprsSomeFreeVars fv_cand = mapUnionVarSet (exprSomeFreeVars fv_cand)
-- | Predicate on possible free variables: returns @True@ iff the variable is interesting
type InterestingVarFun = Var -> Bool
......@@ -294,7 +294,7 @@ ruleFreeVars (Rule { ru_fn = _, ru_bndrs = bndrs, ru_rhs = rhs, ru_args = args }
idRuleRhsVars :: (Activation -> Bool) -> Id -> VarSet
-- Just the variables free on the *rhs* of a rule
idRuleRhsVars is_active id
= foldr (unionVarSet . get_fvs) emptyVarSet (idCoreRules id)
= mapUnionVarSet get_fvs (idCoreRules id)
where
get_fvs (Rule { ru_fn = fn, ru_bndrs = bndrs
, ru_rhs = rhs, ru_act = act })
......@@ -307,7 +307,7 @@ idRuleRhsVars is_active id
-- | Those variables free in the right hand side of several rules
rulesFreeVars :: [CoreRule] -> VarSet
rulesFreeVars rules = foldr (unionVarSet . ruleFreeVars) emptyVarSet rules
rulesFreeVars rules = mapUnionVarSet ruleFreeVars rules
ruleLhsFreeIds :: CoreRule -> VarSet
-- ^ This finds all locally-defined free Ids on the left hand side of a rule
......@@ -330,7 +330,7 @@ breaker, which is perfectly inlinable.
\begin{code}
-- |Free variables of a vectorisation declaration
vectsFreeVars :: [CoreVect] -> VarSet
vectsFreeVars = foldr (unionVarSet . vectFreeVars) emptyVarSet
vectsFreeVars = mapUnionVarSet vectFreeVars
where
vectFreeVars (Vect _ rhs) = expr_fvs rhs isLocalId emptyVarSet
vectFreeVars (NoVect _) = noFVs
......
......@@ -610,8 +610,8 @@ bindLocalsAtBreakpoint hsc_env apStack (Just info) = do
(ids, offsets) = unzip pointers
free_tvs = foldr (unionVarSet . tyVarsOfType . idType)
(tyVarsOfType result_ty) ids
free_tvs = mapUnionVarSet (tyVarsOfType . idType) ids
`unionVarSet` tyVarsOfType result_ty
-- It might be that getIdValFromApStack fails, because the AP_STACK
-- has been accidentally evaluated, or something else has gone wrong.
......
......@@ -635,7 +635,7 @@ chooseExternalIds hsc_env mod omit_prags expose_all binds implicit_binds imp_id_
-- (c) it is the vectorised version of an imported Id
-- See Note [Which rules to expose]
is_external id = isExportedId id || id `elemVarSet` rule_rhs_vars || id `elemVarSet` vect_var_vs
rule_rhs_vars = listFVs ruleRhsFreeVars imp_id_rules emptyVarSet
rule_rhs_vars = mapUnionVarSet ruleRhsFreeVars imp_id_rules
vect_var_vs = mkVarSet [var_v | (var, var_v) <- nameEnvElts vect_vars, isGlobalId var]
binders = bindersOfBinds binds
......@@ -923,7 +923,7 @@ findExternalRules omit_prags binds imp_id_rules unfold_env
= (trimmed_binds, filter keep_rule all_rules)
where
imp_rules = filter expose_rule imp_id_rules
imp_user_rule_fvs = listFVs user_rule_rhs_fvs imp_rules emptyVarSet
imp_user_rule_fvs = mapUnionVarSet user_rule_rhs_fvs imp_rules
user_rule_rhs_fvs rule | isAutoRule rule = emptyVarSet
| otherwise = ruleRhsFreeVars rule
......@@ -980,11 +980,11 @@ findExternalRules omit_prags binds imp_id_rules unfold_env
rhss = rhssOfBind bind
bndr_set' = bndr_set `extendVarSetList` bndrs
needed_fvs' = listFVs idUnfoldingVars bndrs $
needed_fvs' = needed_fvs `unionVarSet`
mapUnionVarSet idUnfoldingVars bndrs `unionVarSet`
-- Ignore type variables in the type of bndrs
listFVs exprFreeVars rhss $
listFVs user_rule_rhs_fvs local_rules $
needed_fvs
mapUnionVarSet exprFreeVars rhss `unionVarSet`
mapUnionVarSet user_rule_rhs_fvs local_rules
-- In needed_fvs', we don't bother to delete binders from the fv set
local_rules = [ rule
......@@ -992,9 +992,6 @@ findExternalRules omit_prags binds imp_id_rules unfold_env
, is_external_id id -- Only collect rules for external Ids
, rule <- idCoreRules id
, expose_rule rule ] -- and ones that can fire in a client
listFVs :: (a -> VarSet) -> [a] -> VarSet -> VarSet
listFVs fv_fn xs fvs = foldr (unionVarSet . fv_fn) fvs xs
\end{code}
%************************************************************************
......
......@@ -274,7 +274,7 @@ interactiveInScope hsc_env
te1 = mkTypeEnvWithImplicits (ic_tythings ictxt)
te = extendTypeEnvWithIds te1 (map instanceDFunId cls_insts)
ids = typeEnvIds te
tyvars = foldr (unionVarSet . tyVarsOfType . idType) emptyVarSet ids
tyvars = mapUnionVarSet (tyVarsOfType . idType) ids
-- Why the type variables? How can the top level envt have free tyvars?
-- I think it's because of the GHCi debugger, which can bind variables
-- f :: [t] -> [t]
......
......@@ -344,7 +344,7 @@ fiExpr dflags to_drop (_,AnnLet (AnnRec bindings) body)
body_fvs = freeVarsOf body
-- See Note [extra_fvs (1,2)]
rule_fvs = foldr (unionVarSet . idRuleAndUnfoldingVars) emptyVarSet ids
rule_fvs = mapUnionVarSet idRuleAndUnfoldingVars ids
extra_fvs = rule_fvs `unionVarSet`
unionVarSets [ fvs | (fvs, rhs) <- rhss
, noFloatIntoExpr rhs ]
......@@ -552,7 +552,7 @@ sepBindsByDropPoint dflags is_case drop_pts floaters
floatedBindsFVs :: FloatInBinds -> FreeVarSet
floatedBindsFVs binds = foldr (unionVarSet . fbFVs) emptyVarSet binds
floatedBindsFVs binds = mapUnionVarSet fbFVs binds
fbFVs :: FloatInBind -> VarSet
fbFVs (FB _ fvs _) = fvs
......
......@@ -684,10 +684,10 @@ makeNode env imp_rules_edges bndr_set (bndr, rhs)
, let fvs = exprFreeVars (ru_rhs rule)
`delVarSetList` ru_bndrs rule
, not (isEmptyVarSet fvs) ]
all_rule_fvs = foldr (unionVarSet . snd) rule_lhs_fvs rules_w_fvs
rule_lhs_fvs = foldr (unionVarSet . (\ru -> exprsFreeVars (ru_args ru)
`delVarSetList` ru_bndrs ru))
emptyVarSet rules
all_rule_fvs = rule_lhs_fvs `unionVarSet` rule_rhs_fvs
rule_rhs_fvs = mapUnionVarSet snd rules_w_fvs
rule_lhs_fvs = mapUnionVarSet (\ru -> exprsFreeVars (ru_args ru)
`delVarSetList` ru_bndrs ru) rules
active_rule_fvs = unionVarSets [fvs | (a,fvs) <- rules_w_fvs, is_active a]
-- Finding the free variables of the INLINE pragma (if any)
......@@ -757,7 +757,7 @@ occAnalRec (CyclicSCC nodes) (body_uds, binds)
-- a fresh SCC computation that will yield a single CyclicSCC result.
weak_fvs :: VarSet
weak_fvs = foldr (unionVarSet . nd_weak . fstOf3) emptyVarSet nodes
weak_fvs = mapUnionVarSet (nd_weak . fstOf3) nodes
-- See Note [Choosing loop breakers] for loop_breaker_edges
loop_breaker_edges = map mk_node tagged_nodes
......
......@@ -316,12 +316,12 @@ coVarsOfTcCo tc_co
= go tc_co
where
go (TcRefl _ _) = emptyVarSet
go (TcTyConAppCo _ _ cos) = foldr (unionVarSet . go) emptyVarSet cos
go (TcTyConAppCo _ _ cos) = mapUnionVarSet go cos
go (TcAppCo co1 co2) = go co1 `unionVarSet` go co2
go (TcCastCo co1 co2) = go co1 `unionVarSet` go co2
go (TcForAllCo _ co) = go co
go (TcCoVarCo v) = unitVarSet v
go (TcAxiomInstCo _ _ cos) = foldr (unionVarSet . go) emptyVarSet cos
go (TcAxiomInstCo _ _ cos) = mapUnionVarSet go cos
go (TcPhantomCo _ _) = emptyVarSet
go (TcSymCo co) = go co
go (TcTransCo co1 co2) = go co1 `unionVarSet` go co2
......@@ -332,7 +332,7 @@ coVarsOfTcCo tc_co
`minusVarSet` get_bndrs bs
go (TcLetCo {}) = emptyVarSet -- Harumph. This does legitimately happen in the call
-- to evVarsOfTerm in the DEBUG check of setEvBind
go (TcAxiomRuleCo _ _ cos) = foldr (unionVarSet . go) emptyVarSet cos
go (TcAxiomRuleCo _ _ cos) = mapUnionVarSet go cos
-- We expect only coercion bindings, so use evTermCoercion
......@@ -738,7 +738,7 @@ evVarsOfTerm (EvDelayedError _ _) = emptyVarSet
evVarsOfTerm (EvLit _) = emptyVarSet
evVarsOfTerms :: [EvTerm] -> VarSet
evVarsOfTerms = foldr (unionVarSet . evVarsOfTerm) emptyVarSet
evVarsOfTerms = mapUnionVarSet evVarsOfTerm
\end{code}
......
......@@ -1371,7 +1371,7 @@ findDefaultableGroups (default_tys, (ovl_strings, extended_defaults)) wanteds
find_unary cc = Right cc -- Non unary or non dictionary
bad_tvs :: TcTyVarSet -- TyVars mentioned by non-unaries
bad_tvs = foldr (unionVarSet . tyVarsOfCt) emptyVarSet non_unaries
bad_tvs = mapUnionVarSet tyVarsOfCt non_unaries
cmp_tv (_,_,tv1) (_,_,tv2) = tv1 `compare` tv2
......
......@@ -571,7 +571,7 @@ exactTyVarsOfType ty
go (ForAllTy tyvar ty) = delVarSet (go ty) tyvar
exactTyVarsOfTypes :: [Type] -> TyVarSet
exactTyVarsOfTypes tys = foldr (unionVarSet . exactTyVarsOfType) emptyVarSet tys
exactTyVarsOfTypes = mapUnionVarSet exactTyVarsOfType
\end{code}
%************************************************************************
......@@ -1319,7 +1319,7 @@ tcTyVarsOfType (ForAllTy tyvar ty) = tcTyVarsOfType ty `delVarSet` tyvar
-- We do sometimes quantify over skolem TcTyVars
tcTyVarsOfTypes :: [Type] -> TyVarSet
tcTyVarsOfTypes tys = foldr (unionVarSet.tcTyVarsOfType) emptyVarSet tys
tcTyVarsOfTypes = mapUnionVarSet tcTyVarsOfType
\end{code}
Find the free tycons and classes of a type. This is used in the front
......
......@@ -535,7 +535,7 @@ tyCoVarsOfCo (SubCo co) = tyCoVarsOfCo co
tyCoVarsOfCo (AxiomRuleCo _ ts cs) = tyVarsOfTypes ts `unionVarSet` tyCoVarsOfCos cs
tyCoVarsOfCos :: [Coercion] -> VarSet
tyCoVarsOfCos cos = foldr (unionVarSet . tyCoVarsOfCo) emptyVarSet cos
tyCoVarsOfCos = mapUnionVarSet tyCoVarsOfCo
coVarsOfCo :: Coercion -> VarSet
-- Extract *coerction* variables only. Tiresome to repeat the code, but easy.
......@@ -555,7 +555,7 @@ coVarsOfCo (SubCo co) = coVarsOfCo co
coVarsOfCo (AxiomRuleCo _ _ cos) = coVarsOfCos cos
coVarsOfCos :: [Coercion] -> VarSet
coVarsOfCos cos = foldr (unionVarSet . coVarsOfCo) emptyVarSet cos
coVarsOfCos = mapUnionVarSet coVarsOfCo
coercionSize :: Coercion -> Int
coercionSize (Refl _ ty) = typeSize ty
......
......@@ -327,7 +327,7 @@ tyVarsOfType (ForAllTy tyvar ty) = delVarSet (tyVarsOfType ty) tyvar
`unionVarSet` tyVarsOfType (tyVarKind tyvar)
tyVarsOfTypes :: [Type] -> TyVarSet
tyVarsOfTypes tys = foldr (unionVarSet . tyVarsOfType) emptyVarSet tys
tyVarsOfTypes = mapUnionVarSet tyVarsOfType
closeOverKinds :: TyVarSet -> TyVarSet
-- Add the kind variables free in the kinds
......
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