move bytecode preparation into the STG pipeline

this makes it possible to combine passes to compute free variables
more efficiently in a future change

5 files changed, 245 insertions, 199 deletions

diff --git a/compiler/GHC/Driver/Main.hs b/compiler/GHC/Driver/Main.hs
index 6f178afc48..ea3040c64e 100644
--- a/compiler/GHC/Driver/Main.hs
+++ b/compiler/GHC/Driver/Main.hs
@@ -1555,7 +1555,7 @@ hscGenHardCode hsc_env cgguts location output_filename = do
                withTiming logger
                    (text "CoreToStg"<+>brackets (ppr this_mod))
                    (\(a, b, (c,d)) -> a `seqList` b `seq` c `seqList` d `seqList` ())
-                   (myCoreToStg logger dflags (hsc_IC hsc_env) this_mod location prepd_binds)
+                   (myCoreToStg logger dflags (hsc_IC hsc_env) False this_mod location prepd_binds)
 
         let cost_centre_info =
               (local_ccs ++ caf_ccs, caf_cc_stacks)
@@ -1629,7 +1629,7 @@ hscInteractive hsc_env cgguts location = do
 
     (stg_binds, _infotable_prov, _caf_ccs__caf_cc_stacks)
       <- {-# SCC "CoreToStg" #-}
-          myCoreToStg logger dflags (hsc_IC hsc_env) this_mod location prepd_binds
+          myCoreToStg logger dflags (hsc_IC hsc_env) True this_mod location prepd_binds
     -----------------  Generate byte code ------------------
     comp_bc <- byteCodeGen hsc_env this_mod stg_binds data_tycons mod_breaks
     ------------------ Create f-x-dynamic C-side stuff -----
@@ -1771,12 +1771,13 @@ doCodeGen hsc_env this_mod denv data_tycons
     return (Stream.mapM dump2 pipeline_stream)
 
 myCoreToStgExpr :: Logger -> DynFlags -> InteractiveContext
+                -> Bool
                 -> Module -> ModLocation -> CoreExpr
                 -> IO ( Id
                       , [StgTopBinding]
                       , InfoTableProvMap
                       , CollectedCCs )
-myCoreToStgExpr logger dflags ictxt this_mod ml prepd_expr = do
+myCoreToStgExpr logger dflags ictxt for_bytecode this_mod ml prepd_expr = do
     {- Create a temporary binding (just because myCoreToStg needs a
        binding for the stg2stg step) -}
     let bco_tmp_id = mkSysLocal (fsLit "BCO_toplevel")
@@ -1787,24 +1788,26 @@ myCoreToStgExpr logger dflags ictxt this_mod ml prepd_expr = do
        myCoreToStg logger
                    dflags
                    ictxt
+                   for_bytecode
                    this_mod
                    ml
                    [NonRec bco_tmp_id prepd_expr]
     return (bco_tmp_id, stg_binds, prov_map, collected_ccs)
 
 myCoreToStg :: Logger -> DynFlags -> InteractiveContext
+            -> Bool
             -> Module -> ModLocation -> CoreProgram
             -> IO ( [StgTopBinding] -- output program
                   , InfoTableProvMap
                   , CollectedCCs )  -- CAF cost centre info (declared and used)
-myCoreToStg logger dflags ictxt this_mod ml prepd_binds = do
+myCoreToStg logger dflags ictxt for_bytecode this_mod ml prepd_binds = do
     let (stg_binds, denv, cost_centre_info)
          = {-# SCC "Core2Stg" #-}
            coreToStg dflags this_mod ml prepd_binds
 
     stg_binds2
         <- {-# SCC "Stg2Stg" #-}
-           stg2stg logger dflags ictxt this_mod stg_binds
+           stg2stg logger dflags ictxt for_bytecode this_mod stg_binds
 
     return (stg_binds2, denv, cost_centre_info)
 
@@ -1950,6 +1953,7 @@ hscParsedDecls hsc_env decls = runInteractiveHsc hsc_env $ do
            liftIO $ myCoreToStg (hsc_logger hsc_env)
                                 (hsc_dflags hsc_env)
                                 (hsc_IC hsc_env)
+                                True
                                 this_mod
                                 iNTERACTIVELoc
                                 prepd_binds
@@ -2134,6 +2138,7 @@ hscCompileCoreExpr' hsc_env srcspan ds_expr
              myCoreToStgExpr (hsc_logger hsc_env)
                              (hsc_dflags hsc_env)
                              ictxt
+                             True
                              (icInteractiveModule ictxt)
                              iNTERACTIVELoc
                              prepd_expr
diff --git a/compiler/GHC/Stg/BcPrep.hs b/compiler/GHC/Stg/BcPrep.hs
new file mode 100644
index 0000000000..1b5f2b37b6
--- /dev/null
+++ b/compiler/GHC/Stg/BcPrep.hs
@@ -0,0 +1,215 @@
+{-|
+  Prepare the STG for bytecode generation:
+
+   - Ensure that all breakpoints are directly under
+        a let-binding, introducing a new binding for
+        those that aren't already.
+
+   - Protect Not-necessarily lifted join points, see
+        Note [Not-necessarily-lifted join points]
+
+ -}
+
+module GHC.Stg.BcPrep ( bcPrep ) where
+
+import GHC.Prelude
+
+import GHC.Types.Id.Make
+import GHC.Types.Id
+import GHC.Core.Type
+import GHC.Builtin.Types ( unboxedUnitTy )
+import GHC.Builtin.Types.Prim
+import GHC.Types.Unique
+import GHC.Data.FastString
+import GHC.Utils.Panic.Plain
+import GHC.Types.Tickish
+import GHC.Types.Unique.Supply
+import qualified GHC.Types.CostCentre as CC
+import GHC.Stg.Syntax
+import GHC.Utils.Monad.State.Strict
+
+data BcPrepM_State
+   = BcPrepM_State
+        { prepUniqSupply :: !UniqSupply      -- for generating fresh variable names
+        }
+
+type BcPrepM a = State BcPrepM_State a
+
+bcPrepRHS :: StgRhs -> BcPrepM StgRhs
+-- explicitly match all constructors so we get a warning if we miss any
+bcPrepRHS (StgRhsClosure fvs cc upd args (StgTick bp@Breakpoint{} expr)) = do
+  {- If we have a breakpoint directly under an StgRhsClosure we don't
+     need to introduce a new binding for it.
+   -}
+  expr' <- bcPrepExpr expr
+  pure (StgRhsClosure fvs cc upd args (StgTick bp expr'))
+bcPrepRHS (StgRhsClosure fvs cc upd args expr) =
+  StgRhsClosure fvs cc upd args <$> bcPrepExpr expr
+bcPrepRHS con@StgRhsCon{} = pure con
+
+bcPrepExpr :: StgExpr -> BcPrepM StgExpr
+-- explicitly match all constructors so we get a warning if we miss any
+bcPrepExpr (StgTick bp@(Breakpoint tick_ty _ _) rhs)
+  | isLiftedTypeKind (typeKind tick_ty) = do
+      id <- newId tick_ty
+      rhs' <- bcPrepExpr rhs
+      let expr' = StgTick bp rhs'
+          bnd = StgNonRec id (StgRhsClosure noExtFieldSilent
+                                            CC.dontCareCCS
+                                            ReEntrant
+                                            []
+                                            expr'
+                             )
+          letExp = StgLet noExtFieldSilent bnd (StgApp id [])
+      pure letExp
+  | otherwise = do
+      id <- newId (mkVisFunTyMany realWorldStatePrimTy tick_ty)
+      rhs' <- bcPrepExpr rhs
+      let expr' = StgTick bp rhs'
+          bnd = StgNonRec id (StgRhsClosure noExtFieldSilent
+                                            CC.dontCareCCS
+                                            ReEntrant
+                                            [voidArgId]
+                                            expr'
+                             )
+      pure $ StgLet noExtFieldSilent bnd (StgApp id [StgVarArg realWorldPrimId])
+bcPrepExpr (StgTick tick rhs) =
+  StgTick tick <$> bcPrepExpr rhs
+bcPrepExpr (StgLet xlet bnds expr) =
+  StgLet xlet <$> bcPrepBind bnds
+              <*> bcPrepExpr expr
+bcPrepExpr (StgLetNoEscape xlne bnds expr) =
+  StgLet xlne <$> bcPrepBind bnds
+              <*> bcPrepExpr expr
+bcPrepExpr (StgCase expr bndr alt_type alts) =
+  StgCase <$> bcPrepExpr expr
+          <*> pure bndr
+          <*> pure alt_type
+          <*> mapM bcPrepAlt alts
+bcPrepExpr lit@StgLit{} = pure lit
+-- See Note [Not-necessarily-lifted join points], step 3.
+bcPrepExpr (StgApp x [])
+  | isNNLJoinPoint x = pure $
+      StgApp (protectNNLJoinPointId x) [StgVarArg voidPrimId]
+bcPrepExpr app@StgApp{} = pure app
+bcPrepExpr app@StgConApp{} = pure app
+bcPrepExpr app@StgOpApp{} = pure app
+
+bcPrepAlt :: StgAlt -> BcPrepM StgAlt
+bcPrepAlt (ac, bndrs, expr) = (,,) ac bndrs <$> bcPrepExpr expr
+
+bcPrepBind :: StgBinding -> BcPrepM StgBinding
+-- explicitly match all constructors so we get a warning if we miss any
+bcPrepBind (StgNonRec bndr rhs) =
+  let (bndr', rhs') = bcPrepSingleBind (bndr, rhs)
+  in  StgNonRec bndr' <$> bcPrepRHS rhs'
+bcPrepBind (StgRec bnds) =
+  StgRec <$> mapM ((\(b,r) -> (,) b <$> bcPrepRHS r) . bcPrepSingleBind)
+                  bnds
+
+bcPrepSingleBind :: (Id, StgRhs) -> (Id, StgRhs)
+-- If necessary, modify this Id and body to protect not-necessarily-lifted join points.
+-- See Note [Not-necessarily-lifted join points], step 2.
+bcPrepSingleBind (x, StgRhsClosure ext cc upd_flag args body)
+  | isNNLJoinPoint x
+  = ( protectNNLJoinPointId x
+    , StgRhsClosure ext cc upd_flag (args ++ [voidArgId]) body)
+bcPrepSingleBind bnd = bnd
+
+bcPrepTopLvl :: StgTopBinding -> BcPrepM StgTopBinding
+bcPrepTopLvl lit@StgTopStringLit{} = pure lit
+bcPrepTopLvl (StgTopLifted bnd) = StgTopLifted <$> bcPrepBind bnd
+
+bcPrep :: UniqSupply -> [InStgTopBinding] -> [OutStgTopBinding]
+bcPrep us bnds = evalState (mapM bcPrepTopLvl bnds) (BcPrepM_State us)
+
+-- Is this Id a not-necessarily-lifted join point?
+-- See Note [Not-necessarily-lifted join points], step 1
+isNNLJoinPoint :: Id -> Bool
+isNNLJoinPoint x = isJoinId x &&
+                   Just True /= isLiftedType_maybe (idType x)
+
+-- Update an Id's type to take a Void# argument.
+-- Precondition: the Id is a not-necessarily-lifted join point.
+-- See Note [Not-necessarily-lifted join points]
+protectNNLJoinPointId :: Id -> Id
+protectNNLJoinPointId x
+  = assert (isNNLJoinPoint x )
+    updateIdTypeButNotMult (unboxedUnitTy `mkVisFunTyMany`) x
+
+newUnique :: BcPrepM Unique
+newUnique = state $
+  \st -> case takeUniqFromSupply (prepUniqSupply st) of
+            (uniq, us) -> (uniq, st { prepUniqSupply = us })
+
+newId :: Type -> BcPrepM Id
+newId ty = do
+    uniq <- newUnique
+    return $ mkSysLocal prepFS uniq Many ty
+
+prepFS :: FastString
+prepFS = fsLit "bcprep"
+
+{-
+
+Note [Not-necessarily-lifted join points]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+A join point variable is essentially a goto-label: it is, for example,
+never used as an argument to another function, and it is called only
+in tail position. See Note [Join points] and Note [Invariants on join points],
+both in GHC.Core. Because join points do not compile to true, red-blooded
+variables (with, e.g., registers allocated to them), they are allowed
+to be representation-polymorphic.
+(See invariant #6 in Note [Invariants on join points] in GHC.Core.)
+
+However, in this byte-code generator, join points *are* treated just as
+ordinary variables. There is no check whether a binding is for a join point
+or not; they are all treated uniformly. (Perhaps there is a missed optimization
+opportunity here, but that is beyond the scope of my (Richard E's) Thursday.)
+
+We thus must have *some* strategy for dealing with representation-polymorphic
+and unlifted join points. Representation-polymorphic variables are generally
+not allowed (though representation -polymorphic join points *are*; see
+Note [Invariants on join points] in GHC.Core, point 6), and we don't wish to
+evaluate unlifted join points eagerly.
+The questionable join points are *not-necessarily-lifted join points*
+(NNLJPs). (Not having such a strategy led to #16509, which panicked in the
+isUnliftedType check in the AnnVar case of schemeE.) Here is the strategy:
+
+1. Detect NNLJPs. This is done in isNNLJoinPoint.
+
+2. When binding an NNLJP, add a `\ (_ :: (# #)) ->` to its RHS, and modify the
+   type to tack on a `(# #) ->`.
+   Note that functions are never representation-polymorphic, so this
+   transformation changes an NNLJP to a non-representation-polymorphic
+   join point. This is done in bcPrepSingleBind.
+
+3. At an occurrence of an NNLJP, add an application to void# (called voidPrimId),
+   being careful to note the new type of the NNLJP. This is done in the AnnVar
+   case of schemeE, with help from protectNNLJoinPointId.
+
+Here is an example. Suppose we have
+
+  f = \(r :: RuntimeRep) (a :: TYPE r) (x :: T).
+      join j :: a
+           j = error @r @a "bloop"
+      in case x of
+           A -> j
+           B -> j
+           C -> error @r @a "blurp"
+
+Our plan is to behave is if the code was
+
+  f = \(r :: RuntimeRep) (a :: TYPE r) (x :: T).
+      let j :: (Void# -> a)
+          j = \ _ -> error @r @a "bloop"
+      in case x of
+           A -> j void#
+           B -> j void#
+           C -> error @r @a "blurp"
+
+It's a bit hacky, but it works well in practice and is local. I suspect the
+Right Fix is to take advantage of join points as goto-labels.
+
+-}
+
diff --git a/compiler/GHC/Stg/Pipeline.hs b/compiler/GHC/Stg/Pipeline.hs
index 57996cbffa..b0e1848f19 100644
--- a/compiler/GHC/Stg/Pipeline.hs
+++ b/compiler/GHC/Stg/Pipeline.hs
@@ -19,6 +19,7 @@ import GHC.Stg.Lint     ( lintStgTopBindings )
 import GHC.Stg.Stats    ( showStgStats )
 import GHC.Stg.DepAnal  ( depSortStgPgm )
 import GHC.Stg.Unarise  ( unarise )
+import GHC.Stg.BcPrep   ( bcPrep )
 import GHC.Stg.CSE      ( stgCse )
 import GHC.Stg.Lift     ( stgLiftLams )
 import GHC.Unit.Module ( Module )
@@ -48,15 +49,16 @@ runStgM mask (StgM m) = runReaderT m mask
 stg2stg :: Logger
         -> DynFlags                  -- includes spec of what stg-to-stg passes to do
         -> InteractiveContext
+        -> Bool                      -- prepare for bytecode?
         -> Module                    -- module being compiled
         -> [StgTopBinding]           -- input program
         -> IO [StgTopBinding]        -- output program
-stg2stg logger dflags ictxt this_mod binds
+stg2stg logger dflags ictxt for_bytecode this_mod binds
   = do  { dump_when Opt_D_dump_stg_from_core "Initial STG:" binds
         ; showPass logger "Stg2Stg"
         -- Do the main business!
         ; binds' <- runStgM 'g' $
-            foldM do_stg_pass binds (getStgToDo dflags)
+            foldM do_stg_pass binds (getStgToDo for_bytecode dflags)
 
           -- Dependency sort the program as last thing. The program needs to be
           -- in dependency order for the SRT algorithm to work (see
@@ -96,6 +98,11 @@ stg2stg logger dflags ictxt this_mod binds
             let binds' = {-# SCC "StgLiftLams" #-} stgLiftLams dflags us binds
             end_pass "StgLiftLams" binds'
 
+          StgBcPrep -> do
+            us <- getUniqueSupplyM
+            let binds' = {-# SCC "StgBcPrep" #-} bcPrep us binds
+            end_pass "StgBcPrep" binds'
+
           StgUnarise -> do
             us <- getUniqueSupplyM
             liftIO (stg_linter False "Pre-unarise" binds)
@@ -128,19 +135,22 @@ data StgToDo
   | StgStats
   | StgUnarise
   -- ^ Mandatory unarise pass, desugaring unboxed tuple and sum binders
+  | StgBcPrep
+  -- ^ Mandatory when compiling to bytecode
   | 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 =
+getStgToDo :: Bool -> DynFlags -> [StgToDo]
+getStgToDo for_bytecode 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
+    , runWhen for_bytecode StgBcPrep
     , optional Opt_StgStats StgStats
     ] where
       optional opt = runWhen (gopt opt dflags)
diff --git a/compiler/GHC/StgToByteCode.hs b/compiler/GHC/StgToByteCode.hs
index 78b24c97cd..1ba0687a9b 100644
--- a/compiler/GHC/StgToByteCode.hs
+++ b/compiler/GHC/StgToByteCode.hs
@@ -36,7 +36,6 @@ import GHCi.RemoteTypes
 import GHC.Types.Basic
 import GHC.Utils.Outputable
 import GHC.Types.Name
-import GHC.Types.Id.Make
 import GHC.Types.Id
 import GHC.Types.ForeignCall
 import GHC.Core
@@ -49,7 +48,6 @@ import GHC.Core.TyCon
 import GHC.Utils.Misc
 import GHC.Utils.Logger
 import GHC.Types.Var.Set
-import GHC.Builtin.Types ( unboxedUnitTy )
 import GHC.Builtin.Types.Prim
 import GHC.Core.TyCo.Ppr ( pprType )
 import GHC.Utils.Error
@@ -75,7 +73,6 @@ import Foreign hiding (shiftL, shiftR)
 import Control.Monad
 import Data.Char
 
-import GHC.Types.Unique.Supply
 import GHC.Unit.Module
 
 import Data.Array
@@ -90,7 +87,6 @@ import Data.Ord
 import GHC.Stack.CCS
 import Data.Either ( partitionEithers )
 
-import qualified GHC.Types.CostCentre as CC
 import GHC.Stg.Syntax
 import GHC.Stg.FVs
 
@@ -118,12 +114,10 @@ byteCodeGen hsc_env this_mod binds tycs mb_modBreaks
             flattenBind (StgRec bs)     = bs
         stringPtrs <- allocateTopStrings interp strings
 
-        us <- mkSplitUniqSupply 'y'
         (BcM_State{..}, proto_bcos) <-
-           runBc hsc_env us this_mod mb_modBreaks (mkVarEnv stringPtrs) $ do
-             prepd_binds <- mapM bcPrepBind lifted_binds
+           runBc hsc_env this_mod mb_modBreaks (mkVarEnv stringPtrs) $ do
              let flattened_binds =
-                   concatMap (flattenBind . annBindingFreeVars) (reverse prepd_binds)
+                   concatMap (flattenBind . annBindingFreeVars) (reverse lifted_binds)
              mapM schemeTopBind flattened_binds
 
         when (notNull ffis)
@@ -176,100 +170,6 @@ literals:
    BcM and used when generating code for variable references.
 -}
 
-{-
-  Prepare the STG for bytecode generation:
-
-   - Ensure that all breakpoints are directly under
-        a let-binding, introducing a new binding for
-        those that aren't already.
-
-   - Protect Not-necessarily lifted join points, see
-        Note [Not-necessarily-lifted join points]
-
- -}
-
-bcPrepRHS :: StgRhs -> BcM StgRhs
--- explicitly match all constructors so we get a warning if we miss any
-bcPrepRHS (StgRhsClosure fvs cc upd args (StgTick bp@Breakpoint{} expr)) = do
-  {- If we have a breakpoint directly under an StgRhsClosure we don't
-     need to introduce a new binding for it.
-   -}
-  expr' <- bcPrepExpr expr
-  pure (StgRhsClosure fvs cc upd args (StgTick bp expr'))
-bcPrepRHS (StgRhsClosure fvs cc upd args expr) =
-  StgRhsClosure fvs cc upd args <$> bcPrepExpr expr
-bcPrepRHS con@StgRhsCon{} = pure con
-
-bcPrepExpr :: StgExpr -> BcM StgExpr
--- explicitly match all constructors so we get a warning if we miss any
-bcPrepExpr (StgTick bp@(Breakpoint tick_ty _ _) rhs)
-  | isLiftedTypeKind (typeKind tick_ty) = do
-      id <- newId tick_ty
-      rhs' <- bcPrepExpr rhs
-      let expr' = StgTick bp rhs'
-          bnd = StgNonRec id (StgRhsClosure noExtFieldSilent
-                                            CC.dontCareCCS
-                                            ReEntrant
-                                            []
-                                            expr'
-                             )
-          letExp = StgLet noExtFieldSilent bnd (StgApp id [])
-      pure letExp
-  | otherwise = do
-      id <- newId (mkVisFunTyMany realWorldStatePrimTy tick_ty)
-      st <- newId realWorldStatePrimTy
-      rhs' <- bcPrepExpr rhs
-      let expr' = StgTick bp rhs'
-          bnd = StgNonRec id (StgRhsClosure noExtFieldSilent
-                                            CC.dontCareCCS
-                                            ReEntrant
-                                            [voidArgId]
-                                            expr'
-                             )
-      pure $ StgLet noExtFieldSilent bnd (StgApp id [StgVarArg st])
-bcPrepExpr (StgTick tick rhs) =
-  StgTick tick <$> bcPrepExpr rhs
-bcPrepExpr (StgLet xlet bnds expr) =
-  StgLet xlet <$> bcPrepBind bnds
-              <*> bcPrepExpr expr
-bcPrepExpr (StgLetNoEscape xlne bnds expr) =
-  StgLet xlne <$> bcPrepBind bnds
-              <*> bcPrepExpr expr
-bcPrepExpr (StgCase expr bndr alt_type alts) =
-  StgCase <$> bcPrepExpr expr
-          <*> pure bndr
-          <*> pure alt_type
-          <*> mapM bcPrepAlt alts
-bcPrepExpr lit@StgLit{} = pure lit
--- See Note [Not-necessarily-lifted join points], step 3.
-bcPrepExpr (StgApp x [])
-  | isNNLJoinPoint x = pure $
-      StgApp (protectNNLJoinPointId x) [StgVarArg voidPrimId]
-bcPrepExpr app@StgApp{} = pure app
-bcPrepExpr app@StgConApp{} = pure app
-bcPrepExpr app@StgOpApp{} = pure app
-
-bcPrepAlt :: StgAlt -> BcM StgAlt
-bcPrepAlt (ac, bndrs, expr) = (,,) ac bndrs <$> bcPrepExpr expr
-
-bcPrepBind :: StgBinding -> BcM StgBinding
--- explicitly match all constructors so we get a warning if we miss any
-bcPrepBind (StgNonRec bndr rhs) =
-  let (bndr', rhs') = bcPrepSingleBind (bndr, rhs)
-  in  StgNonRec bndr' <$> bcPrepRHS rhs'
-bcPrepBind (StgRec bnds) =
-  StgRec <$> mapM ((\(b,r) -> (,) b <$> bcPrepRHS r) . bcPrepSingleBind)
-                  bnds
-
-bcPrepSingleBind :: (Id, StgRhs) -> (Id, StgRhs)
--- If necessary, modify this Id and body to protect not-necessarily-lifted join points.
--- See Note [Not-necessarily-lifted join points], step 2.
-bcPrepSingleBind (x, StgRhsClosure ext cc upd_flag args body)
-  | isNNLJoinPoint x
-  = ( protectNNLJoinPointId x
-    , StgRhsClosure ext cc upd_flag (args ++ [voidArgId]) body)
-bcPrepSingleBind bnd = bnd
-
 -- -----------------------------------------------------------------------------
 -- Compilation schema for the bytecode generator
 
@@ -707,19 +607,6 @@ schemeE d s p (StgCase scrut _ _ []) = schemeE d s p scrut
 schemeE d s p (StgCase scrut bndr _ alts)
    = doCase d s p scrut bndr alts
 
--- Is this Id a not-necessarily-lifted join point?
--- See Note [Not-necessarily-lifted join points], step 1
-isNNLJoinPoint :: Id -> Bool
-isNNLJoinPoint x = isJoinId x &&
-                   Just True /= isLiftedType_maybe (idType x)
-
--- Update an Id's type to take a Void# argument.
--- Precondition: the Id is a not-necessarily-lifted join point.
--- See Note [Not-necessarily-lifted join points]
-protectNNLJoinPointId :: Id -> Id
-protectNNLJoinPointId x
-  = assert (isNNLJoinPoint x )
-    updateIdTypeButNotMult (unboxedUnitTy `mkVisFunTyMany`) x
 
 {-
    Ticked Expressions
@@ -728,66 +615,6 @@ protectNNLJoinPointId x
   The idea is that the "breakpoint<n,fvs> E" is really just an annotation on
   the code. When we find such a thing, we pull out the useful information,
   and then compile the code as if it was just the expression E.
-
-Note [Not-necessarily-lifted join points]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-A join point variable is essentially a goto-label: it is, for example,
-never used as an argument to another function, and it is called only
-in tail position. See Note [Join points] and Note [Invariants on join points],
-both in GHC.Core. Because join points do not compile to true, red-blooded
-variables (with, e.g., registers allocated to them), they are allowed
-to be representation-polymorphic.
-(See invariant #6 in Note [Invariants on join points] in GHC.Core.)
-
-However, in this byte-code generator, join points *are* treated just as
-ordinary variables. There is no check whether a binding is for a join point
-or not; they are all treated uniformly. (Perhaps there is a missed optimization
-opportunity here, but that is beyond the scope of my (Richard E's) Thursday.)
-
-We thus must have *some* strategy for dealing with representation-polymorphic
-and unlifted join points. Representation-polymorphic variables are generally
-not allowed (though representation -polymorphic join points *are*; see
-Note [Invariants on join points] in GHC.Core, point 6), and we don't wish to
-evaluate unlifted join points eagerly.
-The questionable join points are *not-necessarily-lifted join points*
-(NNLJPs). (Not having such a strategy led to #16509, which panicked in the
-isUnliftedType check in the AnnVar case of schemeE.) Here is the strategy:
-
-1. Detect NNLJPs. This is done in isNNLJoinPoint.
-
-2. When binding an NNLJP, add a `\ (_ :: (# #)) ->` to its RHS, and modify the
-   type to tack on a `(# #) ->`.
-   Note that functions are never representation-polymorphic, so this
-   transformation changes an NNLJP to a non-representation-polymorphic
-   join point. This is done in bcPrepSingleBind.
-
-3. At an occurrence of an NNLJP, add an application to void# (called voidPrimId),
-   being careful to note the new type of the NNLJP. This is done in the AnnVar
-   case of schemeE, with help from protectNNLJoinPointId.
-
-Here is an example. Suppose we have
-
-  f = \(r :: RuntimeRep) (a :: TYPE r) (x :: T).
-      join j :: a
-           j = error @r @a "bloop"
-      in case x of
-           A -> j
-           B -> j
-           C -> error @r @a "blurp"
-
-Our plan is to behave is if the code was
-
-  f = \(r :: RuntimeRep) (a :: TYPE r) (x :: T).
-      let j :: (Void# -> a)
-          j = \ _ -> error @r @a "bloop"
-      in case x of
-           A -> j void#
-           B -> j void#
-           C -> error @r @a "blurp"
-
-It's a bit hacky, but it works well in practice and is local. I suspect the
-Right Fix is to take advantage of join points as goto-labels.
-
 -}
 
 -- Compile code to do a tail call.  Specifically, push the fn,
@@ -2160,7 +1987,6 @@ typeArgReps platform = map (toArgRep platform) . typePrimRepArgs
 data BcM_State
    = BcM_State
         { bcm_hsc_env :: HscEnv
-        , uniqSupply  :: UniqSupply      -- for generating fresh variable names
         , thisModule  :: Module          -- current module (for breakpoints)
         , nextlabel   :: Word32          -- for generating local labels
         , ffis        :: [FFIInfo]       -- ffi info blocks, to free later
@@ -2178,12 +2004,12 @@ ioToBc io = BcM $ \st -> do
   x <- io
   return (st, x)
 
-runBc :: HscEnv -> UniqSupply -> Module -> Maybe ModBreaks
+runBc :: HscEnv -> Module -> Maybe ModBreaks
       -> IdEnv (RemotePtr ())
       -> BcM r
       -> IO (BcM_State, r)
-runBc hsc_env us this_mod modBreaks topStrings (BcM m)
-   = m (BcM_State hsc_env us this_mod 0 [] modBreaks IntMap.empty topStrings)
+runBc hsc_env this_mod modBreaks topStrings (BcM m)
+   = m (BcM_State hsc_env this_mod 0 [] modBreaks IntMap.empty topStrings)
 
 thenBc :: BcM a -> (a -> BcM b) -> BcM b
 thenBc (BcM expr) cont = BcM $ \st0 -> do
@@ -2249,22 +2075,11 @@ newBreakInfo :: BreakIndex -> CgBreakInfo -> BcM ()
 newBreakInfo ix info = BcM $ \st ->
   return (st{breakInfo = IntMap.insert ix info (breakInfo st)}, ())
 
-newUnique :: BcM Unique
-newUnique = BcM $
-   \st -> case takeUniqFromSupply (uniqSupply st) of
-             (uniq, us) -> let newState = st { uniqSupply = us }
-                           in  return (newState, uniq)
-
 getCurrentModule :: BcM Module
 getCurrentModule = BcM $ \st -> return (st, thisModule st)
 
 getTopStrings :: BcM (IdEnv (RemotePtr ()))
 getTopStrings = BcM $ \st -> return (st, topStrings st)
 
-newId :: Type -> BcM Id
-newId ty = do
-    uniq <- newUnique
-    return $ mkSysLocal tickFS uniq Many ty
-
 tickFS :: FastString
 tickFS = fsLit "ticked"
diff --git a/compiler/ghc.cabal.in b/compiler/ghc.cabal.in
index 55e37b1d60..e5376dc772 100644
--- a/compiler/ghc.cabal.in
+++ b/compiler/ghc.cabal.in
@@ -544,6 +544,7 @@ Library
         GHC.Settings.Config
         GHC.Settings.Constants
         GHC.Settings.IO
+        GHC.Stg.BcPrep
         GHC.Stg.CSE
         GHC.Stg.Debug
         GHC.Stg.DepAnal