%
-% (c) The GRASP/AQUA Project, Glasgow University, 1992-1995
+% (c) The GRASP/AQUA Project, Glasgow University, 1992-1996
%
Taken quite directly from the Peyton Jones/Lester paper.
\begin{code}
-#include "HsVersions.h"
-
module FreeVars (
- freeVars,
-
-#ifdef DPH
--- ToDo: DPH: you should probably use addExprFVs now... [WDP]
- freeStuff, -- Need a function that gives fvs of
- -- an expression. I therefore need a
- -- way of passing in candidates or top
- -- level will always be empty.
-#endif {- Data Parallel Haskell -}
-
- -- cheap and cheerful variant...
- addTopBindsFVs,
+ -- Cheap and cheerful variant...
+ exprFreeVars, exprFreeTyVars,
+ -- Complicated and expensive variant for float-out
+ freeVars,
freeVarsOf, freeTyVarsOf,
- FVCoreExpr(..), FVCoreBinding(..),
-
- CoreExprWithFVs(..), -- For the above functions
- AnnCoreExpr(..), -- Dito
- FVInfo(..), LeakInfo(..),
-
- -- and to make the interface self-sufficient...
- CoreExpr, Id, IdSet(..), TyVarSet(..), UniqSet(..), UniType,
- AnnCoreExpr', AnnCoreBinding, AnnCoreCaseAlternatives,
- AnnCoreCaseDefault
+ CoreExprWithFVs, -- For the above functions
+ AnnCoreExpr, -- Dito
+ FVInfo(..), LeakInfo(..)
) where
+#include "HsVersions.h"
-import PlainCore -- input
import AnnCoreSyn -- output
-import AbsPrel ( PrimOp(..), PrimKind -- for CCallOp
- IF_ATTACK_PRAGMAS(COMMA tagOf_PrimOp)
- IF_ATTACK_PRAGMAS(COMMA pprPrimOp)
+import CoreSyn
+import CoreUtils ( idSpecVars )
+import Id ( idType, getIdArity, isBottomingId,
+ emptyIdSet, unitIdSet, mkIdSet, unionIdSets,
+ elementOfIdSet, minusIdSet, unionManyIdSets,
+ IdSet, Id
+ )
+import IdInfo ( ArityInfo(..) )
+import PrimOp ( PrimOp(CCallOp) )
+import Type ( tyVarsOfType, Type )
+import TyVar ( emptyTyVarSet, unitTyVarSet, minusTyVarSet,
+ intersectTyVarSets, unionManyTyVarSets,
+ TyVarSet, TyVar
)
-import AbsUniType ( extractTyVarsFromTy )
-import BasicLit ( typeOfBasicLit )
-import Id ( getIdUniType, getIdArity, toplevelishId, isBottomingId )
-import IdInfo -- Wanted for arityMaybe, but it seems you have
- -- to import it all... (Death to the Instance Virus!)
-import Maybes
-import UniqSet
-import Util
+import BasicTypes ( Unused )
+
+import UniqSet ( unionUniqSets, addOneToUniqSet, delOneFromUniqSet )
+import Util ( panic, assertPanic )
+
\end{code}
%************************************************************************
but I might be wrong. (SLPJ, date unknown)
\begin{code}
-type CoreExprWithFVs = AnnCoreExpr Id Id FVInfo
+type CoreExprWithFVs = AnnCoreExpr Id Id Unused FVInfo
type TyVarCands = TyVarSet -- for when we carry around lists of
type IdCands = IdSet -- "candidate" TyVars/Ids.
-noTyVarCands = emptyUniqSet
-noIdCands = emptyUniqSet
-
-data FVInfo = FVInfo
- IdSet -- Free ids
- TyVarSet -- Free tyvars
- LeakInfo
-
-noFreeIds = emptyUniqSet
-noFreeTyVars = emptyUniqSet
-aFreeId i = singletonUniqSet i
-aFreeTyVar t = singletonUniqSet t
-is_among = elementOfUniqSet
-combine = unionUniqSets
-munge_id_ty i = mkUniqSet (extractTyVarsFromTy (getIdUniType i))
+noTyVarCands = emptyTyVarSet
+noIdCands = emptyIdSet
+
+data FVInfo
+ = FVInfo IdSet -- Free ids
+ TyVarSet -- Free tyvars
+ LeakInfo
+
+noFreeIds = emptyIdSet
+noFreeTyVars = emptyTyVarSet
+noFreeAnything = (noFreeIds, noFreeTyVars)
+aFreeId i = unitIdSet i
+aFreeTyVar t = unitTyVarSet t
+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)
- = FVInfo (fvs1 `combine` fvs2)
- (tfvs1 `combine` tfvs2)
- (leak1 `orLeak` leak2)
+ = FVInfo (fvs1 `combine` fvs2)
+ (tfvs1 `combine` tfvs2)
+ (leak1 `orLeak` leak2)
\end{code}
-Leak-free-ness is based only on the value, not the type.
-In particular, nested collections of constructors are guaranteed leak free.
-Function applications are not, except for PAPs.
+Leak-free-ness is based only on the value, not the type. In
+particular, nested collections of constructors are guaranteed leak
+free. Function applications are not, except for PAPs.
Applications of error gets (LeakFree bigArity) -- a hack!
Main public interface:
\begin{code}
-freeVars :: PlainCoreExpr -> CoreExprWithFVs
+freeVars :: CoreExpr -> CoreExprWithFVs
freeVars expr = fvExpr noIdCands noTyVarCands expr
+
\end{code}
+%************************************************************************
+%* *
\subsection{Free variables (and types)}
+%* *
+%************************************************************************
We do the free-variable stuff by passing around ``candidates lists''
of @Ids@ and @TyVars@ that may be considered free. This is useful,
fvExpr :: IdCands -- In-scope Ids
-> TyVarCands -- In-scope tyvars
- -> PlainCoreExpr
+ -> CoreExpr
-> CoreExprWithFVs
-fvExpr id_cands tyvar_cands (CoVar v)
- = (FVInfo (if (v `is_among` id_cands)
- then aFreeId v
- else noFreeIds)
- noFreeTyVars
- leakiness,
- AnnCoVar v)
+fvExpr id_cands tyvar_cands (Var 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 arityMaybe (getIdArity v) of
- Nothing -> lEAK_FREE_0
- Just arity -> LeakFree arity
+ | otherwise = case getIdArity v of
+ UnknownArity -> lEAK_FREE_0
+ ArityAtLeast arity -> LeakFree arity
+ ArityExactly arity -> LeakFree arity
-fvExpr id_cands tyvar_cands (CoLit k)
- = (FVInfo noFreeIds noFreeTyVars lEAK_FREE_0, AnnCoLit k)
+fvExpr id_cands tyvar_cands (Lit k)
+ = (FVInfo noFreeIds noFreeTyVars lEAK_FREE_0, AnnLit k)
-fvExpr id_cands tyvar_cands (CoCon c tys args)
- = (FVInfo args_fvs tfvs lEAK_FREE_0, AnnCoCon c tys args)
+fvExpr id_cands tyvar_cands (Con c args)
+ = (FVInfo args_fvs tfvs lEAK_FREE_0, AnnCon c args)
where
- args_fvs = foldr (combine . freeAtom id_cands) noFreeIds args
- tfvs = foldr (combine . freeTy tyvar_cands) noFreeTyVars tys
+ (args_fvs, tfvs) = freeArgs id_cands tyvar_cands args
-fvExpr id_cands tyvar_cands (CoPrim op@(CCallOp _ _ _ _ res_ty) tys args)
- = ASSERT (null tys)
- (FVInfo args_fvs tfvs lEAK_FREE_0, AnnCoPrim op tys args)
+fvExpr id_cands tyvar_cands (Prim op args)
+ = (FVInfo args_fvs tfvs lEAK_FREE_0, AnnPrim op args)
where
- args_fvs = foldr (combine . freeAtom id_cands) noFreeIds args
- tfvs = foldr (combine . freeTy tyvar_cands) noFreeTyVars (res_ty:tys)
+ (args_fvs, tfvs) = freeArgs id_cands tyvar_cands args_to_use{-NB-}
+ args_to_use
+ = case op of
+ CCallOp _ _ _ _ _ res_ty -> TyArg res_ty : args
+ _ -> args
-fvExpr id_cands tyvar_cands (CoPrim op tys args)
- = (FVInfo args_fvs tfvs lEAK_FREE_0, AnnCoPrim op tys args)
- where
- args_fvs = foldr (combine . freeAtom id_cands) noFreeIds args
- tfvs = foldr (combine . freeTy tyvar_cands) noFreeTyVars tys
+-- this Lam stuff could probably be improved by rewriting (WDP 96/03)
-fvExpr id_cands tyvar_cands (CoLam binders body)
- = (FVInfo (freeVarsOf body2 `minusUniqSet` mkUniqSet binders)
- (freeTyVarsOf body2 `combine` binder_ftvs)
+fvExpr id_cands tyvar_cands (Lam b@(ValBinder binder) body)
+ = (FVInfo (freeVarsOf body2 `minusIdSet` unitIdSet binder)
+ (freeTyVarsOf body2 `combine` munge_id_ty binder)
leakiness,
- AnnCoLam binders body2)
+ AnnLam b body2)
where
-- We need to collect free tyvars from the binders
- body2 = fvExpr (mkUniqSet binders `combine` id_cands) tyvar_cands body
-
- binder_ftvs
- = foldr (combine . munge_id_ty) noFreeTyVars binders
+ body2 = fvExpr (unitIdSet binder `combine` id_cands) tyvar_cands body
- no_args = length binders
leakiness = case leakinessOf body2 of
- MightLeak -> LeakFree no_args
- LeakFree n -> LeakFree (n + no_args)
+ MightLeak -> LeakFree 1
+ LeakFree n -> LeakFree (n + 1)
-fvExpr id_cands tyvar_cands (CoTyLam tyvar body)
+fvExpr id_cands tyvar_cands (Lam b@(TyBinder tyvar) body)
= (FVInfo (freeVarsOf body2)
- (freeTyVarsOf body2 `minusUniqSet` aFreeTyVar tyvar)
+ (freeTyVarsOf body2 `minusTyVarSet` aFreeTyVar tyvar)
(leakinessOf body2),
- AnnCoTyLam tyvar body2)
+ AnnLam b body2)
where
body2 = fvExpr id_cands (aFreeTyVar tyvar `combine` tyvar_cands) body
-fvExpr id_cands tyvar_cands (CoApp fun arg)
- = (FVInfo (freeVarsOf fun2 `combine` fvs_arg)
- (freeTyVarsOf fun2)
+-- ditto on rewriting this App stuff (WDP 96/03)
+
+fvExpr id_cands tyvar_cands (App fun arg)
+ = (FVInfo (freeVarsOf fun2 `combine` fvs_arg)
+ (freeTyVarsOf fun2 `combine` tfvs_arg)
leakiness,
- AnnCoApp fun2 arg)
+ AnnApp fun2 arg)
where
fun2 = fvExpr id_cands tyvar_cands fun
- fvs_arg = freeAtom id_cands arg
+ fun2_leakiness = leakinessOf fun2
- leakiness = case leakinessOf fun2 of
- LeakFree n | n>1 -> LeakFree (n-1) -- Note > not >=
- other -> MightLeak
+ (fvs_arg, tfvs_arg) = freeArgs id_cands tyvar_cands [arg]
-fvExpr id_cands tyvar_cands (CoTyApp expr ty)
- = (FVInfo (freeVarsOf expr2)
- (freeTyVarsOf expr2 `combine` tfvs_arg)
- (leakinessOf expr2),
- AnnCoTyApp expr2 ty)
- where
- expr2 = fvExpr id_cands tyvar_cands expr
- tfvs_arg = freeTy tyvar_cands ty
+ leakiness = if (notValArg arg) then
+ fun2_leakiness
+ else
+ case fun2_leakiness of
+ LeakFree n | n>1 -> LeakFree (n-1) -- Note > not >=
+ other -> MightLeak
-fvExpr id_cands tyvar_cands (CoCase expr alts)
+fvExpr id_cands tyvar_cands (Case expr alts)
= (combineFVInfo expr_fvinfo alts_fvinfo,
- AnnCoCase expr2 alts')
+ AnnCase expr2 alts')
where
expr2@(expr_fvinfo,_) = fvExpr id_cands tyvar_cands expr
(alts_fvinfo, alts') = annotate_alts alts
- annotate_alts (CoAlgAlts alts deflt)
- = (fvinfo, AnnCoAlgAlts alts' deflt')
+ annotate_alts (AlgAlts alts deflt)
+ = (fvinfo, AnnAlgAlts alts' deflt')
where
(alts_fvinfo_s, alts') = unzip (map ann_boxed_alt alts)
(deflt_fvinfo, deflt') = annotate_default deflt
- fvinfo = foldr combineFVInfo deflt_fvinfo alts_fvinfo_s
+ fvinfo = foldr combineFVInfo deflt_fvinfo alts_fvinfo_s
ann_boxed_alt (con, params, rhs)
- = (FVInfo (freeVarsOf rhs' `minusUniqSet` mkUniqSet params)
+ = (FVInfo (freeVarsOf rhs' `minusIdSet` mkIdSet params)
(freeTyVarsOf rhs' `combine` param_ftvs)
(leakinessOf rhs'),
(con, params, rhs'))
where
- rhs' = fvExpr (mkUniqSet params `combine` id_cands) tyvar_cands rhs
+ rhs' = fvExpr (mkIdSet params `combine` id_cands) tyvar_cands rhs
param_ftvs = foldr (combine . munge_id_ty) noFreeTyVars params
-- We need to collect free tyvars from the binders
- annotate_alts (CoPrimAlts alts deflt)
- = (fvinfo, AnnCoPrimAlts alts' deflt')
+ annotate_alts (PrimAlts alts deflt)
+ = (fvinfo, AnnPrimAlts alts' deflt')
where
(alts_fvinfo_s, alts') = unzip (map ann_unboxed_alt alts)
(deflt_fvinfo, deflt') = annotate_default deflt
where
rhs'@(rhs_info,_) = fvExpr id_cands tyvar_cands rhs
-#ifdef DPH
- annotate_alts id_cands tyvar_cands (CoParAlgAlts tycon ctxt binders alts deflt)
- = ((alts_fvs `minusUniqSet` (mkUniqSet binders)) `combine` deflt_fvs,
- AnnCoParAlgAlts tycon ctxt binders alts' deflt')
- where
- (alts_fvs_sets, alts') = unzip (map (ann_boxed_par_alt id_cands tyvar_cands) alts)
- alts_fvs = unionManyUniqSets alts_fvs_sets
- (deflt_fvs, ???ToDo:DPH, deflt') = annotate_default deflt
-
- ann_boxed_par_alt id_cands tyvar_cands (con, rhs)
- = (rhs_fvs, (con, rhs'))
- where
- rhs' = fvExpr (mkUniqSet binders `combine` id_cands) tyvar_cands rhs
- rhs_fvs = freeVarsOf rhs'
-
- annotate_alts id_cands tyvar_cands (CoParPrimAlts tycon ctxt alts deflt)
- = (alts_fvs `combine` deflt_fvs,
- AnnCoParPrimAlts tycon ctxt alts' deflt')
- where
- (alts_fvs_sets, alts') = unzip (map (ann_unboxed_par_alt id_cands tyvar_cands) alts)
- alts_fvs = unionManyUniqSets alts_fvs_sets
- (deflt_fvs, ??? ToDo:DPH, deflt') = annotate_default deflt
-
- ann_unboxed_par_alt id_cands tyvar_cands (lit, rhs)
- = (rhs_fvs, (lit, rhs'))
- where
- rhs' = fvExpr id_cands tyvar_cands rhs
- rhs_fvs = freeVarsOf rhs'
-#endif {- Data Parallel Haskell -}
-
- annotate_default CoNoDefault = (FVInfo noFreeIds noFreeTyVars lEAK_FREE_BIG,
- AnnCoNoDefault)
+ annotate_default NoDefault = (FVInfo noFreeIds noFreeTyVars lEAK_FREE_BIG,
+ AnnNoDefault)
- annotate_default (CoBindDefault binder rhs)
- = (FVInfo (freeVarsOf rhs' `minusUniqSet` aFreeId binder)
+ annotate_default (BindDefault binder rhs)
+ = (FVInfo (freeVarsOf rhs' `minusIdSet` aFreeId binder)
(freeTyVarsOf rhs' `combine` binder_ftvs)
(leakinessOf rhs'),
- AnnCoBindDefault binder rhs')
+ AnnBindDefault binder rhs')
where
rhs' = fvExpr (aFreeId binder `combine` id_cands) tyvar_cands rhs
binder_ftvs = munge_id_ty binder
-- We need to collect free tyvars from the binder
-fvExpr id_cands tyvar_cands (CoLet (CoNonRec binder rhs) body)
- = (FVInfo (freeVarsOf rhs' `combine` body_fvs)
+-- 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 `combine` mkIdSet (idSpecVars binder))
(freeTyVarsOf rhs' `combine` freeTyVarsOf body2 `combine` binder_ftvs)
(leakinessOf rhs' `orLeak` leakinessOf body2),
- AnnCoLet (AnnCoNonRec binder rhs') 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 `minusUniqSet` aFreeId binder
+ body_fvs = freeVarsOf body2 `minusIdSet` aFreeId binder
binder_ftvs = munge_id_ty binder
-- We need to collect free tyvars from the binder
-fvExpr id_cands tyvar_cands (CoLet (CoRec binds) body)
+fvExpr id_cands tyvar_cands (Let (Rec binds) body)
= (FVInfo (binds_fvs `combine` body_fvs)
(rhss_tfvs `combine` freeTyVarsOf body2 `combine` binders_ftvs)
(leakiness_of_rhss `orLeak` leakinessOf body2),
- AnnCoLet (AnnCoRec (binders `zip` rhss')) body2)
+ AnnLet (AnnRec (binders `zip` rhss')) body2)
where
(binders, rhss) = unzip binds
new_id_cands = binders_set `combine` id_cands
- binders_set = mkUniqSet binders
- rhss' = map (fvExpr new_id_cands tyvar_cands) rhss
+ binders_set = mkIdSet binders
+ 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 `minusUniqSet` 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 `minusUniqSet` binders_set
+ body_fvs = freeVarsOf body2 `minusIdSet` binders_set
binders_ftvs = foldr (combine . munge_id_ty) noFreeTyVars binders
-- We need to collect free tyvars from the binders
-fvExpr id_cands tyvar_cands (CoSCC label expr)
- = (fvinfo, AnnCoSCC label expr2)
+fvExpr id_cands tyvar_cands (Note (Coerce to_ty from_ty) expr)
+ = (FVInfo (freeVarsOf expr2)
+ (freeTyVarsOf expr2 `combine` tfvs1 `combine` tfvs2)
+ (leakinessOf expr2),
+ AnnNote (Coerce to_ty from_ty) expr2)
where
- expr2@(fvinfo,_) = fvExpr id_cands tyvar_cands expr
+ expr2 = fvExpr id_cands tyvar_cands expr
+ tfvs1 = freeTy tyvar_cands from_ty
+ tfvs2 = freeTy tyvar_cands to_ty
-#ifdef DPH
-fvExpr id_cands tyvar_cands e@(CoParCon c ctxt tys args)
- = ((args_fvs, typeOfCoreExpr e), AnnCoParCon c ctxt tys args')
+fvExpr id_cands tyvar_cands (Note other_note expr)
+ = (fvinfo, AnnNote other_note expr2)
where
- args' = map (fvExpr id_cands tyvar_cands) args
- args_fvs = unionManyUniqSets [ fvs | ((fvs,_), _) <- args' ]
+ expr2@(fvinfo,_) = fvExpr id_cands tyvar_cands expr
-fvExpr id_cands tyvar_cands e@(CoParComm ctxt expr comm)
- = ((expr_fvs `combine` comm_fvs, tyOf expr2), AnnCoParComm ctxt expr2 comm')
- where
- expr2 = fvExpr id_cands tyvar_cands expr
- expr_fvs = freeVarsOf expr2
- (comm_fvs,comm') = free_stuff_comm id_cands tyvar_cands comm
-
- free_stuff_comm id_cands tyvar_cands (CoParSend exprs)
- = let exprs' = map (fvExpr id_cands tyvar_cands) exprs in
- let exprs_fvs = unionManyUniqSets [fvs | ((fvs,_), _) <- exprs' ] in
- (exprs_fvs,AnnCoParSend exprs')
-
- free_stuff_comm id_cands tyvar_cands (CoParFetch exprs)
- = let exprs' = map (fvExpr id_cands tyvar_cands) exprs in
- let exprs_fvs = unionManyUniqSets [fvs | ((fvs,_), _) <- exprs' ] in
- (exprs_fvs,AnnCoParFetch exprs')
-
- free_stuff_comm id_cands tyvar_cands (CoToPodized)
- = (emptyUniqSet, AnnCoToPodized)
-
- free_stuff_comm id_cands tyvar_cands (CoFromPodized)
- = (emptyUniqSet, AnnCoFromPodized)
-#endif {- Data Parallel Haskell -}
+fvRhs id_cands tyvar_cands (bndr,rhs)
+ = fvExpr id_cands tyvar_cands rhs
\end{code}
\begin{code}
-freeAtom :: IdCands -> PlainCoreAtom -> IdSet
+freeArgs :: IdCands -> TyVarCands
+ -> [CoreArg]
+ -> (IdSet, TyVarSet)
-freeAtom cands (CoLitAtom k) = noFreeIds
-freeAtom cands (CoVarAtom v) | v `is_among` cands = aFreeId v
- | otherwise = noFreeIds
+freeArgs icands tcands [] = noFreeAnything
+freeArgs icands tcands (arg:args)
+ -- this code is written this funny way only for "efficiency" purposes
+ = let
+ free_first_arg@(arg_fvs, tfvs) = free_arg arg
+ in
+ if (null args) then
+ free_first_arg
+ else
+ case (freeArgs icands tcands args) of { (irest, trest) ->
+ (arg_fvs `combine` irest, tfvs `combine` trest) }
+ where
+ free_arg (LitArg _) = noFreeAnything
+ free_arg (TyArg ty) = (noFreeIds, freeTy tcands ty)
+ free_arg (VarArg v)
+ | v `is_among` icands = (aFreeId v, noFreeTyVars)
+ | otherwise = noFreeAnything
-freeTy :: TyVarCands -> UniType -> TyVarSet
+---------
+freeTy :: TyVarCands -> Type -> TyVarSet
-freeTy cands ty = mkUniqSet (extractTyVarsFromTy ty) `intersectUniqSets` cands
+freeTy cands ty = tyVarsOfType ty `intersectTyVarSets` cands
freeVarsOf :: CoreExprWithFVs -> IdSet
freeVarsOf (FVInfo free_vars _ _, _) = free_vars
%************************************************************************
%* *
-\section[freevars-binders]{Attaching free variables to binders
+\section{Finding the free variables of an expression}
%* *
%************************************************************************
-
-Here's an variant of the free-variable pass, which pins free-variable
-information on {\em binders} rather than every single jolly
-expression!
-\begin{itemize}
-\item
- The free vars attached to a lambda binder are the free vars of the
- whole lambda abstraction. If there are multiple binders, they are
- each given the same free-var set.
-\item
- The free vars attached to a let(rec) binder are the free vars of the
- rhs of the binding. In the case of letrecs, this set excludes the
- binders themselves.
-\item
- The free vars attached to a case alternative binder are the free
- vars of the alternative, excluding the alternative's binders.
-\end{itemize}
-
-There's a predicate carried in which tells what is a free-var
-candidate. It is passed the Id and a set of in-scope Ids.
-
-(Global) constructors used on the rhs in a CoCon are also treated as
-potential free-var candidates (though they will not be recorded in the
-in-scope set). The predicate must decide if they are to be recorded as
-free-vars.
-
-As it happens this is only ever used by the Specialiser!
+This function simply finds the free variables of an expression.
\begin{code}
-type FVCoreBinder = (Id, IdSet)
-type FVCoreExpr = CoreExpr FVCoreBinder Id
-type FVCoreBinding = CoreBinding FVCoreBinder Id
-
type InterestingIdFun
- = IdSet -- Non-top-level in-scope variables
- -> Id -- The Id being looked at
+ = Id -- The Id being looked at
-> Bool -- True <=> interesting
-\end{code}
-
-\begin{code}
-addExprFVs :: InterestingIdFun -- "Interesting id" predicate
- -> IdSet -- In scope ids
- -> PlainCoreExpr
- -> (FVCoreExpr, IdSet)
-
-addExprFVs fv_cand in_scope (CoVar v)
- = (CoVar v, if fv_cand in_scope v
- then aFreeId v
- else noFreeIds)
-
-addExprFVs fv_cand in_scope (CoLit lit) = (CoLit lit, noFreeIds)
-
-addExprFVs fv_cand in_scope (CoCon con tys args)
- = (CoCon con tys args,
- if fv_cand in_scope con
- then aFreeId con
- else noFreeIds
- `combine`
- unionManyUniqSets (map (fvsOfAtom fv_cand in_scope) args))
-
-addExprFVs fv_cand in_scope (CoPrim op tys args)
- = (CoPrim op tys args,
- unionManyUniqSets (map (fvsOfAtom fv_cand in_scope) args))
-
-addExprFVs fv_cand in_scope (CoLam binders body)
- = (CoLam (binders `zip` (repeat lam_fvs)) new_body, lam_fvs)
- where
- binder_set = mkUniqSet binders
- new_in_scope = in_scope `combine` binder_set
- (new_body, body_fvs) = addExprFVs fv_cand new_in_scope body
- lam_fvs = body_fvs `minusUniqSet` binder_set
-addExprFVs fv_cand in_scope (CoTyLam tyvar body)
- = (CoTyLam tyvar body2, body_fvs)
- where
- (body2, body_fvs) = addExprFVs fv_cand in_scope body
-
-addExprFVs fv_cand in_scope (CoApp fun arg)
- = (CoApp fun2 arg, fun_fvs `combine` fvsOfAtom fv_cand in_scope arg)
- where
- (fun2, fun_fvs) = addExprFVs fv_cand in_scope fun
+exprFreeVars :: InterestingIdFun -> CoreExpr -> IdSet
+exprFreeVars fv_cand e = expr_fvs fv_cand emptyIdSet e
+\end{code}
-addExprFVs fv_cand in_scope (CoTyApp fun ty)
- = (CoTyApp fun2 ty, fun_fvs)
- where
- (fun2, fun_fvs) = addExprFVs fv_cand in_scope fun
-addExprFVs fv_cand in_scope (CoCase scrut alts)
- = (CoCase scrut' alts', scrut_fvs `combine` alts_fvs)
+\begin{code}
+expr_fvs :: InterestingIdFun -- "Interesting id" predicate
+ -> IdSet -- In scope ids
+ -> CoreExpr
+ -> IdSet
+
+expr_fvs fv_cand in_scope (Var v) = id_fvs fv_cand in_scope v
+expr_fvs fv_cand in_scope (Lit lit) = noFreeIds
+expr_fvs fv_cand in_scope (Con con args) = args_fvs fv_cand in_scope args
+expr_fvs fv_cand in_scope (Prim op args) = args_fvs fv_cand in_scope args
+expr_fvs fv_cand in_scope (Note _ expr) = expr_fvs fv_cand in_scope expr
+expr_fvs fv_cand in_scope (App fun arg) = expr_fvs fv_cand in_scope fun `combine`
+ arg_fvs fv_cand in_scope arg
+
+
+expr_fvs fv_cand in_scope (Lam (ValBinder b) body)
+ = (expr_fvs fv_cand (in_scope `add` b) body)
+expr_fvs fv_cand in_scope (Lam (TyBinder b) body)
+ = expr_fvs fv_cand in_scope body
+
+expr_fvs fv_cand in_scope (Case scrut alts)
+ = expr_fvs fv_cand in_scope scrut `combine` alts_fvs
where
- (scrut', scrut_fvs) = addExprFVs fv_cand in_scope scrut
-
- (alts', alts_fvs)
+ alts_fvs
= case alts of
- CoAlgAlts alg_alts deflt -> (CoAlgAlts alg_alts' deflt', fvs)
+ AlgAlts alg_alts deflt -> unionManyIdSets (deflt_fvs : alt_fvs)
where
- (alg_alts', alt_fvs) = unzip (map do_alg_alt alg_alts)
- (deflt', deflt_fvs) = do_deflt deflt
- fvs = unionManyUniqSets (deflt_fvs : alt_fvs)
+ alt_fvs = map do_alg_alt alg_alts
+ deflt_fvs = do_deflt deflt
- CoPrimAlts prim_alts deflt -> (CoPrimAlts prim_alts' deflt', fvs)
+ PrimAlts prim_alts deflt -> unionManyIdSets (deflt_fvs : alt_fvs)
where
- (prim_alts', alt_fvs) = unzip (map do_prim_alt prim_alts)
- (deflt', deflt_fvs) = do_deflt deflt
- fvs = unionManyUniqSets (deflt_fvs : alt_fvs)
-
- do_alg_alt :: (Id, [Id], PlainCoreExpr)
- -> ((Id, [FVCoreBinder], FVCoreExpr), IdSet)
+ alt_fvs = map do_prim_alt prim_alts
+ deflt_fvs = do_deflt deflt
- do_alg_alt (con, args, rhs) = ((con, args `zip` (repeat fvs), rhs'), fvs)
+ do_alg_alt :: (Id, [Id], CoreExpr) -> IdSet
+ do_alg_alt (con, args, rhs) = expr_fvs fv_cand new_in_scope rhs
where
- new_in_scope = in_scope `combine` arg_set
- (rhs', rhs_fvs) = addExprFVs fv_cand new_in_scope rhs
- fvs = rhs_fvs `minusUniqSet` arg_set
- arg_set = mkUniqSet args
+ new_in_scope = in_scope `combine` mkIdSet args
- do_prim_alt (lit, rhs) = ((lit, rhs'), rhs_fvs)
- where
- (rhs', rhs_fvs) = addExprFVs fv_cand in_scope rhs
+ do_prim_alt (lit, rhs) = expr_fvs fv_cand in_scope rhs
- do_deflt CoNoDefault = (CoNoDefault, noFreeIds)
- do_deflt (CoBindDefault var rhs)
- = (CoBindDefault (var,fvs) rhs', fvs)
- where
- new_in_scope = in_scope `combine` var_set
- (rhs', rhs_fvs) = addExprFVs fv_cand new_in_scope rhs
- fvs = rhs_fvs `minusUniqSet` var_set
- var_set = aFreeId var
+ do_deflt NoDefault = noFreeIds
+ do_deflt (BindDefault b rhs) = expr_fvs fv_cand (in_scope `add` b) rhs
-addExprFVs fv_cand in_scope (CoLet binds body)
- = (CoLet binds' body2, fvs_binds `combine` (fvs_body `minusUniqSet` binder_set))
+expr_fvs fv_cand in_scope (Let (NonRec b r) body)
+ = expr_fvs fv_cand in_scope r `combine`
+ expr_fvs fv_cand (in_scope `add` b) body
+
+expr_fvs fv_cand in_scope (Let (Rec pairs) body)
+ = foldr (combine . expr_fvs fv_cand in_scope' . snd) noFreeIds pairs `combine`
+ expr_fvs fv_cand in_scope' body
where
- (binds', fvs_binds, new_in_scope, binder_set)
- = addBindingFVs fv_cand in_scope binds
+ in_scope' = in_scope `combine` mkIdSet (map fst pairs)
- (body2, fvs_body) = addExprFVs fv_cand new_in_scope body
-addExprFVs fv_cand in_scope (CoSCC label expr)
- = (CoSCC label expr2, expr_fvs)
- where
- (expr2, expr_fvs) = addExprFVs fv_cand in_scope expr
--- ToDo: DPH: add stuff here
+
+--------------------------------------
+arg_fvs fv_cand in_scope (VarArg v) = id_fvs fv_cand in_scope v
+arg_fvs fv_cand in_scope other_arg = noFreeIds
+
+--------------------------------------
+args_fvs fv_cand in_scope args = foldr (combine . arg_fvs fv_cand in_scope) noFreeIds args
+
+
+--------------------------------------
+id_fvs fv_cand in_scope v
+ | v `elementOfIdSet` in_scope = noFreeIds
+ | fv_cand v = aFreeId v
+ | otherwise = noFreeIds
\end{code}
+
\begin{code}
-addBindingFVs
- :: InterestingIdFun -- "Interesting id" predicate
- -> IdSet -- In scope ids
- -> PlainCoreBinding
- -> (FVCoreBinding,
- IdSet, -- Free vars of binding group
- IdSet, -- Augmented in-scope Ids
- IdSet) -- Set of Ids bound by this binding
-
-addBindingFVs fv_cand in_scope (CoNonRec binder rhs)
- = (CoNonRec binder' rhs', fvs, new_in_scope, binder_set)
- where
- ((binder', rhs'), fvs) = do_pair fv_cand in_scope binder_set (binder, rhs)
- new_in_scope = in_scope `combine` binder_set
- binder_set = aFreeId binder
-
-addBindingFVs fv_cand in_scope (CoRec pairs)
- = (CoRec pairs', unionManyUniqSets fvs_s, new_in_scope, binder_set)
+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
- binders = [binder | (binder,_) <- pairs]
- binder_set = mkUniqSet binders
- new_in_scope = in_scope `combine` binder_set
- (pairs', fvs_s) = unzip (map (do_pair fv_cand new_in_scope binder_set) pairs)
-\end{code}
+ 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
-\begin{code}
-addTopBindsFVs
- :: InterestingIdFun -- "Interesting id" predicate
- -> [PlainCoreBinding]
- -> ([FVCoreBinding],
- IdSet)
-
-addTopBindsFVs fv_cand [] = ([], noFreeIds)
-addTopBindsFVs fv_cand (b:bs)
- = let
- (b', fvs_b, _, _) = addBindingFVs fv_cand noFreeIds b
- (bs', fvs_bs) = addTopBindsFVs fv_cand bs
- in
- (b' : bs', fvs_b `combine` fvs_bs)
-\end{code}
+ PrimAlts prim_alts deflt -> unionManyTyVarSets (deflt_ftvs : alt_ftvs)
+ where
+ alt_ftvs = map do_prim_alt prim_alts
+ deflt_ftvs = do_deflt deflt
-\begin{code}
-fvsOfAtom :: InterestingIdFun -- "Interesting id" predicate
- -> IdSet -- In scope ids
- -> PlainCoreAtom
- -> IdSet
-
-fvsOfAtom fv_cand in_scope (CoVarAtom v)
- = if fv_cand in_scope v
- then aFreeId v
- else noFreeIds
-fvsOfAtom _ _ _ = noFreeIds -- if a literal...
-
-do_pair :: InterestingIdFun -- "Interesting id" predicate
- -> IdSet -- In scope ids
- -> IdSet
- -> (Id, PlainCoreExpr)
- -> ((FVCoreBinder, FVCoreExpr), IdSet)
-
-do_pair fv_cand in_scope binder_set (binder,rhs)
- = (((binder, fvs), rhs'), fvs)
- where
- (rhs', rhs_fvs) = addExprFVs fv_cand in_scope rhs
- fvs = rhs_fvs `minusUniqSet` binder_set
+ 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