\begin{code}
-idFreeVars :: Id -> VarSet
-idFreeVars id = ASSERT( isId id) idRuleVars id `unionVarSet` idFreeTyVars id
-
-idFreeTyVars :: Id -> TyVarSet
--- Only local Ids conjured up locally, can have free type variables.
--- (During type checking top-level Ids can have free tyvars)
-idFreeTyVars id = tyVarsOfType (idType id)
--- | isLocalId id = tyVarsOfType (idType id)
--- | otherwise = emptyVarSet
-
-idRuleVars ::Id -> VarSet
-idRuleVars id = ASSERT( isId id) rulesRhsFreeVars (idSpecialisation id)
-
rulesSomeFreeVars :: InterestingVarFun -> CoreRules -> VarSet
rulesSomeFreeVars interesting (Rules rules _)
= foldr (unionVarSet . ruleSomeFreeVars interesting) emptyVarSet rules
aFreeVar = unitVarSet
unionFVs = unionVarSet
-filters :: Var -> VarSet -> VarSet
+delBindersFV :: [Var] -> VarSet -> VarSet
+delBindersFV bs fvs = foldr delBinderFV fvs bs
+
+delBinderFV :: Var -> VarSet -> VarSet
+-- This way round, so we can do it multiple times using foldr
--- (b `filters` s) removes the binder b from the free variable set s,
+-- (b `delBinderFV` s) removes the binder b from the free variable set s,
-- but *adds* to s
-- (a) the free variables of b's type
-- (b) the idSpecVars of b
-- where
-- bottom = bottom -- Never evaluated
-filters b s | isId b = (s `delVarSet` b) `unionFVs` idFreeVars b
- | otherwise = s `delVarSet` b
+delBinderFV b s | isId b = (s `delVarSet` b) `unionFVs` idFreeVars b
+ | otherwise = s `delVarSet` b
+
+idFreeVars :: Id -> VarSet
+idFreeVars id = ASSERT( isId id) idRuleVars id `unionVarSet` idFreeTyVars id
+
+idFreeTyVars :: Id -> TyVarSet
+-- Only local Ids conjured up locally, can have free type variables.
+-- (During type checking top-level Ids can have free tyvars)
+idFreeTyVars id = tyVarsOfType (idType id)
+-- | isLocalId id = tyVarsOfType (idType id)
+-- | otherwise = emptyVarSet
+
+idRuleVars ::Id -> VarSet
+idRuleVars id = ASSERT( isId id) rulesRhsFreeVars (idSpecialisation id)
\end{code}
freeVars (Lit lit) = (noFVs, AnnLit lit)
freeVars (Lam b body)
- = (b `filters` freeVarsOf body', AnnLam b body')
+ = (b `delBinderFV` freeVarsOf body', AnnLam b body')
where
body' = freeVars body
arg2 = freeVars arg
freeVars (Case scrut bndr alts)
- = ((bndr `filters` alts_fvs) `unionFVs` freeVarsOf scrut2,
+ = ((bndr `delBinderFV` alts_fvs) `unionFVs` freeVarsOf scrut2,
AnnCase scrut2 bndr alts2)
where
scrut2 = freeVars scrut
(alts_fvs_s, alts2) = mapAndUnzip fv_alt alts
alts_fvs = foldr1 unionFVs alts_fvs_s
- fv_alt (con,args,rhs) = (foldr filters (freeVarsOf rhs2) args,
+ fv_alt (con,args,rhs) = (delBindersFV args (freeVarsOf rhs2),
(con, args, rhs2))
where
rhs2 = freeVars rhs
where
rhs2 = freeVars rhs
body2 = freeVars body
- body_fvs = binder `filters` freeVarsOf body2
+ body_fvs = binder `delBinderFV` freeVarsOf body2
freeVars (Let (Rec binds) body)
= (foldl delVarSet group_fvs binders,
- -- The "filters" part may have added one of the binders
+ -- The "delBinderFV" part may have added one of the binders
-- via the idSpecVars part, so we must delete it again
AnnLet (AnnRec (binders `zip` rhss2)) body2)
where
rhss2 = map freeVars rhss
all_fvs = foldr (unionFVs . fst) body_fvs rhss2
- group_fvs = foldr filters all_fvs binders
+ group_fvs = delBindersFV binders all_fvs
body2 = freeVars body
body_fvs = freeVarsOf body2
coreTopBindToStg binders fv_binds bind `thenLne` \ (bind', fv_bind) ->
returnLne (
(bind' : binds'),
- (fv_binds `unionFVInfo` fv_bind) `minusFVBinders` binders
+ binders `minusFVBinders` (fv_binds `unionFVInfo` fv_bind)
)
)
coreToStgExpr body `thenLne` \ (body, body_fvs, body_escs) ->
let
set_of_args = mkVarSet args'
- fvs = body_fvs `minusFVBinders` args'
+ fvs = args' `minusFVBinders` body_fvs
escs = body_escs `minusVarSet` set_of_args
in
if null args'
in
returnLne (
StgCase scrut2 live_in_whole_case live_in_alts bndr' noSRT alts2,
- (scrut_fvs `unionFVInfo` alts_fvs) `minusFVBinders` [bndr],
+ bndr `minusFVBinder` (scrut_fvs `unionFVInfo` alts_fvs),
(alts_escs `minusVarSet` unitVarSet bndr) `unionVarSet` getFVSet scrut_fvs
-- You might think we should have scrut_escs, not (getFVSet scrut_fvs),
-- but actually we can't call, and then return from, a let-no-escape thing.
in
returnLne (
(con, binders', good_use_mask, rhs2),
- rhs_fvs `minusFVBinders` binders',
+ binders' `minusFVBinders` rhs_fvs,
rhs_escs `minusVarSet` mkVarSet binders'
-- ToDo: remove the minusVarSet;
-- since escs won't include any of these binders
-- The live variables of this binding are the ones which are live
-- by virtue of being accessible via the free vars of the binding (lvs_from_fvs)
-- together with the live_in_cont ones
- lookupLiveVarsForSet (bind_fvs `minusFVBinders` binders)
+ lookupLiveVarsForSet (binders `minusFVBinders` bind_fvs)
`thenLne` \ lvs_from_fvs ->
let
bind_lvs = lvs_from_fvs `unionVarSet` live_in_cont
| otherwise = StgLet bind2 body2
free_in_whole_let
- = (bind_fvs `unionFVInfo` body_fvs) `minusFVBinders` binders
+ = binders `minusFVBinders` (bind_fvs `unionFVInfo` body_fvs)
live_in_whole_let
= bind_lvs `unionVarSet` (body_lvs `minusVarSet` set_of_binders)
type FreeVarsInfo = VarEnv (Var, Bool, StgBinderInfo)
-- If f is mapped to noBinderInfo, that means
-- that f *is* mentioned (else it wouldn't be in the
- -- IdEnv at all), but only in a saturated applications.
+ -- IdEnv at all), but perhaps in an unsaturated applications.
--
-- All case/lambda-bound things are also mapped to
-- noBinderInfo, since we aren't interested in their
unionFVInfos :: [FreeVarsInfo] -> FreeVarsInfo
unionFVInfos fvs = foldr unionFVInfo emptyFVInfo fvs
-minusFVBinders :: FreeVarsInfo -> [Id] -> FreeVarsInfo
-minusFVBinders fv ids = fv `delVarEnvList` ids
+minusFVBinders :: [Id] -> FreeVarsInfo -> FreeVarsInfo
+minusFVBinders vs fv = foldr minusFVBinder fv vs
+
+minusFVBinder :: Id -> FreeVarsInfo -> FreeVarsInfo
+minusFVBinder v fv | isId v = (fv `delVarEnv` v) `unionFVInfo`
+ tyvarFVInfo (tyVarsOfType (idType v))
+ | otherwise = fv `delVarEnv` v
+ -- When removing a binder, remember to add its type variables
+ -- c.f. CoreFVs.delBinderFV
elementOfFVInfo :: Id -> FreeVarsInfo -> Bool
elementOfFVInfo id fvs = maybeToBool (lookupVarEnv fvs id)
projects / ghc-hetmet.git / commitdiff