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

27 files changed, 610 insertions, 431 deletions

diff --git a/compiler/basicTypes/IdInfo.hs b/compiler/basicTypes/IdInfo.hs
index 2dafafc1e5..6f00df5f6f 100644
--- a/compiler/basicTypes/IdInfo.hs
+++ b/compiler/basicTypes/IdInfo.hs
@@ -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]
diff --git a/compiler/coreSyn/CoreFVs.hs b/compiler/coreSyn/CoreFVs.hs
index 0e5027768a..39a159958e 100644
--- a/compiler/coreSyn/CoreFVs.hs
+++ b/compiler/coreSyn/CoreFVs.hs
@@ -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)
diff --git a/compiler/coreSyn/CoreSeq.hs b/compiler/coreSyn/CoreSeq.hs
index e3c7844f2e..d426bd3581 100644
--- a/compiler/coreSyn/CoreSeq.hs
+++ b/compiler/coreSyn/CoreSeq.hs
@@ -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` ()
diff --git a/compiler/coreSyn/CoreSubst.hs b/compiler/coreSyn/CoreSubst.hs
index c1de2051ee..697ce4b6db 100644
--- a/compiler/coreSyn/CoreSubst.hs
+++ b/compiler/coreSyn/CoreSubst.hs
@@ -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
diff --git a/compiler/deSugar/DsCCall.hs b/compiler/deSugar/DsCCall.hs
index 26551b58fa..f7bfa7b581 100644
--- a/compiler/deSugar/DsCCall.hs
+++ b/compiler/deSugar/DsCCall.hs
@@ -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
 
diff --git a/compiler/deSugar/DsExpr.hs b/compiler/deSugar/DsExpr.hs
index 44e0aa0977..13e7e11431 100644
--- a/compiler/deSugar/DsExpr.hs
+++ b/compiler/deSugar/DsExpr.hs
@@ -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
diff --git a/compiler/ghc.cabal.in b/compiler/ghc.cabal.in
index b78c2b89e9..9ea5b66e90 100644
--- a/compiler/ghc.cabal.in
+++ b/compiler/ghc.cabal.in
@@ -451,6 +451,7 @@ Library
         FastStringEnv
         Fingerprint
         FiniteMap
+        FV
         GraphBase
         GraphColor
         GraphOps
diff --git a/compiler/ghc.mk b/compiler/ghc.mk
index e3f824e5f3..b75fdc2cd5 100644
--- a/compiler/ghc.mk
+++ b/compiler/ghc.mk
@@ -529,6 +529,7 @@ compiler_stage2_dll0_MODULES = \
 	Fingerprint \
 	FiniteMap \
 	ForeignCall \
+	FV \
 	Hooks \
 	HsBinds \
 	HsDecls \
diff --git a/compiler/ghci/ByteCodeGen.hs b/compiler/ghci/ByteCodeGen.hs
index 11a8c6d098..83b8028c19 100644
--- a/compiler/ghci/ByteCodeGen.hs
+++ b/compiler/ghci/ByteCodeGen.hs
@@ -152,7 +152,7 @@ mkProtoBCO
    :: DynFlags
    -> name
    -> BCInstrList
-   -> Either  [AnnAlt Id VarSet] (AnnExpr Id VarSet)
+   -> Either  [AnnAlt Id DVarSet] (AnnExpr Id DVarSet)
    -> Int
    -> Word16
    -> [StgWord]
@@ -215,7 +215,7 @@ argBits dflags (rep : args)
 
 -- Compile code for the right-hand side of a top-level binding
 
-schemeTopBind :: (Id, AnnExpr Id VarSet) -> BcM (ProtoBCO Name)
+schemeTopBind :: (Id, AnnExpr Id DVarSet) -> BcM (ProtoBCO Name)
 
 
 schemeTopBind (id, rhs)
@@ -252,7 +252,7 @@ schemeTopBind (id, rhs)
 schemeR :: [Id]                 -- Free vars of the RHS, ordered as they
                                 -- will appear in the thunk.  Empty for
                                 -- top-level things, which have no free vars.
-        -> (Id, AnnExpr Id VarSet)
+        -> (Id, AnnExpr Id DVarSet)
         -> BcM (ProtoBCO Name)
 schemeR fvs (nm, rhs)
 {-
@@ -267,7 +267,7 @@ schemeR fvs (nm, rhs)
 -}
    = schemeR_wrk fvs nm rhs (collect rhs)
 
-collect :: AnnExpr Id VarSet -> ([Var], AnnExpr' Id VarSet)
+collect :: AnnExpr Id DVarSet -> ([Var], AnnExpr' Id DVarSet)
 collect (_, e) = go [] e
   where
     go xs e | Just e' <- bcView e = go xs e'
@@ -278,7 +278,7 @@ collect (_, e) = go [] e
       = go (x:xs) e
     go xs not_lambda = (reverse xs, not_lambda)
 
-schemeR_wrk :: [Id] -> Id -> AnnExpr Id VarSet -> ([Var], AnnExpr' Var VarSet) -> BcM (ProtoBCO Name)
+schemeR_wrk :: [Id] -> Id -> AnnExpr Id DVarSet -> ([Var], AnnExpr' Var DVarSet) -> BcM (ProtoBCO Name)
 schemeR_wrk fvs nm original_body (args, body)
    = do
      dflags <- getDynFlags
@@ -303,7 +303,7 @@ schemeR_wrk fvs nm original_body (args, body)
                  arity bitmap_size bitmap False{-not alts-})
 
 -- introduce break instructions for ticked expressions
-schemeER_wrk :: Word -> BCEnv -> AnnExpr' Id VarSet -> BcM BCInstrList
+schemeER_wrk :: Word -> BCEnv -> AnnExpr' Id DVarSet -> BcM BCInstrList
 schemeER_wrk d p rhs
   | AnnTick (Breakpoint tick_no fvs) (_annot, newRhs) <- rhs
   = do  code <- schemeE (fromIntegral d) 0 p newRhs
@@ -338,7 +338,7 @@ trunc16 w
     | otherwise
     = fromIntegral w
 
-fvsToEnv :: BCEnv -> VarSet -> [Id]
+fvsToEnv :: BCEnv -> DVarSet -> [Id]
 -- Takes the free variables of a right-hand side, and
 -- delivers an ordered list of the local variables that will
 -- be captured in the thunk for the RHS
@@ -347,7 +347,7 @@ fvsToEnv :: BCEnv -> VarSet -> [Id]
 --
 -- The code that constructs the thunk, and the code that executes
 -- it, have to agree about this layout
-fvsToEnv p fvs = [v | v <- varSetElems fvs,
+fvsToEnv p fvs = [v | v <- dVarSetElems fvs,
                       isId v,           -- Could be a type variable
                       v `Map.member` p]
 
@@ -355,7 +355,7 @@ fvsToEnv p fvs = [v | v <- varSetElems fvs,
 -- schemeE
 
 returnUnboxedAtom :: Word -> Sequel -> BCEnv
-                 -> AnnExpr' Id VarSet -> ArgRep
+                 -> AnnExpr' Id DVarSet -> ArgRep
                  -> BcM BCInstrList
 -- Returning an unlifted value.
 -- Heave it on the stack, SLIDE, and RETURN.
@@ -367,7 +367,7 @@ returnUnboxedAtom d s p e e_rep
 
 -- Compile code to apply the given expression to the remaining args
 -- on the stack, returning a HNF.
-schemeE :: Word -> Sequel -> BCEnv -> AnnExpr' Id VarSet -> BcM BCInstrList
+schemeE :: Word -> Sequel -> BCEnv -> AnnExpr' Id DVarSet -> BcM BCInstrList
 
 schemeE d s p e
    | Just e' <- bcView e
@@ -469,17 +469,17 @@ schemeE d s p exp@(AnnTick (Breakpoint _id _fvs) _rhs)
           -- breakpoint will otherwise work fine.
           id <- newId (mkFunTy realWorldStatePrimTy ty)
           st <- newId realWorldStatePrimTy
-          let letExp = AnnLet (AnnNonRec id (fvs, AnnLam st (emptyVarSet, exp)))
-                              (emptyVarSet, (AnnApp (emptyVarSet, AnnVar id)
-                                                    (emptyVarSet, AnnVar realWorldPrimId)))
+          let letExp = AnnLet (AnnNonRec id (fvs, AnnLam st (emptyDVarSet, exp)))
+                              (emptyDVarSet, (AnnApp (emptyDVarSet, AnnVar id)
+                                                    (emptyDVarSet, AnnVar realWorldPrimId)))
           schemeE d s p letExp
         else do
           id <- newId ty
           -- Todo: is emptyVarSet correct on the next line?
-          let letExp = AnnLet (AnnNonRec id (fvs, exp)) (emptyVarSet, AnnVar id)
+          let letExp = AnnLet (AnnNonRec id (fvs, exp)) (emptyDVarSet, AnnVar id)
           schemeE d s p letExp
    where exp' = deAnnotate' exp
-         fvs  = exprFreeVars exp'
+         fvs  = exprFreeDVars exp'
          ty   = exprType exp'
 
 -- ignore other kinds of tick
@@ -581,7 +581,7 @@ schemeE _ _ _ expr
 schemeT :: Word         -- Stack depth
         -> Sequel       -- Sequel depth
         -> BCEnv        -- stack env
-        -> AnnExpr' Id VarSet
+        -> AnnExpr' Id DVarSet
         -> BcM BCInstrList
 
 schemeT d s p app
@@ -644,7 +644,7 @@ schemeT d s p app
 
 mkConAppCode :: Word -> Sequel -> BCEnv
              -> DataCon                 -- The data constructor
-             -> [AnnExpr' Id VarSet]    -- Args, in *reverse* order
+             -> [AnnExpr' Id DVarSet]    -- Args, in *reverse* order
              -> BcM BCInstrList
 
 mkConAppCode _ _ _ con []       -- Nullary constructor
@@ -680,7 +680,7 @@ mkConAppCode orig_d _ p con args_r_to_l
 
 unboxedTupleReturn
         :: Word -> Sequel -> BCEnv
-        -> AnnExpr' Id VarSet -> BcM BCInstrList
+        -> AnnExpr' Id DVarSet -> BcM BCInstrList
 unboxedTupleReturn d s p arg = returnUnboxedAtom d s p arg (atomRep arg)
 
 -- -----------------------------------------------------------------------------
@@ -688,7 +688,7 @@ unboxedTupleReturn d s p arg = returnUnboxedAtom d s p arg (atomRep arg)
 
 doTailCall
         :: Word -> Sequel -> BCEnv
-        -> Id -> [AnnExpr' Id VarSet]
+        -> Id -> [AnnExpr' Id DVarSet]
         -> BcM BCInstrList
 doTailCall init_d s p fn args
   = do_pushes init_d args (map atomRep args)
@@ -745,7 +745,7 @@ findPushSeq _
 -- Case expressions
 
 doCase  :: Word -> Sequel -> BCEnv
-        -> AnnExpr Id VarSet -> Id -> [AnnAlt Id VarSet]
+        -> AnnExpr Id DVarSet -> Id -> [AnnAlt Id DVarSet]
         -> Maybe Id  -- Just x <=> is an unboxed tuple case with scrut binder, don't enter the result
         -> BcM BCInstrList
 doCase d s p (_,scrut) bndr alts is_unboxed_tuple
@@ -900,7 +900,7 @@ generateCCall :: Word -> Sequel         -- stack and sequel depths
               -> BCEnv
               -> CCallSpec              -- where to call
               -> Id                     -- of target, for type info
-              -> [AnnExpr' Id VarSet]   -- args (atoms)
+              -> [AnnExpr' Id DVarSet]   -- args (atoms)
               -> BcM BCInstrList
 
 generateCCall d0 s p (CCallSpec target cconv safety) fn args_r_to_l
@@ -949,7 +949,7 @@ generateCCall d0 s p (CCallSpec target cconv safety) fn args_r_to_l
          -- Do magic for Ptr/Byte arrays.  Push a ptr to the array on
          -- the stack but then advance it over the headers, so as to
          -- point to the payload.
-         parg_ArrayishRep :: Word16 -> Word -> BCEnv -> AnnExpr' Id VarSet
+         parg_ArrayishRep :: Word16 -> Word -> BCEnv -> AnnExpr' Id DVarSet
                           -> BcM BCInstrList
          parg_ArrayishRep hdrSize d p a
             = do (push_fo, _) <- pushAtom d p a
@@ -1142,7 +1142,7 @@ maybe_getCCallReturnRep fn_ty
      --trace (showSDoc (ppr (a_reps, r_reps))) $
      if ok then maybe_r_rep_to_go else blargh
 
-maybe_is_tagToEnum_call :: AnnExpr' Id VarSet -> Maybe (AnnExpr' Id VarSet, [Name])
+maybe_is_tagToEnum_call :: AnnExpr' Id DVarSet -> Maybe (AnnExpr' Id DVarSet, [Name])
 -- Detect and extract relevant info for the tagToEnum kludge.
 maybe_is_tagToEnum_call app
   | AnnApp (_, AnnApp (_, AnnVar v) (_, AnnType t)) arg <- app
@@ -1200,7 +1200,7 @@ a 1-word null. See Trac #8383.
 
 
 implement_tagToId :: Word -> Sequel -> BCEnv
-                  -> AnnExpr' Id VarSet -> [Name] -> BcM BCInstrList
+                  -> AnnExpr' Id DVarSet -> [Name] -> BcM BCInstrList
 -- See Note [Implementing tagToEnum#]
 implement_tagToId d s p arg names
   = ASSERT( notNull names )
@@ -1243,7 +1243,7 @@ implement_tagToId d s p arg names
 -- to 5 and not to 4.  Stack locations are numbered from zero, so a
 -- depth 6 stack has valid words 0 .. 5.
 
-pushAtom :: Word -> BCEnv -> AnnExpr' Id VarSet -> BcM (BCInstrList, Word16)
+pushAtom :: Word -> BCEnv -> AnnExpr' Id DVarSet -> BcM (BCInstrList, Word16)
 
 pushAtom d p e
    | Just e' <- bcView e
diff --git a/compiler/ghci/ByteCodeInstr.hs b/compiler/ghci/ByteCodeInstr.hs
index fee15bbf74..2de4941aa6 100644
--- a/compiler/ghci/ByteCodeInstr.hs
+++ b/compiler/ghci/ByteCodeInstr.hs
@@ -44,7 +44,7 @@ data ProtoBCO a
         protoBCOBitmapSize :: Word16,
         protoBCOArity      :: Int,
         -- what the BCO came from
-        protoBCOExpr       :: Either  [AnnAlt Id VarSet] (AnnExpr Id VarSet),
+        protoBCOExpr       :: Either  [AnnAlt Id DVarSet] (AnnExpr Id DVarSet),
         -- malloc'd pointers
         protoBCOPtrs       :: [Either ItblPtr (Ptr ())]
    }
diff --git a/compiler/ghci/RtClosureInspect.hs b/compiler/ghci/RtClosureInspect.hs
index 6853fbbaea..1ec127e35b 100644
--- a/compiler/ghci/RtClosureInspect.hs
+++ b/compiler/ghci/RtClosureInspect.hs
@@ -1268,7 +1268,7 @@ quantifyType :: Type -> QuantifiedType
 -- Thus (quantifyType (forall a. a->[b]))
 -- returns ([a,b], a -> [b])
 
-quantifyType ty = (varSetElems (tyVarsOfType rho), rho)
+quantifyType ty = (tyVarsOfTypeList rho, rho)
   where
     (_tvs, rho) = tcSplitForAllTys ty
 
diff --git a/compiler/simplCore/FloatIn.hs b/compiler/simplCore/FloatIn.hs
index 8b2a84d76c..c1147eb446 100644
--- a/compiler/simplCore/FloatIn.hs
+++ b/compiler/simplCore/FloatIn.hs
@@ -28,7 +28,7 @@ import Var
 import Type             ( Type, isUnLiftedType, isFunTy, splitFunTy, applyTy )
 import VarSet
 import Util
-import UniqFM
+import UniqDFM (UniqDFM, udfmToUfm)
 import DynFlags
 import Outputable
 import Data.List( mapAccumL )
@@ -143,7 +143,7 @@ fiExpr dflags to_drop (_, AnnCast expr (fvs_co, co))
   = wrapFloats (drop_here ++ co_drop) $
     Cast (fiExpr dflags e_drop expr) co
   where
-    [drop_here, e_drop, co_drop] = sepBindsByDropPoint dflags False [freeVarsOf expr, fvs_co] to_drop
+    [drop_here, e_drop, co_drop] = sepBindsByDropPoint dflags False [udfmToUfm $ freeVarsOf expr, udfmToUfm fvs_co] to_drop
 
 {-
 Applications: we do float inside applications, mainly because we
@@ -167,16 +167,17 @@ fiExpr dflags to_drop ann_expr@(_,AnnApp {})
     mk_arg_fvs (fun_ty, extra_fvs) (_, AnnType ty)
       = ((applyTy fun_ty ty, extra_fvs), emptyVarSet)
 
-    mk_arg_fvs (fun_ty, extra_fvs) (arg_fvs, ann_arg)
+    mk_arg_fvs (fun_ty, extra_fvs) (arg_dfvs, ann_arg)
       | ASSERT( isFunTy fun_ty ) noFloatIntoRhs ann_arg arg_ty
       = ((res_ty, extra_fvs `unionVarSet` arg_fvs), emptyVarSet)
       | otherwise
       = ((res_ty, extra_fvs), arg_fvs)
       where
+       arg_fvs = udfmToUfm arg_dfvs
        (arg_ty, res_ty) = splitFunTy fun_ty
 
     drop_here : extra_drop : fun_drop : arg_drops
-      = sepBindsByDropPoint dflags False (extra_fvs : fun_fvs : arg_fvs) to_drop
+      = sepBindsByDropPoint dflags False (extra_fvs : udfmToUfm fun_fvs : arg_fvs) to_drop
 
 {-
 Note [Do not destroy the let/app invariant]
@@ -303,12 +304,12 @@ idRuleAndUnfoldingVars of x.  No need for type variables, hence not using
 idFreeVars.
 -}
 
-fiExpr dflags to_drop (_,AnnLet (AnnNonRec id rhs@(rhs_fvs, ann_rhs)) body)
+fiExpr dflags to_drop (_,AnnLet (AnnNonRec id rhs@(rhs_dfvs, ann_rhs)) body)
   = fiExpr dflags new_to_drop body
   where
-    body_fvs = freeVarsOf body `delVarSet` id
+    body_fvs = udfmToUfm (freeVarsOf body) `delVarSet` id
     rhs_ty = idType id
-
+    rhs_fvs = udfmToUfm rhs_dfvs
     rule_fvs = idRuleAndUnfoldingVars id        -- See Note [extra_fvs (2): free variables of rules]
     extra_fvs | noFloatIntoRhs ann_rhs rhs_ty = rule_fvs `unionVarSet` rhs_fvs
               | otherwise                     = rule_fvs
@@ -334,13 +335,13 @@ fiExpr dflags to_drop (_,AnnLet (AnnRec bindings) body)
   = fiExpr dflags new_to_drop body
   where
     (ids, rhss) = unzip bindings
-    rhss_fvs = map freeVarsOf rhss
-    body_fvs = freeVarsOf body
+    rhss_fvs = map (udfmToUfm . freeVarsOf) rhss
+    body_fvs = udfmToUfm $ freeVarsOf body
 
         -- See Note [extra_fvs (1,2)]
     rule_fvs = mapUnionVarSet idRuleAndUnfoldingVars ids
     extra_fvs = rule_fvs `unionVarSet`
-                unionVarSets [ fvs | (fvs, rhs) <- rhss
+                unionVarSets [ udfmToUfm fvs | (fvs, rhs) <- rhss
                              , noFloatIntoExpr rhs ]
 
     (shared_binds:extra_binds:body_binds:rhss_binds)
@@ -392,8 +393,8 @@ fiExpr dflags to_drop (_, AnnCase scrut case_bndr _ [(con,alt_bndrs,rhs)])
     scrut' = fiExpr dflags scrut_binds scrut
     [shared_binds, scrut_binds, rhs_binds]
        = sepBindsByDropPoint dflags False [scrut_fvs, rhs_fvs] to_drop
-    rhs_fvs   = freeVarsOf rhs `delVarSetList` (case_bndr : alt_bndrs)
-    scrut_fvs = freeVarsOf scrut
+    rhs_fvs   = udfmToUfm (freeVarsOf rhs) `delVarSetList` (case_bndr : alt_bndrs)
+    scrut_fvs = udfmToUfm $ freeVarsOf scrut
 
 fiExpr dflags to_drop (_, AnnCase scrut case_bndr ty alts)
   = wrapFloats drop_here1 $
@@ -408,10 +409,10 @@ fiExpr dflags to_drop (_, AnnCase scrut case_bndr ty alts)
         -- Float into the alts with the is_case flag set
     (drop_here2 : alts_drops_s) = sepBindsByDropPoint dflags True alts_fvs alts_drops
 
-    scrut_fvs    = freeVarsOf scrut
+    scrut_fvs    = udfmToUfm $ freeVarsOf scrut
     alts_fvs     = map alt_fvs alts
     all_alts_fvs = unionVarSets alts_fvs
-    alt_fvs (_con, args, rhs) = foldl delVarSet (freeVarsOf rhs) (case_bndr:args)
+    alt_fvs (_con, args, rhs) = foldl delVarSet (udfmToUfm $ freeVarsOf rhs) (case_bndr:args)
                                 -- Delete case_bndr and args from free vars of rhs
                                 -- to get free vars of alt
 
@@ -423,14 +424,14 @@ okToFloatInside bndrs = all ok bndrs
     ok b = not (isId b) || isOneShotBndr b
     -- Push the floats inside there are no non-one-shot value binders
 
-noFloatIntoRhs :: AnnExpr' Var (UniqFM Var) -> Type -> Bool
+noFloatIntoRhs :: AnnExpr' Var (UniqDFM Var) -> Type -> Bool
 -- ^ True if it's a bad idea to float bindings into this RHS
 -- Preconditio:  rhs :: rhs_ty
 noFloatIntoRhs rhs rhs_ty
   =  isUnLiftedType rhs_ty   -- See Note [Do not destroy the let/app invariant]
   || noFloatIntoExpr rhs
 
-noFloatIntoExpr :: AnnExpr' Var (UniqFM Var) -> Bool
+noFloatIntoExpr :: AnnExpr' Var (UniqDFM Var) -> Bool
 noFloatIntoExpr (AnnLam bndr e)
    = not (okToFloatInside (bndr:bndrs))
      -- NB: Must line up with fiExpr (AnnLam...); see Trac #7088
diff --git a/compiler/simplCore/SetLevels.hs b/compiler/simplCore/SetLevels.hs
index d873cc5e15..d37a62df6c 100644
--- a/compiler/simplCore/SetLevels.hs
+++ b/compiler/simplCore/SetLevels.hs
@@ -63,7 +63,7 @@ import CoreFVs          -- all of it
 import Coercion         ( isCoVar )
 import CoreSubst        ( Subst, emptySubst, substBndrs, substRecBndrs,
                           extendIdSubst, extendSubstWithVar, cloneBndrs,
-                          cloneRecIdBndrs, substTy, substCo, substVarSet )
+                          cloneRecIdBndrs, substTy, substCo, substDVarSet )
 import MkCore           ( sortQuantVars )
 import Id
 import IdInfo
@@ -80,6 +80,8 @@ import UniqSupply
 import Util
 import Outputable
 import FastString
+import UniqDFM (udfmToUfm)
+import FV
 
 {-
 ************************************************************************
@@ -362,10 +364,10 @@ lvlExpr env (_, AnnCase scrut@(scrut_fvs,_) case_bndr ty alts)
 
 -------------------------------------------
 lvlCase :: LevelEnv             -- Level of in-scope names/tyvars
-        -> VarSet               -- Free vars of input scrutinee
+        -> DVarSet              -- Free vars of input scrutinee
         -> LevelledExpr         -- Processed scrutinee
         -> Id -> Type           -- Case binder and result type
-        -> [AnnAlt Id VarSet]   -- Input alternatives
+        -> [AnnAlt Id DVarSet]  -- Input alternatives
         -> LvlM LevelledExpr    -- Result expression
 lvlCase env scrut_fvs scrut' case_bndr ty alts
   | [(con@(DataAlt {}), bs, body)] <- alts
@@ -707,7 +709,7 @@ lvlBind env (AnnNonRec bndr rhs@(rhs_fvs,_))
        ; return (NonRec (TB bndr' (FloatMe dest_lvl)) rhs', env') }
 
   where
-    bind_fvs   = rhs_fvs `unionVarSet` idFreeVars bndr
+    bind_fvs   = rhs_fvs `unionDVarSet` runFVDSet (idFreeVarsAcc bndr)
     abs_vars   = abstractVars dest_lvl env bind_fvs
     dest_lvl   = destLevel env bind_fvs (isFunction rhs) is_bot
     is_bot     = exprIsBottom (deAnnotate rhs)
@@ -767,10 +769,12 @@ lvlBind env (AnnRec pairs)
     (bndrs,rhss) = unzip pairs
 
         -- Finding the free vars of the binding group is annoying
-    bind_fvs = (unionVarSets [ idFreeVars bndr `unionVarSet` rhs_fvs
-                            | (bndr, (rhs_fvs,_)) <- pairs])
-               `minusVarSet`
-               mkVarSet bndrs
+    bind_fvs = ((unionDVarSets [ rhs_fvs | (_, (rhs_fvs,_)) <- pairs])
+                `unionDVarSet`
+                (runFVDSet $ foldr unionFV noVars [ idFreeVarsAcc bndr
+                                                  | (bndr, (_,_)) <- pairs]))
+               `minusDVarSet`
+                mkDVarSet bndrs -- XXX: it's a waste to create a set here
 
     dest_lvl = destLevel env bind_fvs (all isFunction rhss) False
     abs_vars = abstractVars dest_lvl env bind_fvs
@@ -850,7 +854,7 @@ lvlBndrs env@(LE { le_lvl_env = lvl_env }) new_lvl bndrs
 
   -- Destination level is the max Id level of the expression
   -- (We'll abstract the type variables, if any.)
-destLevel :: LevelEnv -> VarSet
+destLevel :: LevelEnv -> DVarSet
           -> Bool   -- True <=> is function
           -> Bool   -- True <=> is bottom
           -> Level
@@ -887,8 +891,8 @@ isFunction (_, AnnLam b e) | isId b    = True
 -- isFunction (_, AnnTick _ e)          = isFunction e  -- dubious
 isFunction _                           = False
 
-countFreeIds :: VarSet -> Int
-countFreeIds = foldVarSet add 0
+countFreeIds :: DVarSet -> Int
+countFreeIds = foldVarSet add 0 . udfmToUfm
   where
     add :: Var -> Int -> Int
     add v n | isId v    = n+1
@@ -970,9 +974,9 @@ extendCaseBndrEnv le@(LE { le_subst = subst, le_env = id_env })
        , le_env     = add_id id_env (case_bndr, scrut_var) }
 extendCaseBndrEnv env _ _ = env
 
-maxFvLevel :: (Var -> Bool) -> LevelEnv -> VarSet -> Level
+maxFvLevel :: (Var -> Bool) -> LevelEnv -> DVarSet -> Level
 maxFvLevel max_me (LE { le_lvl_env = lvl_env, le_env = id_env }) var_set
-  = foldVarSet max_in tOP_LEVEL var_set
+  = foldDVarSet max_in tOP_LEVEL var_set
   where
     max_in in_var lvl
        = foldr max_out lvl (case lookupVarEnv id_env in_var of
@@ -990,17 +994,17 @@ lookupVar le v = case lookupVarEnv (le_env le) v of
                     Just (_, expr) -> expr
                     _              -> Var v
 
-abstractVars :: Level -> LevelEnv -> VarSet -> [OutVar]
+abstractVars :: Level -> LevelEnv -> DVarSet -> [OutVar]
         -- Find the variables in fvs, free vars of the target expresion,
         -- whose level is greater than the destination level
         -- These are the ones we are going to abstract out
 abstractVars dest_lvl (LE { le_subst = subst, le_lvl_env = lvl_env }) in_fvs
   = map zap $ uniq $ sortQuantVars
-    [out_var | out_fv  <- varSetElems (substVarSet subst in_fvs)
+    [out_var | out_fv  <- dVarSetElems (substDVarSet subst in_fvs)
              , out_var <- varSetElems (close out_fv)
              , abstract_me out_var ]
         -- NB: it's important to call abstract_me only on the OutIds the
-        -- come from substVarSet (not on fv, which is an InId)
+        -- come from substDVarSet (not on fv, which is an InId)
   where
     uniq :: [Var] -> [Var]
         -- Remove adjacent duplicates; the sort will have brought them together
diff --git a/compiler/specialise/Rules.hs b/compiler/specialise/Rules.hs
index 9b5d3cf763..1aa472b92a 100644
--- a/compiler/specialise/Rules.hs
+++ b/compiler/specialise/Rules.hs
@@ -33,7 +33,7 @@ import Module           ( Module, ModuleSet, elemModuleSet )
 import CoreSubst
 import OccurAnal        ( occurAnalyseExpr )
 import CoreFVs          ( exprFreeVars, exprsFreeVars, bindFreeVars
-                        , rulesFreeVars, exprsOrphNames )
+                        , rulesFreeDVars, exprsOrphNames )
 import CoreUtils        ( exprType, eqExpr, mkTick, mkTicks,
                           stripTicksTopT, stripTicksTopE )
 import PprCore          ( pprRules )
@@ -275,15 +275,15 @@ pprRulesForUser rules
 -- | Make a 'RuleInfo' containing a number of 'CoreRule's, suitable
 -- for putting into an 'IdInfo'
 mkRuleInfo :: [CoreRule] -> RuleInfo
-mkRuleInfo rules = RuleInfo rules (rulesFreeVars rules)
+mkRuleInfo rules = RuleInfo rules (rulesFreeDVars rules)
 
 extendRuleInfo :: RuleInfo -> [CoreRule] -> RuleInfo
 extendRuleInfo (RuleInfo rs1 fvs1) rs2
-  = RuleInfo (rs2 ++ rs1) (rulesFreeVars rs2 `unionVarSet` fvs1)
+  = RuleInfo (rs2 ++ rs1) (rulesFreeDVars rs2 `unionDVarSet` fvs1)
 
 addRuleInfo :: RuleInfo -> RuleInfo -> RuleInfo
 addRuleInfo (RuleInfo rs1 fvs1) (RuleInfo rs2 fvs2)
-  = RuleInfo (rs1 ++ rs2) (fvs1 `unionVarSet` fvs2)
+  = RuleInfo (rs1 ++ rs2) (fvs1 `unionDVarSet` fvs2)
 
 addIdSpecialisations :: Id -> [CoreRule] -> Id
 addIdSpecialisations id []
diff --git a/compiler/typecheck/TcDeriv.hs b/compiler/typecheck/TcDeriv.hs
index 28502b6249..8631bd3342 100644
--- a/compiler/typecheck/TcDeriv.hs
+++ b/compiler/typecheck/TcDeriv.hs
@@ -691,7 +691,7 @@ deriveTyData tvs tc tc_args (L loc deriv_pred)
               final_cls_tys       = substTys subst' cls_tys
 
         ; traceTc "derivTyData1" (vcat [ pprTvBndrs tvs, ppr tc, ppr tc_args, ppr deriv_pred
-                                       , pprTvBndrs (varSetElems $ tyVarsOfTypes tc_args)
+                                       , pprTvBndrs (tyVarsOfTypesList tc_args)
                                        , ppr n_args_to_keep, ppr n_args_to_drop
                                        , ppr inst_ty_kind, ppr cls_arg_kind, ppr mb_match
                                        , ppr final_tc_args, ppr final_cls_tys ])
diff --git a/compiler/typecheck/TcErrors.hs b/compiler/typecheck/TcErrors.hs
index e1550befba..38273630b6 100644
--- a/compiler/typecheck/TcErrors.hs
+++ b/compiler/typecheck/TcErrors.hs
@@ -738,7 +738,7 @@ mkHoleError ctxt ct@(CHoleCan { cc_occ = occ, cc_hole = hole_sort })
     ct_loc      = ctLoc ct
     lcl_env     = ctLocEnv ct_loc
     hole_ty     = ctEvPred (ctEvidence ct)
-    tyvars      = varSetElems (tyVarsOfType hole_ty)
+    tyvars      = tyVarsOfTypeList hole_ty
     boring_type = isTyVarTy hole_ty
 
     out_of_scope_msg -- Print v :: ty only if the type has structure
@@ -1655,7 +1655,7 @@ mk_dict_err ctxt (ct, (matches, unifiers, unsafe_overlapped))
 
              ,  ppWhen (isSingleton matches) $
                 parens (vcat [ ptext (sLit "The choice depends on the instantiation of") <+>
-                                  quotes (pprWithCommas ppr (varSetElems (tyVarsOfTypes tys)))
+                                  quotes (pprWithCommas ppr (tyVarsOfTypesList tys))
                              , ppWhen (null (matching_givens)) $
                                vcat [ ptext (sLit "To pick the first instance above, use IncoherentInstances")
                                     , ptext (sLit "when compiling the other instance declarations")]
diff --git a/compiler/typecheck/TcHsType.hs b/compiler/typecheck/TcHsType.hs
index 191756ac7a..318d7d89b8 100644
--- a/compiler/typecheck/TcHsType.hs
+++ b/compiler/typecheck/TcHsType.hs
@@ -972,7 +972,7 @@ kcHsTyVarBndrs cusk (HsQTvs { hsq_kvs = kv_ns, hsq_tvs = hs_tvs }) thing_inside
        ; (res_kind, stuff) <- tcExtendKindEnv nks thing_inside
        ; let full_kind = mkArrowKinds (map snd nks) res_kind
              kvs       = filter (not . isMetaTyVar) $
-                         varSetElems $ tyVarsOfType full_kind
+                         tyVarsOfTypeList full_kind
              gen_kind  = if cusk
                          then mkForAllTys kvs full_kind
                          else full_kind
diff --git a/compiler/typecheck/TcType.hs b/compiler/typecheck/TcType.hs
index 13422d9020..78a0fbc594 100644
--- a/compiler/typecheck/TcType.hs
+++ b/compiler/typecheck/TcType.hs
@@ -143,6 +143,7 @@ module TcType (
   isPrimitiveType,
 
   tyVarsOfType, tyVarsOfTypes, closeOverKinds,
+  tyVarsOfTypeList, tyVarsOfTypesList,
   tcTyVarsOfType, tcTyVarsOfTypes,
 
   pprKind, pprParendKind, pprSigmaType,
diff --git a/compiler/types/Coercion.hs b/compiler/types/Coercion.hs
index af05d5c1f8..fee8c343a9 100644
--- a/compiler/types/Coercion.hs
+++ b/compiler/types/Coercion.hs
@@ -47,6 +47,7 @@ module Coercion (
 
         -- ** Free variables
         tyCoVarsOfCo, tyCoVarsOfCos, coVarsOfCo, coercionSize,
+        tyCoVarsOfCoAcc, tyCoVarsOfCosAcc,
 
         -- ** Substitution
         CvSubstEnv, emptyCvSubstEnv,
@@ -107,6 +108,7 @@ import Data.Traversable (traverse, sequenceA)
 #endif
 import FastString
 import ListSetOps
+import FV
 
 import qualified Data.Data as Data hiding ( TyCon )
 import Control.Arrow ( first )
@@ -554,24 +556,45 @@ isCoVarType ty      -- Tests for t1 ~# t2, the unboxed equality
       Nothing       -> False
 
 tyCoVarsOfCo :: Coercion -> VarSet
+tyCoVarsOfCo co = runFVSet $ tyCoVarsOfCoAcc co
 -- Extracts type and coercion variables from a coercion
-tyCoVarsOfCo (Refl _ ty)           = tyVarsOfType ty
-tyCoVarsOfCo (TyConAppCo _ _ cos)  = tyCoVarsOfCos cos
-tyCoVarsOfCo (AppCo co1 co2)       = tyCoVarsOfCo co1 `unionVarSet` tyCoVarsOfCo co2
-tyCoVarsOfCo (ForAllCo tv co)      = tyCoVarsOfCo co `delVarSet` tv
-tyCoVarsOfCo (CoVarCo v)           = unitVarSet v
-tyCoVarsOfCo (AxiomInstCo _ _ cos) = tyCoVarsOfCos cos
-tyCoVarsOfCo (UnivCo _ _ ty1 ty2)  = tyVarsOfType ty1 `unionVarSet` tyVarsOfType ty2
-tyCoVarsOfCo (SymCo co)            = tyCoVarsOfCo co
-tyCoVarsOfCo (TransCo co1 co2)     = tyCoVarsOfCo co1 `unionVarSet` tyCoVarsOfCo co2
-tyCoVarsOfCo (NthCo _ co)          = tyCoVarsOfCo co
-tyCoVarsOfCo (LRCo _ co)           = tyCoVarsOfCo co
-tyCoVarsOfCo (InstCo co ty)        = tyCoVarsOfCo co `unionVarSet` tyVarsOfType ty
-tyCoVarsOfCo (SubCo co)            = tyCoVarsOfCo co
-tyCoVarsOfCo (AxiomRuleCo _ ts cs) = tyVarsOfTypes ts `unionVarSet` tyCoVarsOfCos cs
 
 tyCoVarsOfCos :: [Coercion] -> VarSet
-tyCoVarsOfCos = mapUnionVarSet tyCoVarsOfCo
+tyCoVarsOfCos cos = runFVSet $ tyCoVarsOfCosAcc cos
+
+tyCoVarsOfCoAcc :: Coercion -> FV
+tyCoVarsOfCoAcc (Refl _ ty) fv_cand in_scope acc =
+  tyVarsOfTypeAcc ty fv_cand in_scope acc
+tyCoVarsOfCoAcc (TyConAppCo _ _ cos) fv_cand in_scope acc =
+  tyCoVarsOfCosAcc cos fv_cand in_scope acc
+tyCoVarsOfCoAcc (AppCo co1 co2) fv_cand in_scope acc =
+  (tyCoVarsOfCoAcc co1 `unionFV` tyCoVarsOfCoAcc co2) fv_cand in_scope acc
+tyCoVarsOfCoAcc (ForAllCo tv co) fv_cand in_scope acc =
+  delFV tv (tyCoVarsOfCoAcc co) fv_cand in_scope acc
+tyCoVarsOfCoAcc (CoVarCo v) fv_cand in_scope acc = oneVar v fv_cand in_scope acc
+tyCoVarsOfCoAcc (AxiomInstCo _ _ cos) fv_cand in_scope acc =
+  tyCoVarsOfCosAcc cos fv_cand in_scope acc
+tyCoVarsOfCoAcc (UnivCo _ _ ty1 ty2) fv_cand in_scope acc =
+  (tyVarsOfTypeAcc ty1 `unionFV` tyVarsOfTypeAcc ty2) fv_cand in_scope acc
+tyCoVarsOfCoAcc (SymCo co) fv_cand in_scope acc =
+  tyCoVarsOfCoAcc co fv_cand in_scope acc
+tyCoVarsOfCoAcc (TransCo co1 co2) fv_cand in_scope acc =
+  (tyCoVarsOfCoAcc co1 `unionFV` tyCoVarsOfCoAcc co2) fv_cand in_scope acc
+tyCoVarsOfCoAcc (NthCo _ co) fv_cand in_scope acc =
+  tyCoVarsOfCoAcc co fv_cand in_scope acc
+tyCoVarsOfCoAcc (LRCo _ co) fv_cand in_scope acc =
+  tyCoVarsOfCoAcc co fv_cand in_scope acc
+tyCoVarsOfCoAcc (InstCo co ty) fv_cand in_scope acc =
+  (tyCoVarsOfCoAcc co `unionFV` tyVarsOfTypeAcc ty) fv_cand in_scope acc
+tyCoVarsOfCoAcc (SubCo co) fv_cand in_scope acc =
+  tyCoVarsOfCoAcc co fv_cand in_scope acc
+tyCoVarsOfCoAcc (AxiomRuleCo _ ts cs) fv_cand in_scope acc =
+  (tyVarsOfTypesAcc ts `unionFV` tyCoVarsOfCosAcc cs) fv_cand in_scope acc
+
+tyCoVarsOfCosAcc :: [Coercion] -> FV
+tyCoVarsOfCosAcc (co:cos) fv_cand in_scope acc =
+  (tyCoVarsOfCoAcc co `unionFV` tyCoVarsOfCosAcc cos) fv_cand in_scope acc
+tyCoVarsOfCosAcc [] fv_cand in_scope acc = noVars fv_cand in_scope acc
 
 coVarsOfCo :: Coercion -> VarSet
 -- Extract *coerction* variables only.  Tiresome to repeat the code, but easy.
diff --git a/compiler/types/TypeRep.hs b/compiler/types/TypeRep.hs
index 574e15367e..3eac8b5e7a 100644
--- a/compiler/types/TypeRep.hs
+++ b/compiler/types/TypeRep.hs
@@ -43,6 +43,7 @@ module TypeRep (
 
         -- Free variables
         tyVarsOfType, tyVarsOfTypes, closeOverKinds, varSetElemsKvsFirst,
+        tyVarsOfTypeAcc, tyVarsOfTypeList, tyVarsOfTypesAcc, tyVarsOfTypesList,
 
         -- * Tidying type related things up for printing
         tidyType,      tidyTypes,
@@ -73,6 +74,7 @@ import BasicTypes
 import TyCon
 import Class
 import CoAxiom
+import FV
 
 -- others
 import PrelNames
@@ -309,16 +311,43 @@ isKindVar v = isTKVar v && isSuperKind (varType v)
 tyVarsOfType :: Type -> VarSet
 -- ^ NB: for type synonyms tyVarsOfType does /not/ expand the synonym
 -- tyVarsOfType returns free variables of a type, including kind variables.
-tyVarsOfType (TyVarTy v)         = unitVarSet v
-tyVarsOfType (TyConApp _ tys)    = tyVarsOfTypes tys
-tyVarsOfType (LitTy {})          = emptyVarSet
-tyVarsOfType (FunTy arg res)     = tyVarsOfType arg `unionVarSet` tyVarsOfType res
-tyVarsOfType (AppTy fun arg)     = tyVarsOfType fun `unionVarSet` tyVarsOfType arg
-tyVarsOfType (ForAllTy tyvar ty) = delVarSet (tyVarsOfType ty) tyvar
-                                   `unionVarSet` tyVarsOfType (tyVarKind tyvar)
+tyVarsOfType ty = runFVSet $ tyVarsOfTypeAcc ty
+
+-- | `tyVarsOfType` that returns free variables of a type in deterministic
+-- order. For explanation of why using `VarSet` is not deterministic see
+-- Note [Deterministic UniqFM] in UniqDFM.
+tyVarsOfTypeList :: Type -> [Var]
+tyVarsOfTypeList ty = runFVList $ tyVarsOfTypeAcc ty
 
 tyVarsOfTypes :: [Type] -> TyVarSet
-tyVarsOfTypes = mapUnionVarSet tyVarsOfType
+tyVarsOfTypes tys = runFVSet $ tyVarsOfTypesAcc tys
+
+tyVarsOfTypesList :: [Type] -> [Var]
+tyVarsOfTypesList tys = runFVList $ tyVarsOfTypesAcc tys
+
+
+-- | The worker for `tyVarsOfType` and `tyVarsOfTypeList`.
+-- The previous implementation used `unionVarSet` which is O(n+m) and can
+-- make the function quadratic.
+-- It's exported, so that it can be composed with other functions that compute
+-- free variables.
+tyVarsOfTypeAcc :: Type -> FV
+tyVarsOfTypeAcc (TyVarTy v) fv_cand in_scope acc = oneVar v fv_cand in_scope acc
+tyVarsOfTypeAcc (TyConApp _ tys) fv_cand in_scope acc =
+  tyVarsOfTypesAcc tys fv_cand in_scope acc
+tyVarsOfTypeAcc (LitTy {}) fv_cand in_scope acc = noVars fv_cand in_scope acc
+tyVarsOfTypeAcc (FunTy arg res) fv_cand in_scope acc =
+  (tyVarsOfTypeAcc arg `unionFV` tyVarsOfTypeAcc res) fv_cand in_scope acc
+tyVarsOfTypeAcc (AppTy fun arg) fv_cand in_scope acc =
+  (tyVarsOfTypeAcc fun `unionFV` tyVarsOfTypeAcc arg) fv_cand in_scope acc
+tyVarsOfTypeAcc (ForAllTy tyvar ty) fv_cand in_scope acc =
+  (delFV tyvar (tyVarsOfTypeAcc ty) `unionFV`
+    tyVarsOfTypeAcc (tyVarKind tyvar)) fv_cand in_scope acc
+
+tyVarsOfTypesAcc :: [Type] -> FV
+tyVarsOfTypesAcc (ty:tys) fv_cand in_scope acc =
+  (tyVarsOfTypeAcc ty `unionFV` tyVarsOfTypesAcc tys) fv_cand in_scope acc
+tyVarsOfTypesAcc [] fv_cand in_scope acc = noVars fv_cand in_scope acc
 
 closeOverKinds :: TyVarSet -> TyVarSet
 -- Add the kind variables free in the kinds
@@ -934,7 +963,7 @@ tidyOpenType :: TidyEnv -> Type -> (TidyEnv, Type)
 tidyOpenType env ty
   = (env', tidyType (trimmed_occ_env, var_env) ty)
   where
-    (env'@(_, var_env), tvs') = tidyOpenTyVars env (varSetElems (tyVarsOfType ty))
+    (env'@(_, var_env), tvs') = tidyOpenTyVars env (tyVarsOfTypeList ty)
     trimmed_occ_env = initTidyOccEnv (map getOccName tvs')
       -- The idea here was that we restrict the new TidyEnv to the
       -- _free_ vars of the type, so that we don't gratuitously rename
diff --git a/compiler/types/Unify.hs b/compiler/types/Unify.hs
index a29c85f2da..e876b2ebbe 100644
--- a/compiler/types/Unify.hs
+++ b/compiler/types/Unify.hs
@@ -176,7 +176,7 @@ match menv subst (TyVarTy tv1) ty2
     else Nothing        -- ty2 doesn't match
 
   | tv1' `elemVarSet` me_tmpls menv
-  = if any (inRnEnvR rn_env) (varSetElems (tyVarsOfType ty2))
+  = if any (inRnEnvR rn_env) (tyVarsOfTypeList ty2)
     then Nothing        -- Occurs check
                         -- ezyang: Is this really an occurs check?  It seems
                         -- to just reject matching \x. A against \x. x (maintaining
diff --git a/compiler/utils/FV.hs b/compiler/utils/FV.hs
new file mode 100644
index 0000000000..907a20f9ca
--- /dev/null
+++ b/compiler/utils/FV.hs
@@ -0,0 +1,87 @@
+{-
+(c) Bartosz Nitka, Facebook 2015
+
+Utilities for efficiently and deterministically computing free variables.
+
+-}
+
+{-# LANGUAGE BangPatterns #-}
+
+module FV (
+        -- * Deterministic free vars computations
+        FV, InterestingVarFun,
+
+        -- * Running the computations
+        runFV, runFVList, runFVSet, runFVDSet,
+
+        -- ** Manipulating those computations
+        oneVar,
+        noVars,
+        unionFV,
+        delFV,
+        delFVs,
+        filterFV,
+    ) where
+
+import Var
+import VarSet
+
+-- | Predicate on possible free variables: returns @True@ iff the variable is
+-- interesting
+type InterestingVarFun = Var -> Bool
+
+type FV = InterestingVarFun
+          -> VarSet
+             -- Locally bound variables
+          -> ([Var], VarSet)
+             -- List to preserve ordering and set to check for membership,
+             -- so that the list doesn't have duplicates
+             -- For explanation of why using `VarSet` is not deterministic see
+             -- Note [Deterministic UniqFM] in UniqDFM.
+          -> ([Var], VarSet)
+
+runFV :: FV ->  ([Var], VarSet)
+runFV fv = fv (const True) emptyVarSet ([], emptyVarSet)
+
+runFVList :: FV -> [Var]
+runFVList = fst . runFV
+
+runFVDSet :: FV -> DVarSet
+runFVDSet = mkDVarSet . fst . runFV
+
+runFVSet :: FV -> VarSet
+runFVSet = snd . runFV
+
+{-# INLINE oneVar #-}
+oneVar :: Id -> FV
+oneVar var fv_cand in_scope acc@(have, haveSet)
+  = {- ASSERT( isId var ) probably not going to work -} fvs
+  where
+  fvs | var `elemVarSet` in_scope = acc
+      | var `elemVarSet` haveSet = acc
+      | fv_cand var = (var:have, extendVarSet haveSet var)
+      | otherwise = acc
+
+{-# INLINE noVars #-}
+noVars :: FV
+noVars _ _ acc = acc
+
+{-# INLINE unionFV #-}
+unionFV :: FV -> FV -> FV
+unionFV fv1 fv2 fv_cand in_scope acc =
+  fv1 fv_cand in_scope $! fv2 fv_cand in_scope $! acc
+
+{-# INLINE delFV #-}
+delFV :: Var -> FV -> FV
+delFV var fv fv_cand !in_scope acc =
+  fv fv_cand (extendVarSet in_scope var) acc
+
+{-# INLINE delFVs #-}
+delFVs :: VarSet -> FV -> FV
+delFVs vars fv fv_cand !in_scope acc =
+  fv fv_cand (in_scope `unionVarSet` vars) acc
+
+{-# INLINE filterFV #-}
+filterFV :: InterestingVarFun -> FV -> FV
+filterFV fv_cand2 fv fv_cand1 in_scope acc =
+  fv (\v -> fv_cand1 v && fv_cand2 v) in_scope acc
diff --git a/compiler/vectorise/Vectorise/Exp.hs b/compiler/vectorise/Vectorise/Exp.hs
index ae7483a612..83c87100a2 100644
--- a/compiler/vectorise/Vectorise/Exp.hs
+++ b/compiler/vectorise/Vectorise/Exp.hs
@@ -8,7 +8,7 @@ module Vectorise.Exp
   , vectTopExprs
   , vectScalarFun
   , vectScalarDFun
-  ) 
+  )
 where
 
 #include "HsVersions.h"
@@ -44,6 +44,7 @@ import Outputable
 import FastString
 import DynFlags
 import Util
+import UniqDFM (udfmToUfm)
 #if __GLASGOW_HASKELL__ < 709
 import MonadUtils
 #endif
@@ -118,9 +119,9 @@ vectTopExprs binds
     }
   where
     (vars, exprs) = unzip binds
-    
+
     vectAvoidAndEncapsulate pvs = encapsulateScalars <=< vectAvoidInfo pvs . freeVars
-    
+
     vect var exprVI
       = do
         { vExpr  <- closedV $
@@ -180,17 +181,17 @@ encapsulateScalars ((fvs, vi), AnnTick tck expr)
     { encExpr <- encapsulateScalars expr
     ; return ((fvs, vi), AnnTick tck encExpr)
     }
-encapsulateScalars ce@((fvs, vi), AnnLam bndr expr) 
-  = do 
+encapsulateScalars ce@((fvs, vi), AnnLam bndr expr)
+  = do
     { vectAvoid <- isVectAvoidanceAggressive
-    ; varsS     <- allScalarVarTypeSet fvs 
+    ; varsS     <- allScalarVarTypeSet fvs
         -- NB: diverts from the paper: we need to check the scalarness of bound variables as well,
         --     as 'vectScalarFun' will handle them just the same as those introduced for the 'fvs'
         --     by encapsulation.
     ; bndrsS    <- allScalarVarType bndrs
     ; case (vi, vectAvoid && varsS && bndrsS) of
         (VISimple, True) -> liftSimpleAndCase ce
-        _                -> do 
+        _                -> do
                             { encExpr <- encapsulateScalars expr
                             ; return ((fvs, vi), AnnLam bndr encExpr)
                             }
@@ -203,7 +204,7 @@ encapsulateScalars ce@((fvs, vi), AnnApp ce1 ce2)
     ; varsS     <- allScalarVarTypeSet fvs
     ; case (vi, (vectAvoid || isSimpleApplication ce) && varsS) of
         (VISimple, True) -> liftSimpleAndCase ce
-        _                -> do 
+        _                -> do
                             { encCe1 <- encapsulateScalars ce1
                             ; encCe2 <- encapsulateScalars ce2
                             ; return ((fvs, vi), AnnApp encCe1 encCe2)
@@ -224,13 +225,13 @@ encapsulateScalars ce@((fvs, vi), AnnApp ce1 ce2)
     isSimple (_, AnnTick _ ce) = isSimple ce
     isSimple (_, AnnCast ce _) = isSimple ce
     isSimple _                 = False
-encapsulateScalars ce@((fvs, vi), AnnCase scrut bndr ty alts) 
-  = do 
+encapsulateScalars ce@((fvs, vi), AnnCase scrut bndr ty alts)
+  = do
     { vectAvoid <- isVectAvoidanceAggressive
-    ; varsS     <- allScalarVarTypeSet fvs 
+    ; varsS     <- allScalarVarTypeSet fvs
     ; case (vi, vectAvoid && varsS) of
         (VISimple, True) -> liftSimpleAndCase ce
-        _                -> do 
+        _                -> do
                             { encScrut <- encapsulateScalars scrut
                             ; encAlts  <- mapM encAlt alts
                             ; return ((fvs, vi), AnnCase encScrut bndr ty encAlts)
@@ -238,34 +239,34 @@ encapsulateScalars ce@((fvs, vi), AnnCase scrut bndr ty alts)
     }
   where
     encAlt (con, bndrs, expr) = (con, bndrs,) <$> encapsulateScalars expr
-encapsulateScalars ce@((fvs, vi), AnnLet (AnnNonRec bndr expr1) expr2) 
-  = do 
+encapsulateScalars ce@((fvs, vi), AnnLet (AnnNonRec bndr expr1) expr2)
+  = do
     { vectAvoid <- isVectAvoidanceAggressive
-    ; varsS     <- allScalarVarTypeSet fvs 
+    ; varsS     <- allScalarVarTypeSet fvs
     ; case (vi, vectAvoid && varsS) of
         (VISimple, True) -> liftSimpleAndCase ce
-        _                -> do 
+        _                -> do
                             { encExpr1 <- encapsulateScalars expr1
                             ; encExpr2 <- encapsulateScalars expr2
                             ; return ((fvs, vi), AnnLet (AnnNonRec bndr encExpr1) encExpr2)
                             }
     }
-encapsulateScalars ce@((fvs, vi), AnnLet (AnnRec binds) expr) 
-  = do 
+encapsulateScalars ce@((fvs, vi), AnnLet (AnnRec binds) expr)
+  = do
     { vectAvoid <- isVectAvoidanceAggressive
-    ; varsS     <- allScalarVarTypeSet fvs 
-    ; case (vi, vectAvoid && varsS) of 
+    ; varsS     <- allScalarVarTypeSet fvs
+    ; case (vi, vectAvoid && varsS) of
         (VISimple, True) -> liftSimpleAndCase ce
-        _                -> do 
+        _                -> do
                             { encBinds <- mapM encBind binds
                             ; encExpr  <- encapsulateScalars expr
                             ; return ((fvs, vi), AnnLet (AnnRec encBinds) encExpr)
                             }
-    }                            
+    }
  where
    encBind (bndr, expr) = (bndr,) <$> encapsulateScalars expr
 encapsulateScalars ((fvs, vi), AnnCast expr coercion)
-  = do 
+  = do
     { encExpr <- encapsulateScalars expr
     ; return ((fvs, vi), AnnCast encExpr coercion)
     }
@@ -296,8 +297,8 @@ liftSimple ((fvs, vi), AnnVar v)
   | v `elemVarSet` fvs                -- special case to avoid producing: (\v -> v) v
   && not (isToplevel v)               --   NB: if 'v' not free or is toplevel, we must get the 'VIEncaps'
   = return $ ((fvs, vi), AnnVar v)
-liftSimple aexpr@((fvs_orig, VISimple), expr) 
-  = do 
+liftSimple aexpr@((fvs_orig, VISimple), expr)
+  = do
     { let liftedExpr = mkAnnApps (mkAnnLams (reverse vars) fvs expr) vars
 
     ; traceVt "encapsulate:" $ ppr (deAnnotate aexpr) $$ text "==>" $$ ppr (deAnnotate liftedExpr)
@@ -307,18 +308,18 @@ liftSimple aexpr@((fvs_orig, VISimple), expr)
   where
     vars = varSetElems fvs
     fvs  = filterVarSet (not . isToplevel) fvs_orig -- only include 'Id's that are not toplevel
-    
+
     mkAnnLams :: [Var] -> VarSet -> AnnExpr' Var (VarSet, VectAvoidInfo) -> CoreExprWithVectInfo
     mkAnnLams []     fvs expr = ASSERT(isEmptyVarSet fvs)
                                 ((emptyVarSet, VIEncaps), expr)
     mkAnnLams (v:vs) fvs expr = mkAnnLams vs (fvs `delVarSet` v) (AnnLam v ((fvs, VIEncaps), expr))
-      
+
     mkAnnApps :: CoreExprWithVectInfo -> [Var] -> CoreExprWithVectInfo
     mkAnnApps aexpr []     = aexpr
     mkAnnApps aexpr (v:vs) = mkAnnApps (mkAnnApp aexpr v) vs
 
     mkAnnApp :: CoreExprWithVectInfo -> Var -> CoreExprWithVectInfo
-    mkAnnApp aexpr@((fvs, _vi), _expr) v 
+    mkAnnApp aexpr@((fvs, _vi), _expr) v
       = ((fvs `extendVarSet` v, VISimple), AnnApp aexpr ((unitVarSet v, VISimple), AnnVar v))
 liftSimple aexpr
   = pprPanic "Vectorise.Exp.liftSimple: not simple" $ ppr (deAnnotate aexpr)
@@ -327,8 +328,8 @@ isToplevel :: Var -> Bool
 isToplevel v | isId v    = case realIdUnfolding v of
                              NoUnfolding                     -> False
                              OtherCon      {}                -> True
-                             DFunUnfolding {}                -> True 
-                             CoreUnfolding {uf_is_top = top} -> top 
+                             DFunUnfolding {}                -> True
+                             CoreUnfolding {uf_is_top = top} -> top
              | otherwise = False
 
 -- |Vectorise an expression.
@@ -341,7 +342,7 @@ vectExpr aexpr
   = vectFnExpr True False aexpr
     -- encapsulated constant => vectorise as a scalar constant
   | isVIEncaps aexpr
-  = traceVt "vectExpr (encapsulated constant):" (ppr . deAnnotate $ aexpr) >> 
+  = traceVt "vectExpr (encapsulated constant):" (ppr . deAnnotate $ aexpr) >>
     vectConst (deAnnotate aexpr)
 
 vectExpr (_, AnnVar v)
@@ -351,7 +352,7 @@ vectExpr (_, AnnLit lit)
   = vectConst $ Lit lit
 
 vectExpr aexpr@(_, AnnLam _ _)
-  = traceVt "vectExpr [AnnLam]:" (ppr . deAnnotate $ aexpr) >> 
+  = traceVt "vectExpr [AnnLam]:" (ppr . deAnnotate $ aexpr) >>
     vectFnExpr True False aexpr
 
   -- SPECIAL CASE: Vectorise/lift 'patError @ ty err' by only vectorising/lifting the type 'ty';
@@ -360,7 +361,7 @@ vectExpr aexpr@(_, AnnLam _ _)
 -- FIXME: can't be do this with a VECTORISE pragma on 'pAT_ERROR_ID' now?
 vectExpr (_, AnnApp (_, AnnApp (_, AnnVar v) (_, AnnType ty)) err)
   | v == pAT_ERROR_ID
-  = do 
+  = do
     { (vty, lty) <- vectAndLiftType ty
     ; return (mkCoreApps (Var v) [Type vty, err'], mkCoreApps (Var v) [Type lty, err'])
     }
@@ -387,9 +388,9 @@ vectExpr e@(_, AnnApp fn arg)
   | isPredTy arg_ty   -- dictionary application (whose result is not a dictionary)
   = vectPolyApp e
   | otherwise         -- user value
-  = do 
+  = do
     {   -- vectorise the types
-    ; varg_ty <- vectType arg_ty 
+    ; varg_ty <- vectType arg_ty
     ; vres_ty <- vectType res_ty
 
         -- vectorise the function and argument expression
@@ -406,10 +407,10 @@ vectExpr (_, AnnCase scrut bndr ty alts)
   | Just (tycon, ty_args) <- splitTyConApp_maybe scrut_ty
   , isAlgTyCon tycon
   = vectAlgCase tycon ty_args scrut bndr ty alts
-  | otherwise 
-  = do 
+  | otherwise
+  = do
     { dflags <- getDynFlags
-    ; cantVectorise dflags "Can't vectorise expression (no algebraic type constructor)" $ 
+    ; cantVectorise dflags "Can't vectorise expression (no algebraic type constructor)" $
         ppr scrut_ty
     }
   where
@@ -418,8 +419,8 @@ vectExpr (_, AnnCase scrut bndr ty alts)
 vectExpr (_, AnnLet (AnnNonRec bndr rhs) body)
   = do
     { traceVt "let binding (non-recursive)" Outputable.empty
-    ; vrhs <- localV $ 
-                inBind bndr $ 
+    ; vrhs <- localV $
+                inBind bndr $
                   vectAnnPolyExpr False rhs
     ; traceVt "let body (non-recursive)" Outputable.empty
     ; (vbndr, vbody) <- vectBndrIn bndr (vectExpr body)
@@ -433,7 +434,7 @@ vectExpr (_, AnnLet (AnnRec bs) body)
                                   ; vrhss <- zipWithM vect_rhs bndrs rhss
                                   ; traceVt "let body (recursive)" Outputable.empty
                                   ; vbody <- vectExpr body
-                                  ; return (vrhss, vbody) 
+                                  ; return (vrhss, vbody)
                                   }
     ; return $ vLet (vRec vbndrs vrhss) vbody
     }
@@ -451,7 +452,7 @@ vectExpr (_, AnnType ty)
   = vType <$> vectType ty
 
 vectExpr e
-  = do 
+  = do
     { dflags <- getDynFlags
     ; cantVectorise dflags "Can't vectorise expression (vectExpr)" $ ppr (deAnnotate e)
     }
@@ -473,7 +474,7 @@ vectFnExpr inline loop_breaker aexpr@(_ann, AnnLam bndr body)
     -- predicate abstraction: leave as a normal abstraction, but vectorise the predicate type
   | isId bndr
     && isPredTy (idType bndr)
-  = do 
+  = do
     { vBndr <- vectBndr bndr
     ; vbody <- vectFnExpr inline loop_breaker body
     ; return $ mapVect (mkLams [vectorised vBndr]) vbody
@@ -484,10 +485,10 @@ vectFnExpr inline loop_breaker aexpr@(_ann, AnnLam bndr body)
     -- non-predicate abstraction: vectorise as a non-scalar computation
   | isId bndr
   = vectLam inline loop_breaker aexpr
-  | otherwise 
-  = do 
+  | otherwise
+  = do
     { dflags <- getDynFlags
-    ; cantVectorise dflags "Vectorise.Exp.vectFnExpr: Unexpected type lambda" $ 
+    ; cantVectorise dflags "Vectorise.Exp.vectFnExpr: Unexpected type lambda" $
         ppr (deAnnotate aexpr)
     }
 vectFnExpr _ _ aexpr
@@ -522,7 +523,7 @@ vectPolyApp e0
               ; vDictsInner <- mapM vectDictExpr (map deAnnotate dictsInner)
               ; vTysOuter   <- mapM vectType     tysOuter
               ; vTysInner   <- mapM vectType     tysInner
-              
+
               ; let reconstructOuter v = (`mkApps` vDictsOuter) <$> polyApply v vTysOuter
 
               ; case vVar of
@@ -537,10 +538,10 @@ vectPolyApp e0
                               -- arguments are non-vectorised arguments, where no 'PA'dictionaries
                               -- are needed for the type variables
                           ; ve <- if null dictsInner
-                                  then 
+                                  then
                                     return $ Var vv `mkTyApps` vTysOuter `mkApps` vDictsOuter
-                                  else 
-                                    reconstructOuter 
+                                  else
+                                    reconstructOuter
                                       (Var vv `mkTyApps` vTysInner `mkApps` vDictsInner)
                           ; traceVt "  GLOBAL (dict):" (ppr ve)
                           ; vectConst ve
@@ -561,8 +562,8 @@ vectPolyApp e0
     (e4, tysInner)   = collectAnnTypeArgs e3
     --
     isDictComp var = (isJust . isClassOpId_maybe $ var) || isDFunId var
-    
--- |Vectorise the body of a dfun.  
+
+-- |Vectorise the body of a dfun.
 --
 -- Dictionary computations are special for the following reasons.  The application of dictionary
 -- functions are always saturated, so there is no need to create closures.  Dictionary computations
@@ -622,16 +623,16 @@ vectDictExpr (Coercion coe)
 -- "Note [Scalar dfuns]" in 'Vectorise'.
 --
 vectScalarFun :: CoreExpr -> VM VExpr
-vectScalarFun expr 
-  = do 
-    { traceVt "vectScalarFun:" (ppr expr) 
+vectScalarFun expr
+  = do
+    { traceVt "vectScalarFun:" (ppr expr)
     ; let (arg_tys, res_ty) = splitFunTys (exprType expr)
     ; mkScalarFun arg_tys res_ty expr
     }
 
 -- Generate code for a scalar function by generating a scalar closure.  If the function is a
 -- dictionary function, vectorise it as dictionary code.
--- 
+--
 mkScalarFun :: [Type] -> Type -> CoreExpr -> VM VExpr
 mkScalarFun arg_tys res_ty expr
   | isPredTy res_ty
@@ -652,7 +653,7 @@ mkScalarFun arg_tys res_ty expr
     unused = error "Vectorise.Exp.mkScalarFun: we don't lift dictionary expressions"
 
 -- |Vectorise a dictionary function that has a 'VECTORISE SCALAR instance' pragma.
--- 
+--
 -- In other words, all methods in that dictionary are scalar functions — to be vectorised with
 -- 'vectScalarFun'.  The dictionary "function" itself may be a constant, though.
 --
@@ -675,7 +676,7 @@ mkScalarFun arg_tys res_ty expr
 --
 -- > $v$dEqPair :: forall a b. V:Eq a -> V:Eq b -> V:Eq (a, b)
 -- > $v$dEqPair = /\a b -> \dEqa :: V:Eq a -> \dEqb :: V:Eq b ->
--- >                D:V:Eq $(vectScalarFun True recFns 
+-- >                D:V:Eq $(vectScalarFun True recFns
 -- >                         [| (==) @(a, b) ($dEqPair @a @b $(unVect dEqa) $(unVect dEqb)) |])
 --
 -- NB:
@@ -693,7 +694,7 @@ vectScalarDFun var
        ; vTheta     <- mapM vectType theta
        ; vThetaBndr <- mapM (newLocalVar (fsLit "vd")) vTheta
        ; let vThetaVars = varsToCoreExprs vThetaBndr
-       
+
            -- vectorise superclass dictionaries and methods as scalar expressions
        ; thetaVars  <- mapM (newLocalVar (fsLit "d")) theta
        ; thetaExprs <- zipWithM unVectDict theta vThetaVars
@@ -730,7 +731,7 @@ vectScalarDFun var
 -- where 'opTyi' is the type of the i-th superclass or op of the unvectorised dictionary.
 --
 unVectDict :: Type -> CoreExpr -> VM CoreExpr
-unVectDict ty e 
+unVectDict ty e
   = do { vTys <- mapM vectType tys
        ; let meths = map (\sel -> Var sel `mkTyApps` vTys `mkApps` [e]) selIds
        ; scOps <- zipWithM fromVect methTys meths
@@ -755,7 +756,7 @@ vectLam :: Bool                 -- ^ Should the RHS of a binding be inlined?
         -> VM VExpr
 vectLam inline loop_breaker expr@((fvs, _vi), AnnLam _ _)
  = do { traceVt "fully vectorise a lambda expression" (ppr . deAnnotate $ expr)
- 
+
       ; let (bndrs, body) = collectAnnValBinders expr
 
           -- grab the in-scope type variables
@@ -763,7 +764,7 @@ vectLam inline loop_breaker expr@((fvs, _vi), AnnLam _ _)
 
           -- collect and vectorise all /local/ free variables
       ; vfvs <- readLEnv $ \env ->
-                  [ (var, fromJust mb_vv) 
+                  [ (var, fromJust mb_vv)
                   | var <- varSetElems fvs
                   , let mb_vv = lookupVarEnv (local_vars env) var
                   , isJust mb_vv         -- its local == is in local var env
@@ -827,7 +828,7 @@ vectLam _ _ _ = panic "Vectorise.Exp.vectLam: not a lambda"
 --
 
 -- FIXME: this is too lazy...is it?
-vectAlgCase :: TyCon -> [Type] -> CoreExprWithVectInfo -> Var -> Type  
+vectAlgCase :: TyCon -> [Type] -> CoreExprWithVectInfo -> Var -> Type
             -> [(AltCon, [Var], CoreExprWithVectInfo)]
             -> VM VExpr
 vectAlgCase _tycon _ty_args scrut bndr ty [(DEFAULT, [], body)]
@@ -873,7 +874,7 @@ vectAlgCase _tycon _ty_args scrut bndr ty [(DataAlt dc, bndrs, body)]
 
     mk_wild_case expr ty dc bndrs body
       = mkWildCase expr (exprType expr) ty [(DataAlt dc, bndrs, body)]
-      
+
     dataConErr = (text "vectAlgCase: data constructor not vectorised" <+> ppr dc)
 
 vectAlgCase tycon _ty_args scrut bndr ty alts
@@ -977,7 +978,7 @@ vectAlgCase tycon _ty_args scrut bndr ty alts
               }
             _ -> return []
         }
-   
+
 
 -- Support to compute information for vectorisation avoidance ------------------
 
@@ -1039,7 +1040,7 @@ unlessVIParrExpr e1 e2 = e1 `unlessVIParr` vectAvoidInfoOf e2
 --
 vectAvoidInfo :: VarSet -> CoreExprWithFVs -> VM CoreExprWithVectInfo
 vectAvoidInfo pvs ce@(fvs, AnnVar v)
-  = do 
+  = do
     { gpvs <- globalParallelVars
     ; vi <- if v `elemVarSet` pvs || v `elemVarSet` gpvs
             then return VIParr
@@ -1049,37 +1050,37 @@ vectAvoidInfo pvs ce@(fvs, AnnVar v)
         traceVt "  reason:" $ if v `elemVarSet` pvs  then text "local"  else
                               if v `elemVarSet` gpvs then text "global" else text "parallel type"
 
-    ; return ((fvs, vi), AnnVar v)
+    ; return ((udfmToUfm fvs, vi), AnnVar v)
     }
 
 vectAvoidInfo _pvs ce@(fvs, AnnLit lit)
-  = do 
-    { vi <- vectAvoidInfoTypeOf ce  
-    ; viTrace ce vi [] 
-    ; return ((fvs, vi), AnnLit lit)
+  = do
+    { vi <- vectAvoidInfoTypeOf ce
+    ; viTrace ce vi []
+    ; return ((udfmToUfm fvs, vi), AnnLit lit)
     }
 
 vectAvoidInfo pvs ce@(fvs, AnnApp e1 e2)
-  = do 
+  = do
     { ceVI <- vectAvoidInfoTypeOf ce
-    ; eVI1 <- vectAvoidInfo pvs e1  
+    ; eVI1 <- vectAvoidInfo pvs e1
     ; eVI2 <- vectAvoidInfo pvs e2
     ; let vi = ceVI `unlessVIParrExpr` eVI1 `unlessVIParrExpr` eVI2
-    -- ; viTrace ce vi [eVI1, eVI2]                     
-    ; return ((fvs, vi), AnnApp eVI1 eVI2)
+    -- ; viTrace ce vi [eVI1, eVI2]
+    ; return ((udfmToUfm fvs, vi), AnnApp eVI1 eVI2)
     }
 
 vectAvoidInfo pvs (fvs, AnnLam var body)
-  = do 
-    { bodyVI <- vectAvoidInfo pvs body 
+  = do
+    { bodyVI <- vectAvoidInfo pvs body
     ; varVI  <- vectAvoidInfoType $ varType var
     ; let vi = vectAvoidInfoOf bodyVI `unlessVIParr` varVI
     -- ; viTrace ce vi [bodyVI]
-    ; return ((fvs, vi), AnnLam var bodyVI)
+    ; return ((udfmToUfm fvs, vi), AnnLam var bodyVI)
     }
 
-vectAvoidInfo pvs ce@(fvs, AnnLet (AnnNonRec var e) body)  
-  = do 
+vectAvoidInfo pvs ce@(fvs, AnnLet (AnnNonRec var e) body)
+  = do
     { ceVI       <- vectAvoidInfoTypeOf ce
     ; eVI        <- vectAvoidInfo pvs e
     ; isScalarTy <- isScalar $ varType var
@@ -1093,11 +1094,11 @@ vectAvoidInfo pvs ce@(fvs, AnnLet (AnnNonRec var e) body)
         ; return (bodyVI, ceVI `unlessVIParrExpr` bodyVI)
         }
     -- ; viTrace ce vi [eVI, bodyVI]
-    ; return ((fvs, vi), AnnLet (AnnNonRec var eVI) bodyVI)
+    ; return ((udfmToUfm fvs, vi), AnnLet (AnnNonRec var eVI) bodyVI)
     }
 
-vectAvoidInfo pvs ce@(fvs, AnnLet (AnnRec bnds) body)  
-  = do 
+vectAvoidInfo pvs ce@(fvs, AnnLet (AnnRec bnds) body)
+  = do
     { ceVI         <- vectAvoidInfoTypeOf ce
     ; bndsVI       <- mapM (vectAvoidInfoBnd pvs) bnds
     ; parrBndrs    <- map fst <$> filterM isVIParrBnd bndsVI
@@ -1108,36 +1109,36 @@ vectAvoidInfo pvs ce@(fvs, AnnLet (AnnRec bnds) body)
         ; bndsVI <- mapM (vectAvoidInfoBnd extendedPvs) bnds
         ; bodyVI <- vectAvoidInfo extendedPvs body
         -- ; viTrace ce VIParr (map snd bndsVI ++ [bodyVI])
-        ; return ((fvs, VIParr), AnnLet (AnnRec bndsVI) bodyVI)
+        ; return ((udfmToUfm fvs, VIParr), AnnLet (AnnRec bndsVI) bodyVI)
         }
       else do         -- demanded bindings cannot trigger parallelism
         { bodyVI <- vectAvoidInfo pvs body
         ; let vi = ceVI `unlessVIParrExpr` bodyVI
         -- ; viTrace ce vi (map snd bndsVI ++ [bodyVI])
-        ; return ((fvs, vi), AnnLet (AnnRec bndsVI) bodyVI)          
+        ; return ((udfmToUfm fvs, vi), AnnLet (AnnRec bndsVI) bodyVI)
         }
     }
   where
     vectAvoidInfoBnd pvs (var, e) = (var,) <$> vectAvoidInfo pvs e
 
-    isVIParrBnd (var, eVI) 
-      = do 
+    isVIParrBnd (var, eVI)
+      = do
         { isScalarTy <- isScalar (varType var)
         ; return $ isVIParr eVI && not isScalarTy
         }
 
-vectAvoidInfo pvs ce@(fvs, AnnCase e var ty alts) 
-  = do 
+vectAvoidInfo pvs ce@(fvs, AnnCase e var ty alts)
+  = do
     { ceVI           <- vectAvoidInfoTypeOf ce
     ; eVI            <- vectAvoidInfo pvs e
     ; altsVI         <- mapM (vectAvoidInfoAlt (isVIParr eVI)) alts
     ; let alteVIs = [eVI | (_, _, eVI) <- altsVI]
           vi      =  foldl unlessVIParrExpr ceVI (eVI:alteVIs)  -- NB: same effect as in the paper
     -- ; viTrace ce vi (eVI : alteVIs)
-    ; return ((fvs, vi), AnnCase eVI var ty altsVI)
+    ; return ((udfmToUfm fvs, vi), AnnCase eVI var ty altsVI)
     }
   where
-    vectAvoidInfoAlt scrutIsPar (con, bndrs, e) 
+    vectAvoidInfoAlt scrutIsPar (con, bndrs, e)
       = do
         { allScalar <- allScalarVarType bndrs
         ; let altPvs | scrutIsPar && not allScalar = pvs `extendVarSetList` bndrs
@@ -1146,26 +1147,27 @@ vectAvoidInfo pvs ce@(fvs, AnnCase e var ty alts)
         }
 
 vectAvoidInfo pvs (fvs, AnnCast e (fvs_ann, ann))
-  = do 
+  = do
     { eVI <- vectAvoidInfo pvs e
-    ; return ((fvs, vectAvoidInfoOf eVI), AnnCast eVI ((fvs_ann, VISimple), ann))
+    ; return ((udfmToUfm fvs, vectAvoidInfoOf eVI)
+             , AnnCast eVI ((udfmToUfm fvs_ann, VISimple), ann))
     }
 
 vectAvoidInfo pvs (fvs, AnnTick tick e)
-  = do 
+  = do
     { eVI <- vectAvoidInfo pvs e
-    ; return ((fvs, vectAvoidInfoOf eVI), AnnTick tick eVI)
+    ; return ((udfmToUfm fvs, vectAvoidInfoOf eVI), AnnTick tick eVI)
     }
 
 vectAvoidInfo _pvs (fvs, AnnType ty)
-  = return ((fvs, VISimple), AnnType ty)
+  = return ((udfmToUfm fvs, VISimple), AnnType ty)
 
-vectAvoidInfo _pvs (fvs, AnnCoercion coe) 
-  = return ((fvs, VISimple), AnnCoercion coe)
+vectAvoidInfo _pvs (fvs, AnnCoercion coe)
+  = return ((udfmToUfm fvs, VISimple), AnnCoercion coe)
 
 -- Compute vectorisation avoidance information for a type.
 --
-vectAvoidInfoType :: Type -> VM VectAvoidInfo   
+vectAvoidInfoType :: Type -> VM VectAvoidInfo
 vectAvoidInfoType ty
   | isPredTy ty
   = return VIDict
@@ -1183,9 +1185,9 @@ vectAvoidInfoType ty
     { parr <- maybeParrTy ty
     ; if parr
       then return VIParr
-      else do 
+      else do
     { scalar <- isScalar ty
-    ; if scalar 
+    ; if scalar
       then return VISimple
       else return VIComplex
     } }
@@ -1198,16 +1200,16 @@ vectAvoidInfoTypeOf = vectAvoidInfoType . annExprType
 -- Checks whether the type might be a parallel array type.
 --
 maybeParrTy :: Type -> VM Bool
-maybeParrTy ty 
+maybeParrTy ty
     -- looking through newtypes
   | Just ty'      <- coreView ty
   = (== VIParr) <$> vectAvoidInfoType ty'
     -- decompose constructor applications
-  | Just (tc, ts) <- splitTyConApp_maybe ty 
+  | Just (tc, ts) <- splitTyConApp_maybe ty
   = do
     { isParallel <- (tyConName tc `elemNameSet`) <$> globalParallelTyCons
     ; if isParallel
-      then return True 
+      then return True
       else or <$> mapM maybeParrTy ts
     }
 maybeParrTy (ForAllTy _ ty) = maybeParrTy ty
@@ -1232,6 +1234,6 @@ allScalarVarTypeSet = allScalarVarType . varSetElems
 --
 viTrace :: CoreExprWithFVs -> VectAvoidInfo -> [CoreExprWithVectInfo] -> VM ()
 viTrace ce vi vTs
-  = traceVt ("vect info: " ++ show vi ++ "[" ++ 
+  = traceVt ("vect info: " ++ show vi ++ "[" ++
              (concat $ map ((++ " ") . show . vectAvoidInfoOf) vTs) ++ "]")
             (ppr $ deAnnotate ce)
diff --git a/testsuite/tests/partial-sigs/should_compile/T10403.stderr b/testsuite/tests/partial-sigs/should_compile/T10403.stderr
index 8af7da3d81..bfd5367bcd 100644
--- a/testsuite/tests/partial-sigs/should_compile/T10403.stderr
+++ b/testsuite/tests/partial-sigs/should_compile/T10403.stderr
@@ -1,39 +1,39 @@
-

-T10403.hs:15:7: warning:

-    Found hole ‘_’ with inferred constraints: Functor f

-    In the type signature for:

-      h1 :: _ => _

-

-T10403.hs:15:12: warning:

-    Found type wildcard ‘_’ standing for ‘(a -> b) -> f a -> H f’

-    Where: ‘f’ is a rigid type variable bound by

-               the inferred type of h1 :: Functor f => (a -> b) -> f a -> H f

-               at T10403.hs:17:1

-           ‘b’ is a rigid type variable bound by

-               the inferred type of h1 :: Functor f => (a -> b) -> f a -> H f

-               at T10403.hs:17:1

-           ‘a’ is a rigid type variable bound by

-               the inferred type of h1 :: Functor f => (a -> b) -> f a -> H f

-               at T10403.hs:17:1

-    In the type signature for:

-      h1 :: _ => _

-

-T10403.hs:19:7: warning:

-    Found type wildcard ‘_’ standing for ‘(a -> b) -> f a -> H f’

-    Where: ‘f’ is a rigid type variable bound by

-               the inferred type of h2 :: Functor f => (a -> b) -> f a -> H f

-               at T10403.hs:21:1

-           ‘b’ is a rigid type variable bound by

-               the inferred type of h2 :: Functor f => (a -> b) -> f a -> H f

-               at T10403.hs:21:1

-           ‘a’ is a rigid type variable bound by

-               the inferred type of h2 :: Functor f => (a -> b) -> f a -> H f

-               at T10403.hs:21:1

-    In the type signature for:

-      h2 :: _

-

-T10403.hs:21:1: warning:

-    No instance for (Functor f)

-    When checking that ‘h2’ has the inferred type

-      h2 :: forall (f :: * -> *) b a. (a -> b) -> f a -> H f

-    Probable cause: the inferred type is ambiguous

+
+T10403.hs:15:7: warning:
+    Found hole ‘_’ with inferred constraints: Functor f
+    In the type signature for:
+      h1 :: _ => _
+
+T10403.hs:15:12: warning:
+    Found type wildcard ‘_’ standing for ‘(a -> b) -> f a -> H f’
+    Where: ‘b’ is a rigid type variable bound by
+               the inferred type of h1 :: Functor f => (a -> b) -> f a -> H f
+               at T10403.hs:17:1
+           ‘a’ is a rigid type variable bound by
+               the inferred type of h1 :: Functor f => (a -> b) -> f a -> H f
+               at T10403.hs:17:1
+           ‘f’ is a rigid type variable bound by
+               the inferred type of h1 :: Functor f => (a -> b) -> f a -> H f
+               at T10403.hs:17:1
+    In the type signature for:
+      h1 :: _ => _
+
+T10403.hs:19:7: warning:
+    Found type wildcard ‘_’ standing for ‘(a -> b) -> f a -> H f’
+    Where: ‘b’ is a rigid type variable bound by
+               the inferred type of h2 :: Functor f => (a -> b) -> f a -> H f
+               at T10403.hs:21:1
+           ‘a’ is a rigid type variable bound by
+               the inferred type of h2 :: Functor f => (a -> b) -> f a -> H f
+               at T10403.hs:21:1
+           ‘f’ is a rigid type variable bound by
+               the inferred type of h2 :: Functor f => (a -> b) -> f a -> H f
+               at T10403.hs:21:1
+    In the type signature for:
+      h2 :: _
+
+T10403.hs:21:1: warning:
+    No instance for (Functor f)
+    When checking that ‘h2’ has the inferred type
+      h2 :: forall (f :: * -> *) b a. (a -> b) -> f a -> H f
+    Probable cause: the inferred type is ambiguous
diff --git a/testsuite/tests/partial-sigs/should_fail/Trac10045.stderr b/testsuite/tests/partial-sigs/should_fail/Trac10045.stderr
index da0f8c78b7..7eb8b3eebd 100644
--- a/testsuite/tests/partial-sigs/should_fail/Trac10045.stderr
+++ b/testsuite/tests/partial-sigs/should_fail/Trac10045.stderr
@@ -1,46 +1,46 @@
-

-Trac10045.hs:6:17: error:

-    Found type wildcard ‘_’ standing for ‘t1 -> a -> t2’

-    Where: ‘t1’ is a rigid type variable bound by

-                the inferred type of copy :: Num a => t1 -> a -> t2

-                at Trac10045.hs:7:9

-           ‘t2’ is a rigid type variable bound by

-                the inferred type of copy :: Num a => t1 -> a -> t2

-                at Trac10045.hs:7:9

-           ‘a’ is a rigid type variable bound by

-               the inferred type of copy :: Num a => t1 -> a -> t2

-               at Trac10045.hs:7:9

-    To use the inferred type, enable PartialTypeSignatures

-    Relevant bindings include

-      ws1 :: () (bound at Trac10045.hs:5:11)

-      foo :: Meta -> t (bound at Trac10045.hs:5:1)

-    In the type signature for:

-      copy :: _

-    In the expression:

-      let

-        copy :: _

-        copy w from = copy w 1

-      in copy ws1 1

-    In an equation for ‘foo’:

-        foo (Meta ws1)

-          = let

-              copy :: _

-              copy w from = copy w 1

-            in copy ws1 1

-

-Trac10045.hs:7:9: error:

-    No instance for (Num a)

-    When checking that ‘copy’ has the inferred type

-      copy :: forall t t1 a. t -> a -> t1

-    Probable cause: the inferred type is ambiguous

-    In the expression:

-      let

-        copy :: _

-        copy w from = copy w 1

-      in copy ws1 1

-    In an equation for ‘foo’:

-        foo (Meta ws1)

-          = let

-              copy :: _

-              copy w from = copy w 1

-            in copy ws1 1

+
+Trac10045.hs:6:17: error:
+    Found type wildcard ‘_’ standing for ‘t1 -> a -> t2’
+    Where: ‘t1’ is a rigid type variable bound by
+                the inferred type of copy :: Num a => t1 -> a -> t2
+                at Trac10045.hs:7:9
+           ‘a’ is a rigid type variable bound by
+               the inferred type of copy :: Num a => t1 -> a -> t2
+               at Trac10045.hs:7:9
+           ‘t2’ is a rigid type variable bound by
+                the inferred type of copy :: Num a => t1 -> a -> t2
+                at Trac10045.hs:7:9
+    To use the inferred type, enable PartialTypeSignatures
+    Relevant bindings include
+      ws1 :: () (bound at Trac10045.hs:5:11)
+      foo :: Meta -> t (bound at Trac10045.hs:5:1)
+    In the type signature for:
+      copy :: _
+    In the expression:
+      let
+        copy :: _
+        copy w from = copy w 1
+      in copy ws1 1
+    In an equation for ‘foo’:
+        foo (Meta ws1)
+          = let
+              copy :: _
+              copy w from = copy w 1
+            in copy ws1 1
+
+Trac10045.hs:7:9: error:
+    No instance for (Num a)
+    When checking that ‘copy’ has the inferred type
+      copy :: forall t t1 a. t -> a -> t1
+    Probable cause: the inferred type is ambiguous
+    In the expression:
+      let
+        copy :: _
+        copy w from = copy w 1
+      in copy ws1 1
+    In an equation for ‘foo’:
+        foo (Meta ws1)
+          = let
+              copy :: _
+              copy w from = copy w 1
+            in copy ws1 1
diff --git a/testsuite/tests/perf/should_run/T10359 b/testsuite/tests/perf/should_run/T10359
new file mode 100755
index 0000000000..4968e1b1db
--- /dev/null
+++ b/testsuite/tests/perf/should_run/T10359
diff --git a/testsuite/tests/polykinds/T9222.stderr b/testsuite/tests/polykinds/T9222.stderr
index 1d1a1df779..a5b35ee2b1 100644
--- a/testsuite/tests/polykinds/T9222.stderr
+++ b/testsuite/tests/polykinds/T9222.stderr
@@ -1,24 +1,24 @@
-

-T9222.hs:13:3: error:

-    Couldn't match type ‘b0’ with ‘b’

-      ‘b0’ is untouchable

-        inside the constraints: a ~ '(b0, c0)

-        bound by the type of the constructor ‘Want’:

-                   (a ~ '(b0, c0)) => Proxy b0

-        at T9222.hs:13:3

-      ‘b’ is a rigid type variable bound by

-          the type of the constructor ‘Want’:

-            ((a ~ '(b, c)) => Proxy b) -> Want a

-          at T9222.hs:13:3

-    Expected type: '(b, c)

-      Actual type: a

-    In the ambiguity check for the type of the constructor ‘Want’:

-      Want :: forall (k :: BOX)

-                     (k1 :: BOX)

-                     (a :: (,) k k1)

-                     (b :: k)

-                     (c :: k1).

-              ((a ~ '(b, c)) => Proxy b) -> Want a

-    To defer the ambiguity check to use sites, enable AllowAmbiguousTypes

-    In the definition of data constructor ‘Want’

-    In the data type declaration for ‘Want’

+
+T9222.hs:13:3: error:
+    Couldn't match type ‘b0’ with ‘b’
+      ‘b0’ is untouchable
+        inside the constraints: a ~ '(b0, c0)
+        bound by the type of the constructor ‘Want’:
+                   (a ~ '(b0, c0)) => Proxy b0
+        at T9222.hs:13:3
+    ‘b’ is a rigid type variable bound by
+        the type of the constructor ‘Want’:
+          ((a ~ '(b, c)) => Proxy b) -> Want a
+        at T9222.hs:13:3
+    Expected type: '(b, c)
+      Actual type: a
+    In the ambiguity check for the type of the constructor ‘Want’:
+      Want :: forall (k :: BOX)
+                     (k1 :: BOX)
+                     (a :: (,) k k1)
+                     (b :: k)
+                     (c :: k1).
+              ((a ~ '(b, c)) => Proxy b) -> Want a
+    To defer the ambiguity check to use sites, enable AllowAmbiguousTypes
+    In the definition of data constructor ‘Want’
+    In the data type declaration for ‘Want’