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

3 files changed, 342 insertions, 302 deletions

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)