From c498f73689fb3762e92b2611ab4b4d63db7c80a3 Mon Sep 17 00:00:00 2001 From: simonpj Date: Mon, 26 Feb 2001 17:10:16 +0000 Subject: [PATCH] [project @ 2001-02-26 17:10:16 by simonpj] Make CoreToStg generate correct free-var info for type variables --- ghc/compiler/coreSyn/CoreFVs.lhs | 50 ++++++++++++++++++++----------------- ghc/compiler/stgSyn/CoreToStg.lhs | 25 ++++++++++++------- 2 files changed, 43 insertions(+), 32 deletions(-) diff --git a/ghc/compiler/coreSyn/CoreFVs.lhs b/ghc/compiler/coreSyn/CoreFVs.lhs index 49d6b39..d170a3b 100644 --- a/ghc/compiler/coreSyn/CoreFVs.lhs +++ b/ghc/compiler/coreSyn/CoreFVs.lhs @@ -167,19 +167,6 @@ expr_fvs (Let (Rec pairs) body) \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 @@ -228,9 +215,13 @@ noFVs = emptyVarSet 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 @@ -258,8 +249,21 @@ filters :: Var -> VarSet -> VarSet -- 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} @@ -285,7 +289,7 @@ freeVars (Var v) 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 @@ -296,7 +300,7 @@ freeVars (App fun arg) 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 @@ -304,7 +308,7 @@ freeVars (Case scrut bndr alts) (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 @@ -315,11 +319,11 @@ freeVars (Let (NonRec binder rhs) body) 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 @@ -327,7 +331,7 @@ freeVars (Let (Rec binds) body) 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 diff --git a/ghc/compiler/stgSyn/CoreToStg.lhs b/ghc/compiler/stgSyn/CoreToStg.lhs index e4752c5..58c07c8 100644 --- a/ghc/compiler/stgSyn/CoreToStg.lhs +++ b/ghc/compiler/stgSyn/CoreToStg.lhs @@ -125,7 +125,7 @@ coreTopBindsToStg (bind:binds) 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) ) ) @@ -271,7 +271,7 @@ coreToStgExpr expr@(Lam _ _) 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' @@ -330,7 +330,7 @@ coreToStgExpr (Case scrut bndr alts) 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. @@ -386,7 +386,7 @@ coreToStgExpr (Case scrut bndr alts) 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 @@ -578,7 +578,7 @@ coreToStgLet let_no_escape bind body -- 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 @@ -605,7 +605,7 @@ coreToStgLet let_no_escape bind body | 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) @@ -835,7 +835,7 @@ lookupLiveVarsForSet fvs env lvs_cont 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 @@ -869,8 +869,15 @@ unionFVInfo fv1 fv2 = plusVarEnv_C plusFVInfo fv1 fv2 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) -- 1.7.10.4