Don't track free variables in STG syntax by default

Summary:
Currently, `CoreToStg` annotates `StgRhsClosure`s with their set of non-global
free variables.  This free variable information is only needed in the final
code generation step (i.e. `StgCmm.codeGen`), which leads to transformations
such as `StgCse` and `StgUnarise` having to maintain this information.

This is tiresome and unnecessary, so this patch introduces a trees-to-grow-like
approach that only introduces the free variable set into the syntax tree in the
code gen pass, along with a free variable analysis on STG terms to generate
that information.

Fixes #15754.

Reviewers: simonpj, osa1, bgamari, simonmar

Reviewed By: osa1

Subscribers: rwbarton, carter

GHC Trac Issues: #15754

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

15 files changed, 404 insertions, 372 deletions

diff --git a/compiler/basicTypes/VarSet.hs b/compiler/basicTypes/VarSet.hs
index fb44d31fd3..ec8a325b25 100644
--- a/compiler/basicTypes/VarSet.hs
+++ b/compiler/basicTypes/VarSet.hs
@@ -35,7 +35,7 @@ module VarSet (
         intersectDVarSet, dVarSetIntersectVarSet,
         intersectsDVarSet, disjointDVarSet,
         isEmptyDVarSet, delDVarSet, delDVarSetList,
-        minusDVarSet, foldDVarSet, filterDVarSet,
+        minusDVarSet, foldDVarSet, filterDVarSet, mapDVarSet,
         dVarSetMinusVarSet, anyDVarSet, allDVarSet,
         transCloDVarSet,
         sizeDVarSet, seqDVarSet,
@@ -295,6 +295,9 @@ anyDVarSet p = anyUDFM p . getUniqDSet
 allDVarSet :: (Var -> Bool) -> DVarSet -> Bool
 allDVarSet p = allUDFM p . getUniqDSet
 
+mapDVarSet :: Uniquable b => (a -> b) -> UniqDSet a -> UniqDSet b
+mapDVarSet = mapUniqDSet
+
 filterDVarSet :: (Var -> Bool) -> DVarSet -> DVarSet
 filterDVarSet = filterUniqDSet
 
diff --git a/compiler/codeGen/StgCmm.hs b/compiler/codeGen/StgCmm.hs
index 5b80ba61d9..59ceba8706 100644
--- a/compiler/codeGen/StgCmm.hs
+++ b/compiler/codeGen/StgCmm.hs
@@ -1,4 +1,5 @@
 {-# LANGUAGE CPP #-}
+{-# LANGUAGE DataKinds #-}
 
 -----------------------------------------------------------------------------
 --
@@ -44,6 +45,7 @@ import Module
 import Outputable
 import Stream
 import BasicTypes
+import VarSet ( isEmptyVarSet )
 
 import OrdList
 import MkGraph
@@ -57,10 +59,10 @@ codeGen :: DynFlags
         -> Module
         -> [TyCon]
         -> CollectedCCs                -- (Local/global) cost-centres needing declaring/registering.
-        -> [StgTopBinding]             -- Bindings to convert
+        -> [CgStgTopBinding]           -- Bindings to convert
         -> HpcInfo
         -> Stream IO CmmGroup ()       -- Output as a stream, so codegen can
-                                        -- be interleaved with output
+                                       -- be interleaved with output
 
 codeGen dflags this_mod data_tycons
         cost_centre_info stg_binds hpc_info
@@ -117,7 +119,7 @@ This is so that we can write the top level processing in a compositional
 style, with the increasing static environment being plumbed as a state
 variable. -}
 
-cgTopBinding :: DynFlags -> StgTopBinding -> FCode ()
+cgTopBinding :: DynFlags -> CgStgTopBinding -> FCode ()
 cgTopBinding dflags (StgTopLifted (StgNonRec id rhs))
   = do  { id' <- maybeExternaliseId dflags id
         ; let (info, fcode) = cgTopRhs dflags NonRecursive id' rhs
@@ -144,7 +146,7 @@ cgTopBinding dflags (StgTopStringLit id str)
         ; addBindC (litIdInfo dflags id' mkLFStringLit lit)
         }
 
-cgTopRhs :: DynFlags -> RecFlag -> Id -> StgRhs -> (CgIdInfo, FCode ())
+cgTopRhs :: DynFlags -> RecFlag -> Id -> CgStgRhs -> (CgIdInfo, FCode ())
         -- The Id is passed along for setting up a binding...
         -- It's already been externalised if necessary
 
@@ -153,8 +155,8 @@ cgTopRhs dflags _rec bndr (StgRhsCon _cc con args)
       -- con args are always non-void,
       -- see Note [Post-unarisation invariants] in UnariseStg
 
-cgTopRhs dflags rec bndr (StgRhsClosure cc fvs upd_flag args body)
-  = ASSERT(null fvs)    -- There should be no free variables
+cgTopRhs dflags rec bndr (StgRhsClosure fvs cc upd_flag args body)
+  = ASSERT(isEmptyVarSet fvs)    -- There should be no free variables
     cgTopRhsClosure dflags rec bndr cc upd_flag args body
 
 
diff --git a/compiler/codeGen/StgCmmBind.hs b/compiler/codeGen/StgCmmBind.hs
index 004bf90c67..dba122fd0c 100644
--- a/compiler/codeGen/StgCmmBind.hs
+++ b/compiler/codeGen/StgCmmBind.hs
@@ -44,6 +44,7 @@ import Name
 import Module
 import ListSetOps
 import Util
+import UniqSet ( nonDetEltsUniqSet )
 import BasicTypes
 import Outputable
 import FastString
@@ -64,7 +65,7 @@ cgTopRhsClosure :: DynFlags
                 -> CostCentreStack      -- Optional cost centre annotation
                 -> UpdateFlag
                 -> [Id]                 -- Args
-                -> StgExpr
+                -> CgStgExpr
                 -> (CgIdInfo, FCode ())
 
 cgTopRhsClosure dflags rec id ccs upd_flag args body =
@@ -121,7 +122,7 @@ cgTopRhsClosure dflags rec id ccs upd_flag args body =
 --              Non-top-level bindings
 ------------------------------------------------------------------------
 
-cgBind :: StgBinding -> FCode ()
+cgBind :: CgStgBinding -> FCode ()
 cgBind (StgNonRec name rhs)
   = do  { (info, fcode) <- cgRhs name rhs
         ; addBindC info
@@ -190,7 +191,7 @@ cgBind (StgRec pairs)
  -}
 
 cgRhs :: Id
-      -> StgRhs
+      -> CgStgRhs
       -> FCode (
                  CgIdInfo         -- The info for this binding
                , FCode CmmAGraph  -- A computation which will generate the
@@ -206,9 +207,12 @@ cgRhs id (StgRhsCon cc con args)
       -- see Note [Post-unarisation invariants] in UnariseStg
 
 {- See Note [GC recovery] in compiler/codeGen/StgCmmClosure.hs -}
-cgRhs id (StgRhsClosure cc fvs upd_flag args body)
+cgRhs id (StgRhsClosure fvs cc upd_flag args body)
   = do dflags <- getDynFlags
-       mkRhsClosure dflags id cc (nonVoidIds fvs) upd_flag args body
+       mkRhsClosure dflags id cc (nonVoidIds (nonDetEltsUniqSet fvs)) upd_flag args body
+       -- It's OK to use nonDetEltsUniqSet here because we're not aiming for
+       -- bit-for-bit determinism.
+       -- See Note [Unique Determinism and code generation]
 
 ------------------------------------------------------------------------
 --              Non-constructor right hand sides
@@ -218,7 +222,7 @@ mkRhsClosure :: DynFlags -> Id -> CostCentreStack
              -> [NonVoid Id]                    -- Free vars
              -> UpdateFlag
              -> [Id]                            -- Args
-             -> StgExpr
+             -> CgStgExpr
              -> FCode (CgIdInfo, FCode CmmAGraph)
 
 {- mkRhsClosure looks for two special forms of the right-hand side:
@@ -436,7 +440,7 @@ closureCodeBody :: Bool            -- whether this is a top-level binding
                 -> CostCentreStack -- Optional cost centre attached to closure
                 -> [NonVoid Id]    -- incoming args to the closure
                 -> Int             -- arity, including void args
-                -> StgExpr
+                -> CgStgExpr
                 -> [(NonVoid Id, ByteOff)] -- the closure's free vars
                 -> FCode ()
 
@@ -560,7 +564,7 @@ mkSlowEntryCode bndr cl_info arg_regs -- function closure is already in `Node'
 
 -----------------------------------------
 thunkCode :: ClosureInfo -> [(NonVoid Id, ByteOff)] -> CostCentreStack
-          -> LocalReg -> Int -> StgExpr -> FCode ()
+          -> LocalReg -> Int -> CgStgExpr -> FCode ()
 thunkCode cl_info fv_details _cc node arity body
   = do { dflags <- getDynFlags
        ; let node_points = nodeMustPointToIt dflags (closureLFInfo cl_info)
diff --git a/compiler/codeGen/StgCmmBind.hs-boot b/compiler/codeGen/StgCmmBind.hs-boot
index 5840e990c8..8e3dd38ad8 100644
--- a/compiler/codeGen/StgCmmBind.hs-boot
+++ b/compiler/codeGen/StgCmmBind.hs-boot
@@ -1,6 +1,6 @@
 module StgCmmBind where
 
 import StgCmmMonad( FCode )
-import StgSyn( StgBinding )
+import StgSyn( CgStgBinding )
 
-cgBind :: StgBinding -> FCode ()
+cgBind :: CgStgBinding -> FCode ()
diff --git a/compiler/codeGen/StgCmmExpr.hs b/compiler/codeGen/StgCmmExpr.hs
index 7fc9dfc829..e8d111f9d5 100644
--- a/compiler/codeGen/StgCmmExpr.hs
+++ b/compiler/codeGen/StgCmmExpr.hs
@@ -56,7 +56,7 @@ import Data.Function ( on )
 --              cgExpr: the main function
 ------------------------------------------------------------------------
 
-cgExpr  :: StgExpr -> FCode ReturnKind
+cgExpr  :: CgStgExpr -> FCode ReturnKind
 
 cgExpr (StgApp fun args)     = cgIdApp fun args
 
@@ -114,7 +114,7 @@ bound only to stable things like stack locations..  The 'e' part will
 execute *next*, just like the scrutinee of a case. -}
 
 -------------------------
-cgLneBinds :: BlockId -> StgBinding -> FCode ()
+cgLneBinds :: BlockId -> CgStgBinding -> FCode ()
 cgLneBinds join_id (StgNonRec bndr rhs)
   = do  { local_cc <- saveCurrentCostCentre
                 -- See Note [Saving the current cost centre]
@@ -135,7 +135,7 @@ cgLetNoEscapeRhs
     :: BlockId          -- join point for successor of let-no-escape
     -> Maybe LocalReg   -- Saved cost centre
     -> Id
-    -> StgRhs
+    -> CgStgRhs
     -> FCode (CgIdInfo, FCode ())
 
 cgLetNoEscapeRhs join_id local_cc bndr rhs =
@@ -149,9 +149,9 @@ cgLetNoEscapeRhs join_id local_cc bndr rhs =
 cgLetNoEscapeRhsBody
     :: Maybe LocalReg   -- Saved cost centre
     -> Id
-    -> StgRhs
+    -> CgStgRhs
     -> FCode (CgIdInfo, FCode ())
-cgLetNoEscapeRhsBody local_cc bndr (StgRhsClosure cc _ _upd args body)
+cgLetNoEscapeRhsBody local_cc bndr (StgRhsClosure _ cc _upd args body)
   = cgLetNoEscapeClosure bndr local_cc cc (nonVoidIds args) body
 cgLetNoEscapeRhsBody local_cc bndr (StgRhsCon cc con args)
   = cgLetNoEscapeClosure bndr local_cc cc []
@@ -168,7 +168,7 @@ cgLetNoEscapeClosure
         -> Maybe LocalReg       -- Slot for saved current cost centre
         -> CostCentreStack      -- XXX: *** NOT USED *** why not?
         -> [NonVoid Id]         -- Args (as in \ args -> body)
-        -> StgExpr              -- Body (as in above)
+        -> CgStgExpr            -- Body (as in above)
         -> FCode (CgIdInfo, FCode ())
 
 cgLetNoEscapeClosure bndr cc_slot _unused_cc args body
@@ -298,7 +298,7 @@ data GcPlan
                         -- of the case alternative(s) into the upstream check
 
 -------------------------------------
-cgCase :: StgExpr -> Id -> AltType -> [StgAlt] -> FCode ReturnKind
+cgCase :: CgStgExpr -> Id -> AltType -> [CgStgAlt] -> FCode ReturnKind
 
 cgCase (StgOpApp (StgPrimOp op) args _) bndr (AlgAlt tycon) alts
   | isEnumerationTyCon tycon -- Note [case on bool]
@@ -547,7 +547,7 @@ maybeSaveCostCentre simple_scrut
 
 
 -----------------
-isSimpleScrut :: StgExpr -> AltType -> FCode Bool
+isSimpleScrut :: CgStgExpr -> AltType -> FCode Bool
 -- Simple scrutinee, does not block or allocate; hence safe to amalgamate
 -- heap usage from alternatives into the stuff before the case
 -- NB: if you get this wrong, and claim that the expression doesn't allocate
@@ -570,7 +570,7 @@ isSimpleOp (StgPrimOp op) stg_args                  = do
 isSimpleOp (StgPrimCallOp _) _                           = return False
 
 -----------------
-chooseReturnBndrs :: Id -> AltType -> [StgAlt] -> [NonVoid Id]
+chooseReturnBndrs :: Id -> AltType -> [CgStgAlt] -> [NonVoid Id]
 -- These are the binders of a case that are assigned by the evaluation of the
 -- scrutinee.
 -- They're non-void, see Note [Post-unarisation invariants] in UnariseStg.
@@ -591,7 +591,7 @@ chooseReturnBndrs _ _ _ = panic "chooseReturnBndrs"
                              -- MultiValAlt has only one alternative
 
 -------------------------------------
-cgAlts :: (GcPlan,ReturnKind) -> NonVoid Id -> AltType -> [StgAlt]
+cgAlts :: (GcPlan,ReturnKind) -> NonVoid Id -> AltType -> [CgStgAlt]
        -> FCode ReturnKind
 -- At this point the result of the case are in the binders
 cgAlts gc_plan _bndr PolyAlt [(_, _, rhs)]
@@ -666,7 +666,7 @@ cgAlts _ _ _ _ = panic "cgAlts"
 --   goto L1
 
 -------------------
-cgAlgAltRhss :: (GcPlan,ReturnKind) -> NonVoid Id -> [StgAlt]
+cgAlgAltRhss :: (GcPlan,ReturnKind) -> NonVoid Id -> [CgStgAlt]
              -> FCode ( Maybe CmmAGraphScoped
                       , [(ConTagZ, CmmAGraphScoped)] )
 cgAlgAltRhss gc_plan bndr alts
@@ -686,13 +686,13 @@ cgAlgAltRhss gc_plan bndr alts
 
 
 -------------------
-cgAltRhss :: (GcPlan,ReturnKind) -> NonVoid Id -> [StgAlt]
+cgAltRhss :: (GcPlan,ReturnKind) -> NonVoid Id -> [CgStgAlt]
           -> FCode [(AltCon, CmmAGraphScoped)]
 cgAltRhss gc_plan bndr alts = do
   dflags <- getDynFlags
   let
     base_reg = idToReg dflags bndr
-    cg_alt :: StgAlt -> FCode (AltCon, CmmAGraphScoped)
+    cg_alt :: CgStgAlt -> FCode (AltCon, CmmAGraphScoped)
     cg_alt (con, bndrs, rhs)
       = getCodeScoped             $
         maybeAltHeapCheck gc_plan $
diff --git a/compiler/ghc.cabal.in b/compiler/ghc.cabal.in
index 2844e2d56e..893f959b1c 100644
--- a/compiler/ghc.cabal.in
+++ b/compiler/ghc.cabal.in
@@ -441,6 +441,7 @@ Library
         CoreToStg
         StgLint
         StgSyn
+        StgFVs
         CallArity
         DmdAnal
         Exitify
diff --git a/compiler/main/DynFlags.hs b/compiler/main/DynFlags.hs
index d78b5984e1..2b1992274b 100644
--- a/compiler/main/DynFlags.hs
+++ b/compiler/main/DynFlags.hs
@@ -616,7 +616,7 @@ data GeneralFlag
    -- Except for uniques, as some simplifier phases introduce new
    -- variables that have otherwise identical names.
    | Opt_SuppressUniques
-   | Opt_SuppressStgFreeVars
+   | Opt_SuppressStgExts
    | Opt_SuppressTicks     -- Replaces Opt_PprShowTicks
    | Opt_SuppressTimestamps -- ^ Suppress timestamps in dumps
 
@@ -3166,7 +3166,7 @@ dynamic_flags_deps = [
                   setGeneralFlag Opt_SuppressTypeApplications
                   setGeneralFlag Opt_SuppressIdInfo
                   setGeneralFlag Opt_SuppressTicks
-                  setGeneralFlag Opt_SuppressStgFreeVars
+                  setGeneralFlag Opt_SuppressStgExts
                   setGeneralFlag Opt_SuppressTypeSignatures
                   setGeneralFlag Opt_SuppressTimestamps)
 
@@ -3976,7 +3976,9 @@ dFlagsDeps = [
   depFlagSpec' "ppr-ticks"              Opt_PprShowTicks
      (\turn_on -> useInstead "-d" "suppress-ticks" (not turn_on)),
   flagSpec "suppress-ticks"             Opt_SuppressTicks,
-  flagSpec "suppress-stg-free-vars"     Opt_SuppressStgFreeVars,
+  depFlagSpec' "suppress-stg-free-vars" Opt_SuppressStgExts
+     (useInstead "-d" "suppress-stg-exts"),
+  flagSpec "suppress-stg-exts"          Opt_SuppressStgExts,
   flagSpec "suppress-coercions"         Opt_SuppressCoercions,
   flagSpec "suppress-idinfo"            Opt_SuppressIdInfo,
   flagSpec "suppress-unfoldings"        Opt_SuppressUnfoldings,
diff --git a/compiler/main/HscMain.hs b/compiler/main/HscMain.hs
index 9dd750736a..837e903631 100644
--- a/compiler/main/HscMain.hs
+++ b/compiler/main/HscMain.hs
@@ -124,6 +124,7 @@ import CorePrep
 import CoreToStg        ( coreToStg )
 import qualified StgCmm ( codeGen )
 import StgSyn
+import StgFVs           ( annTopBindingsFreeVars )
 import CostCentre
 import ProfInit
 import TyCon
@@ -1426,10 +1427,11 @@ doCodeGen hsc_env this_mod data_tycons
               cost_centre_info stg_binds hpc_info = do
     let dflags = hsc_dflags hsc_env
 
+    let stg_binds_w_fvs = annTopBindingsFreeVars stg_binds
     let cmm_stream :: Stream IO CmmGroup ()
         cmm_stream = {-# SCC "StgCmm" #-}
             StgCmm.codeGen dflags this_mod data_tycons
-                           cost_centre_info stg_binds hpc_info
+                           cost_centre_info stg_binds_w_fvs hpc_info
 
         -- codegen consumes a stream of CmmGroup, and produces a new
         -- stream of CmmGroup (not necessarily synchronised: one
diff --git a/compiler/simplStg/StgCse.hs b/compiler/simplStg/StgCse.hs
index fe7943c7d8..a22a7c1400 100644
--- a/compiler/simplStg/StgCse.hs
+++ b/compiler/simplStg/StgCse.hs
@@ -227,9 +227,6 @@ substArg :: CseEnv -> InStgArg -> OutStgArg
 substArg env (StgVarArg from) = StgVarArg (substVar env from)
 substArg _   (StgLitArg lit)  = StgLitArg lit
 
-substVars :: CseEnv -> [InId] -> [OutId]
-substVars env = map (substVar env)
-
 substVar :: CseEnv -> InId -> OutId
 substVar env id = fromMaybe id $ lookupVarEnv (ce_subst env) id
 
@@ -284,9 +281,9 @@ stgCseTopLvl in_scope (StgTopLifted (StgRec eqs))
   where in_scope' = in_scope `extendInScopeSetList` [ bndr | (bndr, _) <- eqs ]
 
 stgCseTopLvlRhs :: InScopeSet -> InStgRhs -> OutStgRhs
-stgCseTopLvlRhs in_scope (StgRhsClosure ccs occs upd args body)
+stgCseTopLvlRhs in_scope (StgRhsClosure ext ccs upd args body)
     = let body' = stgCseExpr (initEnv in_scope) body
-      in  StgRhsClosure ccs occs upd args body'
+      in  StgRhsClosure ext ccs upd args body'
 stgCseTopLvlRhs _ (StgRhsCon ccs dataCon args)
     = StgRhsCon ccs dataCon args
 
@@ -402,12 +399,11 @@ stgCseRhs env bndr (StgRhsCon ccs dataCon args)
           pair = (bndr, StgRhsCon ccs dataCon args')
       in (Just pair, env')
   where args' = substArgs env args
-stgCseRhs env bndr (StgRhsClosure ccs occs upd args body)
+stgCseRhs env bndr (StgRhsClosure ext ccs upd args body)
     = let (env1, args') = substBndrs env args
           env2 = forgetCse env1 -- See note [Free variables of an StgClosure]
           body' = stgCseExpr env2 body
-      in (Just (substVar env bndr, StgRhsClosure ccs occs' upd args' body'), env)
-  where occs' = substVars env occs
+      in (Just (substVar env bndr, StgRhsClosure ext ccs upd args' body'), env)
 
 
 mkStgCase :: StgExpr -> OutId -> AltType -> [StgAlt] -> StgExpr
diff --git a/compiler/simplStg/StgStats.hs b/compiler/simplStg/StgStats.hs
index c548d80707..a2a9a8530f 100644
--- a/compiler/simplStg/StgStats.hs
+++ b/compiler/simplStg/StgStats.hs
@@ -66,9 +66,6 @@ combineSEs = foldr combineSE emptySE
 countOne :: CounterType -> StatEnv
 countOne c = Map.singleton c 1
 
-countN :: CounterType -> Int -> StatEnv
-countN = Map.singleton
-
 {-
 ************************************************************************
 *                                                                      *
@@ -131,9 +128,8 @@ statRhs :: Bool -> (Id, StgRhs) -> StatEnv
 statRhs top (_, StgRhsCon _ _ _)
   = countOne (ConstructorBinds top)
 
-statRhs top (_, StgRhsClosure _ fv u _ body)
-  = statExpr body                       `combineSE`
-    countN FreeVariables (length fv)    `combineSE`
+statRhs top (_, StgRhsClosure _ _ u _ body)
+  = statExpr body `combineSE`
     countOne (
       case u of
         ReEntrant   -> ReEntrantBinds   top
diff --git a/compiler/simplStg/UnariseStg.hs b/compiler/simplStg/UnariseStg.hs
index a46497452f..c3a8bc76e2 100644
--- a/compiler/simplStg/UnariseStg.hs
+++ b/compiler/simplStg/UnariseStg.hs
@@ -281,11 +281,10 @@ unariseBinding rho (StgRec xrhss)
   = StgRec <$> mapM (\(x, rhs) -> (x,) <$> unariseRhs rho rhs) xrhss
 
 unariseRhs :: UnariseEnv -> StgRhs -> UniqSM StgRhs
-unariseRhs rho (StgRhsClosure ccs fvs update_flag args expr)
+unariseRhs rho (StgRhsClosure ext ccs update_flag args expr)
   = do (rho', args1) <- unariseFunArgBinders rho args
        expr' <- unariseExpr rho' expr
-       let fvs' = unariseFreeVars rho fvs
-       return (StgRhsClosure ccs fvs' update_flag args1 expr')
+       return (StgRhsClosure ext ccs update_flag args1 expr')
 
 unariseRhs rho (StgRhsCon ccs con args)
   = ASSERT(not (isUnboxedTupleCon con || isUnboxedSumCon con))
@@ -723,24 +722,6 @@ unariseConArgBinders rho xs = second concat <$> mapAccumLM unariseConArgBinder r
 unariseConArgBinder :: UnariseEnv -> Id -> UniqSM (UnariseEnv, [Id])
 unariseConArgBinder = unariseArgBinder True
 
-unariseFreeVars :: UnariseEnv -> [InId] -> [OutId]
-unariseFreeVars rho fvs
- = [ v | fv <- fvs, StgVarArg v <- unariseFreeVar rho fv ]
-   -- Notice that we filter out any StgLitArgs
-   -- e.g.   case e of (x :: (# Int | Bool #))
-   --           (# v | #) ->  ... let {g = \y. ..x...} in ...
-   --           (# | w #) -> ...
-   --     Here 'x' is free in g's closure, and the env will have
-   --       x :-> [1, v]
-   --     we want to capture 'v', but not 1, in the free vars
-
-unariseFreeVar :: UnariseEnv -> Id -> [StgArg]
-unariseFreeVar rho x =
-  case lookupVarEnv rho x of
-    Just (MultiVal args) -> args
-    Just (UnaryVal arg)  -> [arg]
-    Nothing              -> [StgVarArg x]
-
 --------------------------------------------------------------------------------
 
 mkIds :: FastString -> [UnaryType] -> UniqSM [Id]
diff --git a/compiler/stgSyn/CoreToStg.hs b/compiler/stgSyn/CoreToStg.hs
index 12940753f9..1b1d4639f2 100644
--- a/compiler/stgSyn/CoreToStg.hs
+++ b/compiler/stgSyn/CoreToStg.hs
@@ -46,11 +46,10 @@ import DynFlags
 import ForeignCall
 import Demand           ( isUsedOnce )
 import PrimOp           ( PrimCall(..) )
-import UniqFM
 import SrcLoc           ( mkGeneralSrcSpan )
 
 import Data.List.NonEmpty (nonEmpty, toList)
-import Data.Maybe    (isJust, fromMaybe)
+import Data.Maybe    (fromMaybe)
 import Control.Monad (liftM, ap)
 
 -- Note [Live vs free]
@@ -208,7 +207,7 @@ coreToStg :: DynFlags -> Module -> CoreProgram
 coreToStg dflags this_mod pgm
   = (pgm', final_ccs)
   where
-    (_, _, (local_ccs, local_cc_stacks), pgm')
+    (_, (local_ccs, local_cc_stacks), pgm')
       = coreTopBindsToStg dflags this_mod emptyVarEnv emptyCollectedCCs pgm
 
     prof = WayProf `elem` ways dflags
@@ -229,45 +228,41 @@ coreTopBindsToStg
     -> IdEnv HowBound           -- environment for the bindings
     -> CollectedCCs
     -> CoreProgram
-    -> (IdEnv HowBound, FreeVarsInfo, CollectedCCs, [StgTopBinding])
+    -> (IdEnv HowBound, CollectedCCs, [StgTopBinding])
 
 coreTopBindsToStg _      _        env ccs []
-  = (env, emptyFVInfo, ccs, [])
+  = (env, ccs, [])
 coreTopBindsToStg dflags this_mod env ccs (b:bs)
-  = (env2, fvs2, ccs2, b':bs')
+  = (env2, ccs2, b':bs')
   where
-        -- Notice the mutually-recursive "knot" here:
-        --   env accumulates down the list of binds,
-        --   fvs accumulates upwards
-        (env1, fvs2, ccs1, b' ) =
-          coreTopBindToStg dflags this_mod env fvs1 ccs b
-        (env2, fvs1, ccs2, bs') =
+        (env1, ccs1, b' ) =
+          coreTopBindToStg dflags this_mod env ccs b
+        (env2, ccs2, bs') =
           coreTopBindsToStg dflags this_mod env1 ccs1 bs
 
 coreTopBindToStg
         :: DynFlags
         -> Module
         -> IdEnv HowBound
-        -> FreeVarsInfo         -- Info about the body
         -> CollectedCCs
         -> CoreBind
-        -> (IdEnv HowBound, FreeVarsInfo, CollectedCCs, StgTopBinding)
+        -> (IdEnv HowBound, CollectedCCs, StgTopBinding)
 
-coreTopBindToStg _ _ env body_fvs ccs (NonRec id e)
+coreTopBindToStg _ _ env ccs (NonRec id e)
   | Just str <- exprIsTickedString_maybe e
   -- top-level string literal
   -- See Note [CoreSyn top-level string literals] in CoreSyn
   = let
         env' = extendVarEnv env id how_bound
         how_bound = LetBound TopLet 0
-    in (env', body_fvs, ccs, StgTopStringLit id str)
+    in (env', ccs, StgTopStringLit id str)
 
-coreTopBindToStg dflags this_mod env body_fvs ccs (NonRec id rhs)
+coreTopBindToStg dflags this_mod env ccs (NonRec id rhs)
   = let
         env'      = extendVarEnv env id how_bound
         how_bound = LetBound TopLet $! manifestArity rhs
 
-        (stg_rhs, fvs', ccs') =
+        (stg_rhs, ccs') =
             initCts env $
               coreToTopStgRhs dflags ccs this_mod (id,rhs)
 
@@ -278,9 +273,9 @@ coreTopBindToStg dflags this_mod env body_fvs ccs (NonRec id rhs)
       --     as well as 'id', but that led to a black hole
       --     where printing the assertion error tripped the
       --     assertion again!
-    (env', fvs' `unionFVInfo` body_fvs, ccs', bind)
+    (env', ccs', bind)
 
-coreTopBindToStg dflags this_mod env body_fvs ccs (Rec pairs)
+coreTopBindToStg dflags this_mod env ccs (Rec pairs)
   = ASSERT( not (null pairs) )
     let
         binders = map fst pairs
@@ -289,28 +284,27 @@ coreTopBindToStg dflags this_mod env body_fvs ccs (Rec pairs)
                      | (b, rhs) <- pairs ]
         env' = extendVarEnvList env extra_env'
 
-        -- generate StgTopBindings, accumulate body_fvs and CAF cost centres
-        -- created for CAFs
-        ((fvs', ccs'), stg_rhss)
+        -- generate StgTopBindings and CAF cost centres created for CAFs
+        (ccs', stg_rhss)
           = initCts env' $ do
-               mapAccumLM (\(fvs, ccs) rhs -> do
-                            (rhs', fvs', ccs') <-
+               mapAccumLM (\ccs rhs -> do
+                            (rhs', ccs') <-
                               coreToTopStgRhs dflags ccs this_mod rhs
-                            return ((fvs' `unionFVInfo` fvs, ccs'), rhs'))
-                          (body_fvs, ccs)
+                            return (ccs', rhs'))
+                          ccs
                           pairs
 
         bind = StgTopLifted $ StgRec (zip binders stg_rhss)
     in
     ASSERT2(consistentCafInfo (head binders) bind, ppr binders)
-    (env', fvs' `unionFVInfo` body_fvs, ccs', bind)
+    (env', ccs', bind)
 
 
 -- Assertion helper: this checks that the CafInfo on the Id matches
 -- what CoreToStg has figured out about the binding's SRT.  The
 -- CafInfo will be exact in all cases except when CorePrep has
 -- floated out a binding, in which case it will be approximate.
-consistentCafInfo :: Id -> GenStgTopBinding Var Id -> Bool
+consistentCafInfo :: Id -> StgTopBinding -> Bool
 consistentCafInfo id bind
   = WARN( not (exact || is_sat_thing) , ppr id <+> ppr id_marked_caffy <+> ppr binding_is_caffy )
     safe
@@ -326,18 +320,17 @@ coreToTopStgRhs
         -> CollectedCCs
         -> Module
         -> (Id,CoreExpr)
-        -> CtsM (StgRhs, FreeVarsInfo, CollectedCCs)
+        -> CtsM (StgRhs, CollectedCCs)
 
 coreToTopStgRhs dflags ccs this_mod (bndr, rhs)
-  = do { (new_rhs, rhs_fvs) <- coreToStgExpr rhs
+  = do { new_rhs <- coreToStgExpr rhs
 
        ; let (stg_rhs, ccs') =
-               mkTopStgRhs dflags this_mod ccs rhs_fvs bndr new_rhs
+               mkTopStgRhs dflags this_mod ccs bndr new_rhs
              stg_arity =
                stgRhsArity stg_rhs
 
        ; return (ASSERT2( arity_ok stg_arity, mk_arity_msg stg_arity) stg_rhs,
-                 rhs_fvs,
                  ccs') }
   where
         -- It's vital that the arity on a top-level Id matches
@@ -365,8 +358,7 @@ coreToTopStgRhs dflags ccs this_mod (bndr, rhs)
 
 coreToStgExpr
         :: CoreExpr
-        -> CtsM (StgExpr,       -- Decorated STG expr
-                 FreeVarsInfo)  -- Its free vars (NB free, not live)
+        -> CtsM StgExpr
 
 -- The second and third components can be derived in a simple bottom up pass, not
 -- dependent on any decisions about which variables will be let-no-escaped or
@@ -378,7 +370,7 @@ coreToStgExpr
 -- CorePrep should have converted them all to a real core representation.
 coreToStgExpr (Lit (LitNumber LitNumInteger _ _)) = panic "coreToStgExpr: LitInteger"
 coreToStgExpr (Lit (LitNumber LitNumNatural _ _)) = panic "coreToStgExpr: LitNatural"
-coreToStgExpr (Lit l)      = return (StgLit l, emptyFVInfo)
+coreToStgExpr (Lit l)      = return (StgLit l)
 coreToStgExpr (App (Lit RubbishLit) _some_unlifted_type)
   -- We lower 'RubbishLit' to @()@ here, which is much easier than doing it in
   -- a STG to Cmm pass.
@@ -397,14 +389,13 @@ coreToStgExpr expr@(Lam _ _)
         args'        = filterStgBinders args
     in
     extendVarEnvCts [ (a, LambdaBound) | a <- args' ] $ do
-    (body, body_fvs) <- coreToStgExpr body
+    body' <- coreToStgExpr body
     let
-        fvs         = args' `minusFVBinders` body_fvs
         result_expr = case nonEmpty args' of
-          Nothing     -> body
-          Just args'' -> StgLam args'' body
+          Nothing     -> body'
+          Just args'' -> StgLam args'' body'
 
-    return (result_expr, fvs)
+    return result_expr
 
 coreToStgExpr (Tick tick expr)
   = do case tick of
@@ -412,8 +403,8 @@ coreToStgExpr (Tick tick expr)
          ProfNote{}   -> return ()
          SourceNote{} -> return ()
          Breakpoint{} -> panic "coreToStgExpr: breakpoint should not happen"
-       (expr2, fvs) <- coreToStgExpr expr
-       return (StgTick tick expr2, fvs)
+       expr2 <- coreToStgExpr expr
+       return (StgTick tick expr2)
 
 coreToStgExpr (Cast expr _)
   = coreToStgExpr expr
@@ -433,31 +424,9 @@ coreToStgExpr (Case scrut _ _ [])
 
 
 coreToStgExpr (Case scrut bndr _ alts) = do
-    (alts2, alts_fvs)
-       <- extendVarEnvCts [(bndr, LambdaBound)] $ do
-            (alts2, fvs_s) <- mapAndUnzipM vars_alt alts
-            return ( alts2,
-                     unionFVInfos fvs_s )
-    let
-        -- Determine whether the default binder is dead or not
-        -- This helps the code generator to avoid generating an assignment
-        -- for the case binder (is extremely rare cases) ToDo: remove.
-        bndr' | bndr `elementOfFVInfo` alts_fvs = bndr
-              | otherwise                       = bndr `setIdOccInfo` IAmDead
-
-        -- Don't consider the default binder as being 'live in alts',
-        -- since this is from the point of view of the case expr, where
-        -- the default binder is not free.
-        alts_fvs_wo_bndr  = bndr `minusFVBinder` alts_fvs
-
-        -- We tell the scrutinee that everything
-        -- live in the alts is live in it, too.
-    (scrut2, scrut_fvs) <- coreToStgExpr scrut
-
-    return (
-      StgCase scrut2 bndr' (mkStgAltType bndr alts) alts2,
-      scrut_fvs `unionFVInfo` alts_fvs_wo_bndr
-      )
+    alts2 <- extendVarEnvCts [(bndr, LambdaBound)] (mapM vars_alt alts)
+    scrut2 <- coreToStgExpr scrut
+    return (StgCase scrut2 bndr (mkStgAltType bndr alts) alts2)
   where
     vars_alt (con, binders, rhs)
       | DataAlt c <- con, c == unboxedUnitDataCon
@@ -465,16 +434,15 @@ coreToStgExpr (Case scrut bndr _ alts) = do
         -- See Note [Nullary unboxed tuple] in Type.hs
         -- where a nullary tuple is mapped to (State# World#)
         ASSERT( null binders )
-        do { (rhs2, rhs_fvs) <- coreToStgExpr rhs
-           ; return ((DEFAULT, [], rhs2), rhs_fvs) }
+        do { rhs2 <- coreToStgExpr rhs
+           ; return (DEFAULT, [], rhs2)  }
       | otherwise
       = let     -- Remove type variables
             binders' = filterStgBinders binders
         in
         extendVarEnvCts [(b, LambdaBound) | b <- binders'] $ do
-        (rhs2, rhs_fvs) <- coreToStgExpr rhs
-        return ( (con, binders', rhs2),
-                 binders' `minusFVBinders` rhs_fvs )
+        rhs2 <- coreToStgExpr rhs
+        return (con, binders', rhs2)
 
 coreToStgExpr (Let bind body) = do
     coreToStgLet bind body
@@ -533,19 +501,15 @@ coreToStgApp
         -> Id                           -- Function
         -> [CoreArg]                    -- Arguments
         -> [Tickish Id]                 -- Debug ticks
-        -> CtsM (StgExpr, FreeVarsInfo)
+        -> CtsM StgExpr
 
 
 coreToStgApp _ f args ticks = do
-    (args', args_fvs, ticks') <- coreToStgArgs args
+    (args', ticks') <- coreToStgArgs args
     how_bound <- lookupVarCts f
 
     let
         n_val_args       = valArgCount args
-        fun_fvs = singletonFVInfo f how_bound
-            -- e.g. (f :: a -> int) (x :: a)
-            -- Here the free variables are "f", "x" AND the type variable "a"
-            -- coreToStgArgs will deal with the arguments recursively
 
         -- Mostly, the arity info of a function is in the fn's IdInfo
         -- But new bindings introduced by CoreSat may not have no
@@ -579,45 +543,39 @@ coreToStgApp _ f args ticks = do
 
                 TickBoxOpId {}   -> pprPanic "coreToStg TickBox" $ ppr (f,args')
                 _other           -> StgApp f args'
-        fvs = fun_fvs  `unionFVInfo` args_fvs
 
         tapp = foldr StgTick app (ticks ++ ticks')
 
     -- Forcing these fixes a leak in the code generator, noticed while
     -- profiling for trac #4367
-    app `seq` fvs `seq` return (
-        tapp,
-        fvs
-     )
+    app `seq` return tapp
 
 -- ---------------------------------------------------------------------------
 -- Argument lists
 -- This is the guy that turns applications into A-normal form
 -- ---------------------------------------------------------------------------
 
-coreToStgArgs :: [CoreArg] -> CtsM ([StgArg], FreeVarsInfo, [Tickish Id])
+coreToStgArgs :: [CoreArg] -> CtsM ([StgArg], [Tickish Id])
 coreToStgArgs []
-  = return ([], emptyFVInfo, [])
+  = return ([], [])
 
 coreToStgArgs (Type _ : args) = do     -- Type argument
-    (args', fvs, ts) <- coreToStgArgs args
-    return (args', fvs, ts)
+    (args', ts) <- coreToStgArgs args
+    return (args', ts)
 
 coreToStgArgs (Coercion _ : args)  -- Coercion argument; replace with place holder
-  = do { (args', fvs, ts) <- coreToStgArgs args
-       ; return (StgVarArg coercionTokenId : args', fvs, ts) }
+  = do { (args', ts) <- coreToStgArgs args
+       ; return (StgVarArg coercionTokenId : args', ts) }
 
 coreToStgArgs (Tick t e : args)
   = ASSERT( not (tickishIsCode t) )
-    do { (args', fvs, ts) <- coreToStgArgs (e : args)
-       ; return (args', fvs, t:ts) }
+    do { (args', ts) <- coreToStgArgs (e : args)
+       ; return (args', t:ts) }
 
 coreToStgArgs (arg : args) = do         -- Non-type argument
-    (stg_args, args_fvs, ticks) <- coreToStgArgs args
-    (arg', arg_fvs) <- coreToStgExpr arg
+    (stg_args, ticks) <- coreToStgArgs args
+    arg' <- coreToStgExpr arg
     let
-        fvs = args_fvs `unionFVInfo` arg_fvs
-
         (aticks, arg'') = stripStgTicksTop tickishFloatable arg'
         stg_arg = case arg'' of
                        StgApp v []        -> StgVarArg v
@@ -646,7 +604,7 @@ coreToStgArgs (arg : args) = do         -- Non-type argument
         -- We also want to check if a pointer is cast to a non-ptr etc
 
     WARN( bad_args, text "Dangerous-looking argument. Probable cause: bad unsafeCoerce#" $$ ppr arg )
-     return (stg_arg : stg_args, fvs, ticks ++ aticks)
+     return (stg_arg : stg_args, ticks ++ aticks)
 
 
 -- ---------------------------------------------------------------------------
@@ -654,56 +612,43 @@ coreToStgArgs (arg : args) = do         -- Non-type argument
 -- ---------------------------------------------------------------------------
 
 coreToStgLet
-         :: CoreBind    -- bindings
-         -> CoreExpr    -- body
-         -> CtsM (StgExpr,      -- new let
-                  FreeVarsInfo) -- variables free in the whole let
+         :: CoreBind     -- bindings
+         -> CoreExpr     -- body
+         -> CtsM StgExpr -- new let
 
 coreToStgLet bind body = do
-    (bind2, bind_fvs,
-     body2, body_fvs)
+    (bind2, body2)
        <- do
 
-          ( bind2, bind_fvs, env_ext)
+          ( bind2, env_ext)
                 <- vars_bind bind
 
           -- Do the body
           extendVarEnvCts env_ext $ do
-             (body2, body_fvs) <- coreToStgExpr body
+             body2 <- coreToStgExpr body
 
-             return (bind2, bind_fvs,
-                     body2, body_fvs)
+             return (bind2, body2)
 
         -- Compute the new let-expression
     let
         new_let | isJoinBind bind = StgLetNoEscape bind2 body2
                 | otherwise       = StgLet bind2 body2
 
-        free_in_whole_let
-          = binders `minusFVBinders` (bind_fvs `unionFVInfo` body_fvs)
-
-    return (
-        new_let,
-        free_in_whole_let
-      )
+    return new_let
   where
-    binders        = bindersOf bind
-
     mk_binding binder rhs
         = (binder, LetBound NestedLet (manifestArity rhs))
 
     vars_bind :: CoreBind
               -> CtsM (StgBinding,
-                       FreeVarsInfo,
                        [(Id, HowBound)])  -- extension to environment
 
     vars_bind (NonRec binder rhs) = do
-        (rhs2, bind_fvs) <- coreToStgRhs (binder,rhs)
+        rhs2 <- coreToStgRhs (binder,rhs)
         let
             env_ext_item = mk_binding binder rhs
 
-        return (StgNonRec binder rhs2,
-                bind_fvs, [env_ext_item])
+        return (StgNonRec binder rhs2, [env_ext_item])
 
     vars_bind (Rec pairs)
       =    let
@@ -712,32 +657,26 @@ coreToStgLet bind body = do
                           | (b,rhs) <- pairs ]
            in
            extendVarEnvCts env_ext $ do
-              (rhss2, fvss)
-                     <- mapAndUnzipM coreToStgRhs pairs
-              let
-                        bind_fvs = unionFVInfos fvss
-
-              return (StgRec (binders `zip` rhss2),
-                      bind_fvs, env_ext)
+              rhss2 <- mapM coreToStgRhs pairs
+              return (StgRec (binders `zip` rhss2), env_ext)
 
 coreToStgRhs :: (Id,CoreExpr)
-             -> CtsM (StgRhs, FreeVarsInfo)
+             -> CtsM StgRhs
 
 coreToStgRhs (bndr, rhs) = do
-    (new_rhs, rhs_fvs) <- coreToStgExpr rhs
-    return (mkStgRhs rhs_fvs bndr new_rhs, rhs_fvs)
+    new_rhs <- coreToStgExpr rhs
+    return (mkStgRhs bndr new_rhs)
 
 -- Generate a top-level RHS. Any new cost centres generated for CAFs will be
 -- appended to `CollectedCCs` argument.
 mkTopStgRhs :: DynFlags -> Module -> CollectedCCs
-            -> FreeVarsInfo -> Id -> StgExpr
-            -> (StgRhs, CollectedCCs)
+            -> Id -> StgExpr -> (StgRhs, CollectedCCs)
 
-mkTopStgRhs dflags this_mod ccs rhs_fvs bndr rhs
+mkTopStgRhs dflags this_mod ccs bndr rhs
   | StgLam bndrs body <- rhs
   = -- StgLam can't have empty arguments, so not CAF
-    ( StgRhsClosure dontCareCCS
-                    (getFVs rhs_fvs)
+    ( StgRhsClosure noExtSilent
+                    dontCareCCS
                     ReEntrant
                     (toList bndrs) body
     , ccs )
@@ -752,14 +691,14 @@ mkTopStgRhs dflags this_mod ccs rhs_fvs bndr rhs
 
   -- Otherwise it's a CAF, see Note [Cost-centre initialization plan].
   | gopt Opt_AutoSccsOnIndividualCafs dflags
-  = ( StgRhsClosure caf_ccs
-                    (getFVs rhs_fvs)
+  = ( StgRhsClosure noExtSilent
+                    caf_ccs
                     upd_flag [] rhs
     , collectCC caf_cc caf_ccs ccs )
 
   | otherwise
-  = ( StgRhsClosure all_cafs_ccs
-                    (getFVs rhs_fvs)
+  = ( StgRhsClosure noExtSilent
+                    all_cafs_ccs
                     upd_flag [] rhs
     , ccs )
 
@@ -783,18 +722,18 @@ mkTopStgRhs dflags this_mod ccs rhs_fvs bndr rhs
 
 -- Generate a non-top-level RHS. Cost-centre is always currentCCS,
 -- see Note [Cost-centre initialzation plan].
-mkStgRhs :: FreeVarsInfo -> Id -> StgExpr -> StgRhs
-mkStgRhs rhs_fvs bndr rhs
+mkStgRhs :: Id -> StgExpr -> StgRhs
+mkStgRhs bndr rhs
   | StgLam bndrs body <- rhs
-  = StgRhsClosure currentCCS
-                  (getFVs rhs_fvs)
+  = StgRhsClosure noExtSilent
+                  currentCCS
                   ReEntrant
                   (toList bndrs) body
 
   | isJoinId bndr -- must be a nullary join point
   = ASSERT(idJoinArity bndr == 0)
-    StgRhsClosure currentCCS
-                  (getFVs rhs_fvs)
+    StgRhsClosure noExtSilent
+                  currentCCS
                   ReEntrant -- ignored for LNE
                   [] rhs
 
@@ -802,8 +741,8 @@ mkStgRhs rhs_fvs bndr rhs
   = StgRhsCon currentCCS con args
 
   | otherwise
-  = StgRhsClosure currentCCS
-                  (getFVs rhs_fvs)
+  = StgRhsClosure noExtSilent
+                  currentCCS
                   upd_flag [] rhs
   where
     (_, unticked_rhs) = stripStgTicksTop (not . tickishIsCode) rhs
@@ -891,11 +830,6 @@ data LetInfo
   | NestedLet
   deriving (Eq)
 
-topLevelBound :: HowBound -> Bool
-topLevelBound ImportBound         = True
-topLevelBound (LetBound TopLet _) = True
-topLevelBound _                   = False
-
 -- For a let(rec)-bound variable, x, we record LiveInfo, the set of
 -- variables that are live if x is live.  This LiveInfo comprises
 --         (a) dynamic live variables (ones with a non-top-level binding)
@@ -961,63 +895,6 @@ getAllCAFsCC this_mod =
     in
       (all_cafs_cc, all_cafs_ccs)
 
--- ---------------------------------------------------------------------------
--- Free variable information
--- ---------------------------------------------------------------------------
-
-type FreeVarsInfo = VarEnv (Var, HowBound)
-        -- The Var is so we can gather up the free variables
-        -- as a set.
-        --
-        -- The HowBound info just saves repeated lookups;
-        -- we look up just once when we encounter the occurrence.
-        -- INVARIANT: Any ImportBound Ids are HaveCafRef Ids
-        --            Imported Ids without CAF refs are simply
-        --            not put in the FreeVarsInfo for an expression.
-        --            See singletonFVInfo and freeVarsToLiveVars
-
-emptyFVInfo :: FreeVarsInfo
-emptyFVInfo = emptyVarEnv
-
-singletonFVInfo :: Id -> HowBound -> FreeVarsInfo
--- Don't record non-CAF imports at all, to keep free-var sets small
-singletonFVInfo id ImportBound
-   | mayHaveCafRefs (idCafInfo id) = unitVarEnv id (id, ImportBound)
-   | otherwise                     = emptyVarEnv
-singletonFVInfo id how_bound = unitVarEnv id (id, how_bound)
-
-unionFVInfo :: FreeVarsInfo -> FreeVarsInfo -> FreeVarsInfo
-unionFVInfo fv1 fv2 = plusVarEnv_C plusFVInfo fv1 fv2
-
-unionFVInfos :: [FreeVarsInfo] -> FreeVarsInfo
-unionFVInfos fvs = foldr unionFVInfo emptyFVInfo fvs
-
-minusFVBinders :: [Id] -> FreeVarsInfo -> FreeVarsInfo
-minusFVBinders vs fv = foldr minusFVBinder fv vs
-
-minusFVBinder :: Id -> FreeVarsInfo -> FreeVarsInfo
-minusFVBinder v fv = fv `delVarEnv` v
-        -- When removing a binder, remember to add its type variables
-        -- c.f. CoreFVs.delBinderFV
-
-elementOfFVInfo :: Id -> FreeVarsInfo -> Bool
-elementOfFVInfo id fvs = isJust (lookupVarEnv fvs id)
-
--- Non-top-level things only, both type variables and ids
-getFVs :: FreeVarsInfo -> [Var]
-getFVs fvs = [id | (id, how_bound) <- nonDetEltsUFM fvs,
-  -- It's OK to use nonDetEltsUFM here because we're not aiming for
-  -- bit-for-bit determinism.
-  -- See Note [Unique Determinism and code generation]
-                    not (topLevelBound how_bound) ]
-
-plusFVInfo :: (Var, HowBound)
-           -> (Var, HowBound)
-           -> (Var, HowBound)
-plusFVInfo (id1,hb1) (id2,hb2)
-  = ASSERT(id1 == id2 && hb1 == hb2)
-    (id1, hb1)
-
 -- Misc.
 
 filterStgBinders :: [Var] -> [Var]
diff --git a/compiler/stgSyn/StgFVs.hs b/compiler/stgSyn/StgFVs.hs
new file mode 100644
index 0000000000..80ce33ff7a
--- /dev/null
+++ b/compiler/stgSyn/StgFVs.hs
@@ -0,0 +1,125 @@
+-- | Free variable analysis on STG terms.
+module StgFVs (
+    annTopBindingsFreeVars
+  ) where
+
+import GhcPrelude
+
+import StgSyn
+import Id
+import VarSet
+import CoreSyn    ( Tickish(Breakpoint) )
+import Outputable
+import Util
+
+import Data.Maybe ( mapMaybe )
+
+newtype Env
+  = Env
+  { locals :: IdSet
+  }
+
+emptyEnv :: Env
+emptyEnv = Env emptyVarSet
+
+addLocals :: [Id] -> Env -> Env
+addLocals bndrs env
+  = env { locals = extendVarSetList (locals env) bndrs }
+
+-- | Annotates a top-level STG binding with its free variables.
+annTopBindingsFreeVars :: [StgTopBinding] -> [CgStgTopBinding]
+annTopBindingsFreeVars = map go
+  where
+    go (StgTopStringLit id bs) = StgTopStringLit id bs
+    go (StgTopLifted bind)
+      = StgTopLifted (fst (binding emptyEnv emptyVarSet bind))
+
+boundIds :: StgBinding -> [Id]
+boundIds (StgNonRec b _) = [b]
+boundIds (StgRec pairs)  = map fst pairs
+
+-- Note [Tracking local binders]
+-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+-- 'locals' contains non-toplevel, non-imported binders.
+-- We maintain the set in 'expr', 'alt' and 'rhs', which are the only
+-- places where new local binders are introduced.
+-- Why do it there rather than in 'binding'? Two reasons:
+--
+--   1. We call 'binding' from 'annTopBindingsFreeVars', which would
+--      add top-level bindings to the 'locals' set.
+--   2. In the let(-no-escape) case, we need to extend the environment
+--      prior to analysing the body, but we also need the fvs from the
+--      body to analyse the RHSs. No way to do this without some
+--      knot-tying.
+
+-- | This makes sure that only local, non-global free vars make it into the set.
+mkFreeVarSet :: Env -> [Id] -> IdSet
+mkFreeVarSet env = mkVarSet . filter (`elemVarSet` locals env)
+
+args :: Env -> [StgArg] -> IdSet
+args env = mkFreeVarSet env . mapMaybe f
+  where
+    f (StgVarArg occ) = Just occ
+    f _               = Nothing
+
+binding :: Env -> IdSet -> StgBinding -> (CgStgBinding, IdSet)
+binding env body_fv (StgNonRec bndr r) = (StgNonRec bndr r', fvs)
+  where
+    -- See Note [Tacking local binders]
+    (r', rhs_fvs) = rhs env r
+    fvs = delVarSet body_fv bndr `unionVarSet` rhs_fvs
+binding env body_fv (StgRec pairs) = (StgRec pairs', fvs)
+  where
+    -- See Note [Tacking local binders]
+    bndrs = map fst pairs
+    (rhss, rhs_fvss) = mapAndUnzip (rhs env . snd) pairs
+    pairs' = zip bndrs rhss
+    fvs = delVarSetList (unionVarSets (body_fv:rhs_fvss)) bndrs
+
+expr :: Env -> StgExpr -> (CgStgExpr, IdSet)
+expr env = go
+  where
+    go (StgApp occ as)
+      = (StgApp occ as, unionVarSet (args env as) (mkFreeVarSet env [occ]))
+    go (StgLit lit) = (StgLit lit, emptyVarSet)
+    go (StgConApp dc as tys) = (StgConApp dc as tys, args env as)
+    go (StgOpApp op as ty) = (StgOpApp op as ty, args env as)
+    go StgLam{} = pprPanic "StgFVs: StgLam" empty
+    go (StgCase scrut bndr ty alts) = (StgCase scrut' bndr ty alts', fvs)
+      where
+        (scrut', scrut_fvs) = go scrut
+        -- See Note [Tacking local binders]
+        (alts', alt_fvss) = mapAndUnzip (alt (addLocals [bndr] env)) alts
+        alt_fvs = unionVarSets alt_fvss
+        fvs = delVarSet (unionVarSet scrut_fvs alt_fvs) bndr
+    go (StgLet bind body) = go_bind StgLet bind body
+    go (StgLetNoEscape bind body) = go_bind StgLetNoEscape bind body
+    go (StgTick tick e) = (StgTick tick e', fvs')
+      where
+        (e', fvs) = go e
+        fvs' = unionVarSet (tickish tick) fvs
+        tickish (Breakpoint _ ids) = mkVarSet ids
+        tickish _                  = emptyVarSet
+
+    go_bind dc bind body = (dc bind' body', fvs)
+      where
+        -- See Note [Tacking local binders]
+        env' = addLocals (boundIds bind) env
+        (body', body_fvs) = expr env' body
+        (bind', fvs) = binding env' body_fvs bind
+
+rhs :: Env -> StgRhs -> (CgStgRhs, IdSet)
+rhs env (StgRhsClosure _ ccs uf bndrs body)
+  = (StgRhsClosure fvs ccs uf bndrs body', fvs)
+  where
+    -- See Note [Tacking local binders]
+    (body', body_fvs) = expr (addLocals bndrs env) body
+    fvs = delVarSetList body_fvs bndrs
+rhs env (StgRhsCon ccs dc as) = (StgRhsCon ccs dc as, args env as)
+
+alt :: Env -> StgAlt -> (CgStgAlt, IdSet)
+alt env (con, bndrs, e) = ((con, bndrs, e'), fvs)
+  where
+    -- See Note [Tacking local binders]
+    (e', rhs_fvs) = expr (addLocals bndrs env) e
+    fvs = delVarSetList rhs_fvs bndrs
diff --git a/compiler/stgSyn/StgSyn.hs b/compiler/stgSyn/StgSyn.hs
index 7d347f4865..145c001046 100644
--- a/compiler/stgSyn/StgSyn.hs
+++ b/compiler/stgSyn/StgSyn.hs
@@ -10,19 +10,29 @@ generation.
 -}
 
 {-# LANGUAGE CPP #-}
+{-# LANGUAGE DataKinds #-}
+{-# LANGUAGE DeriveDataTypeable #-}
+{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
+{-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE UndecidableInstances #-}
 
 module StgSyn (
-        GenStgArg(..),
+        StgArg(..),
 
         GenStgTopBinding(..), GenStgBinding(..), GenStgExpr(..), GenStgRhs(..),
         GenStgAlt, AltType(..),
 
+        StgPass(..), XRhsClosure, NoExtSilent, noExtSilent,
+
         UpdateFlag(..), isUpdatable,
 
-        -- a set of synonyms for the most common (only :-) parameterisation
-        StgArg,
+        -- a set of synonyms for the vanilla parameterisation
         StgTopBinding, StgBinding, StgExpr, StgRhs, StgAlt,
 
+        -- a set of synonyms for the code gen parameterisation
+        CgStgTopBinding, CgStgBinding, CgStgExpr, CgStgRhs, CgStgAlt,
+
         -- a set of synonyms to distinguish in- and out variants
         InStgArg,  InStgTopBinding,  InStgBinding,  InStgExpr,  InStgRhs,  InStgAlt,
         OutStgArg, OutStgTopBinding, OutStgBinding, OutStgExpr, OutStgRhs, OutStgAlt,
@@ -47,6 +57,7 @@ import GhcPrelude
 import CoreSyn     ( AltCon, Tickish )
 import CostCentre  ( CostCentreStack )
 import Data.ByteString ( ByteString )
+import Data.Data   ( Data )
 import Data.List   ( intersperse )
 import DataCon
 import DynFlags
@@ -54,6 +65,7 @@ import FastString
 import ForeignCall ( ForeignCall )
 import Id
 import IdInfo      ( mayHaveCafRefs )
+import VarSet
 import Literal     ( Literal, literalType )
 import Module      ( Module )
 import Outputable
@@ -83,25 +95,25 @@ with respect to binder and occurrence information (just as in
 -}
 
 -- | A top-level binding.
-data GenStgTopBinding bndr occ
+data GenStgTopBinding pass
 -- See Note [CoreSyn top-level string literals]
-  = StgTopLifted (GenStgBinding bndr occ)
-  | StgTopStringLit bndr ByteString
+  = StgTopLifted (GenStgBinding pass)
+  | StgTopStringLit Id ByteString
 
-data GenStgBinding bndr occ
-  = StgNonRec bndr (GenStgRhs bndr occ)
-  | StgRec    [(bndr, GenStgRhs bndr occ)]
+data GenStgBinding pass
+  = StgNonRec Id (GenStgRhs pass)
+  | StgRec    [(Id, GenStgRhs pass)]
 
 {-
 ************************************************************************
 *                                                                      *
-\subsection{@GenStgArg@}
+\subsection{@StgArg@}
 *                                                                      *
 ************************************************************************
 -}
 
-data GenStgArg occ
-  = StgVarArg  occ
+data StgArg
+  = StgVarArg  Id
   | StgLitArg  Literal
 
 -- | Does this constructor application refer to
@@ -147,7 +159,7 @@ stgArgType (StgLitArg lit) = literalType lit
 
 
 -- | Strip ticks of a given type from an STG expression
-stripStgTicksTop :: (Tickish Id -> Bool) -> StgExpr -> ([Tickish Id], StgExpr)
+stripStgTicksTop :: (Tickish Id -> Bool) -> GenStgExpr p -> ([Tickish Id], GenStgExpr p)
 stripStgTicksTop p = go []
    where go ts (StgTick t e) | p t = go (t:ts) e
          go ts other               = (reverse ts, other)
@@ -190,10 +202,10 @@ There is no constructor for a lone variable; it would appear as
 @StgApp var []@.
 -}
 
-data GenStgExpr bndr occ
+data GenStgExpr pass
   = StgApp
-        occ             -- function
-        [GenStgArg occ] -- arguments; may be empty
+        Id       -- function
+        [StgArg] -- arguments; may be empty
 
 {-
 ************************************************************************
@@ -211,14 +223,14 @@ primitives, and literals.
         -- StgConApp is vital for returning unboxed tuples or sums
         -- which can't be let-bound first
   | StgConApp   DataCon
-                [GenStgArg occ] -- Saturated
-                [Type]          -- See Note [Types in StgConApp] in UnariseStg
+                [StgArg] -- Saturated
+                [Type]   -- See Note [Types in StgConApp] in UnariseStg
 
-  | StgOpApp    StgOp           -- Primitive op or foreign call
-                [GenStgArg occ] -- Saturated.
-                Type            -- Result type
-                                -- We need to know this so that we can
-                                -- assign result registers
+  | StgOpApp    StgOp    -- Primitive op or foreign call
+                [StgArg] -- Saturated.
+                Type     -- Result type
+                         -- We need to know this so that we can
+                         -- assign result registers
 
 {-
 ************************************************************************
@@ -229,10 +241,11 @@ primitives, and literals.
 
 StgLam is used *only* during CoreToStg's work. Before CoreToStg has
 finished it encodes (\x -> e) as (let f = \x -> e in f)
+TODO: Encode this via an extension to GenStgExpr à la TTG.
 -}
 
   | StgLam
-        (NonEmpty bndr)
+        (NonEmpty Id)
         StgExpr    -- Body of lambda
 
 {-
@@ -246,14 +259,14 @@ This has the same boxed/unboxed business as Core case expressions.
 -}
 
   | StgCase
-        (GenStgExpr bndr occ)
+        (GenStgExpr pass)
                     -- the thing to examine
 
-        bndr        -- binds the result of evaluating the scrutinee
+        Id          -- binds the result of evaluating the scrutinee
 
         AltType
 
-        [GenStgAlt bndr occ]
+        [GenStgAlt pass]
                     -- The DEFAULT case is always *first*
                     -- if it is there at all
 
@@ -352,12 +365,12 @@ And so the code for let(rec)-things:
 -}
 
   | StgLet
-        (GenStgBinding bndr occ)    -- right hand sides (see below)
-        (GenStgExpr bndr occ)       -- body
+        (GenStgBinding pass)    -- right hand sides (see below)
+        (GenStgExpr pass)       -- body
 
   | StgLetNoEscape
-        (GenStgBinding bndr occ)    -- right hand sides (see below)
-        (GenStgExpr bndr occ)       -- body
+        (GenStgBinding pass)    -- right hand sides (see below)
+        (GenStgExpr pass)       -- body
 
 {-
 %************************************************************************
@@ -370,8 +383,8 @@ Finally for @hpc@ expressions we introduce a new STG construct.
 -}
 
   | StgTick
-    (Tickish bndr)
-    (GenStgExpr bndr occ)       -- sub expression
+    (Tickish Id)
+    (GenStgExpr pass)       -- sub expression
 
 -- END of GenStgExpr
 
@@ -386,15 +399,15 @@ Here's the rest of the interesting stuff for @StgLet@s; the first
 flavour is for closures:
 -}
 
-data GenStgRhs bndr occ
+data GenStgRhs pass
   = StgRhsClosure
-        CostCentreStack         -- CCS to be attached (default is CurrentCCS)
-        [occ]                   -- non-global free vars; a list, rather than
-                                -- a set, because order is important
-        !UpdateFlag             -- ReEntrant | Updatable | SingleEntry
-        [bndr]                  -- arguments; if empty, then not a function;
-                                -- as above, order is important.
-        (GenStgExpr bndr occ)   -- body
+        (XRhsClosure pass) -- ^ Extension point for non-global free var
+                           --   list just before 'CodeGen'.
+        CostCentreStack    -- ^ CCS to be attached (default is CurrentCCS)
+        !UpdateFlag        -- ^ 'ReEntrant' | 'Updatable' | 'SingleEntry'
+        [Id]               -- ^ arguments; if empty, then not a function;
+                           --   as above, order is important.
+        (GenStgExpr pass)  -- ^ body
 
 {-
 An example may be in order.  Consider:
@@ -413,14 +426,38 @@ The second flavour of right-hand-side is for constructors (simple but important)
 -}
 
   | StgRhsCon
-        CostCentreStack  -- CCS to be attached (default is CurrentCCS).
-                         -- Top-level (static) ones will end up with
-                         -- DontCareCCS, because we don't count static
-                         -- data in heap profiles, and we don't set CCCS
-                         -- from static closure.
-        DataCon          -- Constructor. Never an unboxed tuple or sum, as those
-                         -- are not allocated.
-        [GenStgArg occ]  -- Args
+        CostCentreStack -- CCS to be attached (default is CurrentCCS).
+                        -- Top-level (static) ones will end up with
+                        -- DontCareCCS, because we don't count static
+                        -- data in heap profiles, and we don't set CCCS
+                        -- from static closure.
+        DataCon         -- Constructor. Never an unboxed tuple or sum, as those
+                        -- are not allocated.
+        [StgArg]        -- Args
+
+-- | Used as a data type index for the stgSyn AST
+data StgPass
+  = CodeGen
+  | Vanilla
+
+-- | Like 'HsExpression.NoExt', but with an 'Outputable' instance that returns
+-- 'empty'.
+data NoExtSilent = NoExtSilent
+  deriving (Data, Eq, Ord)
+
+instance Outputable NoExtSilent where
+  ppr _ = empty
+
+-- | Used when constructing a term with an unused extension point that should
+-- not appear in pretty-printed output at all.
+noExtSilent :: NoExtSilent
+noExtSilent = NoExtSilent
+-- TODO: Maybe move this to HsExtensions? I'm not sure about the implications
+-- on build time...
+
+type family XRhsClosure (pass :: StgPass) where
+  XRhsClosure 'CodeGen = IdSet -- code gen needs to track non-global free vars
+  XRhsClosure 'Vanilla = NoExtSilent
 
 stgRhsArity :: StgRhs -> Int
 stgRhsArity (StgRhsClosure _ _ _ bndrs _)
@@ -441,7 +478,7 @@ stgRhsArity (StgRhsCon _ _ _) = 0
 -- is that `TidyPgm` computed the CAF info on the `Id` but some transformations
 -- have taken place since then.
 
-topStgBindHasCafRefs :: GenStgTopBinding bndr Id -> Bool
+topStgBindHasCafRefs :: GenStgTopBinding pass -> Bool
 topStgBindHasCafRefs (StgTopLifted (StgNonRec _ rhs))
   = topRhsHasCafRefs rhs
 topStgBindHasCafRefs (StgTopLifted (StgRec binds))
@@ -449,14 +486,14 @@ topStgBindHasCafRefs (StgTopLifted (StgRec binds))
 topStgBindHasCafRefs StgTopStringLit{}
   = False
 
-topRhsHasCafRefs :: GenStgRhs bndr Id -> Bool
+topRhsHasCafRefs :: GenStgRhs pass -> Bool
 topRhsHasCafRefs (StgRhsClosure _ _ upd _ body)
   = -- See Note [CAF consistency]
     isUpdatable upd || exprHasCafRefs body
 topRhsHasCafRefs (StgRhsCon _ _ args)
   = any stgArgHasCafRefs args
 
-exprHasCafRefs :: GenStgExpr bndr Id -> Bool
+exprHasCafRefs :: GenStgExpr pass -> Bool
 exprHasCafRefs (StgApp f args)
   = stgIdHasCafRefs f || any stgArgHasCafRefs args
 exprHasCafRefs StgLit{}
@@ -476,22 +513,22 @@ exprHasCafRefs (StgLetNoEscape bind body)
 exprHasCafRefs (StgTick _ expr)
   = exprHasCafRefs expr
 
-bindHasCafRefs :: GenStgBinding bndr Id -> Bool
+bindHasCafRefs :: GenStgBinding pass -> Bool
 bindHasCafRefs (StgNonRec _ rhs)
   = rhsHasCafRefs rhs
 bindHasCafRefs (StgRec binds)
   = any rhsHasCafRefs (map snd binds)
 
-rhsHasCafRefs :: GenStgRhs bndr Id -> Bool
+rhsHasCafRefs :: GenStgRhs pass -> Bool
 rhsHasCafRefs (StgRhsClosure _ _ _ _ body)
   = exprHasCafRefs body
 rhsHasCafRefs (StgRhsCon _ _ args)
   = any stgArgHasCafRefs args
 
-altHasCafRefs :: GenStgAlt bndr Id -> Bool
+altHasCafRefs :: GenStgAlt pass -> Bool
 altHasCafRefs (_, _, rhs) = exprHasCafRefs rhs
 
-stgArgHasCafRefs :: GenStgArg Id -> Bool
+stgArgHasCafRefs :: StgArg -> Bool
 stgArgHasCafRefs (StgVarArg id)
   = stgIdHasCafRefs id
 stgArgHasCafRefs _
@@ -523,10 +560,10 @@ constructors or literals (which are guaranteed to have the Real McCoy)
 rather than from the scrutinee type.
 -}
 
-type GenStgAlt bndr occ
-  = (AltCon,            -- alts: data constructor,
-     [bndr],            -- constructor's parameters,
-     GenStgExpr bndr occ)       -- ...right-hand side.
+type GenStgAlt pass
+  = (AltCon,          -- alts: data constructor,
+     [Id],            -- constructor's parameters,
+     GenStgExpr pass) -- ...right-hand side.
 
 data AltType
   = PolyAlt             -- Polymorphic (a lifted type variable)
@@ -546,12 +583,17 @@ data AltType
 This happens to be the only one we use at the moment.
 -}
 
-type StgTopBinding = GenStgTopBinding Id Id
-type StgBinding  = GenStgBinding  Id Id
-type StgArg      = GenStgArg      Id
-type StgExpr     = GenStgExpr     Id Id
-type StgRhs      = GenStgRhs      Id Id
-type StgAlt      = GenStgAlt      Id Id
+type StgTopBinding = GenStgTopBinding 'Vanilla
+type StgBinding    = GenStgBinding    'Vanilla
+type StgExpr       = GenStgExpr       'Vanilla
+type StgRhs        = GenStgRhs        'Vanilla
+type StgAlt        = GenStgAlt        'Vanilla
+
+type CgStgTopBinding = GenStgTopBinding 'CodeGen
+type CgStgBinding    = GenStgBinding    'CodeGen
+type CgStgExpr       = GenStgExpr       'CodeGen
+type CgStgRhs        = GenStgRhs        'CodeGen
+type CgStgAlt        = GenStgAlt        'CodeGen
 
 {- Many passes apply a substitution, and it's very handy to have type
    synonyms to remind us whether or not the substitution has been applied.
@@ -634,17 +676,16 @@ Robin Popplestone asked for semi-colon separators on STG binds; here's
 hoping he likes terminators instead...  Ditto for case alternatives.
 -}
 
-pprGenStgTopBinding :: (OutputableBndr bndr, Outputable bdee, Ord bdee)
-                 => GenStgTopBinding bndr bdee -> SDoc
-
+pprGenStgTopBinding
+  :: Outputable (XRhsClosure pass) => GenStgTopBinding pass -> SDoc
 pprGenStgTopBinding (StgTopStringLit bndr str)
   = hang (hsep [pprBndr LetBind bndr, equals])
         4 (pprHsBytes str <> semi)
 pprGenStgTopBinding (StgTopLifted bind)
   = pprGenStgBinding bind
 
-pprGenStgBinding :: (OutputableBndr bndr, Outputable bdee, Ord bdee)
-                 => GenStgBinding bndr bdee -> SDoc
+pprGenStgBinding
+  :: (Outputable (XRhsClosure pass)) => GenStgBinding pass -> SDoc
 
 pprGenStgBinding (StgNonRec bndr rhs)
   = hang (hsep [pprBndr LetBind bndr, equals])
@@ -665,31 +706,30 @@ pprStgTopBindings :: [StgTopBinding] -> SDoc
 pprStgTopBindings binds
   = vcat $ intersperse blankLine (map pprGenStgTopBinding binds)
 
-instance (Outputable bdee) => Outputable (GenStgArg bdee) where
+instance Outputable StgArg where
     ppr = pprStgArg
 
-instance (OutputableBndr bndr, Outputable bdee, Ord bdee)
-                => Outputable (GenStgTopBinding bndr bdee) where
+instance (Outputable (XRhsClosure pass))
+                => Outputable (GenStgTopBinding pass) where
     ppr = pprGenStgTopBinding
 
-instance (OutputableBndr bndr, Outputable bdee, Ord bdee)
-                => Outputable (GenStgBinding bndr bdee) where
+instance (Outputable (XRhsClosure pass))
+                => Outputable (GenStgBinding pass) where
     ppr = pprGenStgBinding
 
-instance (OutputableBndr bndr, Outputable bdee, Ord bdee)
-                => Outputable (GenStgExpr bndr bdee) where
+instance (Outputable (XRhsClosure pass))
+                => Outputable (GenStgExpr pass) where
     ppr = pprStgExpr
 
-instance (OutputableBndr bndr, Outputable bdee, Ord bdee)
-                => Outputable (GenStgRhs bndr bdee) where
+instance (Outputable (XRhsClosure pass))
+                => Outputable (GenStgRhs pass) where
     ppr rhs = pprStgRhs rhs
 
-pprStgArg :: (Outputable bdee) => GenStgArg bdee -> SDoc
+pprStgArg :: StgArg -> SDoc
 pprStgArg (StgVarArg var) = ppr var
 pprStgArg (StgLitArg con) = ppr con
 
-pprStgExpr :: (OutputableBndr bndr, Outputable bdee, Ord bdee)
-           => GenStgExpr bndr bdee -> SDoc
+pprStgExpr :: (Outputable (XRhsClosure pass)) => GenStgExpr pass -> SDoc
 -- special case
 pprStgExpr (StgLit lit)     = ppr lit
 
@@ -765,8 +805,7 @@ pprStgExpr (StgCase expr bndr alt_type alts)
            nest 2 (vcat (map pprStgAlt alts)),
            char '}']
 
-pprStgAlt :: (OutputableBndr bndr, Outputable occ, Ord occ)
-          => GenStgAlt bndr occ -> SDoc
+pprStgAlt :: (Outputable (XRhsClosure pass)) => GenStgAlt pass -> SDoc
 pprStgAlt (con, params, expr)
   = hang (hsep [ppr con, sep (map (pprBndr CasePatBind) params), text "->"])
          4 (ppr expr <> semi)
@@ -782,23 +821,22 @@ instance Outputable AltType where
   ppr (AlgAlt tc)     = text "Alg"    <+> ppr tc
   ppr (PrimAlt tc)    = text "Prim"   <+> ppr tc
 
-pprStgRhs :: (OutputableBndr bndr, Outputable bdee, Ord bdee)
-          => GenStgRhs bndr bdee -> SDoc
+pprStgRhs :: (Outputable (XRhsClosure pass)) => GenStgRhs pass -> SDoc
 
 -- special case
-pprStgRhs (StgRhsClosure cc [free_var] upd_flag [{-no args-}] (StgApp func []))
+pprStgRhs (StgRhsClosure ext cc upd_flag [{-no args-}] (StgApp func []))
   = sdocWithDynFlags $ \dflags ->
     hsep [ ppr cc,
-           if not $ gopt Opt_SuppressStgFreeVars dflags
-             then brackets (ppr free_var) else empty,
+           if not $ gopt Opt_SuppressStgExts dflags
+             then ppr ext else empty,
            text " \\", ppr upd_flag, ptext (sLit " [] "), ppr func ]
 
 -- general case
-pprStgRhs (StgRhsClosure cc free_vars upd_flag args body)
+pprStgRhs (StgRhsClosure ext cc upd_flag args body)
   = sdocWithDynFlags $ \dflags ->
     hang (hsep [if gopt Opt_SccProfilingOn dflags then ppr cc else empty,
-                if not $ gopt Opt_SuppressStgFreeVars dflags
-                  then brackets (interppSP free_vars) else empty,
+                if not $ gopt Opt_SuppressStgExts dflags
+                  then ppr ext else empty,
                 char '\\' <> ppr upd_flag, brackets (interppSP args)])
          4 (ppr body)
 
diff --git a/compiler/utils/UniqDSet.hs b/compiler/utils/UniqDSet.hs
index 92d924ee37..c2ace5787f 100644
--- a/compiler/utils/UniqDSet.hs
+++ b/compiler/utils/UniqDSet.hs
@@ -33,7 +33,8 @@ module UniqDSet (
         isEmptyUniqDSet,
         lookupUniqDSet,
         uniqDSetToList,
-        partitionUniqDSet
+        partitionUniqDSet,
+        mapUniqDSet
     ) where
 
 import GhcPrelude
@@ -121,6 +122,10 @@ uniqDSetToList = eltsUDFM . getUniqDSet
 partitionUniqDSet :: (a -> Bool) -> UniqDSet a -> (UniqDSet a, UniqDSet a)
 partitionUniqDSet p = coerce . partitionUDFM p . getUniqDSet
 
+-- See Note [UniqSet invariant] in UniqSet.hs
+mapUniqDSet :: Uniquable b => (a -> b) -> UniqDSet a -> UniqDSet b
+mapUniqDSet f = mkUniqDSet . map f . uniqDSetToList
+
 -- Two 'UniqDSet's are considered equal if they contain the same
 -- uniques.
 instance Eq (UniqDSet a) where