Commit 2325bd4e authored by niteria's avatar niteria Committed by Ben Gamari

Create a deterministic version of tyVarsOfType

I've run into situations where I need deterministic `tyVarsOfType` and
this implementation achieves that and also brings an algorithmic
improvement.  Union of two `VarSet`s takes linear time the size of the
sets and in the worst case we can have `n` unions of sets of sizes
`(n-1, 1), (n-2, 1)...` making it quadratic.

One reason why we need deterministic `tyVarsOfType` is in `abstractVars`
in `SetLevels`. When we abstract type variables when floating we want
them to be abstracted in deterministic order.

Test Plan: harbormaster

Reviewers: simonpj, goldfire, austin, hvr, simonmar, bgamari

Reviewed By: simonmar

Subscribers: thomie

Differential Revision: https://phabricator.haskell.org/D1468

GHC Trac Issues: #4012
parent 6664ab83
......@@ -376,21 +376,21 @@ and put in the global list.
data RuleInfo
= RuleInfo
[CoreRule]
VarSet -- Locally-defined free vars of *both* LHS and RHS
DVarSet -- Locally-defined free vars of *both* LHS and RHS
-- of rules. I don't think it needs to include the
-- ru_fn though.
-- Note [Rule dependency info] in OccurAnal
-- | Assume that no specilizations exist: always safe
emptyRuleInfo :: RuleInfo
emptyRuleInfo = RuleInfo [] emptyVarSet
emptyRuleInfo = RuleInfo [] emptyDVarSet
isEmptyRuleInfo :: RuleInfo -> Bool
isEmptyRuleInfo (RuleInfo rs _) = null rs
-- | Retrieve the locally-defined free variables of both the left and
-- right hand sides of the specialization rules
ruleInfoFreeVars :: RuleInfo -> VarSet
ruleInfoFreeVars :: RuleInfo -> DVarSet
ruleInfoFreeVars (RuleInfo _ fvs) = fvs
ruleInfoRules :: RuleInfo -> [CoreRule]
......
......@@ -11,6 +11,7 @@ Taken quite directly from the Peyton Jones/Lester paper.
module CoreFVs (
-- * Free variables of expressions and binding groups
exprFreeVars, -- CoreExpr -> VarSet -- Find all locally-defined free Ids or tyvars
exprFreeDVars, -- CoreExpr -> DVarSet -- Find all locally-defined free Ids or tyvars
exprFreeIds, -- CoreExpr -> IdSet -- Find all locally-defined free Ids
exprsFreeVars, -- [CoreExpr] -> VarSet
bindFreeVars, -- CoreBind -> VarSet
......@@ -22,16 +23,20 @@ module CoreFVs (
-- * Free variables of Rules, Vars and Ids
varTypeTyVars,
idUnfoldingVars, idFreeVars, idRuleAndUnfoldingVars,
idFreeVarsAcc,
idRuleVars, idRuleRhsVars, stableUnfoldingVars,
ruleRhsFreeVars, ruleFreeVars, rulesFreeVars,
rulesFreeDVars,
ruleLhsFreeIds, exprsOrphNames,
vectsFreeVars,
expr_fvs,
-- * Core syntax tree annotation with free variables
CoreExprWithFVs, -- = AnnExpr Id VarSet
CoreBindWithFVs, -- = AnnBind Id VarSet
CoreExprWithFVs, -- = AnnExpr Id DVarSet
CoreBindWithFVs, -- = AnnBind Id DVarSet
freeVars, -- CoreExpr -> CoreExprWithFVs
freeVarsOf -- CoreExprWithFVs -> IdSet
freeVarsOf -- CoreExprWithFVs -> DIdSet
) where
#include "HsVersions.h"
......@@ -45,11 +50,13 @@ import Name
import VarSet
import Var
import TcType
import TypeRep
import Coercion
import Maybes( orElse )
import Util
import BasicTypes( Activation )
import Outputable
import FV
{-
************************************************************************
......@@ -69,7 +76,11 @@ but not those that are free in the type of variable occurrence.
-- | Find all locally-defined free Ids or type variables in an expression
exprFreeVars :: CoreExpr -> VarSet
exprFreeVars = exprSomeFreeVars isLocalVar
exprFreeVars = runFVSet . filterFV isLocalVar . expr_fvs
exprFreeDVars :: CoreExpr -> DVarSet
exprFreeDVars = runFVDSet . filterFV isLocalVar . expr_fvs
-- | Find all locally-defined free Ids in an expression
exprFreeIds :: CoreExpr -> IdSet -- Find all locally-defined free Ids
......@@ -81,44 +92,23 @@ exprsFreeVars = mapUnionVarSet exprFreeVars
-- | Find all locally defined free Ids in a binding group
bindFreeVars :: CoreBind -> VarSet
bindFreeVars (NonRec b r) = rhs_fvs (b,r) isLocalVar emptyVarSet
bindFreeVars (Rec prs) = addBndrs (map fst prs)
(foldr (union . rhs_fvs) noVars prs)
isLocalVar emptyVarSet
bindFreeVars (NonRec b r) = runFVSet $ filterFV isLocalVar $ rhs_fvs (b,r)
bindFreeVars (Rec prs) = runFVSet $ filterFV isLocalVar $
addBndrs (map fst prs)
(foldr (unionFV . rhs_fvs) noVars prs)
-- | Finds free variables in an expression selected by a predicate
exprSomeFreeVars :: InterestingVarFun -- ^ Says which 'Var's are interesting
-> CoreExpr
-> VarSet
exprSomeFreeVars fv_cand e = expr_fvs e fv_cand emptyVarSet
exprSomeFreeVars fv_cand e = runFVSet $ filterFV fv_cand $ expr_fvs e
-- | Finds free variables in several expressions selected by a predicate
exprsSomeFreeVars :: InterestingVarFun -- Says which 'Var's are interesting
-> [CoreExpr]
-> VarSet
exprsSomeFreeVars fv_cand = mapUnionVarSet (exprSomeFreeVars fv_cand)
-- | Predicate on possible free variables: returns @True@ iff the variable is interesting
type InterestingVarFun = Var -> Bool
type FV = InterestingVarFun
-> VarSet -- Locally bound
-> VarSet -- Free vars
-- Return the vars that are both (a) interesting
-- and (b) not locally bound
-- See function keep_it
keep_it :: InterestingVarFun -> VarSet -> Var -> Bool
keep_it fv_cand in_scope var
| var `elemVarSet` in_scope = False
| fv_cand var = True
| otherwise = False
union :: FV -> FV -> FV
union fv1 fv2 fv_cand in_scope = fv1 fv_cand in_scope `unionVarSet` fv2 fv_cand in_scope
noVars :: FV
noVars _ _ = emptyVarSet
exprsSomeFreeVars fv_cand es =
runFVSet $ filterFV fv_cand $ foldr (unionFV . expr_fvs) noVars es
-- Comment about obselete code
-- We used to gather the free variables the RULES at a variable occurrence
......@@ -148,63 +138,65 @@ noVars _ _ = emptyVarSet
-- | otherwise = set
-- SLPJ Feb06
oneVar :: Id -> FV
oneVar var fv_cand in_scope
= ASSERT( isId var )
if keep_it fv_cand in_scope var
then unitVarSet var
else emptyVarSet
-- XXX move to FV
someVars :: [Var] -> FV
someVars vars = foldr (unionFV . oneVar) noVars vars
someVars :: VarSet -> FV
someVars vars fv_cand in_scope
= filterVarSet (keep_it fv_cand in_scope) vars
addBndr :: CoreBndr -> FV -> FV
addBndr bndr fv fv_cand in_scope
= someVars (varTypeTyVars bndr) fv_cand in_scope
addBndr bndr fv fv_cand in_scope acc
= (varTypeTyVarsAcc bndr `unionFV`
-- Include type varibles in the binder's type
-- (not just Ids; coercion variables too!)
`unionVarSet` fv fv_cand (in_scope `extendVarSet` bndr)
FV.delFV bndr fv) fv_cand in_scope acc
addBndrs :: [CoreBndr] -> FV -> FV
addBndrs bndrs fv = foldr addBndr fv bndrs
expr_fvs :: CoreExpr -> FV
expr_fvs (Type ty) = someVars (tyVarsOfType ty)
expr_fvs (Coercion co) = someVars (tyCoVarsOfCo co)
expr_fvs (Var var) = oneVar var
expr_fvs (Lit _) = noVars
expr_fvs (Tick t expr) = tickish_fvs t `union` expr_fvs expr
expr_fvs (App fun arg) = expr_fvs fun `union` expr_fvs arg
expr_fvs (Lam bndr body) = addBndr bndr (expr_fvs body)
expr_fvs (Cast expr co) = expr_fvs expr `union` someVars (tyCoVarsOfCo co)
expr_fvs (Case scrut bndr ty alts)
= expr_fvs scrut `union` someVars (tyVarsOfType ty) `union` addBndr bndr
(foldr (union . alt_fvs) noVars alts)
expr_fvs (Type ty) fv_cand in_scope acc =
tyVarsOfTypeAcc ty fv_cand in_scope acc
expr_fvs (Coercion co) fv_cand in_scope acc =
tyCoVarsOfCoAcc co fv_cand in_scope acc
expr_fvs (Var var) fv_cand in_scope acc = oneVar var fv_cand in_scope acc
expr_fvs (Lit _) fv_cand in_scope acc = noVars fv_cand in_scope acc
expr_fvs (Tick t expr) fv_cand in_scope acc =
(tickish_fvs t `unionFV` expr_fvs expr) fv_cand in_scope acc
expr_fvs (App fun arg) fv_cand in_scope acc =
(expr_fvs fun `unionFV` expr_fvs arg) fv_cand in_scope acc
expr_fvs (Lam bndr body) fv_cand in_scope acc =
addBndr bndr (expr_fvs body) fv_cand in_scope acc
expr_fvs (Cast expr co) fv_cand in_scope acc =
(expr_fvs expr `unionFV` tyCoVarsOfCoAcc co) fv_cand in_scope acc
expr_fvs (Case scrut bndr ty alts) fv_cand in_scope acc
= (expr_fvs scrut `unionFV` tyVarsOfTypeAcc ty `unionFV` addBndr bndr
(foldr (unionFV . alt_fvs) noVars alts)) fv_cand in_scope acc
where
alt_fvs (_, bndrs, rhs) = addBndrs bndrs (expr_fvs rhs)
expr_fvs (Let (NonRec bndr rhs) body)
= rhs_fvs (bndr, rhs) `union` addBndr bndr (expr_fvs body)
expr_fvs (Let (NonRec bndr rhs) body) fv_cand in_scope acc
= (rhs_fvs (bndr, rhs) `unionFV` addBndr bndr (expr_fvs body))
fv_cand in_scope acc
expr_fvs (Let (Rec pairs) body)
expr_fvs (Let (Rec pairs) body) fv_cand in_scope acc
= addBndrs (map fst pairs)
(foldr (union . rhs_fvs) (expr_fvs body) pairs)
(foldr (unionFV . rhs_fvs) (expr_fvs body) pairs)
fv_cand in_scope acc
---------
rhs_fvs :: (Id,CoreExpr) -> FV
rhs_fvs (bndr, rhs) = expr_fvs rhs `union`
someVars (bndrRuleAndUnfoldingVars bndr)
rhs_fvs :: (Id, CoreExpr) -> FV
rhs_fvs (bndr, rhs) = expr_fvs rhs `unionFV`
bndrRuleAndUnfoldingVarsAcc bndr -- XXX: FIXME
-- Treat any RULES as extra RHSs of the binding
---------
exprs_fvs :: [CoreExpr] -> FV
exprs_fvs exprs = foldr (union . expr_fvs) noVars exprs
exprs_fvs exprs = foldr (unionFV . expr_fvs) noVars exprs
tickish_fvs :: Tickish Id -> FV
tickish_fvs (Breakpoint _ ids) = someVars (mkVarSet ids)
tickish_fvs (Breakpoint _ ids) = someVars ids
tickish_fvs _ = noVars
{-
......@@ -258,7 +250,7 @@ exprsOrphNames es = foldr (unionNameSet . exprOrphNames) emptyNameSet es
ruleRhsFreeVars :: CoreRule -> VarSet
ruleRhsFreeVars (BuiltinRule {}) = noFVs
ruleRhsFreeVars (Rule { ru_fn = _, ru_bndrs = bndrs, ru_rhs = rhs })
= addBndrs bndrs (expr_fvs rhs) isLocalVar emptyVarSet
= runFVSet $ filterFV isLocalVar $ addBndrs bndrs (expr_fvs rhs)
-- See Note [Rule free var hack]
-- | Those variables free in the both the left right hand sides of a rule
......@@ -267,7 +259,22 @@ ruleFreeVars (BuiltinRule {}) = noFVs
ruleFreeVars (Rule { ru_fn = _do_not_include -- See Note [Rule free var hack]
, ru_bndrs = bndrs
, ru_rhs = rhs, ru_args = args })
= addBndrs bndrs (exprs_fvs (rhs:args)) isLocalVar emptyVarSet
= runFVSet $ filterFV isLocalVar $ addBndrs bndrs (exprs_fvs (rhs:args))
ruleFreeVarsAcc :: CoreRule -> FV
ruleFreeVarsAcc (BuiltinRule {}) =
noVars
ruleFreeVarsAcc (Rule { ru_fn = _do_not_include -- See Note [Rule free var hack]
, ru_bndrs = bndrs
, ru_rhs = rhs, ru_args = args })
= addBndrs bndrs (exprs_fvs (rhs:args))
rulesFreeVarsAcc :: [CoreRule] -> FV
rulesFreeVarsAcc (rule:rules) = ruleFreeVarsAcc rule `unionFV` rulesFreeVarsAcc rules
rulesFreeVarsAcc [] = noVars
rulesFreeDVars :: [CoreRule] -> DVarSet
rulesFreeDVars rules = runFVDSet $ filterFV isLocalVar $ rulesFreeVarsAcc rules
idRuleRhsVars :: (Activation -> Bool) -> Id -> VarSet
......@@ -281,7 +288,7 @@ idRuleRhsVars is_active id
-- See Note [Finding rule RHS free vars] in OccAnal.hs
= delFromUFM fvs fn -- Note [Rule free var hack]
where
fvs = addBndrs bndrs (expr_fvs rhs) isLocalVar emptyVarSet
fvs = runFVSet $ filterFV isLocalVar $ addBndrs bndrs (expr_fvs rhs)
get_fvs _ = noFVs
-- | Those variables free in the right hand side of several rules
......@@ -292,7 +299,7 @@ ruleLhsFreeIds :: CoreRule -> VarSet
-- ^ This finds all locally-defined free Ids on the left hand side of a rule
ruleLhsFreeIds (BuiltinRule {}) = noFVs
ruleLhsFreeIds (Rule { ru_bndrs = bndrs, ru_args = args })
= addBndrs bndrs (exprs_fvs args) isLocalId emptyVarSet
= runFVSet $ filterFV isLocalId $ addBndrs bndrs (exprs_fvs args)
{-
Note [Rule free var hack] (Not a hack any more)
......@@ -311,7 +318,7 @@ breaker, which is perfectly inlinable.
vectsFreeVars :: [CoreVect] -> VarSet
vectsFreeVars = mapUnionVarSet vectFreeVars
where
vectFreeVars (Vect _ rhs) = expr_fvs rhs isLocalId emptyVarSet
vectFreeVars (Vect _ rhs) = runFVSet $ filterFV isLocalId $ expr_fvs rhs
vectFreeVars (NoVect _) = noFVs
vectFreeVars (VectType _ _ _) = noFVs
vectFreeVars (VectClass _) = noFVs
......@@ -331,28 +338,28 @@ NON-GLOBAL free variables and type variables.
-- | Every node in a binding group annotated with its
-- (non-global) free variables, both Ids and TyVars
type CoreBindWithFVs = AnnBind Id VarSet
type CoreBindWithFVs = AnnBind Id DVarSet
-- | Every node in an expression annotated with its
-- (non-global) free variables, both Ids and TyVars
type CoreExprWithFVs = AnnExpr Id VarSet
type CoreExprWithFVs = AnnExpr Id DVarSet
freeVarsOf :: CoreExprWithFVs -> IdSet
freeVarsOf :: CoreExprWithFVs -> DIdSet
-- ^ Inverse function to 'freeVars'
freeVarsOf (free_vars, _) = free_vars
noFVs :: VarSet
noFVs = emptyVarSet
noFVs = emptyVarSet
aFreeVar :: Var -> VarSet
aFreeVar = unitVarSet
aFreeVar :: Var -> DVarSet
aFreeVar = unitDVarSet
unionFVs :: VarSet -> VarSet -> VarSet
unionFVs = unionVarSet
unionFVs :: DVarSet -> DVarSet -> DVarSet
unionFVs = unionDVarSet
delBindersFV :: [Var] -> VarSet -> VarSet
delBindersFV :: [Var] -> DVarSet -> DVarSet
delBindersFV bs fvs = foldr delBinderFV fvs bs
delBinderFV :: Var -> VarSet -> VarSet
delBinderFV :: Var -> DVarSet -> DVarSet
-- This way round, so we can do it multiple times using foldr
-- (b `delBinderFV` s) removes the binder b from the free variable set s,
......@@ -383,32 +390,47 @@ delBinderFV :: Var -> VarSet -> VarSet
-- where
-- bottom = bottom -- Never evaluated
delBinderFV b s = (s `delVarSet` b) `unionFVs` varTypeTyVars b
delBinderFV b s = (s `delDVarSet` b) `unionFVs` dVarTypeTyVars b
-- Include coercion variables too!
varTypeTyVars :: Var -> TyVarSet
-- Find the type/kind variables free in the type of the id/tyvar
varTypeTyVars var = tyVarsOfType (varType var)
varTypeTyVars var = runFVSet $ varTypeTyVarsAcc var
dVarTypeTyVars :: Var -> DTyVarSet
-- Find the type/kind variables free in the type of the id/tyvar
dVarTypeTyVars var = runFVDSet $ varTypeTyVarsAcc var
varTypeTyVarsAcc :: Var -> FV
varTypeTyVarsAcc var = tyVarsOfTypeAcc (varType var)
idFreeVars :: Id -> VarSet
idFreeVars id = ASSERT( isId id) runFVSet $ idFreeVarsAcc id
idFreeVarsAcc :: Id -> FV
-- Type variables, rule variables, and inline variables
idFreeVars id = ASSERT( isId id)
varTypeTyVars id `unionVarSet`
idRuleAndUnfoldingVars id
idFreeVarsAcc id = ASSERT( isId id)
varTypeTyVarsAcc id `unionFV`
idRuleAndUnfoldingVarsAcc id
bndrRuleAndUnfoldingVars ::Var -> VarSet
-- A 'let' can bind a type variable, and idRuleVars assumes
-- it's seeing an Id. This function tests first.
bndrRuleAndUnfoldingVars v | isTyVar v = emptyVarSet
| otherwise = idRuleAndUnfoldingVars v
bndrRuleAndUnfoldingVarsAcc :: Var -> FV
bndrRuleAndUnfoldingVarsAcc v | isTyVar v = noVars
| otherwise = idRuleAndUnfoldingVarsAcc v
idRuleAndUnfoldingVars :: Id -> VarSet
idRuleAndUnfoldingVars id = ASSERT( isId id)
idRuleVars id `unionVarSet`
idUnfoldingVars id
idRuleAndUnfoldingVars id = runFVSet $ idRuleAndUnfoldingVarsAcc id
idRuleAndUnfoldingVarsAcc :: Id -> FV
idRuleAndUnfoldingVarsAcc id = ASSERT( isId id)
idRuleVarsAcc id `unionFV` idUnfoldingVarsAcc id
idRuleVars ::Id -> VarSet -- Does *not* include CoreUnfolding vars
idRuleVars id = ASSERT( isId id) ruleInfoFreeVars (idSpecialisation id)
idRuleVars id = runFVSet $ idRuleVarsAcc id
idRuleVarsAcc :: Id -> FV
idRuleVarsAcc id = ASSERT( isId id)
someVars (dVarSetElems $ ruleInfoFreeVars (idSpecialisation id))
idUnfoldingVars :: Id -> VarSet
-- Produce free vars for an unfolding, but NOT for an ordinary
......@@ -416,19 +438,26 @@ idUnfoldingVars :: Id -> VarSet
-- and we'll get exponential behaviour if we look at both unf and rhs!
-- But do look at the *real* unfolding, even for loop breakers, else
-- we might get out-of-scope variables
idUnfoldingVars id = stableUnfoldingVars (realIdUnfolding id) `orElse` emptyVarSet
idUnfoldingVars id = runFVSet $ idUnfoldingVarsAcc id
idUnfoldingVarsAcc :: Id -> FV
idUnfoldingVarsAcc id = stableUnfoldingVarsAcc (realIdUnfolding id) `orElse` noVars
stableUnfoldingVars :: Unfolding -> Maybe VarSet
stableUnfoldingVars unf
stableUnfoldingVars unf = runFVSet `fmap` stableUnfoldingVarsAcc unf
stableUnfoldingVarsAcc :: Unfolding -> Maybe FV
stableUnfoldingVarsAcc unf
= case unf of
CoreUnfolding { uf_tmpl = rhs, uf_src = src }
| isStableSource src
-> Just (exprFreeVars rhs)
-> Just (filterFV isLocalVar $ expr_fvs rhs)
DFunUnfolding { df_bndrs = bndrs, df_args = args }
-> Just (exprs_fvs args isLocalVar (mkVarSet bndrs))
-> Just (filterFV isLocalVar $ FV.delFVs (mkVarSet bndrs) $ exprs_fvs args)
-- DFuns are top level, so no fvs from types of bndrs
_other -> Nothing
{-
************************************************************************
* *
......@@ -448,9 +477,9 @@ freeVars (Var v)
-- fvs = fvs_v `unionVarSet` idSpecVars v
fvs | isLocalVar v = aFreeVar v
| otherwise = noFVs
| otherwise = emptyDVarSet
freeVars (Lit lit) = (noFVs, AnnLit lit)
freeVars (Lit lit) = (emptyDVarSet, AnnLit lit)
freeVars (Lam b body)
= (b `delBinderFV` freeVarsOf body', AnnLam b body')
where
......@@ -463,13 +492,13 @@ freeVars (App fun arg)
arg2 = freeVars arg
freeVars (Case scrut bndr ty alts)
= ((bndr `delBinderFV` alts_fvs) `unionFVs` freeVarsOf scrut2 `unionFVs` tyVarsOfType ty,
= ((bndr `delBinderFV` alts_fvs) `unionFVs` freeVarsOf scrut2 `unionFVs` runFVDSet (tyVarsOfTypeAcc ty),
AnnCase scrut2 bndr ty alts2)
where
scrut2 = freeVars scrut
(alts_fvs_s, alts2) = mapAndUnzip fv_alt alts
alts_fvs = foldr unionFVs noFVs alts_fvs_s
alts_fvs = foldr unionFVs emptyDVarSet alts_fvs_s
fv_alt (con,args,rhs) = (delBindersFV args (freeVarsOf rhs2),
(con, args, rhs2))
......@@ -479,7 +508,7 @@ freeVars (Case scrut bndr ty alts)
freeVars (Let (NonRec binder rhs) body)
= (freeVarsOf rhs2
`unionFVs` body_fvs
`unionFVs` bndrRuleAndUnfoldingVars binder,
`unionFVs` runFVDSet (bndrRuleAndUnfoldingVarsAcc binder),
-- Remember any rules; cf rhs_fvs above
AnnLet (AnnNonRec binder rhs2) body2)
where
......@@ -495,7 +524,8 @@ freeVars (Let (Rec binds) body)
rhss2 = map freeVars rhss
rhs_body_fvs = foldr (unionFVs . freeVarsOf) body_fvs rhss2
all_fvs = foldr (unionFVs . idRuleAndUnfoldingVars) rhs_body_fvs binders
binders_fvs = runFVDSet $ foldr (unionFV . idRuleAndUnfoldingVarsAcc) noVars binders
all_fvs = rhs_body_fvs `unionFVs` binders_fvs
-- The "delBinderFV" happens after adding the idSpecVars,
-- since the latter may add some of the binders as fvs
......@@ -506,15 +536,15 @@ freeVars (Cast expr co)
= (freeVarsOf expr2 `unionFVs` cfvs, AnnCast expr2 (cfvs, co))
where
expr2 = freeVars expr
cfvs = tyCoVarsOfCo co
cfvs = runFVDSet $ tyCoVarsOfCoAcc co
freeVars (Tick tickish expr)
= (tickishFVs tickish `unionFVs` freeVarsOf expr2, AnnTick tickish expr2)
where
expr2 = freeVars expr
tickishFVs (Breakpoint _ ids) = mkVarSet ids
tickishFVs _ = emptyVarSet
tickishFVs (Breakpoint _ ids) = mkDVarSet ids
tickishFVs _ = emptyDVarSet
freeVars (Type ty) = (tyVarsOfType ty, AnnType ty)
freeVars (Type ty) = (runFVDSet $ tyVarsOfTypeAcc ty, AnnType ty)
freeVars (Coercion co) = (tyCoVarsOfCo co, AnnCoercion co)
freeVars (Coercion co) = (runFVDSet $ tyCoVarsOfCoAcc co, AnnCoercion co)
......@@ -14,7 +14,7 @@ import CoreSyn
import IdInfo
import Demand( seqDemand, seqStrictSig )
import BasicTypes( seqOccInfo )
import VarSet( seqVarSet )
import VarSet( seqDVarSet )
import Var( varType, tyVarKind )
import Type( seqType, isTyVar )
import Coercion( seqCo )
......@@ -40,7 +40,7 @@ seqOneShot :: OneShotInfo -> ()
seqOneShot l = l `seq` ()
seqRuleInfo :: RuleInfo -> ()
seqRuleInfo (RuleInfo rules fvs) = seqRules rules `seq` seqVarSet fvs
seqRuleInfo (RuleInfo rules fvs) = seqRules rules `seq` seqDVarSet fvs
seqCaf :: CafInfo -> ()
seqCaf c = c `seq` ()
......
......@@ -17,7 +17,7 @@ module CoreSubst (
substTy, substCo, substExpr, substExprSC, substBind, substBindSC,
substUnfolding, substUnfoldingSC,
lookupIdSubst, lookupTvSubst, lookupCvSubst, substIdOcc,
substTickish, substVarSet,
substTickish, substDVarSet,
-- ** Operations on substitutions
emptySubst, mkEmptySubst, mkSubst, mkOpenSubst, substInScope, isEmptySubst,
......@@ -53,6 +53,7 @@ import qualified Coercion
-- We are defining local versions
import Type hiding ( substTy, extendTvSubst, extendTvSubstList
, isInScope, substTyVarBndr, cloneTyVarBndr )
import TypeRep (tyVarsOfTypeAcc)
import Coercion hiding ( substTy, substCo, extendTvSubst, substTyVarBndr, substCoVarBndr )
import TyCon ( tyConArity )
......@@ -674,7 +675,7 @@ substSpec subst new_id (RuleInfo rules rhs_fvs)
where
subst_ru_fn = const (idName new_id)
new_spec = RuleInfo (map (substRule subst subst_ru_fn) rules)
(substVarSet subst rhs_fvs)
(substDVarSet subst rhs_fvs)
------------------
substRulesForImportedIds :: Subst -> [CoreRule] -> [CoreRule]
......@@ -721,13 +722,13 @@ substVect _subst vd@(VectClass _) = vd
substVect _subst vd@(VectInst _) = vd
------------------
substVarSet :: Subst -> VarSet -> VarSet
substVarSet subst fvs
= foldVarSet (unionVarSet . subst_fv subst) emptyVarSet fvs
substDVarSet :: Subst -> DVarSet -> DVarSet
substDVarSet subst fvs
= mkDVarSet $ fst $ foldr (subst_fv subst) ([], emptyVarSet) $ dVarSetElems fvs
where
subst_fv subst fv
| isId fv = exprFreeVars (lookupIdSubst (text "substVarSet") subst fv)
| otherwise = Type.tyVarsOfType (lookupTvSubst subst fv)
subst_fv subst fv acc
| isId fv = expr_fvs (lookupIdSubst (text "substDVarSet") subst fv) isLocalVar emptyVarSet $! acc
| otherwise = tyVarsOfTypeAcc (lookupTvSubst subst fv) (const True) emptyVarSet $! acc
------------------
substTickish :: Subst -> Tickish Id -> Tickish Id
......
......@@ -40,7 +40,6 @@ import BasicTypes
import FastString ( unpackFS )
import Literal
import PrelNames
import VarSet
import DynFlags
import Outputable
import Util
......@@ -119,7 +118,7 @@ mkFCall dflags uniq the_fcall val_args res_ty
where
arg_tys = map exprType val_args
body_ty = (mkFunTys arg_tys res_ty)
tyvars = varSetElems (tyVarsOfType body_ty)
tyvars = tyVarsOfTypeList body_ty
ty = mkForAllTys tyvars body_ty
the_fcall_id = mkFCallId dflags uniq the_fcall ty
......
......@@ -445,7 +445,7 @@ dsExpr (HsStatic expr@(L loc _)) = do
, moduleNameFS $ moduleName $ nameModule n'
, occNameFS $ nameOccName n'
]
let tvars = varSetElems $ tyVarsOfType ty
let tvars = tyVarsOfTypeList ty
speTy = mkForAllTys tvars $ mkTyConApp staticPtrTyCon [ty]
speId = mkExportedLocalId VanillaId n' speTy
fp@(Fingerprint w0 w1) = fingerprintName $ idName speId
......
......@@ -451,6 +451,7 @@ Library
FastStringEnv
Fingerprint
FiniteMap
FV
GraphBase
GraphColor
GraphOps
......
......@@ -529,6 +529,7 @@ compiler_stage2_dll0_MODULES = \
Fingerprint \
FiniteMap \
ForeignCall \
FV \
Hooks \
HsBinds \
HsDecls \
......
......@@ -152,7 +152,7 @@ mkProtoBCO