\begin{code}
module FreeVars (
-- Cheap and cheerful variant...
- exprFreeVars,
+ exprFreeVars, exprFreeTyVars,
-- Complicated and expensive variant for float-out
freeVars,
import AnnCoreSyn -- output
import CoreSyn
+import CoreUtils ( idSpecVars )
import Id ( idType, getIdArity, isBottomingId,
- emptyIdSet, unitIdSet, mkIdSet,
+ emptyIdSet, unitIdSet, mkIdSet, unionIdSets,
elementOfIdSet, minusIdSet, unionManyIdSets,
IdSet, Id
)
import PrimOp ( PrimOp(..) )
import Type ( tyVarsOfType, Type )
import TyVar ( emptyTyVarSet, unitTyVarSet, minusTyVarSet,
- intersectTyVarSets,
+ intersectTyVarSets, unionManyTyVarSets,
TyVarSet, TyVar
)
import BasicTypes ( Unused )
-import UniqSet ( unionUniqSets, addOneToUniqSet )
+import UniqSet ( unionUniqSets, addOneToUniqSet, delOneFromUniqSet )
import Util ( panic, assertPanic )
+
\end{code}
%************************************************************************
is_among = elementOfIdSet
munge_id_ty i = tyVarsOfType (idType i)
combine = unionUniqSets -- used both for {Id,TyVar}Sets
+without = delOneFromUniqSet
add = addOneToUniqSet
combineFVInfo (FVInfo fvs1 tfvs1 leak1) (FVInfo fvs2 tfvs2 leak2)
freeVars :: CoreExpr -> CoreExprWithFVs
freeVars expr = fvExpr noIdCands noTyVarCands expr
+
\end{code}
%************************************************************************
-> CoreExprWithFVs
fvExpr id_cands tyvar_cands (Var v)
- = (FVInfo (if (v `is_among` id_cands)
- then aFreeId v
- else noFreeIds)
- noFreeTyVars
- leakiness,
- AnnVar v)
+ = (FVInfo fvs noFreeTyVars leakiness, AnnVar v)
where
+ {-
+ ToDo: insert motivating example for why we *need*
+ to include the idSpecVars in the FV list.
+ -}
+ fvs = fvs_v `unionIdSets` mkIdSet (idSpecVars v)
+
+ fvs_v
+ | v `is_among` id_cands = aFreeId v
+ | otherwise = noFreeIds
+
leakiness
| isBottomingId v = lEAK_FREE_BIG -- Hack
| otherwise = case getIdArity v of
binder_ftvs = munge_id_ty binder
-- We need to collect free tyvars from the binder
+-- Don't forget to notice that the idSpecVars of the binder
+-- are free in the whole expression; albeit not in the RHS or body
+
fvExpr id_cands tyvar_cands (Let (NonRec binder rhs) body)
- = (FVInfo (freeVarsOf rhs' `combine` body_fvs)
+ = (FVInfo (freeVarsOf rhs' `combine` body_fvs `combine` mkIdSet (idSpecVars binder))
(freeTyVarsOf rhs' `combine` freeTyVarsOf body2 `combine` binder_ftvs)
(leakinessOf rhs' `orLeak` leakinessOf body2),
AnnLet (AnnNonRec binder rhs') body2)
where
- rhs' = fvExpr id_cands tyvar_cands rhs
+ rhs' = fvRhs id_cands tyvar_cands (binder, rhs)
body2 = fvExpr (aFreeId binder `combine` id_cands) tyvar_cands body
body_fvs = freeVarsOf body2 `minusIdSet` aFreeId binder
binder_ftvs = munge_id_ty binder
(binders, rhss) = unzip binds
new_id_cands = binders_set `combine` id_cands
binders_set = mkIdSet binders
- rhss' = map (fvExpr new_id_cands tyvar_cands) rhss
+ rhss' = map (fvRhs new_id_cands tyvar_cands) binds
FVInfo rhss_fvs rhss_tfvs leakiness_of_rhss
= foldr1 combineFVInfo [info | (info,_) <- rhss']
- binds_fvs = rhss_fvs `minusIdSet` binders_set
+ -- Don't forget to notice that the idSpecVars of the binder
+ -- are free in the whole expression; albeit not in the RHS or body
+ binds_fvs = (foldr (unionIdSets . mkIdSet . idSpecVars) rhss_fvs binders)
+ `minusIdSet`
+ binders_set
+
body2 = fvExpr new_id_cands tyvar_cands body
body_fvs = freeVarsOf body2 `minusIdSet` binders_set
binders_ftvs = foldr (combine . munge_id_ty) noFreeTyVars binders
= (fvinfo, AnnNote other_note expr2)
where
expr2@(fvinfo,_) = fvExpr id_cands tyvar_cands expr
+
+fvRhs id_cands tyvar_cands (bndr,rhs)
+ = fvExpr id_cands tyvar_cands rhs
\end{code}
\begin{code}
| fv_cand v = aFreeId v
| otherwise = noFreeIds
\end{code}
+
+
+\begin{code}
+exprFreeTyVars :: CoreExpr -> TyVarSet
+exprFreeTyVars = expr_ftvs
+
+expr_ftvs :: CoreExpr -> TyVarSet
+expr_ftvs (Var v) = noFreeTyVars
+expr_ftvs (Lit lit) = noFreeTyVars
+expr_ftvs (Con con args) = args_ftvs args
+expr_ftvs (Prim op args) = args_ftvs args
+expr_ftvs (Note _ expr) = expr_ftvs expr
+expr_ftvs (App fun arg) = expr_ftvs fun `combine` arg_ftvs arg
+
+expr_ftvs (Lam (ValBinder b) body) = expr_ftvs body
+expr_ftvs (Lam (TyBinder b) body) = expr_ftvs body `without` b
+
+expr_ftvs (Case scrut alts)
+ = expr_ftvs scrut `combine` alts_ftvs
+ where
+ alts_ftvs
+ = case alts of
+ AlgAlts alg_alts deflt -> unionManyTyVarSets (deflt_ftvs : alt_ftvs)
+ where
+ alt_ftvs = map do_alg_alt alg_alts
+ deflt_ftvs = do_deflt deflt
+
+ PrimAlts prim_alts deflt -> unionManyTyVarSets (deflt_ftvs : alt_ftvs)
+ where
+ alt_ftvs = map do_prim_alt prim_alts
+ deflt_ftvs = do_deflt deflt
+
+ do_alg_alt :: (Id, [Id], CoreExpr) -> TyVarSet
+ do_alg_alt (con, args, rhs) = expr_ftvs rhs
+
+ do_prim_alt (lit, rhs) = expr_ftvs rhs
+
+ do_deflt NoDefault = noFreeTyVars
+ do_deflt (BindDefault b rhs) = expr_ftvs rhs
+
+expr_ftvs (Let (NonRec b r) body)
+ = bind_ftvs (b,r) `combine` expr_ftvs body
+
+expr_ftvs (Let (Rec pairs) body)
+ = foldr (combine . bind_ftvs) noFreeTyVars pairs `combine`
+ expr_ftvs body
+
+--------------------------------------
+bind_ftvs (b,e) = tyVarsOfType (idType b) `combine` expr_ftvs e
+
+--------------------------------------
+arg_ftvs (TyArg ty) = tyVarsOfType ty
+arg_ftvs other_arg = noFreeTyVars
+
+--------------------------------------
+args_ftvs args = foldr (combine . arg_ftvs) noFreeTyVars args
+\end{code}
projects / ghc-hetmet.git / blobdiff