Module hierarchy (#13009): Stg

11 files changed, 4214 insertions, 0 deletions

diff --git a/compiler/GHC/Stg/CSE.hs b/compiler/GHC/Stg/CSE.hs
new file mode 100644
index 0000000000..66f5004b49
--- /dev/null
+++ b/compiler/GHC/Stg/CSE.hs
@@ -0,0 +1,483 @@
+{-# LANGUAGE TypeFamilies #-}
+
+{-|
+Note [CSE for Stg]
+~~~~~~~~~~~~~~~~~~
+This module implements a simple common subexpression elimination pass for STG.
+This is useful because there are expressions that we want to common up (because
+they are operationally equivalent), but that we cannot common up in Core, because
+their types differ.
+This was originally reported as #9291.
+
+There are two types of common code occurrences that we aim for, see
+note [Case 1: CSEing allocated closures] and
+note [Case 2: CSEing case binders] below.
+
+
+Note [Case 1: CSEing allocated closures]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+The first kind of CSE opportunity we aim for is generated by this Haskell code:
+
+    bar :: a -> (Either Int a, Either Bool a)
+    bar x = (Right x, Right x)
+
+which produces this Core:
+
+    bar :: forall a. a -> (Either Int a, Either Bool a)
+    bar @a x = (Right @Int @a x, Right @Bool @a x)
+
+where the two components of the tuple are different terms, and cannot be
+commoned up (easily). On the STG level we have
+
+    bar [x] = let c1 = Right [x]
+                  c2 = Right [x]
+              in (c1,c2)
+
+and now it is obvious that we can write
+
+    bar [x] = let c1 = Right [x]
+              in (c1,c1)
+
+instead.
+
+
+Note [Case 2: CSEing case binders]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+The second kind of CSE opportunity we aim for is more interesting, and
+came up in #9291 and #5344: The Haskell code
+
+    foo :: Either Int a -> Either Bool a
+    foo (Right x) = Right x
+    foo _         = Left False
+
+produces this Core
+
+    foo :: forall a. Either Int a -> Either Bool a
+    foo @a e = case e of b { Left n -> …
+                           , Right x -> Right @Bool @a x }
+
+where we cannot CSE `Right @Bool @a x` with the case binder `b` as they have
+different types. But in STG we have
+
+    foo [e] = case e of b { Left [n] -> …
+                          , Right [x] -> Right [x] }
+
+and nothing stops us from transforming that to
+
+    foo [e] = case e of b { Left [n] -> …
+                          , Right [x] -> b}
+
+
+Note [StgCse after unarisation]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Consider two unboxed sum terms:
+
+    (# 1 | #) :: (# Int | Int# #)
+    (# 1 | #) :: (# Int | Int  #)
+
+These two terms are not equal as they unarise to different unboxed
+tuples. However if we run StgCse before Unarise, it'll think the two
+terms (# 1 | #) are equal, and replace one of these with a binder to
+the other. That's bad -- #15300.
+
+Solution: do unarise first.
+
+-}
+
+module GHC.Stg.CSE (stgCse) where
+
+import GhcPrelude
+
+import DataCon
+import Id
+import GHC.Stg.Syntax
+import Outputable
+import VarEnv
+import CoreSyn (AltCon(..))
+import Data.List (mapAccumL)
+import Data.Maybe (fromMaybe)
+import CoreMap
+import NameEnv
+import Control.Monad( (>=>) )
+
+--------------
+-- The Trie --
+--------------
+
+-- A lookup trie for data constructor applications, i.e.
+-- keys of type `(DataCon, [StgArg])`, following the patterns in TrieMap.
+
+data StgArgMap a = SAM
+    { sam_var :: DVarEnv a
+    , sam_lit :: LiteralMap a
+    }
+
+instance TrieMap StgArgMap where
+    type Key StgArgMap = StgArg
+    emptyTM  = SAM { sam_var = emptyTM
+                   , sam_lit = emptyTM }
+    lookupTM (StgVarArg var) = sam_var >.> lkDFreeVar var
+    lookupTM (StgLitArg lit) = sam_lit >.> lookupTM lit
+    alterTM  (StgVarArg var) f m = m { sam_var = sam_var m |> xtDFreeVar var f }
+    alterTM  (StgLitArg lit) f m = m { sam_lit = sam_lit m |> alterTM lit f }
+    foldTM k m = foldTM k (sam_var m) . foldTM k (sam_lit m)
+    mapTM f (SAM {sam_var = varm, sam_lit = litm}) =
+        SAM { sam_var = mapTM f varm, sam_lit = mapTM f litm }
+
+newtype ConAppMap a = CAM { un_cam :: DNameEnv (ListMap StgArgMap a) }
+
+instance TrieMap ConAppMap where
+    type Key ConAppMap = (DataCon, [StgArg])
+    emptyTM  = CAM emptyTM
+    lookupTM (dataCon, args) = un_cam >.> lkDNamed dataCon >=> lookupTM args
+    alterTM  (dataCon, args) f m =
+        m { un_cam = un_cam m |> xtDNamed dataCon |>> alterTM args f }
+    foldTM k = un_cam >.> foldTM (foldTM k)
+    mapTM f  = un_cam >.> mapTM (mapTM f) >.> CAM
+
+-----------------
+-- The CSE Env --
+-----------------
+
+-- | The CSE environment. See note [CseEnv Example]
+data CseEnv = CseEnv
+    { ce_conAppMap :: ConAppMap OutId
+        -- ^ The main component of the environment is the trie that maps
+        --   data constructor applications (with their `OutId` arguments)
+        --   to an in-scope name that can be used instead.
+        --   This name is always either a let-bound variable or a case binder.
+    , ce_subst     :: IdEnv OutId
+        -- ^ This substitution is applied to the code as we traverse it.
+        --   Entries have one of two reasons:
+        --
+        --   * The input might have shadowing (see Note [Shadowing]), so we have
+        --     to rename some binders as we traverse the tree.
+        --   * If we remove `let x = Con z` because  `let y = Con z` is in scope,
+        --     we note this here as x ↦ y.
+    , ce_bndrMap     :: IdEnv OutId
+        -- ^ If we come across a case expression case x as b of … with a trivial
+        --   binder, we add b ↦ x to this.
+        --   This map is *only* used when looking something up in the ce_conAppMap.
+        --   See Note [Trivial case scrutinee]
+    , ce_in_scope  :: InScopeSet
+        -- ^ The third component is an in-scope set, to rename away any
+        --   shadowing binders
+    }
+
+{-|
+Note [CseEnv Example]
+~~~~~~~~~~~~~~~~~~~~~
+The following tables shows how the CseEnvironment changes as code is traversed,
+as well as the changes to that code.
+
+  InExpr                         OutExpr
+     conAppMap                   subst          in_scope
+  ───────────────────────────────────────────────────────────
+  -- empty                       {}             {}
+  case … as a of {Con x y ->     case … as a of {Con x y ->
+  -- Con x y ↦ a                 {}             {a,x,y}
+  let b = Con x y                (removed)
+  -- Con x y ↦ a                 b↦a            {a,x,y,b}
+  let c = Bar a                  let c = Bar a
+  -- Con x y ↦ a, Bar a ↦ c      b↦a            {a,x,y,b,c}
+  let c = some expression        let c' = some expression
+  -- Con x y ↦ a, Bar a ↦ c      b↦a, c↦c',     {a,x,y,b,c,c'}
+  let d = Bar b                  (removed)
+  -- Con x y ↦ a, Bar a ↦ c      b↦a, c↦c', d↦c {a,x,y,b,c,c',d}
+  (a, b, c d)                    (a, a, c' c)
+-}
+
+initEnv :: InScopeSet -> CseEnv
+initEnv in_scope = CseEnv
+    { ce_conAppMap = emptyTM
+    , ce_subst     = emptyVarEnv
+    , ce_bndrMap   = emptyVarEnv
+    , ce_in_scope  = in_scope
+    }
+
+envLookup :: DataCon -> [OutStgArg] -> CseEnv -> Maybe OutId
+envLookup dataCon args env = lookupTM (dataCon, args') (ce_conAppMap env)
+  where args' = map go args -- See Note [Trivial case scrutinee]
+        go (StgVarArg v  ) = StgVarArg (fromMaybe v $ lookupVarEnv (ce_bndrMap env) v)
+        go (StgLitArg lit) = StgLitArg lit
+
+addDataCon :: OutId -> DataCon -> [OutStgArg] -> CseEnv -> CseEnv
+-- do not bother with nullary data constructors, they are static anyways
+addDataCon _ _ [] env = env
+addDataCon bndr dataCon args env = env { ce_conAppMap = new_env }
+  where
+    new_env = insertTM (dataCon, args) bndr (ce_conAppMap env)
+
+forgetCse :: CseEnv -> CseEnv
+forgetCse env = env { ce_conAppMap = emptyTM }
+    -- See note [Free variables of an StgClosure]
+
+addSubst :: OutId -> OutId -> CseEnv -> CseEnv
+addSubst from to env
+    = env { ce_subst = extendVarEnv (ce_subst env) from to }
+
+addTrivCaseBndr :: OutId -> OutId -> CseEnv -> CseEnv
+addTrivCaseBndr from to env
+    = env { ce_bndrMap = extendVarEnv (ce_bndrMap env) from to }
+
+substArgs :: CseEnv -> [InStgArg] -> [OutStgArg]
+substArgs env = map (substArg env)
+
+substArg :: CseEnv -> InStgArg -> OutStgArg
+substArg env (StgVarArg from) = StgVarArg (substVar env from)
+substArg _   (StgLitArg lit)  = StgLitArg lit
+
+substVar :: CseEnv -> InId -> OutId
+substVar env id = fromMaybe id $ lookupVarEnv (ce_subst env) id
+
+-- Functions to enter binders
+
+-- This is much simpler than the equivalent code in CoreSubst:
+--  * We do not substitute type variables, and
+--  * There is nothing relevant in IdInfo at this stage
+--    that needs substitutions.
+-- Therefore, no special treatment for a recursive group is required.
+
+substBndr :: CseEnv -> InId -> (CseEnv, OutId)
+substBndr env old_id
+  = (new_env, new_id)
+  where
+    new_id = uniqAway (ce_in_scope env) old_id
+    no_change = new_id == old_id
+    env' = env { ce_in_scope = ce_in_scope env `extendInScopeSet` new_id }
+    new_env | no_change = env'
+            | otherwise = env' { ce_subst = extendVarEnv (ce_subst env) old_id new_id }
+
+substBndrs :: CseEnv -> [InVar] -> (CseEnv, [OutVar])
+substBndrs env bndrs = mapAccumL substBndr env bndrs
+
+substPairs :: CseEnv -> [(InVar, a)] -> (CseEnv, [(OutVar, a)])
+substPairs env bndrs = mapAccumL go env bndrs
+  where go env (id, x) = let (env', id') = substBndr env id
+                         in (env', (id', x))
+
+-- Main entry point
+
+stgCse :: [InStgTopBinding] -> [OutStgTopBinding]
+stgCse binds = snd $ mapAccumL stgCseTopLvl emptyInScopeSet binds
+
+-- Top level bindings.
+--
+-- We do not CSE these, as top-level closures are allocated statically anyways.
+-- Also, they might be exported.
+-- But we still have to collect the set of in-scope variables, otherwise
+-- uniqAway might shadow a top-level closure.
+
+stgCseTopLvl :: InScopeSet -> InStgTopBinding -> (InScopeSet, OutStgTopBinding)
+stgCseTopLvl in_scope t@(StgTopStringLit _ _) = (in_scope, t)
+stgCseTopLvl in_scope (StgTopLifted (StgNonRec bndr rhs))
+    = (in_scope'
+      , StgTopLifted (StgNonRec bndr (stgCseTopLvlRhs in_scope rhs)))
+  where in_scope' = in_scope `extendInScopeSet` bndr
+
+stgCseTopLvl in_scope (StgTopLifted (StgRec eqs))
+    = ( in_scope'
+      , StgTopLifted (StgRec [ (bndr, stgCseTopLvlRhs in_scope' rhs) | (bndr, rhs) <- eqs ]))
+  where in_scope' = in_scope `extendInScopeSetList` [ bndr | (bndr, _) <- eqs ]
+
+stgCseTopLvlRhs :: InScopeSet -> InStgRhs -> OutStgRhs
+stgCseTopLvlRhs in_scope (StgRhsClosure ext ccs upd args body)
+    = let body' = stgCseExpr (initEnv in_scope) body
+      in  StgRhsClosure ext ccs upd args body'
+stgCseTopLvlRhs _ (StgRhsCon ccs dataCon args)
+    = StgRhsCon ccs dataCon args
+
+------------------------------
+-- The actual AST traversal --
+------------------------------
+
+-- Trivial cases
+stgCseExpr :: CseEnv -> InStgExpr -> OutStgExpr
+stgCseExpr env (StgApp fun args)
+    = StgApp fun' args'
+  where fun' = substVar env fun
+        args' = substArgs env args
+stgCseExpr _ (StgLit lit)
+    = StgLit lit
+stgCseExpr env (StgOpApp op args tys)
+    = StgOpApp op args' tys
+  where args' = substArgs env args
+stgCseExpr _ (StgLam _ _)
+    = pprPanic "stgCseExp" (text "StgLam")
+stgCseExpr env (StgTick tick body)
+    = let body' = stgCseExpr env body
+      in StgTick tick body'
+stgCseExpr env (StgCase scrut bndr ty alts)
+    = mkStgCase scrut' bndr' ty alts'
+  where
+    scrut' = stgCseExpr env scrut
+    (env1, bndr') = substBndr env bndr
+    env2 | StgApp trivial_scrut [] <- scrut' = addTrivCaseBndr bndr trivial_scrut env1
+                 -- See Note [Trivial case scrutinee]
+         | otherwise                         = env1
+    alts' = map (stgCseAlt env2 ty bndr') alts
+
+
+-- A constructor application.
+-- To be removed by a variable use when found in the CSE environment
+stgCseExpr env (StgConApp dataCon args tys)
+    | Just bndr' <- envLookup dataCon args' env
+    = StgApp bndr' []
+    | otherwise
+    = StgConApp dataCon args' tys
+  where args' = substArgs env args
+
+-- Let bindings
+-- The binding might be removed due to CSE (we do not want trivial bindings on
+-- the STG level), so use the smart constructor `mkStgLet` to remove the binding
+-- if empty.
+stgCseExpr env (StgLet ext binds body)
+    = let (binds', env') = stgCseBind env binds
+          body' = stgCseExpr env' body
+      in mkStgLet (StgLet ext) binds' body'
+stgCseExpr env (StgLetNoEscape ext binds body)
+    = let (binds', env') = stgCseBind env binds
+          body' = stgCseExpr env' body
+      in mkStgLet (StgLetNoEscape ext) binds' body'
+
+-- Case alternatives
+-- Extend the CSE environment
+stgCseAlt :: CseEnv -> AltType -> OutId -> InStgAlt -> OutStgAlt
+stgCseAlt env ty case_bndr (DataAlt dataCon, args, rhs)
+    = let (env1, args') = substBndrs env args
+          env2
+            -- To avoid dealing with unboxed sums StgCse runs after unarise and
+            -- should maintain invariants listed in Note [Post-unarisation
+            -- invariants]. One of the invariants is that some binders are not
+            -- used (unboxed tuple case binders) which is what we check with
+            -- `stgCaseBndrInScope` here. If the case binder is not in scope we
+            -- don't add it to the CSE env. See also #15300.
+            | stgCaseBndrInScope ty True -- CSE runs after unarise
+            = addDataCon case_bndr dataCon (map StgVarArg args') env1
+            | otherwise
+            = env1
+            -- see note [Case 2: CSEing case binders]
+          rhs' = stgCseExpr env2 rhs
+      in (DataAlt dataCon, args', rhs')
+stgCseAlt env _ _ (altCon, args, rhs)
+    = let (env1, args') = substBndrs env args
+          rhs' = stgCseExpr env1 rhs
+      in (altCon, args', rhs')
+
+-- Bindings
+stgCseBind :: CseEnv -> InStgBinding -> (Maybe OutStgBinding, CseEnv)
+stgCseBind env (StgNonRec b e)
+    = let (env1, b') = substBndr env b
+      in case stgCseRhs env1 b' e of
+        (Nothing,      env2) -> (Nothing,                env2)
+        (Just (b2,e'), env2) -> (Just (StgNonRec b2 e'), env2)
+stgCseBind env (StgRec pairs)
+    = let (env1, pairs1) = substPairs env pairs
+      in case stgCsePairs env1 pairs1 of
+        ([],     env2) -> (Nothing, env2)
+        (pairs2, env2) -> (Just (StgRec pairs2), env2)
+
+stgCsePairs :: CseEnv -> [(OutId, InStgRhs)] -> ([(OutId, OutStgRhs)], CseEnv)
+stgCsePairs env [] = ([], env)
+stgCsePairs env0 ((b,e):pairs)
+  = let (pairMB, env1) = stgCseRhs env0 b e
+        (pairs', env2) = stgCsePairs env1 pairs
+    in (pairMB `mbCons` pairs', env2)
+  where
+    mbCons = maybe id (:)
+
+-- The RHS of a binding.
+-- If it is a constructor application, either short-cut it or extend the environment
+stgCseRhs :: CseEnv -> OutId -> InStgRhs -> (Maybe (OutId, OutStgRhs), CseEnv)
+stgCseRhs env bndr (StgRhsCon ccs dataCon args)
+    | Just other_bndr <- envLookup dataCon args' env
+    = let env' = addSubst bndr other_bndr env
+      in (Nothing, env')
+    | otherwise
+    = let env' = addDataCon bndr dataCon args' env
+            -- see note [Case 1: CSEing allocated closures]
+          pair = (bndr, StgRhsCon ccs dataCon args')
+      in (Just pair, env')
+  where args' = substArgs env args
+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 ext ccs upd args' body'), env)
+
+
+mkStgCase :: StgExpr -> OutId -> AltType -> [StgAlt] -> StgExpr
+mkStgCase scrut bndr ty alts | all isBndr alts = scrut
+                             | otherwise       = StgCase scrut bndr ty alts
+
+  where
+    -- see Note [All alternatives are the binder]
+    isBndr (_, _, StgApp f []) = f == bndr
+    isBndr _                   = False
+
+
+-- Utilities
+
+-- | This function short-cuts let-bindings that are now obsolete
+mkStgLet :: (a -> b -> b) -> Maybe a -> b -> b
+mkStgLet _      Nothing      body = body
+mkStgLet stgLet (Just binds) body = stgLet binds body
+
+
+{-
+Note [All alternatives are the binder]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+
+When all alternatives simply refer to the case binder, then we do not have
+to bother with the case expression at all (#13588). CoreSTG does this as well,
+but sometimes, types get into the way:
+
+    newtype T = MkT Int
+    f :: (Int, Int) -> (T, Int)
+    f (x, y) = (MkT x, y)
+
+Core cannot just turn this into
+
+    f p = p
+
+as this would not be well-typed. But to STG, where MkT is no longer in the way,
+we can.
+
+Note [Trivial case scrutinee]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+We want to be able to handle nested reconstruction of constructors as in
+
+    nested :: Either Int (Either Int a) -> Either Bool (Either Bool a)
+    nested (Right (Right v)) = Right (Right v)
+    nested _ = Left True
+
+So if we come across
+
+    case x of r1
+      Right a -> case a of r2
+              Right b -> let v = Right b
+                         in Right v
+
+we first replace v with r2. Next we want to replace Right r2 with r1. But the
+ce_conAppMap contains Right a!
+
+Therefore, we add r1 ↦ x to ce_bndrMap when analysing the outer case, and use
+this substitution before looking Right r2 up in ce_conAppMap, and everything
+works out.
+
+Note [Free variables of an StgClosure]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+StgClosures (function and thunks) have an explicit list of free variables:
+
+foo [x] =
+    let not_a_free_var = Left [x]
+    let a_free_var = Right [x]
+    let closure = \[x a_free_var] -> \[y] -> bar y (Left [x]) a_free_var
+    in closure
+
+If we were to CSE `Left [x]` in the body of `closure` with `not_a_free_var`,
+then the list of free variables would be wrong, so for now, we do not CSE
+across such a closure, simply because I (Joachim) was not sure about possible
+knock-on effects. If deemed safe and worth the slight code complication of
+re-calculating this list during or after this pass, this can surely be done.
+-}
diff --git a/compiler/GHC/Stg/FVs.hs b/compiler/GHC/Stg/FVs.hs
new file mode 100644
index 0000000000..65f80d97af
--- /dev/null
+++ b/compiler/GHC/Stg/FVs.hs
@@ -0,0 +1,130 @@
+-- | Free variable analysis on STG terms.
+module GHC.Stg.FVs (
+    annTopBindingsFreeVars,
+    annBindingFreeVars
+  ) where
+
+import GhcPrelude
+
+import GHC.Stg.Syntax
+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 group with its free variables.
+annTopBindingsFreeVars :: [StgTopBinding] -> [CgStgTopBinding]
+annTopBindingsFreeVars = map go
+  where
+    go (StgTopStringLit id bs) = StgTopStringLit id bs
+    go (StgTopLifted bind)
+      = StgTopLifted (annBindingFreeVars bind)
+
+-- | Annotates an STG binding with its free variables.
+annBindingFreeVars :: StgBinding -> CgStgBinding
+annBindingFreeVars = fst . binding emptyEnv emptyDVarSet
+
+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] -> DIdSet
+mkFreeVarSet env = mkDVarSet . filter (`elemVarSet` locals env)
+
+args :: Env -> [StgArg] -> DIdSet
+args env = mkFreeVarSet env . mapMaybe f
+  where
+    f (StgVarArg occ) = Just occ
+    f _               = Nothing
+
+binding :: Env -> DIdSet -> StgBinding -> (CgStgBinding, DIdSet)
+binding env body_fv (StgNonRec bndr r) = (StgNonRec bndr r', fvs)
+  where
+    -- See Note [Tracking local binders]
+    (r', rhs_fvs) = rhs env r
+    fvs = delDVarSet body_fv bndr `unionDVarSet` rhs_fvs
+binding env body_fv (StgRec pairs) = (StgRec pairs', fvs)
+  where
+    -- See Note [Tracking local binders]
+    bndrs = map fst pairs
+    (rhss, rhs_fvss) = mapAndUnzip (rhs env . snd) pairs
+    pairs' = zip bndrs rhss
+    fvs = delDVarSetList (unionDVarSets (body_fv:rhs_fvss)) bndrs
+
+expr :: Env -> StgExpr -> (CgStgExpr, DIdSet)
+expr env = go
+  where
+    go (StgApp occ as)
+      = (StgApp occ as, unionDVarSet (args env as) (mkFreeVarSet env [occ]))
+    go (StgLit lit) = (StgLit lit, emptyDVarSet)
+    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 [Tracking local binders]
+        (alts', alt_fvss) = mapAndUnzip (alt (addLocals [bndr] env)) alts
+        alt_fvs = unionDVarSets alt_fvss
+        fvs = delDVarSet (unionDVarSet scrut_fvs alt_fvs) bndr
+    go (StgLet ext bind body) = go_bind (StgLet ext) bind body
+    go (StgLetNoEscape ext bind body) = go_bind (StgLetNoEscape ext) bind body
+    go (StgTick tick e) = (StgTick tick e', fvs')
+      where
+        (e', fvs) = go e
+        fvs' = unionDVarSet (tickish tick) fvs
+        tickish (Breakpoint _ ids) = mkDVarSet ids
+        tickish _                  = emptyDVarSet
+
+    go_bind dc bind body = (dc bind' body', fvs)
+      where
+        -- See Note [Tracking local binders]
+        env' = addLocals (boundIds bind) env
+        (body', body_fvs) = expr env' body
+        (bind', fvs) = binding env' body_fvs bind
+
+rhs :: Env -> StgRhs -> (CgStgRhs, DIdSet)
+rhs env (StgRhsClosure _ ccs uf bndrs body)
+  = (StgRhsClosure fvs ccs uf bndrs body', fvs)
+  where
+    -- See Note [Tracking local binders]
+    (body', body_fvs) = expr (addLocals bndrs env) body
+    fvs = delDVarSetList body_fvs bndrs
+rhs env (StgRhsCon ccs dc as) = (StgRhsCon ccs dc as, args env as)
+
+alt :: Env -> StgAlt -> (CgStgAlt, DIdSet)
+alt env (con, bndrs, e) = ((con, bndrs, e'), fvs)
+  where
+    -- See Note [Tracking local binders]
+    (e', rhs_fvs) = expr (addLocals bndrs env) e
+    fvs = delDVarSetList rhs_fvs bndrs
diff --git a/compiler/GHC/Stg/Lift.hs b/compiler/GHC/Stg/Lift.hs
new file mode 100644
index 0000000000..cafcafbd42
--- /dev/null
+++ b/compiler/GHC/Stg/Lift.hs
@@ -0,0 +1,258 @@
+{-# LANGUAGE CPP #-}
+
+-- | Implements a selective lambda lifter, running late in the optimisation
+-- pipeline.
+--
+-- If you are interested in the cost model that is employed to decide whether
+-- to lift a binding or not, look at "GHC.Stg.Lift.Analysis".
+-- "GHC.Stg.Lift.Monad" contains the transformation monad that hides away some
+-- plumbing of the transformation.
+module GHC.Stg.Lift
+   (
+    -- * Late lambda lifting in STG
+    -- $note
+   stgLiftLams
+   )
+where
+
+#include "HsVersions.h"
+
+import GhcPrelude
+
+import BasicTypes
+import DynFlags
+import Id
+import IdInfo
+import GHC.Stg.FVs ( annBindingFreeVars )
+import GHC.Stg.Lift.Analysis
+import GHC.Stg.Lift.Monad
+import GHC.Stg.Syntax
+import Outputable
+import UniqSupply
+import Util
+import VarSet
+import Control.Monad ( when )
+import Data.Maybe ( isNothing )
+
+-- Note [Late lambda lifting in STG]
+-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+-- $note
+-- See also the <https://gitlab.haskell.org/ghc/ghc/wikis/late-lam-lift wiki page>
+-- and #9476.
+--
+-- The basic idea behind lambda lifting is to turn locally defined functions
+-- into top-level functions. Free variables are then passed as additional
+-- arguments at *call sites* instead of having a closure allocated for them at
+-- *definition site*. Example:
+--
+-- @
+--    let x = ...; y = ... in
+--    let f = {x y} \a -> a + x + y in
+--    let g = {f x} \b -> f b + x in
+--    g 5
+-- @
+--
+-- Lambda lifting @f@ would
+--
+--   1. Turn @f@'s free variables into formal parameters
+--   2. Update @f@'s call site within @g@ to @f x y b@
+--   3. Update @g@'s closure: Add @y@ as an additional free variable, while
+--      removing @f@, because @f@ no longer allocates and can be floated to
+--      top-level.
+--   4. Actually float the binding of @f@ to top-level, eliminating the @let@
+--      in the process.
+--
+-- This results in the following program (with free var annotations):
+--
+-- @
+--    f x y a = a + x + y;
+--    let x = ...; y = ... in
+--    let g = {x y} \b -> f x y b + x in
+--    g 5
+-- @
+--
+-- This optimisation is all about lifting only when it is beneficial to do so.
+-- The above seems like a worthwhile lift, judging from heap allocation:
+-- We eliminate @f@'s closure, saving to allocate a closure with 2 words, while
+-- not changing the size of @g@'s closure.
+--
+-- You can probably sense that there's some kind of cost model at play here.
+-- And you are right! But we also employ a couple of other heuristics for the
+-- lifting decision which are outlined in "GHC.Stg.Lift.Analysis#when".
+--
+-- The transformation is done in "GHC.Stg.Lift", which calls out to
+-- 'GHC.Stg.Lift.Analysis.goodToLift' for its lifting decision.  It relies on
+-- "GHC.Stg.Lift.Monad", which abstracts some subtle STG invariants into a
+-- monadic substrate.
+--
+-- Suffice to say: We trade heap allocation for stack allocation.
+-- The additional arguments have to passed on the stack (or in registers,
+-- depending on architecture) every time we call the function to save a single
+-- heap allocation when entering the let binding. Nofib suggests a mean
+-- improvement of about 1% for this pass, so it seems like a worthwhile thing to
+-- do. Compile-times went up by 0.6%, so all in all a very modest change.
+--
+-- For a concrete example, look at @spectral/atom@. There's a call to 'zipWith'
+-- that is ultimately compiled to something like this
+-- (module desugaring/lowering to actual STG):
+--
+-- @
+--    propagate dt = ...;
+--    runExperiment ... =
+--      let xs = ... in
+--      let ys = ... in
+--      let go = {dt go} \xs ys -> case (xs, ys) of
+--            ([], []) -> []
+--            (x:xs', y:ys') -> propagate dt x y : go xs' ys'
+--      in go xs ys
+-- @
+--
+-- This will lambda lift @go@ to top-level, speeding up the resulting program
+-- by roughly one percent:
+--
+-- @
+--    propagate dt = ...;
+--    go dt xs ys = case (xs, ys) of
+--      ([], []) -> []
+--      (x:xs', y:ys') -> propagate dt x y : go dt xs' ys'
+--    runExperiment ... =
+--      let xs = ... in
+--      let ys = ... in
+--      in go dt xs ys
+-- @
+
+
+
+-- | Lambda lifts bindings to top-level deemed worth lifting (see 'goodToLift').
+--
+-- (Mostly) textbook instance of the lambda lifting transformation, selecting
+-- which bindings to lambda lift by consulting 'goodToLift'.
+stgLiftLams :: DynFlags -> UniqSupply -> [InStgTopBinding] -> [OutStgTopBinding]
+stgLiftLams dflags us = runLiftM dflags us . foldr liftTopLvl (pure ())
+
+liftTopLvl :: InStgTopBinding -> LiftM () -> LiftM ()
+liftTopLvl (StgTopStringLit bndr lit) rest = withSubstBndr bndr $ \bndr' -> do
+  addTopStringLit bndr' lit
+  rest
+liftTopLvl (StgTopLifted bind) rest = do
+  let is_rec = isRec $ fst $ decomposeStgBinding bind
+  when is_rec startBindingGroup
+  let bind_w_fvs = annBindingFreeVars bind
+  withLiftedBind TopLevel (tagSkeletonTopBind bind_w_fvs) NilSk $ \mb_bind' -> do
+    -- We signal lifting of a binding through returning Nothing.
+    -- Should never happen for a top-level binding, though, since we are already
+    -- at top-level.
+    case mb_bind' of
+      Nothing -> pprPanic "StgLiftLams" (text "Lifted top-level binding")
+      Just bind' -> addLiftedBinding bind'
+    when is_rec endBindingGroup
+    rest
+
+withLiftedBind
+  :: TopLevelFlag
+  -> LlStgBinding
+  -> Skeleton
+  -> (Maybe OutStgBinding -> LiftM a)
+  -> LiftM a
+withLiftedBind top_lvl bind scope k
+  | isTopLevel top_lvl
+  = withCaffyness (is_caffy pairs) go
+  | otherwise
+  = go
+  where
+    (rec, pairs) = decomposeStgBinding bind
+    is_caffy = any (mayHaveCafRefs . idCafInfo . binderInfoBndr . fst)
+    go = withLiftedBindPairs top_lvl rec pairs scope (k . fmap (mkStgBinding rec))
+
+withLiftedBindPairs
+  :: TopLevelFlag
+  -> RecFlag
+  -> [(BinderInfo, LlStgRhs)]
+  -> Skeleton
+  -> (Maybe [(Id, OutStgRhs)] -> LiftM a)
+  -> LiftM a
+withLiftedBindPairs top rec pairs scope k = do
+  let (infos, rhss) = unzip pairs
+  let bndrs = map binderInfoBndr infos
+  expander <- liftedIdsExpander
+  dflags <- getDynFlags
+  case goodToLift dflags top rec expander pairs scope of
+    -- @abs_ids@ is the set of all variables that need to become parameters.
+    Just abs_ids -> withLiftedBndrs abs_ids bndrs $ \bndrs' -> do
+      -- Within this block, all binders in @bndrs@ will be noted as lifted, so
+      -- that the return value of @liftedIdsExpander@ in this context will also
+      -- expand the bindings in @bndrs@ to their free variables.
+      -- Now we can recurse into the RHSs and see if we can lift any further
+      -- bindings. We pass the set of expanded free variables (thus OutIds) on
+      -- to @liftRhs@ so that it can add them as parameter binders.
+      when (isRec rec) startBindingGroup
+      rhss' <- traverse (liftRhs (Just abs_ids)) rhss
+      let pairs' = zip bndrs' rhss'
+      addLiftedBinding (mkStgBinding rec pairs')
+      when (isRec rec) endBindingGroup
+      k Nothing
+    Nothing -> withSubstBndrs bndrs $ \bndrs' -> do
+      -- Don't lift the current binding, but possibly some bindings in their
+      -- RHSs.
+      rhss' <- traverse (liftRhs Nothing) rhss
+      let pairs' = zip bndrs' rhss'
+      k (Just pairs')
+
+liftRhs
+  :: Maybe (DIdSet)
+  -- ^ @Just former_fvs@ <=> this RHS was lifted and we have to add @former_fvs@
+  -- as lambda binders, discarding all free vars.
+  -> LlStgRhs
+  -> LiftM OutStgRhs
+liftRhs mb_former_fvs rhs@(StgRhsCon ccs con args)
+  = ASSERT2(isNothing mb_former_fvs, text "Should never lift a constructor" $$ ppr rhs)
+    StgRhsCon ccs con <$> traverse liftArgs args
+liftRhs Nothing (StgRhsClosure _ ccs upd infos body) = do
+  -- This RHS wasn't lifted.
+  withSubstBndrs (map binderInfoBndr infos) $ \bndrs' ->
+    StgRhsClosure noExtFieldSilent ccs upd bndrs' <$> liftExpr body
+liftRhs (Just former_fvs) (StgRhsClosure _ ccs upd infos body) = do
+  -- This RHS was lifted. Insert extra binders for @former_fvs@.
+  withSubstBndrs (map binderInfoBndr infos) $ \bndrs' -> do
+    let bndrs'' = dVarSetElems former_fvs ++ bndrs'
+    StgRhsClosure noExtFieldSilent ccs upd bndrs'' <$> liftExpr body
+
+liftArgs :: InStgArg -> LiftM OutStgArg
+liftArgs a@(StgLitArg _) = pure a
+liftArgs (StgVarArg occ) = do
+  ASSERTM2( not <$> isLifted occ, text "StgArgs should never be lifted" $$ ppr occ )
+  StgVarArg <$> substOcc occ
+
+liftExpr :: LlStgExpr -> LiftM OutStgExpr
+liftExpr (StgLit lit) = pure (StgLit lit)
+liftExpr (StgTick t e) = StgTick t <$> liftExpr e
+liftExpr (StgApp f args) = do
+  f' <- substOcc f
+  args' <- traverse liftArgs args
+  fvs' <- formerFreeVars f
+  let top_lvl_args = map StgVarArg fvs' ++ args'
+  pure (StgApp f' top_lvl_args)
+liftExpr (StgConApp con args tys) = StgConApp con <$> traverse liftArgs args <*> pure tys
+liftExpr (StgOpApp op args ty) = StgOpApp op <$> traverse liftArgs args <*> pure ty
+liftExpr (StgLam _ _) = pprPanic "stgLiftLams" (text "StgLam")
+liftExpr (StgCase scrut info ty alts) = do
+  scrut' <- liftExpr scrut
+  withSubstBndr (binderInfoBndr info) $ \bndr' -> do
+    alts' <- traverse liftAlt alts
+    pure (StgCase scrut' bndr' ty alts')
+liftExpr (StgLet scope bind body)
+  = withLiftedBind NotTopLevel bind scope $ \mb_bind' -> do
+      body' <- liftExpr body
+      case mb_bind' of
+        Nothing -> pure body' -- withLiftedBindPairs decided to lift it and already added floats
+        Just bind' -> pure (StgLet noExtFieldSilent bind' body')
+liftExpr (StgLetNoEscape scope bind body)
+  = withLiftedBind NotTopLevel bind scope $ \mb_bind' -> do
+      body' <- liftExpr body
+      case mb_bind' of
+        Nothing -> pprPanic "stgLiftLams" (text "Should never decide to lift LNEs")
+        Just bind' -> pure (StgLetNoEscape noExtFieldSilent bind' body')
+
+liftAlt :: LlStgAlt -> LiftM OutStgAlt
+liftAlt (con, infos, rhs) = withSubstBndrs (map binderInfoBndr infos) $ \bndrs' ->
+  (,,) con bndrs' <$> liftExpr rhs
diff --git a/compiler/GHC/Stg/Lift/Analysis.hs b/compiler/GHC/Stg/Lift/Analysis.hs
new file mode 100644
index 0000000000..02d439cef7
--- /dev/null
+++ b/compiler/GHC/Stg/Lift/Analysis.hs
@@ -0,0 +1,565 @@
+{-# LANGUAGE BangPatterns #-}
+{-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE DataKinds #-}
+
+-- | Provides the heuristics for when it's beneficial to lambda lift bindings.
+-- Most significantly, this employs a cost model to estimate impact on heap
+-- allocations, by looking at an STG expression's 'Skeleton'.
+module GHC.Stg.Lift.Analysis (
+    -- * #when# When to lift
+    -- $when
+
+    -- * #clogro# Estimating closure growth
+    -- $clogro
+
+    -- * AST annotation
+    Skeleton(..), BinderInfo(..), binderInfoBndr,
+    LlStgBinding, LlStgExpr, LlStgRhs, LlStgAlt, tagSkeletonTopBind,
+    -- * Lifting decision
+    goodToLift,
+    closureGrowth -- Exported just for the docs
+  ) where
+
+import GhcPrelude
+
+import BasicTypes
+import Demand
+import DynFlags
+import Id
+import SMRep ( WordOff )
+import GHC.Stg.Syntax
+import qualified GHC.StgToCmm.ArgRep  as StgToCmm.ArgRep
+import qualified GHC.StgToCmm.Closure as StgToCmm.Closure
+import qualified GHC.StgToCmm.Layout  as StgToCmm.Layout
+import Outputable
+import Util
+import VarSet
+
+import Data.Maybe ( mapMaybe )
+
+-- Note [When to lift]
+-- ~~~~~~~~~~~~~~~~~~~
+-- $when
+-- The analysis proceeds in two steps:
+--
+--   1. It tags the syntax tree with analysis information in the form of
+--      'BinderInfo' at each binder and 'Skeleton's at each let-binding
+--      by 'tagSkeletonTopBind' and friends.
+--   2. The resulting syntax tree is treated by the "GHC.Stg.Lift"
+--      module, calling out to 'goodToLift' to decide if a binding is worthwhile
+--      to lift.
+--      'goodToLift' consults argument occurrence information in 'BinderInfo'
+--      and estimates 'closureGrowth', for which it needs the 'Skeleton'.
+--
+-- So the annotations from 'tagSkeletonTopBind' ultimately fuel 'goodToLift',
+-- which employs a number of heuristics to identify and exclude lambda lifting
+-- opportunities deemed non-beneficial:
+--
+--  [Top-level bindings] can't be lifted.
+--  [Thunks] and data constructors shouldn't be lifted in order not to destroy
+--    sharing.
+--  [Argument occurrences] #arg_occs# of binders prohibit them to be lifted.
+--    Doing the lift would re-introduce the very allocation at call sites that
+--    we tried to get rid off in the first place. We capture analysis
+--    information in 'BinderInfo'. Note that we also consider a nullary
+--    application as argument occurrence, because it would turn into an n-ary
+--    partial application created by a generic apply function. This occurs in
+--    CPS-heavy code like the CS benchmark.
+--  [Join points] should not be lifted, simply because there's no reduction in
+--    allocation to be had.
+--  [Abstracting over join points] destroys join points, because they end up as
+--    arguments to the lifted function.
+--  [Abstracting over known local functions] turns a known call into an unknown
+--    call (e.g. some @stg_ap_*@), which is generally slower. Can be turned off
+--    with @-fstg-lift-lams-known@.
+--  [Calling convention] Don't lift when the resulting function would have a
+--    higher arity than available argument registers for the calling convention.
+--    Can be influenced with @-fstg-lift-(non)rec-args(-any)@.
+--  [Closure growth] introduced when former free variables have to be available
+--    at call sites may actually lead to an increase in overall allocations
+--  resulting from a lift. Estimating closure growth is described in
+--  "GHC.Stg.Lift.Analysis#clogro" and is what most of this module is ultimately
+--  concerned with.
+--
+-- There's a <https://gitlab.haskell.org/ghc/ghc/wikis/late-lam-lift wiki page> with
+-- some more background and history.
+
+-- Note [Estimating closure growth]
+-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+-- $clogro
+-- We estimate closure growth by abstracting the syntax tree into a 'Skeleton',
+-- capturing only syntactic details relevant to 'closureGrowth', such as
+--
+--   * 'ClosureSk', representing closure allocation.
+--   * 'RhsSk', representing a RHS of a binding and how many times it's called
+--     by an appropriate 'DmdShell'.
+--   * 'AltSk', 'BothSk' and 'NilSk' for choice, sequence and empty element.
+--
+-- This abstraction is mostly so that the main analysis function 'closureGrowth'
+-- can stay simple and focused. Also, skeletons tend to be much smaller than
+-- the syntax tree they abstract, so it makes sense to construct them once and
+-- and operate on them instead of the actual syntax tree.
+--
+-- A more detailed treatment of computing closure growth, including examples,
+-- can be found in the paper referenced from the
+-- <https://gitlab.haskell.org/ghc/ghc/wikis/late-lam-lift wiki page>.
+
+llTrace :: String -> SDoc -> a -> a
+llTrace _ _ c = c
+-- llTrace a b c = pprTrace a b c
+
+type instance BinderP      'LiftLams = BinderInfo
+type instance XRhsClosure  'LiftLams = DIdSet
+type instance XLet         'LiftLams = Skeleton
+type instance XLetNoEscape 'LiftLams = Skeleton
+
+freeVarsOfRhs :: (XRhsClosure pass ~ DIdSet) => GenStgRhs pass -> DIdSet
+freeVarsOfRhs (StgRhsCon _ _ args) = mkDVarSet [ id | StgVarArg id <- args ]
+freeVarsOfRhs (StgRhsClosure fvs _ _ _ _) = fvs
+
+-- | Captures details of the syntax tree relevant to the cost model, such as
+-- closures, multi-shot lambdas and case expressions.
+data Skeleton
+  = ClosureSk !Id !DIdSet {- ^ free vars -} !Skeleton
+  | RhsSk !DmdShell {- ^ how often the RHS was entered -} !Skeleton
+  | AltSk !Skeleton !Skeleton
+  | BothSk !Skeleton !Skeleton
+  | NilSk
+
+bothSk :: Skeleton -> Skeleton -> Skeleton
+bothSk NilSk b = b
+bothSk a NilSk = a
+bothSk a b     = BothSk a b
+
+altSk :: Skeleton -> Skeleton -> Skeleton
+altSk NilSk b = b
+altSk a NilSk = a
+altSk a b     = AltSk a b
+
+rhsSk :: DmdShell -> Skeleton -> Skeleton
+rhsSk _        NilSk = NilSk
+rhsSk body_dmd skel  = RhsSk body_dmd skel
+
+-- | The type used in binder positions in 'GenStgExpr's.
+data BinderInfo
+  = BindsClosure !Id !Bool -- ^ Let(-no-escape)-bound thing with a flag
+                           --   indicating whether it occurs as an argument
+                           --   or in a nullary application
+                           --   (see "GHC.Stg.Lift.Analysis#arg_occs").
+  | BoringBinder !Id       -- ^ Every other kind of binder
+
+-- | Gets the bound 'Id' out a 'BinderInfo'.
+binderInfoBndr :: BinderInfo -> Id
+binderInfoBndr (BoringBinder bndr)   = bndr
+binderInfoBndr (BindsClosure bndr _) = bndr
+
+-- | Returns 'Nothing' for 'BoringBinder's and 'Just' the flag indicating
+-- occurrences as argument or in a nullary applications otherwise.
+binderInfoOccursAsArg :: BinderInfo -> Maybe Bool
+binderInfoOccursAsArg BoringBinder{}     = Nothing
+binderInfoOccursAsArg (BindsClosure _ b) = Just b
+
+instance Outputable Skeleton where
+  ppr NilSk = text ""
+  ppr (AltSk l r) = vcat
+    [ text "{ " <+> ppr l
+    , text "ALT"
+    , text "  " <+> ppr r
+    , text "}"
+    ]
+  ppr (BothSk l r) = ppr l $$ ppr r
+  ppr (ClosureSk f fvs body) = ppr f <+> ppr fvs $$ nest 2 (ppr body)
+  ppr (RhsSk body_dmd body) = hcat
+    [ text "λ["
+    , ppr str
+    , text ", "
+    , ppr use
+    , text "]. "
+    , ppr body
+    ]
+    where
+      str
+        | isStrictDmd body_dmd = '1'
+        | otherwise = '0'
+      use
+        | isAbsDmd body_dmd = '0'
+        | isUsedOnce body_dmd = '1'
+        | otherwise = 'ω'
+
+instance Outputable BinderInfo where
+  ppr = ppr . binderInfoBndr
+
+instance OutputableBndr BinderInfo where
+  pprBndr b = pprBndr b . binderInfoBndr
+  pprPrefixOcc = pprPrefixOcc . binderInfoBndr
+  pprInfixOcc = pprInfixOcc . binderInfoBndr
+  bndrIsJoin_maybe = bndrIsJoin_maybe . binderInfoBndr
+
+mkArgOccs :: [StgArg] -> IdSet
+mkArgOccs = mkVarSet . mapMaybe stg_arg_var
+  where
+    stg_arg_var (StgVarArg occ) = Just occ
+    stg_arg_var _               = Nothing
+
+-- | Tags every binder with its 'BinderInfo' and let bindings with their
+-- 'Skeleton's.
+tagSkeletonTopBind :: CgStgBinding -> LlStgBinding
+-- NilSk is OK when tagging top-level bindings. Also, top-level things are never
+-- lambda-lifted, so no need to track their argument occurrences. They can also
+-- never be let-no-escapes (thus we pass False).
+tagSkeletonTopBind bind = bind'
+  where
+    (_, _, _, bind') = tagSkeletonBinding False NilSk emptyVarSet bind
+
+-- | Tags binders of an 'StgExpr' with its 'BinderInfo' and let bindings with
+-- their 'Skeleton's. Additionally, returns its 'Skeleton' and the set of binder
+-- occurrences in argument and nullary application position
+-- (cf. "GHC.Stg.Lift.Analysis#arg_occs").
+tagSkeletonExpr :: CgStgExpr -> (Skeleton, IdSet, LlStgExpr)
+tagSkeletonExpr (StgLit lit)
+  = (NilSk, emptyVarSet, StgLit lit)
+tagSkeletonExpr (StgConApp con args tys)
+  = (NilSk, mkArgOccs args, StgConApp con args tys)
+tagSkeletonExpr (StgOpApp op args ty)
+  = (NilSk, mkArgOccs args, StgOpApp op args ty)
+tagSkeletonExpr (StgApp f args)
+  = (NilSk, arg_occs, StgApp f args)
+  where
+    arg_occs
+      -- This checks for nullary applications, which we treat the same as
+      -- argument occurrences, see "GHC.Stg.Lift.Analysis#arg_occs".
+      | null args = unitVarSet f
+      | otherwise = mkArgOccs args
+tagSkeletonExpr (StgLam _ _) = pprPanic "stgLiftLams" (text "StgLam")
+tagSkeletonExpr (StgCase scrut bndr ty alts)
+  = (skel, arg_occs, StgCase scrut' bndr' ty alts')
+  where
+    (scrut_skel, scrut_arg_occs, scrut') = tagSkeletonExpr scrut
+    (alt_skels, alt_arg_occss, alts') = mapAndUnzip3 tagSkeletonAlt alts
+    skel = bothSk scrut_skel (foldr altSk NilSk alt_skels)
+    arg_occs = unionVarSets (scrut_arg_occs:alt_arg_occss) `delVarSet` bndr
+    bndr' = BoringBinder bndr
+tagSkeletonExpr (StgTick t e)
+  = (skel, arg_occs, StgTick t e')
+  where
+    (skel, arg_occs, e') = tagSkeletonExpr e
+tagSkeletonExpr (StgLet _ bind body) = tagSkeletonLet False body bind
+tagSkeletonExpr (StgLetNoEscape _ bind body) = tagSkeletonLet True body bind
+
+mkLet :: Bool -> Skeleton -> LlStgBinding -> LlStgExpr -> LlStgExpr
+mkLet True = StgLetNoEscape
+mkLet _    = StgLet
+
+tagSkeletonLet
+  :: Bool
+  -- ^ Is the binding a let-no-escape?
+  -> CgStgExpr
+  -- ^ Let body
+  -> CgStgBinding
+  -- ^ Binding group
+  -> (Skeleton, IdSet, LlStgExpr)
+  -- ^ RHS skeletons, argument occurrences and annotated binding
+tagSkeletonLet is_lne body bind
+  = (let_skel, arg_occs, mkLet is_lne scope bind' body')
+  where
+    (body_skel, body_arg_occs, body') = tagSkeletonExpr body
+    (let_skel, arg_occs, scope, bind')
+      = tagSkeletonBinding is_lne body_skel body_arg_occs bind
+
+tagSkeletonBinding
+  :: Bool
+  -- ^ Is the binding a let-no-escape?
+  -> Skeleton
+  -- ^ Let body skeleton
+  -> IdSet
+  -- ^ Argument occurrences in the body
+  -> CgStgBinding
+  -- ^ Binding group
+  -> (Skeleton, IdSet, Skeleton, LlStgBinding)
+  -- ^ Let skeleton, argument occurrences, scope skeleton of binding and
+  --   the annotated binding
+tagSkeletonBinding is_lne body_skel body_arg_occs (StgNonRec bndr rhs)
+  = (let_skel, arg_occs, scope, bind')
+  where
+    (rhs_skel, rhs_arg_occs, rhs') = tagSkeletonRhs bndr rhs
+    arg_occs = (body_arg_occs `unionVarSet` rhs_arg_occs) `delVarSet` bndr
+    bind_skel
+      | is_lne    = rhs_skel -- no closure is allocated for let-no-escapes
+      | otherwise = ClosureSk bndr (freeVarsOfRhs rhs) rhs_skel
+    let_skel = bothSk body_skel bind_skel
+    occurs_as_arg = bndr `elemVarSet` body_arg_occs
+    -- Compared to the recursive case, this exploits the fact that @bndr@ is
+    -- never free in @rhs@.
+    scope = body_skel
+    bind' = StgNonRec (BindsClosure bndr occurs_as_arg) rhs'
+tagSkeletonBinding is_lne body_skel body_arg_occs (StgRec pairs)
+  = (let_skel, arg_occs, scope, StgRec pairs')
+  where
+    (bndrs, _) = unzip pairs
+    -- Local recursive STG bindings also regard the defined binders as free
+    -- vars. We want to delete those for our cost model, as these are known
+    -- calls anyway when we add them to the same top-level recursive group as
+    -- the top-level binding currently being analysed.
+    skel_occs_rhss' = map (uncurry tagSkeletonRhs) pairs
+    rhss_arg_occs = map sndOf3 skel_occs_rhss'
+    scope_occs = unionVarSets (body_arg_occs:rhss_arg_occs)
+    arg_occs = scope_occs `delVarSetList` bndrs
+    -- @skel_rhss@ aren't yet wrapped in closures. We'll do that in a moment,
+    -- but we also need the un-wrapped skeletons for calculating the @scope@
+    -- of the group, as the outer closures don't contribute to closure growth
+    -- when we lift this specific binding.
+    scope = foldr (bothSk . fstOf3) body_skel skel_occs_rhss'
+    -- Now we can build the actual Skeleton for the expression just by
+    -- iterating over each bind pair.
+    (bind_skels, pairs') = unzip (zipWith single_bind bndrs skel_occs_rhss')
+    let_skel = foldr bothSk body_skel bind_skels
+    single_bind bndr (skel_rhs, _, rhs') = (bind_skel, (bndr', rhs'))
+      where
+        -- Here, we finally add the closure around each @skel_rhs@.
+        bind_skel
+          | is_lne    = skel_rhs -- no closure is allocated for let-no-escapes
+          | otherwise = ClosureSk bndr fvs skel_rhs
+        fvs = freeVarsOfRhs rhs' `dVarSetMinusVarSet` mkVarSet bndrs
+        bndr' = BindsClosure bndr (bndr `elemVarSet` scope_occs)
+
+tagSkeletonRhs :: Id -> CgStgRhs -> (Skeleton, IdSet, LlStgRhs)
+tagSkeletonRhs _ (StgRhsCon ccs dc args)
+  = (NilSk, mkArgOccs args, StgRhsCon ccs dc args)
+tagSkeletonRhs bndr (StgRhsClosure fvs ccs upd bndrs body)
+  = (rhs_skel, body_arg_occs, StgRhsClosure fvs ccs upd bndrs' body')
+  where
+    bndrs' = map BoringBinder bndrs
+    (body_skel, body_arg_occs, body') = tagSkeletonExpr body
+    rhs_skel = rhsSk (rhsDmdShell bndr) body_skel
+
+-- | How many times will the lambda body of the RHS bound to the given
+-- identifier be evaluated, relative to its defining context? This function
+-- computes the answer in form of a 'DmdShell'.
+rhsDmdShell :: Id -> DmdShell
+rhsDmdShell bndr
+  | is_thunk = oneifyDmd ds
+  | otherwise = peelManyCalls (idArity bndr) cd
+  where
+    is_thunk = idArity bndr == 0
+    -- Let's pray idDemandInfo is still OK after unarise...
+    (ds, cd) = toCleanDmd (idDemandInfo bndr)
+
+tagSkeletonAlt :: CgStgAlt -> (Skeleton, IdSet, LlStgAlt)
+tagSkeletonAlt (con, bndrs, rhs)
+  = (alt_skel, arg_occs, (con, map BoringBinder bndrs, rhs'))
+  where
+    (alt_skel, alt_arg_occs, rhs') = tagSkeletonExpr rhs
+    arg_occs = alt_arg_occs `delVarSetList` bndrs
+
+-- | Combines several heuristics to decide whether to lambda-lift a given
+-- @let@-binding to top-level. See "GHC.Stg.Lift.Analysis#when" for details.
+goodToLift
+  :: DynFlags
+  -> TopLevelFlag
+  -> RecFlag
+  -> (DIdSet -> DIdSet) -- ^ An expander function, turning 'InId's into
+                        -- 'OutId's. See 'GHC.Stg.Lift.Monad.liftedIdsExpander'.
+  -> [(BinderInfo, LlStgRhs)]
+  -> Skeleton
+  -> Maybe DIdSet       -- ^ @Just abs_ids@ <=> This binding is beneficial to
+                        -- lift and @abs_ids@ are the variables it would
+                        -- abstract over
+goodToLift dflags top_lvl rec_flag expander pairs scope = decide
+  [ ("top-level", isTopLevel top_lvl) -- keep in sync with Note [When to lift]
+  , ("memoized", any_memoized)
+  , ("argument occurrences", arg_occs)
+  , ("join point", is_join_point)
+  , ("abstracts join points", abstracts_join_ids)
+  , ("abstracts known local function", abstracts_known_local_fun)
+  , ("args spill on stack", args_spill_on_stack)
+  , ("increases allocation", inc_allocs)
+  ] where
+      decide deciders
+        | not (fancy_or deciders)
+        = llTrace "stgLiftLams:lifting"
+                  (ppr bndrs <+> ppr abs_ids $$
+                   ppr allocs $$
+                   ppr scope) $
+          Just abs_ids
+        | otherwise
+        = Nothing
+      ppr_deciders = vcat . map (text . fst) . filter snd
+      fancy_or deciders
+        = llTrace "stgLiftLams:goodToLift" (ppr bndrs $$ ppr_deciders deciders) $
+          any snd deciders
+
+      bndrs = map (binderInfoBndr . fst) pairs
+      bndrs_set = mkVarSet bndrs
+      rhss = map snd pairs
+
+      -- First objective: Calculate @abs_ids@, e.g. the former free variables
+      -- the lifted binding would abstract over. We have to merge the free
+      -- variables of all RHS to get the set of variables that will have to be
+      -- passed through parameters.
+      fvs = unionDVarSets (map freeVarsOfRhs rhss)
+      -- To lift the binding to top-level, we want to delete the lifted binders
+      -- themselves from the free var set. Local let bindings track recursive
+      -- occurrences in their free variable set. We neither want to apply our
+      -- cost model to them (see 'tagSkeletonRhs'), nor pass them as parameters
+      -- when lifted, as these are known calls. We call the resulting set the
+      -- identifiers we abstract over, thus @abs_ids@. These are all 'OutId's.
+      -- We will save the set in 'LiftM.e_expansions' for each of the variables
+      -- if we perform the lift.
+      abs_ids = expander (delDVarSetList fvs bndrs)
+
+      -- We don't lift updatable thunks or constructors
+      any_memoized = any is_memoized_rhs rhss
+      is_memoized_rhs StgRhsCon{} = True
+      is_memoized_rhs (StgRhsClosure _ _ upd _ _) = isUpdatable upd
+
+      -- Don't lift binders occurring as arguments. This would result in complex
+      -- argument expressions which would have to be given a name, reintroducing
+      -- the very allocation at each call site that we wanted to get rid off in
+      -- the first place.
+      arg_occs = or (mapMaybe (binderInfoOccursAsArg . fst) pairs)
+
+      -- These don't allocate anyway.
+      is_join_point = any isJoinId bndrs
+
+      -- Abstracting over join points/let-no-escapes spoils them.
+      abstracts_join_ids = any isJoinId (dVarSetElems abs_ids)
+
+      -- Abstracting over known local functions that aren't floated themselves
+      -- turns a known, fast call into an unknown, slow call:
+      --
+      --    let f x = ...
+      --        g y = ... f x ... -- this was a known call
+      --    in g 4
+      --
+      -- After lifting @g@, but not @f@:
+      --
+      --    l_g f y = ... f y ... -- this is now an unknown call
+      --    let f x = ...
+      --    in l_g f 4
+      --
+      -- We can abuse the results of arity analysis for this:
+      -- idArity f > 0 ==> known
+      known_fun id = idArity id > 0
+      abstracts_known_local_fun
+        = not (liftLamsKnown dflags) && any known_fun (dVarSetElems abs_ids)
+
+      -- Number of arguments of a RHS in the current binding group if we decide
+      -- to lift it
+      n_args
+        = length
+        . StgToCmm.Closure.nonVoidIds -- void parameters don't appear in Cmm
+        . (dVarSetElems abs_ids ++)
+        . rhsLambdaBndrs
+      max_n_args
+        | isRec rec_flag = liftLamsRecArgs dflags
+        | otherwise      = liftLamsNonRecArgs dflags
+      -- We have 5 hardware registers on x86_64 to pass arguments in. Any excess
+      -- args are passed on the stack, which means slow memory accesses
+      args_spill_on_stack
+        | Just n <- max_n_args = maximum (map n_args rhss) > n
+        | otherwise = False
+
+      -- We only perform the lift if allocations didn't increase.
+      -- Note that @clo_growth@ will be 'infinity' if there was positive growth
+      -- under a multi-shot lambda.
+      -- Also, abstracting over LNEs is unacceptable. LNEs might return
+      -- unlifted tuples, which idClosureFootprint can't cope with.
+      inc_allocs = abstracts_join_ids || allocs > 0
+      allocs = clo_growth + mkIntWithInf (negate closuresSize)
+      -- We calculate and then add up the size of each binding's closure.
+      -- GHC does not currently share closure environments, and we either lift
+      -- the entire recursive binding group or none of it.
+      closuresSize = sum $ flip map rhss $ \rhs ->
+        closureSize dflags
+        . dVarSetElems
+        . expander
+        . flip dVarSetMinusVarSet bndrs_set
+        $ freeVarsOfRhs rhs
+      clo_growth = closureGrowth expander (idClosureFootprint dflags) bndrs_set abs_ids scope
+
+rhsLambdaBndrs :: LlStgRhs -> [Id]
+rhsLambdaBndrs StgRhsCon{} = []
+rhsLambdaBndrs (StgRhsClosure _ _ _ bndrs _) = map binderInfoBndr bndrs
+
+-- | The size in words of a function closure closing over the given 'Id's,
+-- including the header.
+closureSize :: DynFlags -> [Id] -> WordOff
+closureSize dflags ids = words + sTD_HDR_SIZE dflags
+  -- We go through sTD_HDR_SIZE rather than fixedHdrSizeW so that we don't
+  -- optimise differently when profiling is enabled.
+  where
+    (words, _, _)
+      -- Functions have a StdHeader (as opposed to ThunkHeader).
+      = StgToCmm.Layout.mkVirtHeapOffsets dflags StgToCmm.Layout.StdHeader
+      . StgToCmm.Closure.addIdReps
+      . StgToCmm.Closure.nonVoidIds
+      $ ids
+
+-- | The number of words a single 'Id' adds to a closure's size.
+-- Note that this can't handle unboxed tuples (which may still be present in
+-- let-no-escapes, even after Unarise), in which case
+-- @'GHC.StgToCmm.Closure.idPrimRep'@ will crash.
+idClosureFootprint:: DynFlags -> Id -> WordOff
+idClosureFootprint dflags
+  = StgToCmm.ArgRep.argRepSizeW dflags
+  . StgToCmm.ArgRep.idArgRep
+
+-- | @closureGrowth expander sizer f fvs@ computes the closure growth in words
+-- as a result of lifting @f@ to top-level. If there was any growing closure
+-- under a multi-shot lambda, the result will be 'infinity'.
+-- Also see "GHC.Stg.Lift.Analysis#clogro".
+closureGrowth
+  :: (DIdSet -> DIdSet)
+  -- ^ Expands outer free ids that were lifted to their free vars
+  -> (Id -> Int)
+  -- ^ Computes the closure footprint of an identifier
+  -> IdSet
+  -- ^ Binding group for which lifting is to be decided
+  -> DIdSet
+  -- ^ Free vars of the whole binding group prior to lifting it. These must be
+  --   available at call sites if we decide to lift the binding group.
+  -> Skeleton
+  -- ^ Abstraction of the scope of the function
+  -> IntWithInf
+  -- ^ Closure growth. 'infinity' indicates there was growth under a
+  --   (multi-shot) lambda.
+closureGrowth expander sizer group abs_ids = go
+  where
+    go NilSk = 0
+    go (BothSk a b) = go a + go b
+    go (AltSk a b) = max (go a) (go b)
+    go (ClosureSk _ clo_fvs rhs)
+      -- If no binder of the @group@ occurs free in the closure, the lifting
+      -- won't have any effect on it and we can omit the recursive call.
+      | n_occs == 0 = 0
+      -- Otherwise, we account the cost of allocating the closure and add it to
+      -- the closure growth of its RHS.
+      | otherwise   = mkIntWithInf cost + go rhs
+      where
+        n_occs = sizeDVarSet (clo_fvs' `dVarSetIntersectVarSet` group)
+        -- What we close over considering prior lifting decisions
+        clo_fvs' = expander clo_fvs
+        -- Variables that would additionally occur free in the closure body if
+        -- we lift @f@
+        newbies = abs_ids `minusDVarSet` clo_fvs'
+        -- Lifting @f@ removes @f@ from the closure but adds all @newbies@
+        cost = foldDVarSet (\id size -> sizer id + size) 0 newbies - n_occs
+    go (RhsSk body_dmd body)
+      -- The conservative assumption would be that
+      --   1. Every RHS with positive growth would be called multiple times,
+      --      modulo thunks.
+      --   2. Every RHS with negative growth wouldn't be called at all.
+      --
+      -- In the first case, we'd have to return 'infinity', while in the
+      -- second case, we'd have to return 0. But we can do far better
+      -- considering information from the demand analyser, which provides us
+      -- with conservative estimates on minimum and maximum evaluation
+      -- cardinality. The @body_dmd@ part of 'RhsSk' is the result of
+      -- 'rhsDmdShell' and accurately captures the cardinality of the RHSs body
+      -- relative to its defining context.
+      | isAbsDmd body_dmd   = 0
+      | cg <= 0             = if isStrictDmd body_dmd then cg else 0
+      | isUsedOnce body_dmd = cg
+      | otherwise           = infinity
+      where
+        cg = go body
diff --git a/compiler/GHC/Stg/Lift/Monad.hs b/compiler/GHC/Stg/Lift/Monad.hs
new file mode 100644
index 0000000000..7d17e53cd9
--- /dev/null
+++ b/compiler/GHC/Stg/Lift/Monad.hs
@@ -0,0 +1,348 @@
+{-# LANGUAGE CPP #-}
+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
+{-# LANGUAGE TypeFamilies #-}
+
+-- | Hides away distracting bookkeeping while lambda lifting into a 'LiftM'
+-- monad.
+module GHC.Stg.Lift.Monad (
+    decomposeStgBinding, mkStgBinding,
+    Env (..),
+    -- * #floats# Handling floats
+    -- $floats
+    FloatLang (..), collectFloats, -- Exported just for the docs
+    -- * Transformation monad
+    LiftM, runLiftM, withCaffyness,
+    -- ** Adding bindings
+    startBindingGroup, endBindingGroup, addTopStringLit, addLiftedBinding,
+    -- ** Substitution and binders
+    withSubstBndr, withSubstBndrs, withLiftedBndr, withLiftedBndrs,
+    -- ** Occurrences
+    substOcc, isLifted, formerFreeVars, liftedIdsExpander
+  ) where
+
+#include "HsVersions.h"
+
+import GhcPrelude
+
+import BasicTypes
+import CostCentre ( isCurrentCCS, dontCareCCS )
+import DynFlags
+import FastString
+import Id
+import IdInfo
+import Name
+import Outputable
+import OrdList
+import GHC.Stg.Subst
+import GHC.Stg.Syntax
+import Type
+import UniqSupply
+import Util
+import VarEnv
+import VarSet
+
+import Control.Arrow ( second )
+import Control.Monad.Trans.Class
+import Control.Monad.Trans.RWS.Strict ( RWST, runRWST )
+import qualified Control.Monad.Trans.RWS.Strict as RWS
+import Control.Monad.Trans.Cont ( ContT (..) )
+import Data.ByteString ( ByteString )
+
+-- | @uncurry 'mkStgBinding' . 'decomposeStgBinding' = id@
+decomposeStgBinding :: GenStgBinding pass -> (RecFlag, [(BinderP pass, GenStgRhs pass)])
+decomposeStgBinding (StgRec pairs) = (Recursive, pairs)
+decomposeStgBinding (StgNonRec bndr rhs) = (NonRecursive, [(bndr, rhs)])
+
+mkStgBinding :: RecFlag -> [(BinderP pass, GenStgRhs pass)] -> GenStgBinding pass
+mkStgBinding Recursive = StgRec
+mkStgBinding NonRecursive = uncurry StgNonRec . head
+
+-- | Environment threaded around in a scoped, @Reader@-like fashion.
+data Env
+  = Env
+  { e_dflags     :: !DynFlags
+  -- ^ Read-only.
+  , e_subst      :: !Subst
+  -- ^ We need to track the renamings of local 'InId's to their lifted 'OutId',
+  -- because shadowing might make a closure's free variables unavailable at its
+  -- call sites. Consider:
+  -- @
+  --    let f y = x + y in let x = 4 in f x
+  -- @
+  -- Here, @f@ can't be lifted to top-level, because its free variable @x@ isn't
+  -- available at its call site.
+  , e_expansions :: !(IdEnv DIdSet)
+  -- ^ Lifted 'Id's don't occur as free variables in any closure anymore, because
+  -- they are bound at the top-level. Every occurrence must supply the formerly
+  -- free variables of the lifted 'Id', so they in turn become free variables of
+  -- the call sites. This environment tracks this expansion from lifted 'Id's to
+  -- their free variables.
+  --
+  -- 'InId's to 'OutId's.
+  --
+  -- Invariant: 'Id's not present in this map won't be substituted.
+  , e_in_caffy_context :: !Bool
+  -- ^ Are we currently analysing within a caffy context (e.g. the containing
+  -- top-level binder's 'idCafInfo' is 'MayHaveCafRefs')? If not, we can safely
+  -- assume that functions we lift out aren't caffy either.
+  }
+
+emptyEnv :: DynFlags -> Env
+emptyEnv dflags = Env dflags emptySubst emptyVarEnv False
+
+
+-- Note [Handling floats]
+-- ~~~~~~~~~~~~~~~~~~~~~~
+-- $floats
+-- Consider the following expression:
+--
+-- @
+--     f x =
+--       let g y = ... f y ...
+--       in g x
+-- @
+--
+-- What happens when we want to lift @g@? Normally, we'd put the lifted @l_g@
+-- binding above the binding for @f@:
+--
+-- @
+--     g f y = ... f y ...
+--     f x = g f x
+-- @
+--
+-- But this very unnecessarily turns a known call to @f@ into an unknown one, in
+-- addition to complicating matters for the analysis.
+-- Instead, we'd really like to put both functions in the same recursive group,
+-- thereby preserving the known call:
+--
+-- @
+--     Rec {
+--       g y = ... f y ...
+--       f x = g x
+--     }
+-- @
+--
+-- But we don't want this to happen for just /any/ binding. That would create
+-- possibly huge recursive groups in the process, calling for an occurrence
+-- analyser on STG.
+-- So, we need to track when we lift a binding out of a recursive RHS and add
+-- the binding to the same recursive group as the enclosing recursive binding
+-- (which must have either already been at the top-level or decided to be
+-- lifted itself in order to preserve the known call).
+--
+-- This is done by expressing this kind of nesting structure as a 'Writer' over
+-- @['FloatLang']@ and flattening this expression in 'runLiftM' by a call to
+-- 'collectFloats'.
+-- API-wise, the analysis will not need to know about the whole 'FloatLang'
+-- business and will just manipulate it indirectly through actions in 'LiftM'.
+
+-- | We need to detect when we are lifting something out of the RHS of a
+-- recursive binding (c.f. "GHC.Stg.Lift.Monad#floats"), in which case that
+-- binding needs to be added to the same top-level recursive group. This
+-- requires we detect a certain nesting structure, which is encoded by
+-- 'StartBindingGroup' and 'EndBindingGroup'.
+--
+-- Although 'collectFloats' will only ever care if the current binding to be
+-- lifted (through 'LiftedBinding') will occur inside such a binding group or
+-- not, e.g. doesn't care about the nesting level as long as its greater than 0.
+data FloatLang
+  = StartBindingGroup
+  | EndBindingGroup
+  | PlainTopBinding OutStgTopBinding
+  | LiftedBinding OutStgBinding
+
+instance Outputable FloatLang where
+  ppr StartBindingGroup = char '('
+  ppr EndBindingGroup = char ')'
+  ppr (PlainTopBinding StgTopStringLit{}) = text "<str>"
+  ppr (PlainTopBinding (StgTopLifted b)) = ppr (LiftedBinding b)
+  ppr (LiftedBinding bind) = (if isRec rec then char 'r' else char 'n') <+> ppr (map fst pairs)
+    where
+      (rec, pairs) = decomposeStgBinding bind
+
+-- | Flattens an expression in @['FloatLang']@ into an STG program, see #floats.
+-- Important pre-conditions: The nesting of opening 'StartBindinGroup's and
+-- closing 'EndBindinGroup's is balanced. Also, it is crucial that every binding
+-- group has at least one recursive binding inside. Otherwise there's no point
+-- in announcing the binding group in the first place and an @ASSERT@ will
+-- trigger.
+collectFloats :: [FloatLang] -> [OutStgTopBinding]
+collectFloats = go (0 :: Int) []
+  where
+    go 0 [] [] = []
+    go _ _ [] = pprPanic "collectFloats" (text "unterminated group")
+    go n binds (f:rest) = case f of
+      StartBindingGroup -> go (n+1) binds rest
+      EndBindingGroup
+        | n == 0 -> pprPanic "collectFloats" (text "no group to end")
+        | n == 1 -> StgTopLifted (merge_binds binds) : go 0 [] rest
+        | otherwise -> go (n-1) binds rest
+      PlainTopBinding top_bind
+        | n == 0 -> top_bind : go n binds rest
+        | otherwise -> pprPanic "collectFloats" (text "plain top binding inside group")
+      LiftedBinding bind
+        | n == 0 -> StgTopLifted (rm_cccs bind) : go n binds rest
+        | otherwise -> go n (bind:binds) rest
+
+    map_rhss f = uncurry mkStgBinding . second (map (second f)) . decomposeStgBinding
+    rm_cccs = map_rhss removeRhsCCCS
+    merge_binds binds = ASSERT( any is_rec binds )
+                        StgRec (concatMap (snd . decomposeStgBinding . rm_cccs) binds)
+    is_rec StgRec{} = True
+    is_rec _ = False
+
+-- | Omitting this makes for strange closure allocation schemes that crash the
+-- GC.
+removeRhsCCCS :: GenStgRhs pass -> GenStgRhs pass
+removeRhsCCCS (StgRhsClosure ext ccs upd bndrs body)
+  | isCurrentCCS ccs
+  = StgRhsClosure ext dontCareCCS upd bndrs body
+removeRhsCCCS (StgRhsCon ccs con args)
+  | isCurrentCCS ccs
+  = StgRhsCon dontCareCCS con args
+removeRhsCCCS rhs = rhs
+
+-- | The analysis monad consists of the following 'RWST' components:
+--
+--     * 'Env': Reader-like context. Contains a substitution, info about how
+--       how lifted identifiers are to be expanded into applications and details
+--       such as 'DynFlags' and a flag helping with determining if a lifted
+--       binding is caffy.
+--
+--     * @'OrdList' 'FloatLang'@: Writer output for the resulting STG program.
+--
+--     * No pure state component
+--
+--     * But wrapping around 'UniqSM' for generating fresh lifted binders.
+--       (The @uniqAway@ approach could give the same name to two different
+--       lifted binders, so this is necessary.)
+newtype LiftM a
+  = LiftM { unwrapLiftM :: RWST Env (OrdList FloatLang) () UniqSM a }
+  deriving (Functor, Applicative, Monad)
+
+instance HasDynFlags LiftM where
+  getDynFlags = LiftM (RWS.asks e_dflags)
+
+instance MonadUnique LiftM where
+  getUniqueSupplyM = LiftM (lift getUniqueSupplyM)
+  getUniqueM = LiftM (lift getUniqueM)
+  getUniquesM = LiftM (lift getUniquesM)
+
+runLiftM :: DynFlags -> UniqSupply -> LiftM () -> [OutStgTopBinding]
+runLiftM dflags us (LiftM m) = collectFloats (fromOL floats)
+  where
+    (_, _, floats) = initUs_ us (runRWST m (emptyEnv dflags) ())
+
+-- | Assumes a given caffyness for the execution of the passed action, which
+-- influences the 'cafInfo' of lifted bindings.
+withCaffyness :: Bool -> LiftM a -> LiftM a
+withCaffyness caffy action
+  = LiftM (RWS.local (\e -> e { e_in_caffy_context = caffy }) (unwrapLiftM action))
+
+-- | Writes a plain 'StgTopStringLit' to the output.
+addTopStringLit :: OutId -> ByteString -> LiftM ()
+addTopStringLit id = LiftM . RWS.tell . unitOL . PlainTopBinding . StgTopStringLit id
+
+-- | Starts a recursive binding group. See #floats# and 'collectFloats'.
+startBindingGroup :: LiftM ()
+startBindingGroup = LiftM $ RWS.tell $ unitOL $ StartBindingGroup
+
+-- | Ends a recursive binding group. See #floats# and 'collectFloats'.
+endBindingGroup :: LiftM ()
+endBindingGroup = LiftM $ RWS.tell $ unitOL $ EndBindingGroup
+
+-- | Lifts a binding to top-level. Depending on whether it's declared inside
+-- a recursive RHS (see #floats# and 'collectFloats'), this might be added to
+-- an existing recursive top-level binding group.
+addLiftedBinding :: OutStgBinding -> LiftM ()
+addLiftedBinding = LiftM . RWS.tell . unitOL . LiftedBinding
+
+-- | Takes a binder and a continuation which is called with the substituted
+-- binder. The continuation will be evaluated in a 'LiftM' context in which that
+-- binder is deemed in scope. Think of it as a 'RWS.local' computation: After
+-- the continuation finishes, the new binding won't be in scope anymore.
+withSubstBndr :: Id -> (Id -> LiftM a) -> LiftM a
+withSubstBndr bndr inner = LiftM $ do
+  subst <- RWS.asks e_subst
+  let (bndr', subst') = substBndr bndr subst
+  RWS.local (\e -> e { e_subst = subst' }) (unwrapLiftM (inner bndr'))
+
+-- | See 'withSubstBndr'.
+withSubstBndrs :: Traversable f => f Id -> (f Id -> LiftM a) -> LiftM a
+withSubstBndrs = runContT . traverse (ContT . withSubstBndr)
+
+-- | Similarly to 'withSubstBndr', this function takes a set of variables to
+-- abstract over, the binder to lift (and generate a fresh, substituted name
+-- for) and a continuation in which that fresh, lifted binder is in scope.
+--
+-- It takes care of all the details involved with copying and adjusting the
+-- binder, fresh name generation and caffyness.
+withLiftedBndr :: DIdSet -> Id -> (Id -> LiftM a) -> LiftM a
+withLiftedBndr abs_ids bndr inner = do
+  uniq <- getUniqueM
+  let str = "$l" ++ occNameString (getOccName bndr)
+  let ty = mkLamTypes (dVarSetElems abs_ids) (idType bndr)
+  -- When the enclosing top-level binding is not caffy, then the lifted
+  -- binding will not be caffy either. If we don't recognize this, non-caffy
+  -- things call caffy things and then codegen screws up.
+  in_caffy_ctxt <- LiftM (RWS.asks e_in_caffy_context)
+  let caf_info = if in_caffy_ctxt then MayHaveCafRefs else NoCafRefs
+  let bndr'
+        -- See Note [transferPolyIdInfo] in Id.hs. We need to do this at least
+        -- for arity information.
+        = transferPolyIdInfo bndr (dVarSetElems abs_ids)
+        -- Otherwise we confuse code gen if bndr was not caffy: the new bndr is
+        -- assumed to be caffy and will need an SRT. Transitive call sites might
+        -- not be caffy themselves and subsequently will miss a static link
+        -- field in their closure. Chaos ensues.
+        . flip setIdCafInfo caf_info
+        . mkSysLocal (mkFastString str) uniq
+        $ ty
+  LiftM $ RWS.local
+    (\e -> e
+      { e_subst = extendSubst bndr bndr' $ extendInScope bndr' $ e_subst e
+      , e_expansions = extendVarEnv (e_expansions e) bndr abs_ids
+      })
+    (unwrapLiftM (inner bndr'))
+
+-- | See 'withLiftedBndr'.
+withLiftedBndrs :: Traversable f => DIdSet -> f Id -> (f Id -> LiftM a) -> LiftM a
+withLiftedBndrs abs_ids = runContT . traverse (ContT . withLiftedBndr abs_ids)
+
+-- | Substitutes a binder /occurrence/, which was brought in scope earlier by
+-- 'withSubstBndr'\/'withLiftedBndr'.
+substOcc :: Id -> LiftM Id
+substOcc id = LiftM (RWS.asks (lookupIdSubst id . e_subst))
+
+-- | Whether the given binding was decided to be lambda lifted.
+isLifted :: InId -> LiftM Bool
+isLifted bndr = LiftM (RWS.asks (elemVarEnv bndr . e_expansions))
+
+-- | Returns an empty list for a binding that was not lifted and the list of all
+-- local variables the binding abstracts over (so, exactly the additional
+-- arguments at adjusted call sites) otherwise.
+formerFreeVars :: InId -> LiftM [OutId]
+formerFreeVars f = LiftM $ do
+  expansions <- RWS.asks e_expansions
+  pure $ case lookupVarEnv expansions f of
+    Nothing -> []
+    Just fvs -> dVarSetElems fvs
+
+-- | Creates an /expander function/ for the current set of lifted binders.
+-- This expander function will replace any 'InId' by their corresponding 'OutId'
+-- and, in addition, will expand any lifted binders by the former free variables
+-- it abstracts over.
+liftedIdsExpander :: LiftM (DIdSet -> DIdSet)
+liftedIdsExpander = LiftM $ do
+  expansions <- RWS.asks e_expansions
+  subst <- RWS.asks e_subst
+  -- We use @noWarnLookupIdSubst@ here in order to suppress "not in scope"
+  -- warnings generated by 'lookupIdSubst' due to local bindings within RHS.
+  -- These are not in the InScopeSet of @subst@ and extending the InScopeSet in
+  -- @goodToLift@/@closureGrowth@ before passing it on to @expander@ is too much
+  -- trouble.
+  let go set fv = case lookupVarEnv expansions fv of
+        Nothing -> extendDVarSet set (noWarnLookupIdSubst fv subst) -- Not lifted
+        Just fvs' -> unionDVarSet set fvs'
+  let expander fvs = foldl' go emptyDVarSet (dVarSetElems fvs)
+  pure expander
diff --git a/compiler/GHC/Stg/Lint.hs b/compiler/GHC/Stg/Lint.hs
new file mode 100644
index 0000000000..e7044a89e0
--- /dev/null
+++ b/compiler/GHC/Stg/Lint.hs
@@ -0,0 +1,396 @@
+{- |
+(c) The GRASP/AQUA Project, Glasgow University, 1993-1998
+
+A lint pass to check basic STG invariants:
+
+- Variables should be defined before used.
+
+- Let bindings should not have unboxed types (unboxed bindings should only
+  appear in case), except when they're join points (see Note [CoreSyn let/app
+  invariant] and #14117).
+
+- If linting after unarisation, invariants listed in Note [Post-unarisation
+  invariants].
+
+Because we don't have types and coercions in STG we can't really check types
+here.
+
+Some history:
+
+StgLint used to check types, but it never worked and so it was disabled in 2000
+with this note:
+
+    WARNING:
+    ~~~~~~~~
+
+    This module has suffered bit-rot; it is likely to yield lint errors
+    for Stg code that is currently perfectly acceptable for code
+    generation.  Solution: don't use it!  (KSW 2000-05).
+
+Since then there were some attempts at enabling it again, as summarised in
+#14787. It's finally decided that we remove all type checking and only look for
+basic properties listed above.
+-}
+
+{-# LANGUAGE ScopedTypeVariables, FlexibleContexts, TypeFamilies,
+  DeriveFunctor #-}
+
+module GHC.Stg.Lint ( lintStgTopBindings ) where
+
+import GhcPrelude
+
+import GHC.Stg.Syntax
+
+import DynFlags
+import Bag              ( Bag, emptyBag, isEmptyBag, snocBag, bagToList )
+import BasicTypes       ( TopLevelFlag(..), isTopLevel )
+import CostCentre       ( isCurrentCCS )
+import Id               ( Id, idType, isJoinId, idName )
+import VarSet
+import DataCon
+import CoreSyn          ( AltCon(..) )
+import Name             ( getSrcLoc, nameIsLocalOrFrom )
+import ErrUtils         ( MsgDoc, Severity(..), mkLocMessage )
+import Type
+import GHC.Types.RepType
+import SrcLoc
+import Outputable
+import Module           ( Module )
+import qualified ErrUtils as Err
+import Control.Applicative ((<|>))
+import Control.Monad
+
+lintStgTopBindings :: forall a . (OutputablePass a, BinderP a ~ Id)
+                   => DynFlags
+                   -> Module -- ^ module being compiled
+                   -> Bool   -- ^ have we run Unarise yet?
+                   -> String -- ^ who produced the STG?
+                   -> [GenStgTopBinding a]
+                   -> IO ()
+
+lintStgTopBindings dflags this_mod unarised whodunnit binds
+  = {-# SCC "StgLint" #-}
+    case initL this_mod unarised top_level_binds (lint_binds binds) of
+      Nothing  ->
+        return ()
+      Just msg -> do
+        putLogMsg dflags NoReason Err.SevDump noSrcSpan
+          (defaultDumpStyle dflags)
+          (vcat [ text "*** Stg Lint ErrMsgs: in" <+>
+                        text whodunnit <+> text "***",
+                  msg,
+                  text "*** Offending Program ***",
+                  pprGenStgTopBindings binds,
+                  text "*** End of Offense ***"])
+        Err.ghcExit dflags 1
+  where
+    -- Bring all top-level binds into scope because CoreToStg does not generate
+    -- bindings in dependency order (so we may see a use before its definition).
+    top_level_binds = mkVarSet (bindersOfTopBinds binds)
+
+    lint_binds :: [GenStgTopBinding a] -> LintM ()
+
+    lint_binds [] = return ()
+    lint_binds (bind:binds) = do
+        binders <- lint_bind bind
+        addInScopeVars binders $
+            lint_binds binds
+
+    lint_bind (StgTopLifted bind) = lintStgBinds TopLevel bind
+    lint_bind (StgTopStringLit v _) = return [v]
+
+lintStgArg :: StgArg -> LintM ()
+lintStgArg (StgLitArg _) = return ()
+lintStgArg (StgVarArg v) = lintStgVar v
+
+lintStgVar :: Id -> LintM ()
+lintStgVar id = checkInScope id
+
+lintStgBinds
+    :: (OutputablePass a, BinderP a ~ Id)
+    => TopLevelFlag -> GenStgBinding a -> LintM [Id] -- Returns the binders
+lintStgBinds top_lvl (StgNonRec binder rhs) = do
+    lint_binds_help top_lvl (binder,rhs)
+    return [binder]
+
+lintStgBinds top_lvl (StgRec pairs)
+  = addInScopeVars binders $ do
+        mapM_ (lint_binds_help top_lvl) pairs
+        return binders
+  where
+    binders = [b | (b,_) <- pairs]
+
+lint_binds_help
+    :: (OutputablePass a, BinderP a ~ Id)
+    => TopLevelFlag
+    -> (Id, GenStgRhs a)
+    -> LintM ()
+lint_binds_help top_lvl (binder, rhs)
+  = addLoc (RhsOf binder) $ do
+        when (isTopLevel top_lvl) (checkNoCurrentCCS rhs)
+        lintStgRhs rhs
+        -- Check binder doesn't have unlifted type or it's a join point
+        checkL (isJoinId binder || not (isUnliftedType (idType binder)))
+               (mkUnliftedTyMsg binder rhs)
+
+-- | Top-level bindings can't inherit the cost centre stack from their
+-- (static) allocation site.
+checkNoCurrentCCS
+    :: (OutputablePass a, BinderP a ~ Id)
+    => GenStgRhs a
+    -> LintM ()
+checkNoCurrentCCS rhs@(StgRhsClosure _ ccs _ _ _)
+  | isCurrentCCS ccs
+  = addErrL (text "Top-level StgRhsClosure with CurrentCCS" $$ ppr rhs)
+checkNoCurrentCCS rhs@(StgRhsCon ccs _ _)
+  | isCurrentCCS ccs
+  = addErrL (text "Top-level StgRhsCon with CurrentCCS" $$ ppr rhs)
+checkNoCurrentCCS _
+  = return ()
+
+lintStgRhs :: (OutputablePass a, BinderP a ~ Id) => GenStgRhs a -> LintM ()
+
+lintStgRhs (StgRhsClosure _ _ _ [] expr)
+  = lintStgExpr expr
+
+lintStgRhs (StgRhsClosure _ _ _ binders expr)
+  = addLoc (LambdaBodyOf binders) $
+      addInScopeVars binders $
+        lintStgExpr expr
+
+lintStgRhs rhs@(StgRhsCon _ con args) = do
+    when (isUnboxedTupleCon con || isUnboxedSumCon con) $
+      addErrL (text "StgRhsCon is an unboxed tuple or sum application" $$
+               ppr rhs)
+    mapM_ lintStgArg args
+    mapM_ checkPostUnariseConArg args
+
+lintStgExpr :: (OutputablePass a, BinderP a ~ Id) => GenStgExpr a -> LintM ()
+
+lintStgExpr (StgLit _) = return ()
+
+lintStgExpr (StgApp fun args) = do
+    lintStgVar fun
+    mapM_ lintStgArg args
+
+lintStgExpr app@(StgConApp con args _arg_tys) = do
+    -- unboxed sums should vanish during unarise
+    lf <- getLintFlags
+    when (lf_unarised lf && isUnboxedSumCon con) $
+      addErrL (text "Unboxed sum after unarise:" $$
+               ppr app)
+    mapM_ lintStgArg args
+    mapM_ checkPostUnariseConArg args
+
+lintStgExpr (StgOpApp _ args _) =
+    mapM_ lintStgArg args
+
+lintStgExpr lam@(StgLam _ _) =
+    addErrL (text "Unexpected StgLam" <+> ppr lam)
+
+lintStgExpr (StgLet _ binds body) = do
+    binders <- lintStgBinds NotTopLevel binds
+    addLoc (BodyOfLetRec binders) $
+      addInScopeVars binders $
+        lintStgExpr body
+
+lintStgExpr (StgLetNoEscape _ binds body) = do
+    binders <- lintStgBinds NotTopLevel binds
+    addLoc (BodyOfLetRec binders) $
+      addInScopeVars binders $
+        lintStgExpr body
+
+lintStgExpr (StgTick _ expr) = lintStgExpr expr
+
+lintStgExpr (StgCase scrut bndr alts_type alts) = do
+    lintStgExpr scrut
+
+    lf <- getLintFlags
+    let in_scope = stgCaseBndrInScope alts_type (lf_unarised lf)
+
+    addInScopeVars [bndr | in_scope] (mapM_ lintAlt alts)
+
+lintAlt
+    :: (OutputablePass a, BinderP a ~ Id)
+    => (AltCon, [Id], GenStgExpr a) -> LintM ()
+
+lintAlt (DEFAULT, _, rhs) =
+    lintStgExpr rhs
+
+lintAlt (LitAlt _, _, rhs) =
+    lintStgExpr rhs
+
+lintAlt (DataAlt _, bndrs, rhs) = do
+    mapM_ checkPostUnariseBndr bndrs
+    addInScopeVars bndrs (lintStgExpr rhs)
+
+{-
+************************************************************************
+*                                                                      *
+Utilities
+*                                                                      *
+************************************************************************
+-}
+
+bindersOf :: BinderP a ~ Id => GenStgBinding a -> [Id]
+bindersOf (StgNonRec binder _) = [binder]
+bindersOf (StgRec pairs)       = [binder | (binder, _) <- pairs]
+
+bindersOfTop :: BinderP a ~ Id => GenStgTopBinding a -> [Id]
+bindersOfTop (StgTopLifted bind) = bindersOf bind
+bindersOfTop (StgTopStringLit binder _) = [binder]
+
+bindersOfTopBinds :: BinderP a ~ Id => [GenStgTopBinding a] -> [Id]
+bindersOfTopBinds = foldr ((++) . bindersOfTop) []
+
+{-
+************************************************************************
+*                                                                      *
+The Lint monad
+*                                                                      *
+************************************************************************
+-}
+
+newtype LintM a = LintM
+    { unLintM :: Module
+              -> LintFlags
+              -> [LintLocInfo]     -- Locations
+              -> IdSet             -- Local vars in scope
+              -> Bag MsgDoc        -- Error messages so far
+              -> (a, Bag MsgDoc)   -- Result and error messages (if any)
+    }
+    deriving (Functor)
+
+data LintFlags = LintFlags { lf_unarised :: !Bool
+                             -- ^ have we run the unariser yet?
+                           }
+
+data LintLocInfo
+  = RhsOf Id            -- The variable bound
+  | LambdaBodyOf [Id]   -- The lambda-binder
+  | BodyOfLetRec [Id]   -- One of the binders
+
+dumpLoc :: LintLocInfo -> (SrcSpan, SDoc)
+dumpLoc (RhsOf v) =
+  (srcLocSpan (getSrcLoc v), text " [RHS of " <> pp_binders [v] <> char ']' )
+dumpLoc (LambdaBodyOf bs) =
+  (srcLocSpan (getSrcLoc (head bs)), text " [in body of lambda with binders " <> pp_binders bs <> char ']' )
+
+dumpLoc (BodyOfLetRec bs) =
+  (srcLocSpan (getSrcLoc (head bs)), text " [in body of letrec with binders " <> pp_binders bs <> char ']' )
+
+
+pp_binders :: [Id] -> SDoc
+pp_binders bs
+  = sep (punctuate comma (map pp_binder bs))
+  where
+    pp_binder b
+      = hsep [ppr b, dcolon, ppr (idType b)]
+
+initL :: Module -> Bool -> IdSet -> LintM a -> Maybe MsgDoc
+initL this_mod unarised locals (LintM m) = do
+  let (_, errs) = m this_mod (LintFlags unarised) [] locals emptyBag
+  if isEmptyBag errs then
+      Nothing
+  else
+      Just (vcat (punctuate blankLine (bagToList errs)))
+
+instance Applicative LintM where
+      pure a = LintM $ \_mod _lf _loc _scope errs -> (a, errs)
+      (<*>) = ap
+      (*>)  = thenL_
+
+instance Monad LintM where
+    (>>=) = thenL
+    (>>)  = (*>)
+
+thenL :: LintM a -> (a -> LintM b) -> LintM b
+thenL m k = LintM $ \mod lf loc scope errs
+  -> case unLintM m mod lf loc scope errs of
+      (r, errs') -> unLintM (k r) mod lf loc scope errs'
+
+thenL_ :: LintM a -> LintM b -> LintM b
+thenL_ m k = LintM $ \mod lf loc scope errs
+  -> case unLintM m mod lf loc scope errs of
+      (_, errs') -> unLintM k mod lf loc scope errs'
+
+checkL :: Bool -> MsgDoc -> LintM ()
+checkL True  _   = return ()
+checkL False msg = addErrL msg
+
+-- Case alts shouldn't have unboxed sum, unboxed tuple, or void binders.
+checkPostUnariseBndr :: Id -> LintM ()
+checkPostUnariseBndr bndr = do
+    lf <- getLintFlags
+    when (lf_unarised lf) $
+      forM_ (checkPostUnariseId bndr) $ \unexpected ->
+        addErrL $
+          text "After unarisation, binder " <>
+          ppr bndr <> text " has " <> text unexpected <> text " type " <>
+          ppr (idType bndr)
+
+-- Arguments shouldn't have sum, tuple, or void types.
+checkPostUnariseConArg :: StgArg -> LintM ()
+checkPostUnariseConArg arg = case arg of
+    StgLitArg _ ->
+      return ()
+    StgVarArg id -> do
+      lf <- getLintFlags
+      when (lf_unarised lf) $
+        forM_ (checkPostUnariseId id) $ \unexpected ->
+          addErrL $
+            text "After unarisation, arg " <>
+            ppr id <> text " has " <> text unexpected <> text " type " <>
+            ppr (idType id)
+
+-- Post-unarisation args and case alt binders should not have unboxed tuple,
+-- unboxed sum, or void types. Return what the binder is if it is one of these.
+checkPostUnariseId :: Id -> Maybe String
+checkPostUnariseId id =
+    let
+      id_ty = idType id
+      is_sum, is_tuple, is_void :: Maybe String
+      is_sum = guard (isUnboxedSumType id_ty) >> return "unboxed sum"
+      is_tuple = guard (isUnboxedTupleType id_ty) >> return "unboxed tuple"
+      is_void = guard (isVoidTy id_ty) >> return "void"
+    in
+      is_sum <|> is_tuple <|> is_void
+
+addErrL :: MsgDoc -> LintM ()
+addErrL msg = LintM $ \_mod _lf loc _scope errs -> ((), addErr errs msg loc)
+
+addErr :: Bag MsgDoc -> MsgDoc -> [LintLocInfo] -> Bag MsgDoc
+addErr errs_so_far msg locs
+  = errs_so_far `snocBag` mk_msg locs
+  where
+    mk_msg (loc:_) = let (l,hdr) = dumpLoc loc
+                     in  mkLocMessage SevWarning l (hdr $$ msg)
+    mk_msg []      = msg
+
+addLoc :: LintLocInfo -> LintM a -> LintM a
+addLoc extra_loc m = LintM $ \mod lf loc scope errs
+   -> unLintM m mod lf (extra_loc:loc) scope errs
+
+addInScopeVars :: [Id] -> LintM a -> LintM a
+addInScopeVars ids m = LintM $ \mod lf loc scope errs
+ -> let
+        new_set = mkVarSet ids
+    in unLintM m mod lf loc (scope `unionVarSet` new_set) errs
+
+getLintFlags :: LintM LintFlags
+getLintFlags = LintM $ \_mod lf _loc _scope errs -> (lf, errs)
+
+checkInScope :: Id -> LintM ()
+checkInScope id = LintM $ \mod _lf loc scope errs
+ -> if nameIsLocalOrFrom mod (idName id) && not (id `elemVarSet` scope) then
+        ((), addErr errs (hsep [ppr id, dcolon, ppr (idType id),
+                                text "is out of scope"]) loc)
+    else
+        ((), errs)
+
+mkUnliftedTyMsg :: OutputablePass a => Id -> GenStgRhs a -> SDoc
+mkUnliftedTyMsg binder rhs
+  = (text "Let(rec) binder" <+> quotes (ppr binder) <+>
+     text "has unlifted type" <+> quotes (ppr (idType binder)))
+    $$
+    (text "RHS:" <+> ppr rhs)
diff --git a/compiler/GHC/Stg/Pipeline.hs b/compiler/GHC/Stg/Pipeline.hs
new file mode 100644
index 0000000000..13b403fc53
--- /dev/null
+++ b/compiler/GHC/Stg/Pipeline.hs
@@ -0,0 +1,141 @@
+{-
+(c) The GRASP/AQUA Project, Glasgow University, 1993-1998
+
+\section[SimplStg]{Driver for simplifying @STG@ programs}
+-}
+
+{-# LANGUAGE CPP #-}
+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
+{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE TypeFamilies #-}
+
+module GHC.Stg.Pipeline ( stg2stg ) where
+
+#include "HsVersions.h"
+
+import GhcPrelude
+
+import GHC.Stg.Syntax
+
+import GHC.Stg.Lint     ( lintStgTopBindings )
+import GHC.Stg.Stats    ( showStgStats )
+import GHC.Stg.Unarise  ( unarise )
+import GHC.Stg.CSE      ( stgCse )
+import GHC.Stg.Lift     ( stgLiftLams )
+import Module           ( Module )
+
+import DynFlags
+import ErrUtils
+import UniqSupply
+import Outputable
+import Control.Monad
+import Control.Monad.IO.Class
+import Control.Monad.Trans.State.Strict
+
+newtype StgM a = StgM { _unStgM :: StateT Char IO a }
+  deriving (Functor, Applicative, Monad, MonadIO)
+
+instance MonadUnique StgM where
+  getUniqueSupplyM = StgM $ do { mask <- get
+                               ; liftIO $! mkSplitUniqSupply mask}
+  getUniqueM = StgM $ do { mask <- get
+                         ; liftIO $! uniqFromMask mask}
+
+runStgM :: Char -> StgM a -> IO a
+runStgM mask (StgM m) = evalStateT m mask
+
+stg2stg :: DynFlags                  -- includes spec of what stg-to-stg passes to do
+        -> Module                    -- module being compiled
+        -> [StgTopBinding]           -- input program
+        -> IO [StgTopBinding]        -- output program
+
+stg2stg dflags this_mod binds
+  = do  { dump_when Opt_D_dump_stg "STG:" binds
+        ; showPass dflags "Stg2Stg"
+        -- Do the main business!
+        ; binds' <- runStgM 'g' $
+            foldM do_stg_pass binds (getStgToDo dflags)
+
+        ; dump_when Opt_D_dump_stg_final "Final STG:" binds'
+
+        ; return binds'
+   }
+
+  where
+    stg_linter unarised
+      | gopt Opt_DoStgLinting dflags
+      = lintStgTopBindings dflags this_mod unarised
+      | otherwise
+      = \ _whodunnit _binds -> return ()
+
+    -------------------------------------------
+    do_stg_pass :: [StgTopBinding] -> StgToDo -> StgM [StgTopBinding]
+    do_stg_pass binds to_do
+      = case to_do of
+          StgDoNothing ->
+            return binds
+
+          StgStats ->
+            trace (showStgStats binds) (return binds)
+
+          StgCSE -> do
+            let binds' = {-# SCC "StgCse" #-} stgCse binds
+            end_pass "StgCse" binds'
+
+          StgLiftLams -> do
+            us <- getUniqueSupplyM
+            let binds' = {-# SCC "StgLiftLams" #-} stgLiftLams dflags us binds
+            end_pass "StgLiftLams" binds'
+
+          StgUnarise -> do
+            us <- getUniqueSupplyM
+            liftIO (stg_linter False "Pre-unarise" binds)
+            let binds' = unarise us binds
+            liftIO (dump_when Opt_D_dump_stg_unarised "Unarised STG:" binds')
+            liftIO (stg_linter True "Unarise" binds')
+            return binds'
+
+    dump_when flag header binds
+      = dumpIfSet_dyn dflags flag header FormatSTG (pprStgTopBindings binds)
+
+    end_pass what binds2
+      = liftIO $ do -- report verbosely, if required
+          dumpIfSet_dyn dflags Opt_D_verbose_stg2stg what
+            FormatSTG (vcat (map ppr binds2))
+          stg_linter False what binds2
+          return binds2
+
+-- -----------------------------------------------------------------------------
+-- StgToDo:  abstraction of stg-to-stg passes to run.
+
+-- | Optional Stg-to-Stg passes.
+data StgToDo
+  = StgCSE
+  -- ^ Common subexpression elimination
+  | StgLiftLams
+  -- ^ Lambda lifting closure variables, trading stack/register allocation for
+  -- heap allocation
+  | StgStats
+  | StgUnarise
+  -- ^ Mandatory unarise pass, desugaring unboxed tuple and sum binders
+  | StgDoNothing
+  -- ^ Useful for building up 'getStgToDo'
+  deriving Eq
+
+-- | Which Stg-to-Stg passes to run. Depends on flags, ways etc.
+getStgToDo :: DynFlags -> [StgToDo]
+getStgToDo dflags =
+  filter (/= StgDoNothing)
+    [ mandatory StgUnarise
+    -- Important that unarisation comes first
+    -- See Note [StgCse after unarisation] in GHC.Stg.CSE
+    , optional Opt_StgCSE StgCSE
+    , optional Opt_StgLiftLams StgLiftLams
+    , optional Opt_StgStats StgStats
+    ] where
+      optional opt = runWhen (gopt opt dflags)
+      mandatory = id
+
+runWhen :: Bool -> StgToDo -> StgToDo
+runWhen True todo = todo
+runWhen _    _    = StgDoNothing
diff --git a/compiler/GHC/Stg/Stats.hs b/compiler/GHC/Stg/Stats.hs
new file mode 100644
index 0000000000..c70184e60b
--- /dev/null
+++ b/compiler/GHC/Stg/Stats.hs
@@ -0,0 +1,173 @@
+{-
+(c) The GRASP/AQUA Project, Glasgow University, 1992-1998
+
+\section[StgStats]{Gathers statistical information about programs}
+
+
+The program gather statistics about
+\begin{enumerate}
+\item number of boxed cases
+\item number of unboxed cases
+\item number of let-no-escapes
+\item number of non-updatable lets
+\item number of updatable lets
+\item number of applications
+\item number of primitive applications
+\item number of closures (does not include lets bound to constructors)
+\item number of free variables in closures
+%\item number of top-level functions
+%\item number of top-level CAFs
+\item number of constructors
+\end{enumerate}
+-}
+
+{-# LANGUAGE CPP #-}
+
+module GHC.Stg.Stats ( showStgStats ) where
+
+#include "HsVersions.h"
+
+import GhcPrelude
+
+import GHC.Stg.Syntax
+
+import Id (Id)
+import Panic
+
+import Data.Map (Map)
+import qualified Data.Map as Map
+
+data CounterType
+  = Literals
+  | Applications
+  | ConstructorApps
+  | PrimitiveApps
+  | LetNoEscapes
+  | StgCases
+  | FreeVariables
+  | ConstructorBinds Bool{-True<=>top-level-}
+  | ReEntrantBinds   Bool{-ditto-}
+  | SingleEntryBinds Bool{-ditto-}
+  | UpdatableBinds   Bool{-ditto-}
+  deriving (Eq, Ord)
+
+type Count      = Int
+type StatEnv    = Map CounterType Count
+
+emptySE :: StatEnv
+emptySE = Map.empty
+
+combineSE :: StatEnv -> StatEnv -> StatEnv
+combineSE = Map.unionWith (+)
+
+combineSEs :: [StatEnv] -> StatEnv
+combineSEs = foldr combineSE emptySE
+
+countOne :: CounterType -> StatEnv
+countOne c = Map.singleton c 1
+
+{-
+************************************************************************
+*                                                                      *
+\subsection{Top-level list of bindings (a ``program'')}
+*                                                                      *
+************************************************************************
+-}
+
+showStgStats :: [StgTopBinding] -> String
+
+showStgStats prog
+  = "STG Statistics:\n\n"
+    ++ concat (map showc (Map.toList (gatherStgStats prog)))
+  where
+    showc (x,n) = (showString (s x) . shows n) "\n"
+
+    s Literals                = "Literals                   "
+    s Applications            = "Applications               "
+    s ConstructorApps         = "ConstructorApps            "
+    s PrimitiveApps           = "PrimitiveApps              "
+    s LetNoEscapes            = "LetNoEscapes               "
+    s StgCases                = "StgCases                   "
+    s FreeVariables           = "FreeVariables              "
+    s (ConstructorBinds True) = "ConstructorBinds_Top       "
+    s (ReEntrantBinds True)   = "ReEntrantBinds_Top         "
+    s (SingleEntryBinds True) = "SingleEntryBinds_Top       "
+    s (UpdatableBinds True)   = "UpdatableBinds_Top         "
+    s (ConstructorBinds _)    = "ConstructorBinds_Nested    "
+    s (ReEntrantBinds _)      = "ReEntrantBindsBinds_Nested "
+    s (SingleEntryBinds _)    = "SingleEntryBinds_Nested    "
+    s (UpdatableBinds _)      = "UpdatableBinds_Nested      "
+
+gatherStgStats :: [StgTopBinding] -> StatEnv
+gatherStgStats binds = combineSEs (map statTopBinding binds)
+
+{-
+************************************************************************
+*                                                                      *
+\subsection{Bindings}
+*                                                                      *
+************************************************************************
+-}
+
+statTopBinding :: StgTopBinding -> StatEnv
+statTopBinding (StgTopStringLit _ _) = countOne Literals
+statTopBinding (StgTopLifted bind) = statBinding True bind
+
+statBinding :: Bool -- True <=> top-level; False <=> nested
+            -> StgBinding
+            -> StatEnv
+
+statBinding top (StgNonRec b rhs)
+  = statRhs top (b, rhs)
+
+statBinding top (StgRec pairs)
+  = combineSEs (map (statRhs top) pairs)
+
+statRhs :: Bool -> (Id, StgRhs) -> StatEnv
+
+statRhs top (_, StgRhsCon _ _ _)
+  = countOne (ConstructorBinds top)
+
+statRhs top (_, StgRhsClosure _ _ u _ body)
+  = statExpr body `combineSE`
+    countOne (
+      case u of
+        ReEntrant   -> ReEntrantBinds   top
+        Updatable   -> UpdatableBinds   top
+        SingleEntry -> SingleEntryBinds top
+    )
+
+{-
+************************************************************************
+*                                                                      *
+\subsection{Expressions}
+*                                                                      *
+************************************************************************
+-}
+
+statExpr :: StgExpr -> StatEnv
+
+statExpr (StgApp _ _)     = countOne Applications
+statExpr (StgLit _)       = countOne Literals
+statExpr (StgConApp _ _ _)= countOne ConstructorApps
+statExpr (StgOpApp _ _ _) = countOne PrimitiveApps
+statExpr (StgTick _ e)    = statExpr e
+
+statExpr (StgLetNoEscape _ binds body)
+  = statBinding False{-not top-level-} binds    `combineSE`
+    statExpr body                               `combineSE`
+    countOne LetNoEscapes
+
+statExpr (StgLet _ binds body)
+  = statBinding False{-not top-level-} binds    `combineSE`
+    statExpr body
+
+statExpr (StgCase expr _ _ alts)
+  = statExpr expr       `combineSE`
+    stat_alts alts      `combineSE`
+    countOne StgCases
+  where
+    stat_alts alts
+        = combineSEs (map statExpr [ e | (_,_,e) <- alts ])
+
+statExpr (StgLam {}) = panic "statExpr StgLam"
diff --git a/compiler/GHC/Stg/Subst.hs b/compiler/GHC/Stg/Subst.hs
new file mode 100644
index 0000000000..84b9f29c3c
--- /dev/null
+++ b/compiler/GHC/Stg/Subst.hs
@@ -0,0 +1,80 @@
+{-# LANGUAGE CPP #-}
+
+module GHC.Stg.Subst where
+
+#include "HsVersions.h"
+
+import GhcPrelude
+
+import Id
+import VarEnv
+import Control.Monad.Trans.State.Strict
+import Outputable
+import Util
+
+-- | A renaming substitution from 'Id's to 'Id's. Like 'RnEnv2', but not
+-- maintaining pairs of substitutions. Like @"CoreSubst".'CoreSubst.Subst'@, but
+-- with the domain being 'Id's instead of entire 'CoreExpr'.
+data Subst = Subst InScopeSet IdSubstEnv
+
+type IdSubstEnv = IdEnv Id
+
+-- | @emptySubst = 'mkEmptySubst' 'emptyInScopeSet'@
+emptySubst :: Subst
+emptySubst = mkEmptySubst emptyInScopeSet
+
+-- | Constructs a new 'Subst' assuming the variables in the given 'InScopeSet'
+-- are in scope.
+mkEmptySubst :: InScopeSet -> Subst
+mkEmptySubst in_scope = Subst in_scope emptyVarEnv
+
+-- | Substitutes an 'Id' for another one according to the 'Subst' given in a way
+-- that avoids shadowing the 'InScopeSet', returning the result and an updated
+-- 'Subst' that should be used by subsequent substitutions.
+substBndr :: Id -> Subst -> (Id, Subst)
+substBndr id (Subst in_scope env)
+  = (new_id, Subst new_in_scope new_env)
+  where
+    new_id = uniqAway in_scope id
+    no_change = new_id == id -- in case nothing shadowed
+    new_in_scope = in_scope `extendInScopeSet` new_id
+    new_env
+      | no_change = delVarEnv env id
+      | otherwise = extendVarEnv env id new_id
+
+-- | @substBndrs = runState . traverse (state . substBndr)@
+substBndrs :: Traversable f => f Id -> Subst -> (f Id, Subst)
+substBndrs = runState . traverse (state . substBndr)
+
+-- | Substitutes an occurrence of an identifier for its counterpart recorded
+-- in the 'Subst'.
+lookupIdSubst :: HasCallStack => Id -> Subst -> Id
+lookupIdSubst id (Subst in_scope env)
+  | not (isLocalId id) = id
+  | Just id' <- lookupVarEnv env id = id'
+  | Just id' <- lookupInScope in_scope id = id'
+  | otherwise = WARN( True, text "StgSubst.lookupIdSubst" <+> ppr id $$ ppr in_scope)
+                id
+
+-- | Substitutes an occurrence of an identifier for its counterpart recorded
+-- in the 'Subst'. Does not generate a debug warning if the identifier to
+-- to substitute wasn't in scope.
+noWarnLookupIdSubst :: HasCallStack => Id -> Subst -> Id
+noWarnLookupIdSubst id (Subst in_scope env)
+  | not (isLocalId id) = id
+  | Just id' <- lookupVarEnv env id = id'
+  | Just id' <- lookupInScope in_scope id = id'
+  | otherwise = id
+
+-- | Add the 'Id' to the in-scope set and remove any existing substitutions for
+-- it.
+extendInScope :: Id -> Subst -> Subst
+extendInScope id (Subst in_scope env) = Subst (in_scope `extendInScopeSet` id) env
+
+-- | Add a substitution for an 'Id' to the 'Subst': you must ensure that the
+-- in-scope set is such that TyCoSubst Note [The substitution invariant]
+-- holds after extending the substitution like this.
+extendSubst :: Id -> Id -> Subst -> Subst
+extendSubst id new_id (Subst in_scope env)
+  = ASSERT2( new_id `elemInScopeSet` in_scope, ppr id <+> ppr new_id $$ ppr in_scope )
+    Subst in_scope (extendVarEnv env id new_id)
diff --git a/compiler/GHC/Stg/Syntax.hs b/compiler/GHC/Stg/Syntax.hs
new file mode 100644
index 0000000000..b82fea5de2
--- /dev/null
+++ b/compiler/GHC/Stg/Syntax.hs
@@ -0,0 +1,871 @@
+{-
+(c) The GRASP/AQUA Project, Glasgow University, 1992-1998
+
+Shared term graph (STG) syntax for spineless-tagless code generation
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+
+This data type represents programs just before code generation (conversion to
+@Cmm@): basically, what we have is a stylised form of @CoreSyntax@, the style
+being one that happens to be ideally suited to spineless tagless code
+generation.
+-}
+
+{-# LANGUAGE CPP #-}
+{-# LANGUAGE DataKinds #-}
+{-# LANGUAGE DeriveDataTypeable #-}
+{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
+{-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE UndecidableInstances #-}
+{-# LANGUAGE ConstraintKinds #-}
+
+module GHC.Stg.Syntax (
+        StgArg(..),
+
+        GenStgTopBinding(..), GenStgBinding(..), GenStgExpr(..), GenStgRhs(..),
+        GenStgAlt, AltType(..),
+
+        StgPass(..), BinderP, XRhsClosure, XLet, XLetNoEscape,
+        NoExtFieldSilent, noExtFieldSilent,
+        OutputablePass,
+
+        UpdateFlag(..), isUpdatable,
+
+        -- 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 for the lambda lifting parameterisation
+        LlStgTopBinding, LlStgBinding, LlStgExpr, LlStgRhs, LlStgAlt,
+
+        -- a set of synonyms to distinguish in- and out variants
+        InStgArg,  InStgTopBinding,  InStgBinding,  InStgExpr,  InStgRhs,  InStgAlt,
+        OutStgArg, OutStgTopBinding, OutStgBinding, OutStgExpr, OutStgRhs, OutStgAlt,
+
+        -- StgOp
+        StgOp(..),
+
+        -- utils
+        topStgBindHasCafRefs, stgArgHasCafRefs, stgRhsArity,
+        isDllConApp,
+        stgArgType,
+        stripStgTicksTop, stripStgTicksTopE,
+        stgCaseBndrInScope,
+
+        pprStgBinding, pprGenStgTopBindings, pprStgTopBindings
+    ) where
+
+#include "HsVersions.h"
+
+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
+import ForeignCall ( ForeignCall )
+import Id
+import IdInfo      ( mayHaveCafRefs )
+import VarSet
+import Literal     ( Literal, literalType )
+import Module      ( Module )
+import Outputable
+import Packages    ( isDllName )
+import GHC.Platform
+import PprCore     ( {- instances -} )
+import PrimOp      ( PrimOp, PrimCall )
+import TyCon       ( PrimRep(..), TyCon )
+import Type        ( Type )
+import GHC.Types.RepType     ( typePrimRep1 )
+import Util
+
+import Data.List.NonEmpty ( NonEmpty, toList )
+
+{-
+************************************************************************
+*                                                                      *
+GenStgBinding
+*                                                                      *
+************************************************************************
+
+As usual, expressions are interesting; other things are boring. Here are the
+boring things (except note the @GenStgRhs@), parameterised with respect to
+binder and occurrence information (just as in @CoreSyn@):
+-}
+
+-- | A top-level binding.
+data GenStgTopBinding pass
+-- See Note [CoreSyn top-level string literals]
+  = StgTopLifted (GenStgBinding pass)
+  | StgTopStringLit Id ByteString
+
+data GenStgBinding pass
+  = StgNonRec (BinderP pass) (GenStgRhs pass)
+  | StgRec    [(BinderP pass, GenStgRhs pass)]
+
+{-
+************************************************************************
+*                                                                      *
+StgArg
+*                                                                      *
+************************************************************************
+-}
+
+data StgArg
+  = StgVarArg  Id
+  | StgLitArg  Literal
+
+-- | Does this constructor application refer to anything in a different
+-- *Windows* DLL?
+-- If so, we can't allocate it statically
+isDllConApp :: DynFlags -> Module -> DataCon -> [StgArg] -> Bool
+isDllConApp dflags this_mod con args
+ | platformOS (targetPlatform dflags) == OSMinGW32
+    = isDllName dflags this_mod (dataConName con) || any is_dll_arg args
+ | otherwise = False
+  where
+    -- NB: typePrimRep1 is legit because any free variables won't have
+    -- unlifted type (there are no unlifted things at top level)
+    is_dll_arg :: StgArg -> Bool
+    is_dll_arg (StgVarArg v) =  isAddrRep (typePrimRep1 (idType v))
+                             && isDllName dflags this_mod (idName v)
+    is_dll_arg _             = False
+
+-- True of machine addresses; these are the things that don't work across DLLs.
+-- The key point here is that VoidRep comes out False, so that a top level
+-- nullary GADT constructor is False for isDllConApp
+--
+--    data T a where
+--      T1 :: T Int
+--
+-- gives
+--
+--    T1 :: forall a. (a~Int) -> T a
+--
+-- and hence the top-level binding
+--
+--    $WT1 :: T Int
+--    $WT1 = T1 Int (Coercion (Refl Int))
+--
+-- The coercion argument here gets VoidRep
+isAddrRep :: PrimRep -> Bool
+isAddrRep AddrRep     = True
+isAddrRep LiftedRep   = True
+isAddrRep UnliftedRep = True
+isAddrRep _           = False
+
+-- | Type of an @StgArg@
+--
+-- Very half baked because we have lost the type arguments.
+stgArgType :: StgArg -> Type
+stgArgType (StgVarArg v)   = idType v
+stgArgType (StgLitArg lit) = literalType lit
+
+
+-- | Strip ticks of a given type from an STG expression.
+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)
+
+-- | Strip ticks of a given type from an STG expression returning only the expression.
+stripStgTicksTopE :: (Tickish Id -> Bool) -> GenStgExpr p -> GenStgExpr p
+stripStgTicksTopE p = go
+   where go (StgTick t e) | p t = go e
+         go other               = other
+
+-- | Given an alt type and whether the program is unarised, return whether the
+-- case binder is in scope.
+--
+-- Case binders of unboxed tuple or unboxed sum type always dead after the
+-- unariser has run. See Note [Post-unarisation invariants].
+stgCaseBndrInScope :: AltType -> Bool {- ^ unarised? -} -> Bool
+stgCaseBndrInScope alt_ty unarised =
+    case alt_ty of
+      AlgAlt _      -> True
+      PrimAlt _     -> True
+      MultiValAlt _ -> not unarised
+      PolyAlt       -> True
+
+{-
+************************************************************************
+*                                                                      *
+STG expressions
+*                                                                      *
+************************************************************************
+
+The @GenStgExpr@ data type is parameterised on binder and occurrence info, as
+before.
+
+************************************************************************
+*                                                                      *
+GenStgExpr
+*                                                                      *
+************************************************************************
+
+An application is of a function to a list of atoms (not expressions).
+Operationally, we want to push the arguments on the stack and call the function.
+(If the arguments were expressions, we would have to build their closures
+first.)
+
+There is no constructor for a lone variable; it would appear as @StgApp var []@.
+-}
+
+data GenStgExpr pass
+  = StgApp
+        Id       -- function
+        [StgArg] -- arguments; may be empty
+
+{-
+************************************************************************
+*                                                                      *
+StgConApp and StgPrimApp --- saturated applications
+*                                                                      *
+************************************************************************
+
+There are specialised forms of application, for constructors, primitives, and
+literals.
+-}
+
+  | StgLit      Literal
+
+        -- StgConApp is vital for returning unboxed tuples or sums
+        -- which can't be let-bound
+  | StgConApp   DataCon
+                [StgArg] -- Saturated
+                [Type]   -- See Note [Types in StgConApp] in GHC.Stg.Unarise
+
+  | StgOpApp    StgOp    -- Primitive op or foreign call
+                [StgArg] -- Saturated.
+                Type     -- Result type
+                         -- We need to know this so that we can
+                         -- assign result registers
+
+{-
+************************************************************************
+*                                                                      *
+StgLam
+*                                                                      *
+************************************************************************
+
+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 (BinderP pass))
+        StgExpr    -- Body of lambda
+
+{-
+************************************************************************
+*                                                                      *
+GenStgExpr: case-expressions
+*                                                                      *
+************************************************************************
+
+This has the same boxed/unboxed business as Core case expressions.
+-}
+
+  | StgCase
+        (GenStgExpr pass) -- the thing to examine
+        (BinderP pass) -- binds the result of evaluating the scrutinee
+        AltType
+        [GenStgAlt pass]
+                    -- The DEFAULT case is always *first*
+                    -- if it is there at all
+
+{-
+************************************************************************
+*                                                                      *
+GenStgExpr: let(rec)-expressions
+*                                                                      *
+************************************************************************
+
+The various forms of let(rec)-expression encode most of the interesting things
+we want to do.
+
+-   let-closure x = [free-vars] [args] expr in e
+
+  is equivalent to
+
+    let x = (\free-vars -> \args -> expr) free-vars
+
+  @args@ may be empty (and is for most closures). It isn't under circumstances
+  like this:
+
+    let x = (\y -> y+z)
+
+  This gets mangled to
+
+    let-closure x = [z] [y] (y+z)
+
+  The idea is that we compile code for @(y+z)@ in an environment in which @z@ is
+  bound to an offset from Node, and `y` is bound to an offset from the stack
+  pointer.
+
+  (A let-closure is an @StgLet@ with a @StgRhsClosure@ RHS.)
+
+-   let-constructor x = Constructor [args] in e
+
+  (A let-constructor is an @StgLet@ with a @StgRhsCon@ RHS.)
+
+- Letrec-expressions are essentially the same deal as let-closure/
+  let-constructor, so we use a common structure and distinguish between them
+  with an @is_recursive@ boolean flag.
+
+-   let-unboxed u = <an arbitrary arithmetic expression in unboxed values> in e
+
+  All the stuff on the RHS must be fully evaluated. No function calls either!
+
+  (We've backed away from this toward case-expressions with suitably-magical
+  alts ...)
+
+- Advanced stuff here! Not to start with, but makes pattern matching generate
+  more efficient code.
+
+    let-escapes-not fail = expr
+    in e'
+
+  Here the idea is that @e'@ guarantees not to put @fail@ in a data structure,
+  or pass it to another function. All @e'@ will ever do is tail-call @fail@.
+  Rather than build a closure for @fail@, all we need do is to record the stack
+  level at the moment of the @let-escapes-not@; then entering @fail@ is just a
+  matter of adjusting the stack pointer back down to that point and entering the
+  code for it.
+
+  Another example:
+
+    f x y = let z = huge-expression in
+            if y==1 then z else
+            if y==2 then z else
+            1
+
+  (A let-escapes-not is an @StgLetNoEscape@.)
+
+- We may eventually want:
+
+    let-literal x = Literal in e
+
+And so the code for let(rec)-things:
+-}
+
+  | StgLet
+        (XLet pass)
+        (GenStgBinding pass)    -- right hand sides (see below)
+        (GenStgExpr pass)       -- body
+
+  | StgLetNoEscape
+        (XLetNoEscape pass)
+        (GenStgBinding pass)    -- right hand sides (see below)
+        (GenStgExpr pass)       -- body
+
+{-
+*************************************************************************
+*                                                                      *
+GenStgExpr: hpc, scc and other debug annotations
+*                                                                      *
+*************************************************************************
+
+Finally for @hpc@ expressions we introduce a new STG construct.
+-}
+
+  | StgTick
+    (Tickish Id)
+    (GenStgExpr pass)       -- sub expression
+
+-- END of GenStgExpr
+
+{-
+************************************************************************
+*                                                                      *
+STG right-hand sides
+*                                                                      *
+************************************************************************
+
+Here's the rest of the interesting stuff for @StgLet@s; the first flavour is for
+closures:
+-}
+
+data GenStgRhs pass
+  = StgRhsClosure
+        (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'
+        [BinderP pass]     -- ^ arguments; if empty, then not a function;
+                           --   as above, order is important.
+        (GenStgExpr pass)  -- ^ body
+
+{-
+An example may be in order.  Consider:
+
+  let t = \x -> \y -> ... x ... y ... p ... q in e
+
+Pulling out the free vars and stylising somewhat, we get the equivalent:
+
+  let t = (\[p,q] -> \[x,y] -> ... x ... y ... p ...q) p q
+
+Stg-operationally, the @[x,y]@ are on the stack, the @[p,q]@ are offsets from
+@Node@ into the closure, and the code ptr for the closure will be exactly that
+in parentheses above.
+
+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.
+        [StgArg]        -- Args
+
+-- | Used as a data type index for the stgSyn AST
+data StgPass
+  = Vanilla
+  | LiftLams
+  | CodeGen
+
+-- | Like 'GHC.Hs.Extension.NoExtField', but with an 'Outputable' instance that
+-- returns 'empty'.
+data NoExtFieldSilent = NoExtFieldSilent
+  deriving (Data, Eq, Ord)
+
+instance Outputable NoExtFieldSilent where
+  ppr _ = empty
+
+-- | Used when constructing a term with an unused extension point that should
+-- not appear in pretty-printed output at all.
+noExtFieldSilent :: NoExtFieldSilent
+noExtFieldSilent = NoExtFieldSilent
+-- TODO: Maybe move this to GHC.Hs.Extension? I'm not sure about the
+-- implications on build time...
+
+-- TODO: Do we really want to the extension point type families to have a closed
+-- domain?
+type family BinderP (pass :: StgPass)
+type instance BinderP 'Vanilla = Id
+type instance BinderP 'CodeGen = Id
+
+type family XRhsClosure (pass :: StgPass)
+type instance XRhsClosure 'Vanilla = NoExtFieldSilent
+-- | Code gen needs to track non-global free vars
+type instance XRhsClosure 'CodeGen = DIdSet
+
+type family XLet (pass :: StgPass)
+type instance XLet 'Vanilla = NoExtFieldSilent
+type instance XLet 'CodeGen = NoExtFieldSilent
+
+type family XLetNoEscape (pass :: StgPass)
+type instance XLetNoEscape 'Vanilla = NoExtFieldSilent
+type instance XLetNoEscape 'CodeGen = NoExtFieldSilent
+
+stgRhsArity :: StgRhs -> Int
+stgRhsArity (StgRhsClosure _ _ _ bndrs _)
+  = ASSERT( all isId bndrs ) length bndrs
+  -- The arity never includes type parameters, but they should have gone by now
+stgRhsArity (StgRhsCon _ _ _) = 0
+
+-- Note [CAF consistency]
+-- ~~~~~~~~~~~~~~~~~~~~~~
+--
+-- `topStgBindHasCafRefs` is only used by an assert (`consistentCafInfo` in
+-- `CoreToStg`) to make sure CAF-ness predicted by `TidyPgm` is consistent with
+-- reality.
+--
+-- Specifically, if the RHS mentions any Id that itself is marked
+-- `MayHaveCafRefs`; or if the binding is a top-level updateable thunk; then the
+-- `Id` for the binding should be marked `MayHaveCafRefs`. The potential trouble
+-- is that `TidyPgm` computed the CAF info on the `Id` but some transformations
+-- have taken place since then.
+
+topStgBindHasCafRefs :: GenStgTopBinding pass -> Bool
+topStgBindHasCafRefs (StgTopLifted (StgNonRec _ rhs))
+  = topRhsHasCafRefs rhs
+topStgBindHasCafRefs (StgTopLifted (StgRec binds))
+  = any topRhsHasCafRefs (map snd binds)
+topStgBindHasCafRefs StgTopStringLit{}
+  = False
+
+topRhsHasCafRefs :: GenStgRhs pass -> Bool
+topRhsHasCafRefs (StgRhsClosure _ _ upd _ body)
+  = -- See Note [CAF consistency]
+    isUpdatable upd || exprHasCafRefs body
+topRhsHasCafRefs (StgRhsCon _ _ args)
+  = any stgArgHasCafRefs args
+
+exprHasCafRefs :: GenStgExpr pass -> Bool
+exprHasCafRefs (StgApp f args)
+  = stgIdHasCafRefs f || any stgArgHasCafRefs args
+exprHasCafRefs StgLit{}
+  = False
+exprHasCafRefs (StgConApp _ args _)
+  = any stgArgHasCafRefs args
+exprHasCafRefs (StgOpApp _ args _)
+  = any stgArgHasCafRefs args
+exprHasCafRefs (StgLam _ body)
+  = exprHasCafRefs body
+exprHasCafRefs (StgCase scrt _ _ alts)
+  = exprHasCafRefs scrt || any altHasCafRefs alts
+exprHasCafRefs (StgLet _ bind body)
+  = bindHasCafRefs bind || exprHasCafRefs body
+exprHasCafRefs (StgLetNoEscape _ bind body)
+  = bindHasCafRefs bind || exprHasCafRefs body
+exprHasCafRefs (StgTick _ expr)
+  = exprHasCafRefs expr
+
+bindHasCafRefs :: GenStgBinding pass -> Bool
+bindHasCafRefs (StgNonRec _ rhs)
+  = rhsHasCafRefs rhs
+bindHasCafRefs (StgRec binds)
+  = any rhsHasCafRefs (map snd binds)
+
+rhsHasCafRefs :: GenStgRhs pass -> Bool
+rhsHasCafRefs (StgRhsClosure _ _ _ _ body)
+  = exprHasCafRefs body
+rhsHasCafRefs (StgRhsCon _ _ args)
+  = any stgArgHasCafRefs args
+
+altHasCafRefs :: GenStgAlt pass -> Bool
+altHasCafRefs (_, _, rhs) = exprHasCafRefs rhs
+
+stgArgHasCafRefs :: StgArg -> Bool
+stgArgHasCafRefs (StgVarArg id)
+  = stgIdHasCafRefs id
+stgArgHasCafRefs _
+  = False
+
+stgIdHasCafRefs :: Id -> Bool
+stgIdHasCafRefs id =
+  -- We are looking for occurrences of an Id that is bound at top level, and may
+  -- have CAF refs. At this point (after TidyPgm) top-level Ids (whether
+  -- imported or defined in this module) are GlobalIds, so the test is easy.
+  isGlobalId id && mayHaveCafRefs (idCafInfo id)
+
+{-
+************************************************************************
+*                                                                      *
+STG case alternatives
+*                                                                      *
+************************************************************************
+
+Very like in @CoreSyntax@ (except no type-world stuff).
+
+The type constructor is guaranteed not to be abstract; that is, we can see its
+representation. This is important because the code generator uses it to
+determine return conventions etc. But it's not trivial where there's a module
+loop involved, because some versions of a type constructor might not have all
+the constructors visible. So mkStgAlgAlts (in CoreToStg) ensures that it gets
+the TyCon from the constructors or literals (which are guaranteed to have the
+Real McCoy) rather than from the scrutinee type.
+-}
+
+type GenStgAlt pass
+  = (AltCon,          -- alts: data constructor,
+     [BinderP pass],  -- constructor's parameters,
+     GenStgExpr pass) -- ...right-hand side.
+
+data AltType
+  = PolyAlt             -- Polymorphic (a lifted type variable)
+  | MultiValAlt Int     -- Multi value of this arity (unboxed tuple or sum)
+                        -- the arity could indeed be 1 for unary unboxed tuple
+                        -- or enum-like unboxed sums
+  | AlgAlt      TyCon   -- Algebraic data type; the AltCons will be DataAlts
+  | PrimAlt     PrimRep -- Primitive data type; the AltCons (if any) will be LitAlts
+
+{-
+************************************************************************
+*                                                                      *
+The Plain STG parameterisation
+*                                                                      *
+************************************************************************
+
+This happens to be the only one we use at the moment.
+-}
+
+type StgTopBinding = GenStgTopBinding 'Vanilla
+type StgBinding    = GenStgBinding    'Vanilla
+type StgExpr       = GenStgExpr       'Vanilla
+type StgRhs        = GenStgRhs        'Vanilla
+type StgAlt        = GenStgAlt        'Vanilla
+
+type LlStgTopBinding = GenStgTopBinding 'LiftLams
+type LlStgBinding    = GenStgBinding    'LiftLams
+type LlStgExpr       = GenStgExpr       'LiftLams
+type LlStgRhs        = GenStgRhs        'LiftLams
+type LlStgAlt        = GenStgAlt        'LiftLams
+
+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.
+   See CoreSyn for precedence in Core land
+-}
+
+type InStgTopBinding  = StgTopBinding
+type InStgBinding     = StgBinding
+type InStgArg         = StgArg
+type InStgExpr        = StgExpr
+type InStgRhs         = StgRhs
+type InStgAlt         = StgAlt
+type OutStgTopBinding = StgTopBinding
+type OutStgBinding    = StgBinding
+type OutStgArg        = StgArg
+type OutStgExpr       = StgExpr
+type OutStgRhs        = StgRhs
+type OutStgAlt        = StgAlt
+
+{-
+
+************************************************************************
+*                                                                      *
+UpdateFlag
+*                                                                      *
+************************************************************************
+
+This is also used in @LambdaFormInfo@ in the @ClosureInfo@ module.
+
+A @ReEntrant@ closure may be entered multiple times, but should not be updated
+or blackholed. An @Updatable@ closure should be updated after evaluation (and
+may be blackholed during evaluation). A @SingleEntry@ closure will only be
+entered once, and so need not be updated but may safely be blackholed.
+-}
+
+data UpdateFlag = ReEntrant | Updatable | SingleEntry
+
+instance Outputable UpdateFlag where
+    ppr u = char $ case u of
+                       ReEntrant   -> 'r'
+                       Updatable   -> 'u'
+                       SingleEntry -> 's'
+
+isUpdatable :: UpdateFlag -> Bool
+isUpdatable ReEntrant   = False
+isUpdatable SingleEntry = False
+isUpdatable Updatable   = True
+
+{-
+************************************************************************
+*                                                                      *
+StgOp
+*                                                                      *
+************************************************************************
+
+An StgOp allows us to group together PrimOps and ForeignCalls. It's quite useful
+to move these around together, notably in StgOpApp and COpStmt.
+-}
+
+data StgOp
+  = StgPrimOp  PrimOp
+
+  | StgPrimCallOp PrimCall
+
+  | StgFCallOp ForeignCall Type
+        -- The Type, which is obtained from the foreign import declaration
+        -- itself, is needed by the stg-to-cmm pass to determine the offset to
+        -- apply to unlifted boxed arguments in GHC.StgToCmm.Foreign. See Note
+        -- [Unlifted boxed arguments to foreign calls]
+
+{-
+************************************************************************
+*                                                                      *
+Pretty-printing
+*                                                                      *
+************************************************************************
+
+Robin Popplestone asked for semi-colon separators on STG binds; here's hoping he
+likes terminators instead...  Ditto for case alternatives.
+-}
+
+type OutputablePass pass =
+  ( Outputable (XLet pass)
+  , Outputable (XLetNoEscape pass)
+  , Outputable (XRhsClosure pass)
+  , OutputableBndr (BinderP pass)
+  )
+
+pprGenStgTopBinding
+  :: OutputablePass pass => GenStgTopBinding pass -> SDoc
+pprGenStgTopBinding (StgTopStringLit bndr str)
+  = hang (hsep [pprBndr LetBind bndr, equals])
+        4 (pprHsBytes str <> semi)
+pprGenStgTopBinding (StgTopLifted bind)
+  = pprGenStgBinding bind
+
+pprGenStgBinding
+  :: OutputablePass pass => GenStgBinding pass -> SDoc
+
+pprGenStgBinding (StgNonRec bndr rhs)
+  = hang (hsep [pprBndr LetBind bndr, equals])
+        4 (ppr rhs <> semi)
+
+pprGenStgBinding (StgRec pairs)
+  = vcat [ text "Rec {"
+         , vcat (intersperse blankLine (map ppr_bind pairs))
+         , text "end Rec }" ]
+  where
+    ppr_bind (bndr, expr)
+      = hang (hsep [pprBndr LetBind bndr, equals])
+             4 (ppr expr <> semi)
+
+pprGenStgTopBindings
+  :: (OutputablePass pass) => [GenStgTopBinding pass] -> SDoc
+pprGenStgTopBindings binds
+  = vcat $ intersperse blankLine (map pprGenStgTopBinding binds)
+
+pprStgBinding :: StgBinding -> SDoc
+pprStgBinding = pprGenStgBinding
+
+pprStgTopBindings :: [StgTopBinding] -> SDoc
+pprStgTopBindings = pprGenStgTopBindings
+
+instance Outputable StgArg where
+    ppr = pprStgArg
+
+instance OutputablePass pass => Outputable (GenStgTopBinding pass) where
+    ppr = pprGenStgTopBinding
+
+instance OutputablePass pass => Outputable (GenStgBinding pass) where
+    ppr = pprGenStgBinding
+
+instance OutputablePass pass => Outputable (GenStgExpr pass) where
+    ppr = pprStgExpr
+
+instance OutputablePass pass => Outputable (GenStgRhs pass) where
+    ppr rhs = pprStgRhs rhs
+
+pprStgArg :: StgArg -> SDoc
+pprStgArg (StgVarArg var) = ppr var
+pprStgArg (StgLitArg con) = ppr con
+
+pprStgExpr :: OutputablePass pass => GenStgExpr pass -> SDoc
+-- special case
+pprStgExpr (StgLit lit)     = ppr lit
+
+-- general case
+pprStgExpr (StgApp func args)
+  = hang (ppr func) 4 (sep (map (ppr) args))
+
+pprStgExpr (StgConApp con args _)
+  = hsep [ ppr con, brackets (interppSP args) ]
+
+pprStgExpr (StgOpApp op args _)
+  = hsep [ pprStgOp op, brackets (interppSP args)]
+
+pprStgExpr (StgLam bndrs body)
+  = sep [ char '\\' <+> ppr_list (map (pprBndr LambdaBind) (toList bndrs))
+            <+> text "->",
+         pprStgExpr body ]
+  where ppr_list = brackets . fsep . punctuate comma
+
+-- special case: let v = <very specific thing>
+--               in
+--               let ...
+--               in
+--               ...
+--
+-- Very special!  Suspicious! (SLPJ)
+
+{-
+pprStgExpr (StgLet srt (StgNonRec bndr (StgRhsClosure cc bi free_vars upd_flag args rhs))
+                        expr@(StgLet _ _))
+  = ($$)
+      (hang (hcat [text "let { ", ppr bndr, ptext (sLit " = "),
+                          ppr cc,
+                          pp_binder_info bi,
+                          text " [", whenPprDebug (interppSP free_vars), ptext (sLit "] \\"),
+                          ppr upd_flag, text " [",
+                          interppSP args, char ']'])
+            8 (sep [hsep [ppr rhs, text "} in"]]))
+      (ppr expr)
+-}
+
+-- special case: let ... in let ...
+
+pprStgExpr (StgLet ext bind expr@StgLet{})
+  = ($$)
+      (sep [hang (text "let" <+> ppr ext <+> text "{")
+                2 (hsep [pprGenStgBinding bind, text "} in"])])
+      (ppr expr)
+
+-- general case
+pprStgExpr (StgLet ext bind expr)
+  = sep [hang (text "let" <+> ppr ext <+> text "{") 2 (pprGenStgBinding bind),
+           hang (text "} in ") 2 (ppr expr)]
+
+pprStgExpr (StgLetNoEscape ext bind expr)
+  = sep [hang (text "let-no-escape" <+> ppr ext <+> text "{")
+                2 (pprGenStgBinding bind),
+           hang (text "} in ")
+                2 (ppr expr)]
+
+pprStgExpr (StgTick tickish expr)
+  = sdocWithDynFlags $ \dflags ->
+    if gopt Opt_SuppressTicks dflags
+    then pprStgExpr expr
+    else sep [ ppr tickish, pprStgExpr expr ]
+
+
+-- Don't indent for a single case alternative.
+pprStgExpr (StgCase expr bndr alt_type [alt])
+  = sep [sep [text "case",
+           nest 4 (hsep [pprStgExpr expr,
+             whenPprDebug (dcolon <+> ppr alt_type)]),
+           text "of", pprBndr CaseBind bndr, char '{'],
+           pprStgAlt False alt,
+           char '}']
+
+pprStgExpr (StgCase expr bndr alt_type alts)
+  = sep [sep [text "case",
+           nest 4 (hsep [pprStgExpr expr,
+             whenPprDebug (dcolon <+> ppr alt_type)]),
+           text "of", pprBndr CaseBind bndr, char '{'],
+           nest 2 (vcat (map (pprStgAlt True) alts)),
+           char '}']
+
+
+pprStgAlt :: OutputablePass pass => Bool -> GenStgAlt pass -> SDoc
+pprStgAlt indent (con, params, expr)
+  | indent    = hang altPattern 4 (ppr expr <> semi)
+  | otherwise = sep [altPattern, ppr expr <> semi]
+    where
+      altPattern = (hsep [ppr con, sep (map (pprBndr CasePatBind) params), text "->"])
+
+
+pprStgOp :: StgOp -> SDoc
+pprStgOp (StgPrimOp  op)   = ppr op
+pprStgOp (StgPrimCallOp op)= ppr op
+pprStgOp (StgFCallOp op _) = ppr op
+
+instance Outputable AltType where
+  ppr PolyAlt         = text "Polymorphic"
+  ppr (MultiValAlt n) = text "MultiAlt" <+> ppr n
+  ppr (AlgAlt tc)     = text "Alg"    <+> ppr tc
+  ppr (PrimAlt tc)    = text "Prim"   <+> ppr tc
+
+pprStgRhs :: OutputablePass pass => GenStgRhs pass -> SDoc
+
+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_SuppressStgExts dflags
+                  then ppr ext else empty,
+                char '\\' <> ppr upd_flag, brackets (interppSP args)])
+         4 (ppr body)
+
+pprStgRhs (StgRhsCon cc con args)
+  = hcat [ ppr cc,
+           space, ppr con, text "! ", brackets (interppSP args)]
diff --git a/compiler/GHC/Stg/Unarise.hs b/compiler/GHC/Stg/Unarise.hs
new file mode 100644
index 0000000000..bc2ce4cb87
--- /dev/null
+++ b/compiler/GHC/Stg/Unarise.hs
@@ -0,0 +1,769 @@
+{-
+(c) The GRASP/AQUA Project, Glasgow University, 1992-2012
+
+Note [Unarisation]
+~~~~~~~~~~~~~~~~~~
+The idea of this pass is to translate away *all* unboxed-tuple and unboxed-sum
+binders. So for example:
+
+  f (x :: (# Int, Bool #)) = f x + f (# 1, True #)
+
+  ==>
+
+  f (x1 :: Int) (x2 :: Bool) = f x1 x2 + f 1 True
+
+It is important that we do this at the STG level and NOT at the Core level
+because it would be very hard to make this pass Core-type-preserving. In this
+example the type of 'f' changes, for example.
+
+STG fed to the code generators *must* be unarised because the code generators do
+not support unboxed tuple and unboxed sum binders natively.
+
+In more detail: (see next note for unboxed sums)
+
+Suppose that a variable x : (# t1, t2 #).
+
+  * At the binding site for x, make up fresh vars  x1:t1, x2:t2
+
+  * Extend the UnariseEnv   x :-> MultiVal [x1,x2]
+
+  * Replace the binding with a curried binding for x1,x2
+
+       Lambda:   \x.e                ==>   \x1 x2. e
+       Case alt: MkT a b x c d -> e  ==>   MkT a b x1 x2 c d -> e
+
+  * Replace argument occurrences with a sequence of args via a lookup in
+    UnariseEnv
+
+       f a b x c d   ==>   f a b x1 x2 c d
+
+  * Replace tail-call occurrences with an unboxed tuple via a lookup in
+    UnariseEnv
+
+       x  ==>  (# x1, x2 #)
+
+    So, for example
+
+       f x = x    ==>   f x1 x2 = (# x1, x2 #)
+
+  * We /always/ eliminate a case expression when
+
+       - It scrutinises an unboxed tuple or unboxed sum
+
+       - The scrutinee is a variable (or when it is an explicit tuple, but the
+         simplifier eliminates those)
+
+    The case alternative (there can be only one) can be one of these two
+    things:
+
+      - An unboxed tuple pattern. e.g.
+
+          case v of x { (# x1, x2, x3 #) -> ... }
+
+        Scrutinee has to be in form `(# t1, t2, t3 #)` so we just extend the
+        environment with
+
+          x :-> MultiVal [t1,t2,t3]
+          x1 :-> UnaryVal t1, x2 :-> UnaryVal t2, x3 :-> UnaryVal t3
+
+      - A DEFAULT alternative. Just the same, without the bindings for x1,x2,x3
+
+By the end of this pass, we only have unboxed tuples in return positions.
+Unboxed sums are completely eliminated, see next note.
+
+Note [Translating unboxed sums to unboxed tuples]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Unarise also eliminates unboxed sum binders, and translates unboxed sums in
+return positions to unboxed tuples. We want to overlap fields of a sum when
+translating it to a tuple to have efficient memory layout. When translating a
+sum pattern to a tuple pattern, we need to translate it so that binders of sum
+alternatives will be mapped to right arguments after the term translation. So
+translation of sum DataCon applications to tuple DataCon applications and
+translation of sum patterns to tuple patterns need to be in sync.
+
+These translations work like this. Suppose we have
+
+  (# x1 | | ... #) :: (# t1 | t2 | ... #)
+
+remember that t1, t2 ... can be sums and tuples too. So we first generate
+layouts of those. Then we "merge" layouts of each alternative, which gives us a
+sum layout with best overlapping possible.
+
+Layout of a flat type 'ty1' is just [ty1].
+Layout of a tuple is just concatenation of layouts of its fields.
+
+For layout of a sum type,
+
+  - We first get layouts of all alternatives.
+  - We sort these layouts based on their "slot types".
+  - We merge all the alternatives.
+
+For example, say we have (# (# Int#, Char #) | (# Int#, Int# #) | Int# #)
+
+  - Layouts of alternatives: [ [Word, Ptr], [Word, Word], [Word] ]
+  - Sorted: [ [Ptr, Word], [Word, Word], [Word] ]
+  - Merge all alternatives together: [ Ptr, Word, Word ]
+
+We add a slot for the tag to the first position. So our tuple type is
+
+  (# Tag#, Any, Word#, Word# #)
+  (we use Any for pointer slots)
+
+Now, any term of this sum type needs to generate a tuple of this type instead.
+The translation works by simply putting arguments to first slots that they fit
+in. Suppose we had
+
+  (# (# 42#, 'c' #) | | #)
+
+42# fits in Word#, 'c' fits in Any, so we generate this application:
+
+  (# 1#, 'c', 42#, rubbish #)
+
+Another example using the same type: (# | (# 2#, 3# #) | #). 2# fits in Word#,
+3# fits in Word #, so we get:
+
+  (# 2#, rubbish, 2#, 3# #).
+
+Note [Types in StgConApp]
+~~~~~~~~~~~~~~~~~~~~~~~~~
+Suppose we have this unboxed sum term:
+
+  (# 123 | #)
+
+What will be the unboxed tuple representation? We can't tell without knowing the
+type of this term. For example, these are all valid tuples for this:
+
+  (# 1#, 123 #)          -- when type is (# Int | String #)
+  (# 1#, 123, rubbish #) -- when type is (# Int | Float# #)
+  (# 1#, 123, rubbish, rubbish #)
+                         -- when type is (# Int | (# Int, Int, Int #) #)
+
+So we pass type arguments of the DataCon's TyCon in StgConApp to decide what
+layout to use. Note that unlifted values can't be let-bound, so we don't need
+types in StgRhsCon.
+
+Note [UnariseEnv can map to literals]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+To avoid redundant case expressions when unarising unboxed sums, UnariseEnv
+needs to map variables to literals too. Suppose we have this Core:
+
+  f (# x | #)
+
+  ==> (CorePrep)
+
+  case (# x | #) of y {
+    _ -> f y
+  }
+
+  ==> (MultiVal)
+
+  case (# 1#, x #) of [x1, x2] {
+    _ -> f x1 x2
+  }
+
+To eliminate this case expression we need to map x1 to 1# in UnariseEnv:
+
+  x1 :-> UnaryVal 1#, x2 :-> UnaryVal x
+
+so that `f x1 x2` becomes `f 1# x`.
+
+Note [Unarisation and arity]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Because of unarisation, the arity that will be recorded in the generated info
+table for an Id may be larger than the idArity. Instead we record what we call
+the RepArity, which is the Arity taking into account any expanded arguments, and
+corresponds to the number of (possibly-void) *registers* arguments will arrive
+in.
+
+Note [Post-unarisation invariants]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+STG programs after unarisation have these invariants:
+
+  * No unboxed sums at all.
+
+  * No unboxed tuple binders. Tuples only appear in return position.
+
+  * DataCon applications (StgRhsCon and StgConApp) don't have void arguments.
+    This means that it's safe to wrap `StgArg`s of DataCon applications with
+    `GHC.StgToCmm.Env.NonVoid`, for example.
+
+  * Alt binders (binders in patterns) are always non-void.
+
+  * Binders always have zero (for void arguments) or one PrimRep.
+-}
+
+{-# LANGUAGE CPP, TupleSections #-}
+
+module GHC.Stg.Unarise (unarise) where
+
+#include "HsVersions.h"
+
+import GhcPrelude
+
+import BasicTypes
+import CoreSyn
+import DataCon
+import FastString (FastString, mkFastString)
+import Id
+import Literal
+import MkCore (aBSENT_SUM_FIELD_ERROR_ID)
+import MkId (voidPrimId, voidArgId)
+import MonadUtils (mapAccumLM)
+import Outputable
+import GHC.Types.RepType
+import GHC.Stg.Syntax
+import Type
+import TysPrim (intPrimTy,wordPrimTy,word64PrimTy)
+import TysWiredIn
+import UniqSupply
+import Util
+import VarEnv
+
+import Data.Bifunctor (second)
+import Data.Maybe (mapMaybe)
+import qualified Data.IntMap as IM
+
+--------------------------------------------------------------------------------
+
+-- | A mapping from binders to the Ids they were expanded/renamed to.
+--
+--   x :-> MultiVal [a,b,c] in rho
+--
+-- iff  x's typePrimRep is not a singleton, or equivalently
+--      x's type is an unboxed tuple, sum or void.
+--
+--    x :-> UnaryVal x'
+--
+-- iff x's RepType is UnaryRep or equivalently
+--     x's type is not unboxed tuple, sum or void.
+--
+-- So
+--     x :-> MultiVal [a] in rho
+-- means x is represented by singleton tuple.
+--
+--     x :-> MultiVal [] in rho
+-- means x is void.
+--
+-- INVARIANT: OutStgArgs in the range only have NvUnaryTypes
+--            (i.e. no unboxed tuples, sums or voids)
+--
+type UnariseEnv = VarEnv UnariseVal
+
+data UnariseVal
+  = MultiVal [OutStgArg] -- MultiVal to tuple. Can be empty list (void).
+  | UnaryVal OutStgArg   -- See NOTE [Renaming during unarisation].
+
+instance Outputable UnariseVal where
+  ppr (MultiVal args) = text "MultiVal" <+> ppr args
+  ppr (UnaryVal arg)   = text "UnaryVal" <+> ppr arg
+
+-- | Extend the environment, checking the UnariseEnv invariant.
+extendRho :: UnariseEnv -> Id -> UnariseVal -> UnariseEnv
+extendRho rho x (MultiVal args)
+  = ASSERT(all (isNvUnaryType . stgArgType) args)
+    extendVarEnv rho x (MultiVal args)
+extendRho rho x (UnaryVal val)
+  = ASSERT(isNvUnaryType (stgArgType val))
+    extendVarEnv rho x (UnaryVal val)
+
+--------------------------------------------------------------------------------
+
+unarise :: UniqSupply -> [StgTopBinding] -> [StgTopBinding]
+unarise us binds = initUs_ us (mapM (unariseTopBinding emptyVarEnv) binds)
+
+unariseTopBinding :: UnariseEnv -> StgTopBinding -> UniqSM StgTopBinding
+unariseTopBinding rho (StgTopLifted bind)
+  = StgTopLifted <$> unariseBinding rho bind
+unariseTopBinding _ bind@StgTopStringLit{} = return bind
+
+unariseBinding :: UnariseEnv -> StgBinding -> UniqSM StgBinding
+unariseBinding rho (StgNonRec x rhs)
+  = StgNonRec x <$> unariseRhs rho rhs
+unariseBinding rho (StgRec xrhss)
+  = StgRec <$> mapM (\(x, rhs) -> (x,) <$> unariseRhs rho rhs) xrhss
+
+unariseRhs :: UnariseEnv -> StgRhs -> UniqSM StgRhs
+unariseRhs rho (StgRhsClosure ext ccs update_flag args expr)
+  = do (rho', args1) <- unariseFunArgBinders rho args
+       expr' <- unariseExpr rho' expr
+       return (StgRhsClosure ext ccs update_flag args1 expr')
+
+unariseRhs rho (StgRhsCon ccs con args)
+  = ASSERT(not (isUnboxedTupleCon con || isUnboxedSumCon con))
+    return (StgRhsCon ccs con (unariseConArgs rho args))
+
+--------------------------------------------------------------------------------
+
+unariseExpr :: UnariseEnv -> StgExpr -> UniqSM StgExpr
+
+unariseExpr rho e@(StgApp f [])
+  = case lookupVarEnv rho f of
+      Just (MultiVal args)  -- Including empty tuples
+        -> return (mkTuple args)
+      Just (UnaryVal (StgVarArg f'))
+        -> return (StgApp f' [])
+      Just (UnaryVal (StgLitArg f'))
+        -> return (StgLit f')
+      Nothing
+        -> return e
+
+unariseExpr rho e@(StgApp f args)
+  = return (StgApp f' (unariseFunArgs rho args))
+  where
+    f' = case lookupVarEnv rho f of
+           Just (UnaryVal (StgVarArg f')) -> f'
+           Nothing -> f
+           err -> pprPanic "unariseExpr - app2" (ppr e $$ ppr err)
+               -- Can't happen because 'args' is non-empty, and
+               -- a tuple or sum cannot be applied to anything
+
+unariseExpr _ (StgLit l)
+  = return (StgLit l)
+
+unariseExpr rho (StgConApp dc args ty_args)
+  | Just args' <- unariseMulti_maybe rho dc args ty_args
+  = return (mkTuple args')
+
+  | otherwise
+  , let args' = unariseConArgs rho args
+  = return (StgConApp dc args' (map stgArgType args'))
+
+unariseExpr rho (StgOpApp op args ty)
+  = return (StgOpApp op (unariseFunArgs rho args) ty)
+
+unariseExpr _ e@StgLam{}
+  = pprPanic "unariseExpr: found lambda" (ppr e)
+
+unariseExpr rho (StgCase scrut bndr alt_ty alts)
+  -- tuple/sum binders in the scrutinee can always be eliminated
+  | StgApp v [] <- scrut
+  , Just (MultiVal xs) <- lookupVarEnv rho v
+  = elimCase rho xs bndr alt_ty alts
+
+  -- Handle strict lets for tuples and sums:
+  --   case (# a,b #) of r -> rhs
+  -- and analogously for sums
+  | StgConApp dc args ty_args <- scrut
+  , Just args' <- unariseMulti_maybe rho dc args ty_args
+  = elimCase rho args' bndr alt_ty alts
+
+  -- general case
+  | otherwise
+  = do scrut' <- unariseExpr rho scrut
+       alts'  <- unariseAlts rho alt_ty bndr alts
+       return (StgCase scrut' bndr alt_ty alts')
+                       -- bndr may have a unboxed sum/tuple type but it will be
+                       -- dead after unarise (checked in GHC.Stg.Lint)
+
+unariseExpr rho (StgLet ext bind e)
+  = StgLet ext <$> unariseBinding rho bind <*> unariseExpr rho e
+
+unariseExpr rho (StgLetNoEscape ext bind e)
+  = StgLetNoEscape ext <$> unariseBinding rho bind <*> unariseExpr rho e
+
+unariseExpr rho (StgTick tick e)
+  = StgTick tick <$> unariseExpr rho e
+
+-- Doesn't return void args.
+unariseMulti_maybe :: UnariseEnv -> DataCon -> [InStgArg] -> [Type] -> Maybe [OutStgArg]
+unariseMulti_maybe rho dc args ty_args
+  | isUnboxedTupleCon dc
+  = Just (unariseConArgs rho args)
+
+  | isUnboxedSumCon dc
+  , let args1 = ASSERT(isSingleton args) (unariseConArgs rho args)
+  = Just (mkUbxSum dc ty_args args1)
+
+  | otherwise
+  = Nothing
+
+--------------------------------------------------------------------------------
+
+elimCase :: UnariseEnv
+         -> [OutStgArg] -- non-void args
+         -> InId -> AltType -> [InStgAlt] -> UniqSM OutStgExpr
+
+elimCase rho args bndr (MultiValAlt _) [(_, bndrs, rhs)]
+  = do let rho1 = extendRho rho bndr (MultiVal args)
+           rho2
+             | isUnboxedTupleBndr bndr
+             = mapTupleIdBinders bndrs args rho1
+             | otherwise
+             = ASSERT(isUnboxedSumBndr bndr)
+               if null bndrs then rho1
+                             else mapSumIdBinders bndrs args rho1
+
+       unariseExpr rho2 rhs
+
+elimCase rho args bndr (MultiValAlt _) alts
+  | isUnboxedSumBndr bndr
+  = do let (tag_arg : real_args) = args
+       tag_bndr <- mkId (mkFastString "tag") tagTy
+          -- this won't be used but we need a binder anyway
+       let rho1 = extendRho rho bndr (MultiVal args)
+           scrut' = case tag_arg of
+                      StgVarArg v     -> StgApp v []
+                      StgLitArg l     -> StgLit l
+
+       alts' <- unariseSumAlts rho1 real_args alts
+       return (StgCase scrut' tag_bndr tagAltTy alts')
+
+elimCase _ args bndr alt_ty alts
+  = pprPanic "elimCase - unhandled case"
+      (ppr args <+> ppr bndr <+> ppr alt_ty $$ ppr alts)
+
+--------------------------------------------------------------------------------
+
+unariseAlts :: UnariseEnv -> AltType -> InId -> [StgAlt] -> UniqSM [StgAlt]
+unariseAlts rho (MultiValAlt n) bndr [(DEFAULT, [], e)]
+  | isUnboxedTupleBndr bndr
+  = do (rho', ys) <- unariseConArgBinder rho bndr
+       e' <- unariseExpr rho' e
+       return [(DataAlt (tupleDataCon Unboxed n), ys, e')]
+
+unariseAlts rho (MultiValAlt n) bndr [(DataAlt _, ys, e)]
+  | isUnboxedTupleBndr bndr
+  = do (rho', ys1) <- unariseConArgBinders rho ys
+       MASSERT(ys1 `lengthIs` n)
+       let rho'' = extendRho rho' bndr (MultiVal (map StgVarArg ys1))
+       e' <- unariseExpr rho'' e
+       return [(DataAlt (tupleDataCon Unboxed n), ys1, e')]
+
+unariseAlts _ (MultiValAlt _) bndr alts
+  | isUnboxedTupleBndr bndr
+  = pprPanic "unariseExpr: strange multi val alts" (ppr alts)
+
+-- In this case we don't need to scrutinize the tag bit
+unariseAlts rho (MultiValAlt _) bndr [(DEFAULT, _, rhs)]
+  | isUnboxedSumBndr bndr
+  = do (rho_sum_bndrs, sum_bndrs) <- unariseConArgBinder rho bndr
+       rhs' <- unariseExpr rho_sum_bndrs rhs
+       return [(DataAlt (tupleDataCon Unboxed (length sum_bndrs)), sum_bndrs, rhs')]
+
+unariseAlts rho (MultiValAlt _) bndr alts
+  | isUnboxedSumBndr bndr
+  = do (rho_sum_bndrs, scrt_bndrs@(tag_bndr : real_bndrs)) <- unariseConArgBinder rho bndr
+       alts' <- unariseSumAlts rho_sum_bndrs (map StgVarArg real_bndrs) alts
+       let inner_case = StgCase (StgApp tag_bndr []) tag_bndr tagAltTy alts'
+       return [ (DataAlt (tupleDataCon Unboxed (length scrt_bndrs)),
+                 scrt_bndrs,
+                 inner_case) ]
+
+unariseAlts rho _ _ alts
+  = mapM (\alt -> unariseAlt rho alt) alts
+
+unariseAlt :: UnariseEnv -> StgAlt -> UniqSM StgAlt
+unariseAlt rho (con, xs, e)
+  = do (rho', xs') <- unariseConArgBinders rho xs
+       (con, xs',) <$> unariseExpr rho' e
+
+--------------------------------------------------------------------------------
+
+-- | Make alternatives that match on the tag of a sum
+-- (i.e. generate LitAlts for the tag)
+unariseSumAlts :: UnariseEnv
+               -> [StgArg] -- sum components _excluding_ the tag bit.
+               -> [StgAlt] -- original alternative with sum LHS
+               -> UniqSM [StgAlt]
+unariseSumAlts env args alts
+  = do alts' <- mapM (unariseSumAlt env args) alts
+       return (mkDefaultLitAlt alts')
+
+unariseSumAlt :: UnariseEnv
+              -> [StgArg] -- sum components _excluding_ the tag bit.
+              -> StgAlt   -- original alternative with sum LHS
+              -> UniqSM StgAlt
+unariseSumAlt rho _ (DEFAULT, _, e)
+  = ( DEFAULT, [], ) <$> unariseExpr rho e
+
+unariseSumAlt rho args (DataAlt sumCon, bs, e)
+  = do let rho' = mapSumIdBinders bs args rho
+       e' <- unariseExpr rho' e
+       return ( LitAlt (LitNumber LitNumInt (fromIntegral (dataConTag sumCon)) intPrimTy), [], e' )
+
+unariseSumAlt _ scrt alt
+  = pprPanic "unariseSumAlt" (ppr scrt $$ ppr alt)
+
+--------------------------------------------------------------------------------
+
+mapTupleIdBinders
+  :: [InId]       -- Un-processed binders of a tuple alternative.
+                  -- Can have void binders.
+  -> [OutStgArg]  -- Arguments that form the tuple (after unarisation).
+                  -- Can't have void args.
+  -> UnariseEnv
+  -> UnariseEnv
+mapTupleIdBinders ids args0 rho0
+  = ASSERT(not (any (isVoidTy . stgArgType) args0))
+    let
+      ids_unarised :: [(Id, [PrimRep])]
+      ids_unarised = map (\id -> (id, typePrimRep (idType id))) ids
+
+      map_ids :: UnariseEnv -> [(Id, [PrimRep])] -> [StgArg] -> UnariseEnv
+      map_ids rho [] _  = rho
+      map_ids rho ((x, x_reps) : xs) args =
+        let
+          x_arity = length x_reps
+          (x_args, args') =
+            ASSERT(args `lengthAtLeast` x_arity)
+            splitAt x_arity args
+
+          rho'
+            | x_arity == 1
+            = ASSERT(x_args `lengthIs` 1)
+              extendRho rho x (UnaryVal (head x_args))
+            | otherwise
+            = extendRho rho x (MultiVal x_args)
+        in
+          map_ids rho' xs args'
+    in
+      map_ids rho0 ids_unarised args0
+
+mapSumIdBinders
+  :: [InId]      -- Binder of a sum alternative (remember that sum patterns
+                 -- only have one binder, so this list should be a singleton)
+  -> [OutStgArg] -- Arguments that form the sum (NOT including the tag).
+                 -- Can't have void args.
+  -> UnariseEnv
+  -> UnariseEnv
+
+mapSumIdBinders [id] args rho0
+  = ASSERT(not (any (isVoidTy . stgArgType) args))
+    let
+      arg_slots = map primRepSlot $ concatMap (typePrimRep . stgArgType) args
+      id_slots  = map primRepSlot $ typePrimRep (idType id)
+      layout1   = layoutUbxSum arg_slots id_slots
+    in
+      if isMultiValBndr id
+        then extendRho rho0 id (MultiVal [ args !! i | i <- layout1 ])
+        else ASSERT(layout1 `lengthIs` 1)
+             extendRho rho0 id (UnaryVal (args !! head layout1))
+
+mapSumIdBinders ids sum_args _
+  = pprPanic "mapSumIdBinders" (ppr ids $$ ppr sum_args)
+
+-- | Build a unboxed sum term from arguments of an alternative.
+--
+-- Example, for (# x | #) :: (# (# #) | Int #) we call
+--
+--   mkUbxSum (# _ | #) [ (# #), Int ] [ voidPrimId ]
+--
+-- which returns
+--
+--   [ 1#, rubbish ]
+--
+mkUbxSum
+  :: DataCon      -- Sum data con
+  -> [Type]       -- Type arguments of the sum data con
+  -> [OutStgArg]  -- Actual arguments of the alternative.
+  -> [OutStgArg]  -- Final tuple arguments
+mkUbxSum dc ty_args args0
+  = let
+      (_ : sum_slots) = ubxSumRepType (map typePrimRep ty_args)
+        -- drop tag slot
+
+      tag = dataConTag dc
+
+      layout'  = layoutUbxSum sum_slots (mapMaybe (typeSlotTy . stgArgType) args0)
+      tag_arg  = StgLitArg (LitNumber LitNumInt (fromIntegral tag) intPrimTy)
+      arg_idxs = IM.fromList (zipEqual "mkUbxSum" layout' args0)
+
+      mkTupArgs :: Int -> [SlotTy] -> IM.IntMap StgArg -> [StgArg]
+      mkTupArgs _ [] _
+        = []
+      mkTupArgs arg_idx (slot : slots_left) arg_map
+        | Just stg_arg <- IM.lookup arg_idx arg_map
+        = stg_arg : mkTupArgs (arg_idx + 1) slots_left arg_map
+        | otherwise
+        = slotRubbishArg slot : mkTupArgs (arg_idx + 1) slots_left arg_map
+
+      slotRubbishArg :: SlotTy -> StgArg
+      slotRubbishArg PtrSlot    = StgVarArg aBSENT_SUM_FIELD_ERROR_ID
+                         -- See Note [aBSENT_SUM_FIELD_ERROR_ID] in MkCore
+      slotRubbishArg WordSlot   = StgLitArg (LitNumber LitNumWord 0 wordPrimTy)
+      slotRubbishArg Word64Slot = StgLitArg (LitNumber LitNumWord64 0 word64PrimTy)
+      slotRubbishArg FloatSlot  = StgLitArg (LitFloat 0)
+      slotRubbishArg DoubleSlot = StgLitArg (LitDouble 0)
+    in
+      tag_arg : mkTupArgs 0 sum_slots arg_idxs
+
+--------------------------------------------------------------------------------
+
+{-
+For arguments (StgArg) and binders (Id) we have two kind of unarisation:
+
+  - When unarising function arg binders and arguments, we don't want to remove
+    void binders and arguments. For example,
+
+      f :: (# (# #), (# #) #) -> Void# -> RealWorld# -> ...
+      f x y z = <body>
+
+    Here after unarise we should still get a function with arity 3. Similarly
+    in the call site we shouldn't remove void arguments:
+
+      f (# (# #), (# #) #) voidId rw
+
+    When unarising <body>, we extend the environment with these binders:
+
+      x :-> MultiVal [], y :-> MultiVal [], z :-> MultiVal []
+
+    Because their rep types are `MultiRep []` (aka. void). This means that when
+    we see `x` in a function argument position, we actually replace it with a
+    void argument. When we see it in a DataCon argument position, we just get
+    rid of it, because DataCon applications in STG are always saturated.
+
+  - When unarising case alternative binders we remove void binders, but we
+    still update the environment the same way, because those binders may be
+    used in the RHS. Example:
+
+      case x of y {
+        (# x1, x2, x3 #) -> <RHS>
+      }
+
+    We know that y can't be void, because we don't scrutinize voids, so x will
+    be unarised to some number of arguments, and those arguments will have at
+    least one non-void thing. So in the rho we will have something like:
+
+      x :-> MultiVal [xu1, xu2]
+
+    Now, after we eliminate void binders in the pattern, we get exactly the same
+    number of binders, and extend rho again with these:
+
+      x1 :-> UnaryVal xu1
+      x2 :-> MultiVal [] -- x2 is void
+      x3 :-> UnaryVal xu2
+
+    Now when we see x2 in a function argument position or in return position, we
+    generate void#. In constructor argument position, we just remove it.
+
+So in short, when we have a void id,
+
+  - We keep it if it's a lambda argument binder or
+                       in argument position of an application.
+
+  - We remove it if it's a DataCon field binder or
+                         in argument position of a DataCon application.
+-}
+
+unariseArgBinder
+    :: Bool -- data con arg?
+    -> UnariseEnv -> Id -> UniqSM (UnariseEnv, [Id])
+unariseArgBinder is_con_arg rho x =
+  case typePrimRep (idType x) of
+    []
+      | is_con_arg
+      -> return (extendRho rho x (MultiVal []), [])
+      | otherwise -- fun arg, do not remove void binders
+      -> return (extendRho rho x (MultiVal []), [voidArgId])
+
+    [rep]
+      -- Arg represented as single variable, but original type may still be an
+      -- unboxed sum/tuple, e.g. (# Void# | Void# #).
+      --
+      -- While not unarising the binder in this case does not break any programs
+      -- (because it unarises to a single variable), it triggers StgLint as we
+      -- break the the post-unarisation invariant that says unboxed tuple/sum
+      -- binders should vanish. See Note [Post-unarisation invariants].
+      | isUnboxedSumType (idType x) || isUnboxedTupleType (idType x)
+      -> do x' <- mkId (mkFastString "us") (primRepToType rep)
+            return (extendRho rho x (MultiVal [StgVarArg x']), [x'])
+      | otherwise
+      -> return (rho, [x])
+
+    reps -> do
+      xs <- mkIds (mkFastString "us") (map primRepToType reps)
+      return (extendRho rho x (MultiVal (map StgVarArg xs)), xs)
+
+--------------------------------------------------------------------------------
+
+-- | MultiVal a function argument. Never returns an empty list.
+unariseFunArg :: UnariseEnv -> StgArg -> [StgArg]
+unariseFunArg rho (StgVarArg x) =
+  case lookupVarEnv rho x of
+    Just (MultiVal [])  -> [voidArg]   -- NB: do not remove void args
+    Just (MultiVal as)  -> as
+    Just (UnaryVal arg) -> [arg]
+    Nothing             -> [StgVarArg x]
+unariseFunArg _ arg = [arg]
+
+unariseFunArgs :: UnariseEnv -> [StgArg] -> [StgArg]
+unariseFunArgs = concatMap . unariseFunArg
+
+unariseFunArgBinders :: UnariseEnv -> [Id] -> UniqSM (UnariseEnv, [Id])
+unariseFunArgBinders rho xs = second concat <$> mapAccumLM unariseFunArgBinder rho xs
+
+-- Result list of binders is never empty
+unariseFunArgBinder :: UnariseEnv -> Id -> UniqSM (UnariseEnv, [Id])
+unariseFunArgBinder = unariseArgBinder False
+
+--------------------------------------------------------------------------------
+
+-- | MultiVal a DataCon argument. Returns an empty list when argument is void.
+unariseConArg :: UnariseEnv -> InStgArg -> [OutStgArg]
+unariseConArg rho (StgVarArg x) =
+  case lookupVarEnv rho x of
+    Just (UnaryVal arg) -> [arg]
+    Just (MultiVal as) -> as      -- 'as' can be empty
+    Nothing
+      | isVoidTy (idType x) -> [] -- e.g. C realWorld#
+                                  -- Here realWorld# is not in the envt, but
+                                  -- is a void, and so should be eliminated
+      | otherwise -> [StgVarArg x]
+unariseConArg _ arg@(StgLitArg lit) =
+    ASSERT(not (isVoidTy (literalType lit)))  -- We have no void literals
+    [arg]
+
+unariseConArgs :: UnariseEnv -> [InStgArg] -> [OutStgArg]
+unariseConArgs = concatMap . unariseConArg
+
+unariseConArgBinders :: UnariseEnv -> [Id] -> UniqSM (UnariseEnv, [Id])
+unariseConArgBinders rho xs = second concat <$> mapAccumLM unariseConArgBinder rho xs
+
+-- Different from `unariseFunArgBinder`: result list of binders may be empty.
+-- See DataCon applications case in Note [Post-unarisation invariants].
+unariseConArgBinder :: UnariseEnv -> Id -> UniqSM (UnariseEnv, [Id])
+unariseConArgBinder = unariseArgBinder True
+
+--------------------------------------------------------------------------------
+
+mkIds :: FastString -> [UnaryType] -> UniqSM [Id]
+mkIds fs tys = mapM (mkId fs) tys
+
+mkId :: FastString -> UnaryType -> UniqSM Id
+mkId = mkSysLocalM
+
+isMultiValBndr :: Id -> Bool
+isMultiValBndr id
+  | [_] <- typePrimRep (idType id)
+  = False
+  | otherwise
+  = True
+
+isUnboxedSumBndr :: Id -> Bool
+isUnboxedSumBndr = isUnboxedSumType . idType
+
+isUnboxedTupleBndr :: Id -> Bool
+isUnboxedTupleBndr = isUnboxedTupleType . idType
+
+mkTuple :: [StgArg] -> StgExpr
+mkTuple args = StgConApp (tupleDataCon Unboxed (length args)) args (map stgArgType args)
+
+tagAltTy :: AltType
+tagAltTy = PrimAlt IntRep
+
+tagTy :: Type
+tagTy = intPrimTy
+
+voidArg :: StgArg
+voidArg = StgVarArg voidPrimId
+
+mkDefaultLitAlt :: [StgAlt] -> [StgAlt]
+-- We have an exhauseive list of literal alternatives
+--    1# -> e1
+--    2# -> e2
+-- Since they are exhaustive, we can replace one with DEFAULT, to avoid
+-- generating a final test. Remember, the DEFAULT comes first if it exists.
+mkDefaultLitAlt [] = pprPanic "elimUbxSumExpr.mkDefaultAlt" (text "Empty alts")
+mkDefaultLitAlt alts@((DEFAULT, _, _) : _) = alts
+mkDefaultLitAlt ((LitAlt{}, [], rhs) : alts) = (DEFAULT, [], rhs) : alts
+mkDefaultLitAlt alts = pprPanic "mkDefaultLitAlt" (text "Not a lit alt:" <+> ppr alts)