Commit 72a9e0e2 authored by simonpj's avatar simonpj
Browse files

[project @ 1998-04-14 13:59:59 by simonpj]

Finally replace Specialise.dictRhsFVs with a proper free-variable finder, FreeVars.exprFreeVars
parent a7c7caa8
......@@ -5,16 +5,14 @@ Taken quite directly from the Peyton Jones/Lester paper.
module FreeVars (
-- cheap and cheerful variant...
addTopBindsFVs, addExprFVs,
-- Cheap and cheerful variant...
-- Complicated and expensive variant for float-out
freeVarsOf, freeTyVarsOf,
FVCoreExpr, FVCoreBinding,
CoreExprWithFVs, -- For the above functions
AnnCoreExpr, -- Dito
AnnCoreExpr, -- Dito
FVInfo(..), LeakInfo(..)
) where
......@@ -36,7 +34,7 @@ import TyVar ( emptyTyVarSet, unitTyVarSet, minusTyVarSet,
TyVarSet, TyVar
import BasicTypes ( Unused )
import UniqSet ( unionUniqSets )
import UniqSet ( unionUniqSets, addOneToUniqSet )
import Util ( panic, assertPanic )
......@@ -77,6 +75,7 @@ aFreeTyVar t = unitTyVarSet t
is_among = elementOfIdSet
munge_id_ty i = tyVarsOfType (idType i)
combine = unionUniqSets -- used both for {Id,TyVar}Sets
add = addOneToUniqSet
combineFVInfo (FVInfo fvs1 tfvs1 leak1) (FVInfo fvs2 tfvs2 leak2)
= FVInfo (fvs1 `combine` fvs2)
......@@ -344,213 +343,91 @@ leakinessOf (FVInfo _ _ leakiness, _) = leakiness
%* *
\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
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.
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.
The free vars attached to a case alternative binder are the free
vars of the alternative, excluding the alternative's binders.
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 Con 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
As it happens this is only ever used by the Specialiser!
This function simply finds the free variables of an expression.
type FVCoreBinder = (Id, IdSet)
type FVCoreExpr = GenCoreExpr FVCoreBinder Id Unused
type FVCoreBinding = GenCoreBinding FVCoreBinder Id Unused
type InterestingIdFun
= IdSet -- Non-top-level in-scope variables
-> Id -- The Id being looked at
= Id -- The Id being looked at
-> Bool -- True <=> interesting
addExprFVs :: InterestingIdFun -- "Interesting id" predicate
-> IdSet -- In scope ids
-> CoreExpr
-> (FVCoreExpr, IdSet)
addExprFVs fv_cand in_scope (Var v)
= (Var v, if fv_cand in_scope v
then aFreeId v
else noFreeIds)
addExprFVs fv_cand in_scope (Lit lit) = (Lit lit, noFreeIds)
addExprFVs fv_cand in_scope (Con con args)
= (Con con args,
if fv_cand in_scope con
then aFreeId con
else noFreeIds `combine` fvsOfArgs fv_cand in_scope args)
addExprFVs fv_cand in_scope (Prim op args)
= (Prim op args, fvsOfArgs fv_cand in_scope args)
exprFreeVars :: InterestingIdFun -> CoreExpr -> IdSet
exprFreeVars fv_cand e = expr_fvs fv_cand emptyIdSet e
addExprFVs fv_cand in_scope (Lam binder body)
= (Lam new_binder new_body, lam_fvs)
(new_binder, binder_set)
= case binder of
TyBinder t -> (TyBinder t, emptyIdSet)
ValBinder b -> (ValBinder (b, lam_fvs),
unitIdSet b)
new_in_scope = in_scope `combine` binder_set
(new_body, body_fvs) = addExprFVs fv_cand new_in_scope body
lam_fvs = body_fvs `minusIdSet` binder_set
addExprFVs fv_cand in_scope (App fun arg)
= (App fun2 arg, fun_fvs `combine` fvsOfArgs fv_cand in_scope [arg])
(fun2, fun_fvs) = addExprFVs fv_cand in_scope fun
addExprFVs fv_cand in_scope (Case scrut alts)
= (Case scrut' alts', scrut_fvs `combine` alts_fvs)
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
(scrut', scrut_fvs) = addExprFVs fv_cand in_scope scrut
(alts', alts_fvs)
= case alts of
AlgAlts alg_alts deflt -> (AlgAlts alg_alts' deflt', fvs)
AlgAlts alg_alts deflt -> unionManyIdSets (deflt_fvs : alt_fvs)
(alg_alts', alt_fvs) = unzip (map do_alg_alt alg_alts)
(deflt', deflt_fvs) = do_deflt deflt
fvs = unionManyIdSets (deflt_fvs : alt_fvs)
alt_fvs = map do_alg_alt alg_alts
deflt_fvs = do_deflt deflt
PrimAlts prim_alts deflt -> (PrimAlts prim_alts' deflt', fvs)
PrimAlts prim_alts deflt -> unionManyIdSets (deflt_fvs : alt_fvs)
(prim_alts', alt_fvs) = unzip (map do_prim_alt prim_alts)
(deflt', deflt_fvs) = do_deflt deflt
fvs = unionManyIdSets (deflt_fvs : alt_fvs)
alt_fvs = map do_prim_alt prim_alts
deflt_fvs = do_deflt deflt
do_alg_alt :: (Id, [Id], CoreExpr)
-> ((Id, [FVCoreBinder], FVCoreExpr), IdSet)
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
new_in_scope = in_scope `combine` arg_set
(rhs', rhs_fvs) = addExprFVs fv_cand new_in_scope rhs
fvs = rhs_fvs `minusIdSet` arg_set
arg_set = mkIdSet args
new_in_scope = in_scope `combine` mkIdSet args
do_prim_alt (lit, rhs) = ((lit, rhs'), rhs_fvs)
(rhs', rhs_fvs) = addExprFVs fv_cand in_scope rhs
do_prim_alt (lit, rhs) = expr_fvs fv_cand in_scope rhs
do_deflt NoDefault = (NoDefault, noFreeIds)
do_deflt (BindDefault var rhs)
= (BindDefault (var,fvs) rhs', fvs)
new_in_scope = in_scope `combine` var_set
(rhs', rhs_fvs) = addExprFVs fv_cand new_in_scope rhs
fvs = rhs_fvs `minusIdSet` var_set
var_set = aFreeId var
do_deflt NoDefault = noFreeIds
do_deflt (BindDefault b rhs) = expr_fvs fv_cand (in_scope `add` b) rhs
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
addExprFVs fv_cand in_scope (Let binds body)
= (Let binds' body2, fvs_binds `combine` (fvs_body `minusIdSet` binder_set))
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
(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 (Note note expr)
= (Note note expr2, expr_fvs)
(expr2, expr_fvs) = addExprFVs fv_cand in_scope expr
:: InterestingIdFun -- "Interesting id" predicate
-> IdSet -- In scope ids
-> CoreBinding
-> (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 (NonRec binder rhs)
= (NonRec binder' rhs', fvs, new_in_scope, binder_set)
((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 (Rec pairs)
= (Rec pairs', unionManyIdSets fvs_s, new_in_scope, binder_set)
binders = [binder | (binder,_) <- pairs]
binder_set = mkIdSet binders
new_in_scope = in_scope `combine` binder_set
(pairs', fvs_s) = unzip (map (do_pair fv_cand new_in_scope binder_set) pairs)
arg_fvs fv_cand in_scope (VarArg v) = id_fvs fv_cand in_scope v
arg_fvs fv_cand in_scope other_arg = noFreeIds
:: InterestingIdFun -- "Interesting id" predicate
-> [CoreBinding]
-> ([FVCoreBinding],
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
(b' : bs', fvs_b `combine` fvs_bs)
args_fvs fv_cand in_scope args = foldr (combine . arg_fvs fv_cand in_scope) noFreeIds args
fvsOfArgs :: InterestingIdFun -- "Interesting id" predicate
-> IdSet -- In scope ids
-> [CoreArg]
-> IdSet
fvsOfArgs _ _ [] = noFreeIds
fvsOfArgs fv_cand in_scope [VarArg v] -- this is only a short-cut...
= if (fv_cand in_scope v) then aFreeId v else noFreeIds
fvsOfArgs _ _ [ _ ] = noFreeIds
fvsOfArgs fv_cand in_scope args
= mkIdSet [ v | (VarArg v) <- args, fv_cand in_scope v ]
-- all other types of args are uninteresting here...
do_pair :: InterestingIdFun -- "Interesting id" predicate
-> IdSet -- In scope ids
-> IdSet
-> (Id, CoreExpr)
-> ((FVCoreBinder, FVCoreExpr), IdSet)
do_pair fv_cand in_scope binder_set (binder,rhs)
= (((binder, fvs), rhs'), fvs)
(rhs', rhs_fvs) = addExprFVs fv_cand in_scope rhs
fvs = rhs_fvs `minusIdSet` binder_set
id_fvs fv_cand in_scope v
| v `elementOfIdSet` in_scope = noFreeIds
| fv_cand v = aFreeId v
| otherwise = noFreeIds
......@@ -42,7 +42,7 @@ import IdInfo ( IdInfo, StrictnessInfo, ArityInfo, InlinePragInfo(..), inlinePr
import CoreSyn ( CoreExpr, CoreBinding, GenCoreExpr, GenCoreBinding(..) )
import CoreUnfold ( calcUnfoldingGuidance, UnfoldingGuidance(..), Unfolding )
import FreeVars ( addExprFVs )
import FreeVars ( exprFreeVars )
import Name ( isLocallyDefined, isWiredInName, modAndOcc, nameModule, pprOccName,
OccName, occNameString, nameOccName, nameString, isExported,
Name {-instance NamedThing-}, Provenance, NamedThing(..)
......@@ -346,10 +346,9 @@ ifaceId get_idinfo needed_ids is_rec id rhs
find_fvs expr = free_vars
(_,free_vars) = addExprFVs interesting emptyIdSet expr
interesting bound id = isLocallyDefined id &&
not (id `elementOfIdSet` bound) &&
not (omitIfaceSigForId id)
free_vars = exprFreeVars interesting expr
interesting id = isLocallyDefined id &&
not (omitIfaceSigForId id)
......@@ -34,8 +34,9 @@ import TyVar ( TyVar, mkTyVar,
import Kind ( mkBoxedTypeKind )
import CoreSyn
import FreeVars ( exprFreeVars )
import PprCore () -- Instances
import Name ( NamedThing(..), getSrcLoc, mkSysLocalName )
import Name ( NamedThing(..), getSrcLoc, mkSysLocalName, isLocallyDefined )
import SrcLoc ( noSrcLoc )
import SpecEnv ( addToSpecEnv, lookupSpecEnv, specEnvValues )
......@@ -1096,29 +1097,7 @@ lookupId env id = case lookupIdEnv env id of
Just id' -> id'
dictRhsFVs :: CoreExpr -> IdSet
-- Cheapo function for simple RHSs
dictRhsFVs e
= go e
go (App e1 (VarArg a)) = go e1 `addOneToIdSet` a
go (App e1 (LitArg l)) = go e1
go (App e1 (TyArg t)) = go e1
go (Var v) = unitIdSet v
go (Lit l) = emptyIdSet
go (Con _ args) = mkIdSet [id | VarArg id <- args]
go (Note _ e) = go e
go (Case e _) = go e -- Claim: no free dictionaries in the alternatives
-- These case expressions are of the form
-- case d of { D a b c -> b }
go (Lam _ _) = emptyIdSet -- This can happen for a Functor "dict",
-- which is represented by the function
-- itself; but it won't have any further
-- dicts inside it. I hope.
go other = pprPanic "dictRhsFVs" (ppr e)
dictRhsFVs e = exprFreeVars isLocallyDefined e
addIdSpecialisations id spec_stuff
= (if not (null errs) then
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