Commit 928d7473 authored by niteria's avatar niteria

Kill some unnecessary varSetElems

When you do `varSetElems (tyCoVarsOfType x)` it's equivalent to
`tyCoVarsOfTypeList x`.

Why? If you look at the implementation:
```
tyCoVarsOfTypeList ty = runFVList $ tyCoVarsOfTypeAcc ty
tyCoVarsOfType ty = runFVSet $ tyCoVarsOfTypeAcc ty
```
they use the same helper function. The helper function returns a
deterministically ordered list and a set. The only difference
between the two is which part of the result they take. It is redundant
to take the set and then immediately convert it to a list.

This helps with determinism and we eventually want to replace the uses
of `varSetElems` with functions that don't leak the values of uniques.
This change gets rid of some instances that are easy to kill.

I chose not to annotate every place where I got rid of `varSetElems`
with a comment about non-determinism, because once we get rid of
`varSetElems` it will not be possible to do the wrong thing.

Test Plan: ./validate

Reviewers: goldfire, austin, simonmar, bgamari, simonpj

Reviewed By: simonpj

Subscribers: thomie

Differential Revision: https://phabricator.haskell.org/D2115

GHC Trac Issues: #4012
parent f4fd98c7
......@@ -12,7 +12,9 @@ module CoreFVs (
-- * Free variables of expressions and binding groups
exprFreeVars,
exprFreeVarsDSet,
exprFreeVarsList,
exprFreeIds,
exprsFreeIdsList,
exprsFreeVars,
exprsFreeVarsList,
bindFreeVars,
......@@ -20,6 +22,7 @@ module CoreFVs (
-- * Selective free variables of expressions
InterestingVarFun,
exprSomeFreeVars, exprsSomeFreeVars,
exprsSomeFreeVarsList,
-- * Free variables of Rules, Vars and Ids
varTypeTyCoVars,
......@@ -30,7 +33,7 @@ module CoreFVs (
idRuleVars, idRuleRhsVars, stableUnfoldingVars,
ruleRhsFreeVars, ruleFreeVars, rulesFreeVars,
rulesFreeVarsDSet,
ruleLhsFreeIds,
ruleLhsFreeIds, ruleLhsFreeIdsList,
vectsFreeVars,
expr_fvs,
......@@ -109,10 +112,20 @@ exprFreeVarsAcc = filterFV isLocalVar . expr_fvs
exprFreeVarsDSet :: CoreExpr -> DVarSet
exprFreeVarsDSet = runFVDSet . exprFreeVarsAcc
-- | Find all locally-defined free Ids or type variables in an expression
-- returning a deterministically ordered list.
exprFreeVarsList :: CoreExpr -> [Var]
exprFreeVarsList = runFVList . exprFreeVarsAcc
-- | Find all locally-defined free Ids in an expression
exprFreeIds :: CoreExpr -> IdSet -- Find all locally-defined free Ids
exprFreeIds = exprSomeFreeVars isLocalId
-- | Find all locally-defined free Ids in an expression
-- returning a deterministically ordered list.
exprsFreeIdsList :: [CoreExpr] -> [Id] -- Find all locally-defined free Ids
exprsFreeIdsList = exprsSomeFreeVarsList isLocalId
-- | Find all locally-defined free Ids or type variables in several expressions
-- returning a non-deterministic set.
exprsFreeVars :: [CoreExpr] -> VarSet
......@@ -149,6 +162,14 @@ exprsSomeFreeVars :: InterestingVarFun -- Says which 'Var's are interesting
exprsSomeFreeVars fv_cand es =
runFVSet $ filterFV fv_cand $ mapUnionFV expr_fvs es
-- | Finds free variables in several expressions selected by a predicate
-- returning a deterministically ordered list.
exprsSomeFreeVarsList :: InterestingVarFun -- Says which 'Var's are interesting
-> [CoreExpr]
-> [Var]
exprsSomeFreeVarsList fv_cand es =
runFVList $ filterFV fv_cand $ mapUnionFV expr_fvs es
-- Comment about obselete code
-- We used to gather the free variables the RULES at a variable occurrence
-- with the following cryptic comment:
......@@ -422,9 +443,20 @@ rulesFreeVars rules = mapUnionVarSet ruleFreeVars rules
ruleLhsFreeIds :: CoreRule -> VarSet
-- ^ This finds all locally-defined free Ids on the left hand side of a rule
ruleLhsFreeIds (BuiltinRule {}) = noFVs
ruleLhsFreeIds (Rule { ru_bndrs = bndrs, ru_args = args })
= runFVSet $ filterFV isLocalId $ addBndrs bndrs (exprs_fvs args)
-- and returns them as a non-deterministic set
ruleLhsFreeIds = runFVSet . ruleLhsFreeIdsAcc
ruleLhsFreeIdsList :: CoreRule -> [Var]
-- ^ This finds all locally-defined free Ids on the left hand side of a rule
-- and returns them as a determinisitcally ordered list
ruleLhsFreeIdsList = runFVList . ruleLhsFreeIdsAcc
ruleLhsFreeIdsAcc :: CoreRule -> FV
-- ^ This finds all locally-defined free Ids on the left hand side of a rule
-- and returns an FV computation
ruleLhsFreeIdsAcc (BuiltinRule {}) = noVars
ruleLhsFreeIdsAcc (Rule { ru_bndrs = bndrs, ru_args = args })
= filterFV isLocalId $ addBndrs bndrs (exprs_fvs args)
{-
Note [Rule free var hack] (Not a hack any more)
......
......@@ -339,7 +339,7 @@ interactiveInScope :: HscEnv -> [Var]
--
-- See Trac #8215 for an example
interactiveInScope hsc_env
= varSetElems tyvars ++ ids
= tyvars ++ ids
where
-- C.f. TcRnDriver.setInteractiveContext, Desugar.deSugarExpr
ictxt = hsc_IC hsc_env
......@@ -347,7 +347,7 @@ interactiveInScope hsc_env
te1 = mkTypeEnvWithImplicits (ic_tythings ictxt)
te = extendTypeEnvWithIds te1 (map instanceDFunId cls_insts)
ids = typeEnvIds te
tyvars = mapUnionVarSet (tyCoVarsOfType . idType) ids
tyvars = tyCoVarsOfTypesList $ map 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]
......
......@@ -30,7 +30,7 @@ import InstEnv
import Class
import Avail
import CoreSyn
import CoreFVs( exprsSomeFreeVars )
import CoreFVs( exprsSomeFreeVarsList )
import CoreSubst
import PprCore
import DsMonad
......@@ -574,7 +574,9 @@ dsRule (L loc (HsRule name rule_act vars lhs _tv_lhs rhs _fv_rhs))
fn_name = idName fn_id
final_rhs = simpleOptExpr rhs'' -- De-crap it
rule_name = snd (unLoc name)
arg_ids = varSetElems (exprsSomeFreeVars isId args `delVarSetList` final_bndrs)
final_bndrs_set = mkVarSet final_bndrs
arg_ids = filterOut (`elemVarSet` final_bndrs_set) $
exprsSomeFreeVarsList isId args
; dflags <- getDynFlags
; rule <- dsMkUserRule this_mod is_local
......
......@@ -937,7 +937,7 @@ dsRecCmd ids local_vars stmts later_ids later_rets rec_ids rec_rets = do
core_rec_rets <- mapM dsExpr rec_rets
let
-- possibly polymorphic version of vars of later_ids and rec_ids
out_ids = varSetElems (unionVarSets (map exprFreeIds (core_later_rets ++ core_rec_rets)))
out_ids = exprsFreeIdsList (core_later_rets ++ core_rec_rets)
out_ty = mkBigCoreVarTupTy out_ids
later_tuple = mkBigCoreTup core_later_rets
......
......@@ -800,7 +800,9 @@ decomposeRuleLhs orig_bndrs orig_lhs
-- Add extra dict binders: Note [Free dictionaries]
mk_extra_dict_bndrs fn_id args
= [ mkLocalId (localiseName (idName d)) (idType d)
| d <- varSetElems (exprsFreeVars args `delVarSetList` (fn_id : orig_bndrs))
| d <- exprsFreeVarsList args
, not (d `elemVarSet` orig_bndr_set)
, not (d == fn_id)
-- fn_id: do not quantify over the function itself, which may
-- itself be a dictionary (in pathological cases, Trac #10251)
, isDictId d ]
......
......@@ -526,8 +526,7 @@ bindLocalsAtBreakpoint hsc_env apStack_fhv (Just BreakInfo{..}) = do
(ids, offsets) = unzip pointers
free_tvs = mapUnionVarSet (tyCoVarsOfType . idType) ids
`unionVarSet` tyCoVarsOfType result_ty
free_tvs = tyCoVarsOfTypesList (result_ty:map idType ids)
-- It might be that getIdValFromApStack fails, because the AP_STACK
-- has been accidentally evaluated, or something else has gone wrong.
......@@ -573,12 +572,12 @@ bindLocalsAtBreakpoint hsc_env apStack_fhv (Just BreakInfo{..}) = do
= do { name <- newInteractiveBinder hsc_env occ (getSrcSpan old_id)
; return (Id.mkVanillaGlobalWithInfo name ty (idInfo old_id)) }
newTyVars :: UniqSupply -> TcTyVarSet -> TCvSubst
newTyVars :: UniqSupply -> [TcTyVar] -> TCvSubst
-- Similarly, clone the type variables mentioned in the types
-- we have here, *and* make them all RuntimeUnk tyvars
newTyVars us tvs
= mkTvSubstPrs [ (tv, mkTyVarTy (mkRuntimeUnkTyVar name (tyVarKind tv)))
| (tv, uniq) <- varSetElems tvs `zip` uniqsFromSupply us
| (tv, uniq) <- tvs `zip` uniqsFromSupply us
, let name = setNameUnique (tyVarName tv) uniq ]
rttiEnvironment :: HscEnv -> IO HscEnv
......
......@@ -951,7 +951,7 @@ findExternalRules omit_prags binds imp_id_rules unfold_env
expose_rule rule
| omit_prags = False
| otherwise = all is_external_id (varSetElems (ruleLhsFreeIds rule))
| otherwise = all is_external_id (ruleLhsFreeIdsList rule)
-- Don't expose a rule whose LHS mentions a locally-defined
-- Id that is completely internal (i.e. not visible to an
-- importing module). NB: ruleLhsFreeIds only returns LocalIds.
......
......@@ -33,7 +33,7 @@ import Module ( Module, ModuleSet, elemModuleSet )
import CoreSubst
import OccurAnal ( occurAnalyseExpr )
import CoreFVs ( exprFreeVars, exprsFreeVars, bindFreeVars
, rulesFreeVarsDSet, exprsOrphNames )
, rulesFreeVarsDSet, exprsOrphNames, exprFreeVarsList )
import CoreUtils ( exprType, eqExpr, mkTick, mkTicks,
stripTicksTopT, stripTicksTopE )
import PprCore ( pprRules )
......@@ -898,7 +898,7 @@ match_tmpl_var :: RuleMatchEnv
match_tmpl_var renv@(RV { rv_lcl = rn_env, rv_fltR = flt_env })
subst@(RS { rs_id_subst = id_subst, rs_bndrs = let_bndrs })
v1' e2
| any (inRnEnvR rn_env) (varSetElems (exprFreeVars e2))
| any (inRnEnvR rn_env) (exprFreeVarsList e2)
= Nothing -- Occurs check failure
-- e.g. match forall a. (\x-> a x) against (\y. y y)
......
......@@ -1950,7 +1950,7 @@ mkDictErr ctxt cts
is_no_inst (ct, (matches, unifiers, _))
= no_givens
&& null matches
&& (null unifiers || all (not . isAmbiguousTyVar) (varSetElems (tyCoVarsOfCt ct)))
&& (null unifiers || all (not . isAmbiguousTyVar) (tyCoVarsOfCtList ct))
lookup_cls_inst inst_envs ct
-- Note [Flattening in error message generation]
......
......@@ -395,7 +395,7 @@ runSolverPipeline pipeline workItem
ContinueWith ct -> do { traceFireTcS (ctEvidence ct) (text "Kept as inert")
; traceTcS "End solver pipeline (kept as inert) }" $
vcat [ text "final_item =" <+> ppr ct
, pprTvBndrs (varSetElems $ tyCoVarsOfCt ct)
, pprTvBndrs $ tyCoVarsOfCtList ct
, text "inerts =" <+> ppr final_is]
; addInertCan ct }
}
......
......@@ -560,7 +560,8 @@ simplifyInfer rhs_tclvl apply_mr sigs name_taus wanteds
-- hence "incl_derivs"
else do { let quant_cand = approximateWC wanted_transformed
meta_tvs = filter isMetaTyVar (varSetElems (tyCoVarsOfCts quant_cand))
meta_tvs = filter isMetaTyVar $
tyCoVarsOfCtsList quant_cand
; gbl_tvs <- tcGetGlobalTyCoVars
-- Miminise quant_cand. We are not interested in any evidence
......@@ -1775,7 +1776,7 @@ floatEqualities skols no_given_eqs
| otherwise
= do { outer_tclvl <- TcS.getTcLevel
; mapM_ (promoteTyVarTcS outer_tclvl)
(varSetElems (tyCoVarsOfCts float_eqs))
(tyCoVarsOfCtsList float_eqs)
-- See Note [Promoting unification variables]
; traceTcS "floatEqualities" (vcat [ text "Skols =" <+> ppr skols
......
......@@ -672,8 +672,8 @@ irClass cls
cls_tv_set = mkVarSet cls_tvs
ir_at at_tc
= mapM_ (updateRole Nominal) (varSetElems nvars)
where nvars = (mkVarSet $ tyConTyVars at_tc) `intersectVarSet` cls_tv_set
= mapM_ (updateRole Nominal) nvars
where nvars = filter (`elemVarSet` cls_tv_set) $ tyConTyVars at_tc
-- See Note [Role inference]
irDataCon :: DataCon -> RoleM ()
......
......@@ -1755,8 +1755,9 @@ checkZonkValidTelescope hs_tvs orig_tvs extra
-- over it in kindGeneralize, as we should.
go errs in_scope (tv:tvs)
= let bad_tvs = tyCoVarsOfType (tyVarKind tv) `minusVarSet` in_scope in
go (varSetElems bad_tvs ++ errs) (in_scope `extendVarSet` tv) tvs
= let bad_tvs = filterOut (`elemVarSet` in_scope) $
tyCoVarsOfTypeList (tyVarKind tv)
in go (bad_tvs ++ errs) (in_scope `extendVarSet` tv) tvs
-- | After inferring kinds of type variables, check to make sure that the
-- inferred kinds any of the type variables bound in a smaller scope.
......
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