diff --git a/compiler/GHC/Cmm/Parser.y b/compiler/GHC/Cmm/Parser.y
--- a/compiler/GHC/Cmm/Parser.y
+++ b/compiler/GHC/Cmm/Parser.y
@@ -229,6 +229,7 @@
 import GHC.StgToCmm.Ticky
 import GHC.StgToCmm.Prof
 import GHC.StgToCmm.Bind  ( emitBlackHoleCode, emitUpdateFrame )
+import GHC.StgToCmm.InfoTableProv
 
 import GHC.Cmm.Opt
 import GHC.Cmm.Graph
@@ -1519,14 +1520,18 @@
     POk pst code -> do
         st <- initC
         let fstate = F.initFCodeState (profilePlatform $ targetProfile dflags)
+        let config = initStgToCmmConfig dflags no_module
         let fcode = do
               ((), cmm) <- getCmm $ unEC code "global" (initEnv (targetProfile dflags)) [] >> return ()
               -- See Note [Mapping Info Tables to Source Positions] (IPE Maps)
-              let used_info = map (cmmInfoTableToInfoProvEnt this_mod)
-                                              (mapMaybe topInfoTable cmm)
-              ((), cmm2) <- getCmm $ mapM_ emitInfoTableProv used_info
+              let used_info
+                    | do_ipe    = map (cmmInfoTableToInfoProvEnt this_mod) (mapMaybe topInfoTable cmm)
+                    | otherwise = []
+                    where
+                      do_ipe = stgToCmmInfoTableMap config
+              ((), cmm2) <- getCmm $ emitIpeBufferListNode this_mod used_info
               return (cmm ++ cmm2, used_info)
-            (cmm, _) = runC (initStgToCmmConfig dflags no_module) fstate st fcode
+            (cmm, _) = runC config fstate st fcode
             (warnings,errors) = getPsMessages pst
         if not (isEmptyMessages errors)
          then return (warnings, errors, Nothing)
diff --git a/compiler/GHC/CmmToAsm/AArch64/CodeGen.hs b/compiler/GHC/CmmToAsm/AArch64/CodeGen.hs
--- a/compiler/GHC/CmmToAsm/AArch64/CodeGen.hs
+++ b/compiler/GHC/CmmToAsm/AArch64/CodeGen.hs
@@ -662,10 +662,11 @@
         -- See Note [Signed arithmetic on AArch64].
         negate code w reg = do
             let w' = opRegWidth w
+            (reg', code_sx) <- signExtendReg w w' reg
             return $ Any (intFormat w) $ \dst ->
                 code `appOL`
-                signExtendReg w w' reg `snocOL`
-                NEG (OpReg w' dst) (OpReg w' reg) `appOL`
+                code_sx `snocOL`
+                NEG (OpReg w' dst) (OpReg w' reg') `appOL`
                 truncateReg w' w dst
 
         ss_conv from to reg code =
@@ -815,15 +816,17 @@
               -- should be performed.
               let w' = opRegWidth w
                   signExt r
-                    | not is_signed  = nilOL
+                    | not is_signed  = return (r, nilOL)
                     | otherwise      = signExtendReg w w' r
+              (reg_x_sx, code_x_sx) <- signExt reg_x
+              (reg_y_sx, code_y_sx) <- signExt reg_y
               return $ Any (intFormat w) $ \dst ->
                   code_x `appOL`
                   code_y `appOL`
                   -- sign-extend both operands
-                  signExt reg_x `appOL`
-                  signExt reg_y `appOL`
-                  op (OpReg w' dst) (OpReg w' reg_x) (OpReg w' reg_y) `appOL`
+                  code_x_sx `appOL`
+                  code_y_sx `appOL`
+                  op (OpReg w' dst) (OpReg w' reg_x_sx) (OpReg w' reg_y_sx) `appOL`
                   truncateReg w' w dst -- truncate back to the operand's original width
 
           floatOp w op = do
@@ -1019,16 +1022,21 @@
 
 -- | Instructions to sign-extend the value in the given register from width @w@
 -- up to width @w'@.
-signExtendReg :: Width -> Width -> Reg -> OrdList Instr
+signExtendReg :: Width -> Width -> Reg -> NatM (Reg, OrdList Instr)
 signExtendReg w w' r =
     case w of
-      W64 -> nilOL
+      W64 -> noop
       W32
-        | w' == W32 -> nilOL
-        | otherwise -> unitOL $ SXTH (OpReg w' r) (OpReg w' r)
-      W16           -> unitOL $ SXTH (OpReg w' r) (OpReg w' r)
-      W8            -> unitOL $ SXTB (OpReg w' r) (OpReg w' r)
+        | w' == W32 -> noop
+        | otherwise -> extend SXTH
+      W16           -> extend SXTH
+      W8            -> extend SXTB
       _             -> panic "intOp"
+  where
+    noop = return (r, nilOL)
+    extend instr = do
+        r' <- getNewRegNat II64
+        return (r', unitOL $ instr (OpReg w' r') (OpReg w' r))
 
 -- | Instructions to truncate the value in the given register from width @w@
 -- down to width @w'@.
diff --git a/compiler/GHC/CmmToLlvm/Base.hs b/compiler/GHC/CmmToLlvm/Base.hs
--- a/compiler/GHC/CmmToLlvm/Base.hs
+++ b/compiler/GHC/CmmToLlvm/Base.hs
@@ -67,7 +67,7 @@
 import Data.Maybe (fromJust)
 import Control.Monad (ap)
 import Data.Char (isDigit)
-import Data.List (sortBy, groupBy, intercalate)
+import Data.List (sortBy, groupBy, intercalate, isPrefixOf)
 import Data.Ord (comparing)
 import qualified Data.List.NonEmpty as NE
 
@@ -550,6 +550,12 @@
   modifyEnv $ \env -> env { envAliases = emptyUniqSet }
   return (concat defss, [])
 
+-- | Is a variable one of the special @$llvm@ globals?
+isBuiltinLlvmVar :: LlvmVar -> Bool
+isBuiltinLlvmVar (LMGlobalVar lbl _ _ _ _ _) =
+    "$llvm" `isPrefixOf` unpackFS lbl
+isBuiltinLlvmVar _ = False
+
 -- | Here we take a global variable definition, rename it with a
 -- @$def@ suffix, and generate the appropriate alias.
 aliasify :: LMGlobal -> LlvmM [LMGlobal]
@@ -557,8 +563,9 @@
 -- Here we obtain the indirectee's precise type and introduce
 -- fresh aliases to both the precise typed label (lbl$def) and the i8*
 -- typed (regular) label of it with the matching new names.
-aliasify (LMGlobal (LMGlobalVar lbl ty@LMAlias{} link sect align Alias)
-                   (Just orig)) = do
+aliasify (LMGlobal var@(LMGlobalVar lbl ty@LMAlias{} link sect align Alias)
+                   (Just orig))
+  | not $ isBuiltinLlvmVar var = do
     let defLbl = llvmDefLabel lbl
         LMStaticPointer (LMGlobalVar origLbl _ oLnk Nothing Nothing Alias) = orig
         defOrigLbl = llvmDefLabel origLbl
@@ -571,7 +578,8 @@
     pure [ LMGlobal (LMGlobalVar defLbl ty link sect align Alias) (Just defOrig)
          , LMGlobal (LMGlobalVar lbl i8Ptr link sect align Alias) (Just orig')
          ]
-aliasify (LMGlobal var val) = do
+aliasify (LMGlobal var val)
+  | not $ isBuiltinLlvmVar var = do
     let LMGlobalVar lbl ty link sect align const = var
 
         defLbl = llvmDefLabel lbl
@@ -589,6 +597,7 @@
     return [ LMGlobal defVar val
            , LMGlobal aliasVar (Just aliasVal)
            ]
+aliasify global = pure [global]
 
 -- Note [Llvm Forward References]
 -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
@@ -647,3 +656,6 @@
 -- away with casting the alias to the desired type in @getSymbolPtr@
 -- and instead just emit a reference to the definition symbol directly.
 -- This is the @Just@ case in @getSymbolPtr@.
+--
+-- Note that we must take care not to turn LLVM's builtin variables into
+-- aliases (e.g. $llvm.global_ctors) since this confuses LLVM.
diff --git a/compiler/GHC/Core/Opt/CprAnal.hs b/compiler/GHC/Core/Opt/CprAnal.hs
--- a/compiler/GHC/Core/Opt/CprAnal.hs
+++ b/compiler/GHC/Core/Opt/CprAnal.hs
@@ -398,8 +398,10 @@
   where
     init_sig id
       -- See Note [CPR for data structures]
-      | isDataStructure id = topCprSig
-      | otherwise          = mkCprSig 0 botCpr
+      -- Don't set the sig to bottom in this case, because cprAnalBind won't
+      -- update it to something reasonable. Result: Assertion error in WW
+      | isDataStructure id || isDFunId id = topCprSig
+      | otherwise                         = mkCprSig 0 botCpr
     -- See Note [Initialising strictness] in GHC.Core.Opt.DmdAnal
     orig_virgin = ae_virgin orig_env
     init_pairs | orig_virgin  = [(setIdCprSig id (init_sig id), rhs) | (id, rhs) <- orig_pairs ]
@@ -464,10 +466,10 @@
   | isDFunId id -- Never give DFuns the CPR property; we'll never save allocs.
   = (id,  rhs,  extendSigEnv env id topCprSig)
   -- See Note [CPR for data structures]
-  | isDataStructure id
-  = (id,  rhs,  env) -- Data structure => no code => no need to analyse rhs
+  | isDataStructure id -- Data structure => no code => no need to analyse rhs
+  = (id,  rhs,  env)
   | otherwise
-  = (id', rhs', env')
+  = (id `setIdCprSig` sig',       rhs', env')
   where
     (rhs_ty, rhs')  = cprAnal env rhs
     -- possibly trim thunk CPR info
@@ -481,7 +483,6 @@
     -- See Note [The OPAQUE pragma and avoiding the reboxing of results]
     sig' | isOpaquePragma (idInlinePragma id) = topCprSig
          | otherwise                          = sig
-    id'  = setIdCprSig id sig'
     env' = extendSigEnv env id sig'
 
     -- See Note [CPR for thunks]
diff --git a/compiler/GHC/Core/Opt/Simplify.hs b/compiler/GHC/Core/Opt/Simplify.hs
--- a/compiler/GHC/Core/Opt/Simplify.hs
+++ b/compiler/GHC/Core/Opt/Simplify.hs
@@ -64,6 +64,7 @@
 import GHC.Data.Maybe   ( isNothing, orElse )
 import GHC.Data.FastString
 import GHC.Unit.Module ( moduleName, pprModuleName )
+import GHC.Utils.Misc
 import GHC.Utils.Outputable
 import GHC.Utils.Panic
 import GHC.Utils.Panic.Plain
@@ -256,9 +257,11 @@
              -> [(InId, InExpr)]
              -> SimplM (SimplFloats, SimplEnv)
 simplRecBind env0 bind_cxt pairs0
-  = do  { (env_with_info, triples) <- mapAccumLM add_rules env0 pairs0
-        ; (rec_floats, env1) <- go env_with_info triples
-        ; return (mkRecFloats rec_floats, env1) }
+  = do  { (env1, triples) <- mapAccumLM add_rules env0 pairs0
+        ; let new_bndrs = map sndOf3 triples
+        ; (rec_floats, env2) <- enterRecGroupRHSs env1 new_bndrs $ \env ->
+            go env triples
+        ; return (mkRecFloats rec_floats, env2) }
   where
     add_rules :: SimplEnv -> (InBndr,InExpr) -> SimplM (SimplEnv, (InBndr, OutBndr, InExpr))
         -- Add the (substituted) rules to the binder
@@ -2141,19 +2144,32 @@
             (ApplyToVal { sc_arg = arg, sc_env = arg_se
                         , sc_cont = cont, sc_hole_ty = fun_ty })
   | fun_id `hasKey` runRWKey
-  , not (contIsStop cont)  -- Don't fiddle around if the continuation is boring
   , [ TyArg {}, TyArg {} ] <- rev_args
-  = do { s <- newId (fsLit "s") Many realWorldStatePrimTy
-       ; let (m,_,_) = splitFunTy fun_ty
-             env'  = (arg_se `setInScopeFromE` env) `addNewInScopeIds` [s]
+  -- Do this even if (contIsStop cont)
+  -- See Note [No eta-expansion in runRW#]
+  = do { let arg_env = arg_se `setInScopeFromE` env
              ty'   = contResultType cont
-             cont' = ApplyToVal { sc_dup = Simplified, sc_arg = Var s
-                                , sc_env = env', sc_cont = cont
-                                , sc_hole_ty = mkVisFunTy m realWorldStatePrimTy ty' }
-                     -- cont' applies to s, then K
-       ; body' <- simplExprC env' arg cont'
-       ; let arg'  = Lam s body'
-             rr'   = getRuntimeRep ty'
+
+       -- If the argument is a literal lambda already, take a short cut
+       -- This isn't just efficiency; if we don't do this we get a beta-redex
+       -- every time, so the simplifier keeps doing more iterations.
+       ; arg' <- case arg of
+           Lam s body -> do { (env', s') <- simplBinder arg_env s
+                            ; body' <- simplExprC env' body cont
+                            ; return (Lam s' body') }
+                            -- Important: do not try to eta-expand this lambda
+                            -- See Note [No eta-expansion in runRW#]
+           _ -> do { s' <- newId (fsLit "s") Many realWorldStatePrimTy
+                   ; let (m,_,_) = splitFunTy fun_ty
+                         env'  = arg_env `addNewInScopeIds` [s']
+                         cont' = ApplyToVal { sc_dup = Simplified, sc_arg = Var s'
+                                            , sc_env = env', sc_cont = cont
+                                            , sc_hole_ty = mkVisFunTy m realWorldStatePrimTy ty' }
+                                -- cont' applies to s', then K
+                   ; body' <- simplExprC env' arg cont'
+                   ; return (Lam s' body') }
+
+       ; let rr'   = getRuntimeRep ty'
              call' = mkApps (Var fun_id) [mkTyArg rr', mkTyArg ty', arg']
        ; return (emptyFloats env, call') }
 
@@ -2260,6 +2276,19 @@
 discard the entire application and replace it with (error "foo").  Getting
 all this at once is TOO HARD!
 
+Note [No eta-expansion in runRW#]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+When we see `runRW# (\s. blah)` we must not attempt to eta-expand that
+lambda.  Why not?  Because
+* `blah` can mention join points bound outside the runRW#
+* eta-expansion uses arityType, and
+* `arityType` cannot cope with free join Ids:
+
+So the simplifier spots the literal lambda, and simplifies inside it.
+It's a very special lambda, because it is the one the OccAnal spots and
+allows join points bound /outside/ to be called /inside/.
+
+See Note [No free join points in arityType] in GHC.Core.Opt.Arity
 
 ************************************************************************
 *                                                                      *
diff --git a/compiler/GHC/Core/Opt/Simplify/Env.hs b/compiler/GHC/Core/Opt/Simplify/Env.hs
--- a/compiler/GHC/Core/Opt/Simplify/Env.hs
+++ b/compiler/GHC/Core/Opt/Simplify/Env.hs
@@ -17,7 +17,7 @@
         zapSubstEnv, setSubstEnv, bumpCaseDepth,
         getInScope, setInScopeFromE, setInScopeFromF,
         setInScopeSet, modifyInScope, addNewInScopeIds,
-        getSimplRules,
+        getSimplRules, enterRecGroupRHSs,
 
         -- * Substitution results
         SimplSR(..), mkContEx, substId, lookupRecBndr, refineFromInScope,
@@ -55,6 +55,7 @@
 import GHC.Types.Var.Env
 import GHC.Types.Var.Set
 import GHC.Data.OrdList
+import GHC.Data.Graph.UnVar
 import GHC.Types.Id as Id
 import GHC.Core.Make            ( mkWildValBinder )
 import GHC.Driver.Session       ( DynFlags )
@@ -96,6 +97,10 @@
       , seCvSubst   :: CvSubstEnv      -- InCoVar |--> OutCoercion
       , seIdSubst   :: SimplIdSubst    -- InId    |--> OutExpr
 
+        -- | Fast OutVarSet tracking which recursive RHSs we are analysing.
+        -- See Note [Eta reduction in recursive RHSs] in GHC.Core.Opt.Arity.
+      , seRecIds :: !UnVarSet
+
      ----------- Dynamic part of the environment -----------
      -- Dynamic in the sense of describing the setup where
      -- the expression finally ends up
@@ -286,6 +291,7 @@
              , seTvSubst   = emptyVarEnv
              , seCvSubst   = emptyVarEnv
              , seIdSubst   = emptyVarEnv
+             , seRecIds    = emptyUnVarSet
              , seCaseDepth = 0 }
         -- The top level "enclosing CC" is "SUBSUMED".
 
@@ -391,6 +397,13 @@
 modifyInScope env@(SimplEnv {seInScope = in_scope}) v
   = env {seInScope = extendInScopeSet in_scope v}
 
+enterRecGroupRHSs :: SimplEnv -> [OutBndr] -> (SimplEnv -> SimplM (r, SimplEnv))
+                  -> SimplM (r, SimplEnv)
+enterRecGroupRHSs env bndrs k = do
+  --pprTraceM "enterRecGroupRHSs" (ppr bndrs)
+  (r, env'') <- k env{seRecIds = extendUnVarSetList bndrs (seRecIds env)}
+  return (r, env''{seRecIds = seRecIds env})
+
 {- Note [Setting the right in-scope set]
 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 Consider
@@ -886,31 +899,18 @@
 Note [Arity robustness]
 ~~~~~~~~~~~~~~~~~~~~~~~
 We *do* transfer the arity from the in_id of a let binding to the
-out_id.  This is important, so that the arity of an Id is visible in
-its own RHS.  For example:
-        f = \x. ....g (\y. f y)....
-We can eta-reduce the arg to g, because f is a value.  But that
-needs to be visible.
-
-This interacts with the 'state hack' too:
-        f :: Bool -> IO Int
-        f = \x. case x of
-                  True  -> f y
-                  False -> \s -> ...
-Can we eta-expand f?  Only if we see that f has arity 1, and then we
-take advantage of the 'state hack' on the result of
-(f y) :: State# -> (State#, Int) to expand the arity one more.
-
-There is a disadvantage though.  Making the arity visible in the RHS
-allows us to eta-reduce
-        f = \x -> f x
-to
-        f = f
-which technically is not sound.   This is very much a corner case, so
-I'm not worried about it.  Another idea is to ensure that f's arity
-never decreases; its arity started as 1, and we should never eta-reduce
-below that.
+out_id so that its arity is visible in its RHS. Examples:
 
+  * f = \x y. let g = \p q. f (p+q) in Just (...g..g...)
+    Here we want to give `g` arity 3 and eta-expand. `findRhsArity` will have a
+    hard time figuring that out when `f` only has arity 0 in its own RHS.
+  * f = \x y. ....(f `seq` blah)....
+    We want to drop the seq.
+  * f = \x. g (\y. f y)
+    You'd think we could eta-reduce `\y. f y` to `f` here. And indeed, that is true.
+    Unfortunately, it is not sound in general to eta-reduce in f's RHS.
+    Example: `f = \x. f x`. See Note [Eta reduction in recursive RHSs] for how
+    we prevent that.
 
 Note [Robust OccInfo]
 ~~~~~~~~~~~~~~~~~~~~~
diff --git a/compiler/GHC/Core/Opt/Simplify/Utils.hs b/compiler/GHC/Core/Opt/Simplify/Utils.hs
--- a/compiler/GHC/Core/Opt/Simplify/Utils.hs
+++ b/compiler/GHC/Core/Opt/Simplify/Utils.hs
@@ -1610,6 +1610,7 @@
        ; mkLam' dflags bndrs body }
   where
     mode = getMode env
+    rec_ids  = seRecIds env
 
     mkLam' :: DynFlags -> [OutBndr] -> OutExpr -> SimplM OutExpr
     mkLam' dflags bndrs body@(Lam {})
@@ -1633,7 +1634,7 @@
 
     mkLam' dflags bndrs body
       | gopt Opt_DoEtaReduction dflags
-      , Just etad_lam <- {-# SCC "tryee" #-} tryEtaReduce bndrs body
+      , Just etad_lam <- {-# SCC "tryee" #-} tryEtaReduce rec_ids bndrs body
       = do { tick (EtaReduction (head bndrs))
            ; return etad_lam }
 
@@ -1731,9 +1732,7 @@
 tryEtaExpandRhs env bndr rhs
   | Just join_arity <- isJoinId_maybe bndr
   = do { let (join_bndrs, join_body) = collectNBinders join_arity rhs
-             oss   = [idOneShotInfo id | id <- join_bndrs, isId id]
-             arity_type | exprIsDeadEnd join_body = mkBotArityType oss
-                        | otherwise               = mkTopArityType oss
+             arity_type = mkManifestArityType join_bndrs join_body
        ; return (arity_type, rhs) }
          -- Note [Do not eta-expand join points]
          -- But do return the correct arity and bottom-ness, because
diff --git a/compiler/GHC/Core/Opt/SpecConstr.hs b/compiler/GHC/Core/Opt/SpecConstr.hs
--- a/compiler/GHC/Core/Opt/SpecConstr.hs
+++ b/compiler/GHC/Core/Opt/SpecConstr.hs
@@ -1732,14 +1732,6 @@
               -- changes (#4012).
               rule_name  = mkFastString ("SC:" ++ occNameString fn_occ ++ show rule_number)
               spec_name  = mkInternalName spec_uniq spec_occ fn_loc
---      ; pprTrace "spec_one {" (vcat [ text "function:" <+> ppr fn <+> ppr (idUnique fn)
---                                    , text "sc_count:" <+> ppr (sc_count env)
---                                    , text "pats:" <+> ppr pats
---                                    , text "-->" <+> ppr spec_name
---                                    , text "bndrs" <+> ppr arg_bndrs
---                                    , text "body" <+> ppr body
---                                    , text "how_bound" <+> ppr (sc_how_bound env) ]) $
---        return ()
 
         -- Specialise the body
         -- ; pprTraceM "body_subst_for" $ ppr (spec_occ) $$ ppr (sc_subst body_env)
@@ -1754,9 +1746,10 @@
                   = calcSpecInfo fn call_pat extra_bndrs
                   -- Annotate the variables with the strictness information from
                   -- the function (see Note [Strictness information in worker binders])
-
+              add_void_arg = needsVoidWorkerArg fn arg_bndrs spec_lam_args1
               (spec_lam_args, spec_call_args, spec_arity, spec_join_arity)
-                  | needsVoidWorkerArg fn arg_bndrs spec_lam_args1
+                  | add_void_arg
+                  -- See Note [SpecConst needs to add void args first]
                   , (spec_lam_args, spec_call_args, _) <- addVoidWorkerArg spec_lam_args1 []
                       -- needsVoidWorkerArg: usual w/w hack to avoid generating
                       -- a spec_rhs of unlifted type and no args.
@@ -1777,13 +1770,32 @@
 
                 -- Conditionally use result of new worker-wrapper transform
               spec_rhs   = mkLams spec_lam_args (mkSeqs cbv_args spec_body_ty spec_body)
-              rule_rhs   = mkVarApps (Var spec_id) $
-                           dropTail (length extra_bndrs) spec_call_args
+              rule_rhs = mkVarApps (Var spec_id) $
+                              -- This will give us all the arguments we quantify over
+                              -- in the rule plus the void argument if present
+                              -- since `length(qvars) + void + length(extra_bndrs) = length spec_call_args`
+                              dropTail (length extra_bndrs) spec_call_args
               inline_act = idInlineActivation fn
               this_mod   = sc_module env
               rule       = mkRule this_mod True {- Auto -} True {- Local -}
                                   rule_name inline_act fn_name qvars pats rule_rhs
                            -- See Note [Transfer activation]
+
+        -- ; pprTrace "spec_one {" (vcat [ text "function:" <+> ppr fn <+> ppr (idUnique fn)
+        --                               , text "sc_count:" <+> ppr (sc_count env)
+        --                               , text "pats:" <+> ppr pats
+        --                               , text "call_pat:" <+> ppr call_pat
+        --                               , text "-->" <+> ppr spec_name
+        --                               , text "bndrs" <+> ppr arg_bndrs
+        --                               , text "extra_bndrs" <+> ppr extra_bndrs
+        --                               , text "spec_lam_args" <+> ppr spec_lam_args
+        --                               , text "spec_call_args" <+> ppr spec_call_args
+        --                               , text "rule_rhs" <+> ppr rule_rhs
+        --                               , text "adds_void_worker_arg" <+> ppr adds_void_worker_arg
+        --                               , text "body" <+> ppr body
+        --                               , text "spec_rhs" <+> ppr spec_rhs
+        --                               , text "how_bound" <+> ppr (sc_how_bound env) ]) $
+        --   return ()
         ; return (spec_usg, OS { os_pat = call_pat, os_rule = rule
                                , os_id = spec_id
                                , os_rhs = spec_rhs }) }
@@ -2262,9 +2274,14 @@
               "SpecConstr: bad covars"
               (ppr bad_covars $$ ppr call) $
           if interesting && isEmptyVarSet bad_covars
-          then
+          then do
               -- pprTraceM "callToPatsOut" (
-              --   text "fun" <> ppr fn $$
+              --         text "fn:" <+> ppr fn $$
+              --         text "args:" <+> ppr args $$
+              --         text "in_scope:" <+> ppr in_scope $$
+              --         -- text "in_scope:" <+> ppr in_scope $$
+              --         text "pat_fvs:" <+> ppr pat_fvs
+              --       )
               --   ppr (CP { cp_qvars = qvars', cp_args = pats })) >>
               return (Just (CP { cp_qvars = qvars', cp_args = pats, cp_strict_args = concat cbv_ids }))
           else return Nothing }
diff --git a/compiler/GHC/CoreToStg/Prep.hs b/compiler/GHC/CoreToStg/Prep.hs
--- a/compiler/GHC/CoreToStg/Prep.hs
+++ b/compiler/GHC/CoreToStg/Prep.hs
@@ -49,6 +49,7 @@
 import GHC.Data.OrdList
 import GHC.Data.FastString
 import GHC.Data.Pair
+import GHC.Data.Graph.UnVar
 
 import GHC.Utils.Error
 import GHC.Utils.Misc
@@ -594,7 +595,7 @@
                      | otherwise
                      = addFloat floats new_float
 
-             new_float = mkFloat dmd is_unlifted bndr1 rhs1
+             new_float = mkFloat env dmd is_unlifted bndr1 rhs1
 
        ; return (env2, floats1, Nothing) }
 
@@ -608,24 +609,27 @@
 
 cpeBind top_lvl env (Rec pairs)
   | not (isJoinId (head bndrs))
-  = do { (env', bndrs1) <- cpCloneBndrs env bndrs
+  = do { (env, bndrs1) <- cpCloneBndrs env bndrs
+       ; let env' = enterRecGroupRHSs env bndrs1
        ; stuff <- zipWithM (cpePair top_lvl Recursive topDmd False env')
                            bndrs1 rhss
 
        ; let (floats_s, rhss1) = unzip stuff
              all_pairs = foldrOL add_float (bndrs1 `zip` rhss1)
                                            (concatFloats floats_s)
-
+       -- use env below, so that we reset cpe_rec_ids
        ; return (extendCorePrepEnvList env (bndrs `zip` bndrs1),
                  unitFloat (FloatLet (Rec all_pairs)),
                  Nothing) }
 
   | otherwise -- See Note [Join points and floating]
-  = do { (env', bndrs1) <- cpCloneBndrs env bndrs
+  = do { (env, bndrs1) <- cpCloneBndrs env bndrs
+       ; let env' = enterRecGroupRHSs env bndrs1
        ; pairs1 <- zipWithM (cpeJoinPair env') bndrs1 rhss
 
        ; let bndrs2 = map fst pairs1
-       ; return (extendCorePrepEnvList env' (bndrs `zip` bndrs2),
+       -- use env below, so that we reset cpe_rec_ids
+       ; return (extendCorePrepEnvList env (bndrs `zip` bndrs2),
                  emptyFloats,
                  Just (Rec pairs1)) }
   where
@@ -657,7 +661,7 @@
                else warnPprTrace True "CorePrep: silly extra arguments:" (ppr bndr) $
                                -- Note [Silly extra arguments]
                     (do { v <- newVar (idType bndr)
-                        ; let float = mkFloat topDmd False v rhs2
+                        ; let float = mkFloat env topDmd False v rhs2
                         ; return ( addFloat floats2 float
                                  , cpeEtaExpand arity (Var v)) })
 
@@ -1464,7 +1468,7 @@
        ; if okCpeArg arg2
          then do { v <- newVar arg_ty
                  ; let arg3      = cpeEtaExpand (exprArity arg2) arg2
-                       arg_float = mkFloat dmd is_unlifted v arg3
+                       arg_float = mkFloat env dmd is_unlifted v arg3
                  ; return (addFloat floats2 arg_float, varToCoreExpr v) }
          else return (floats2, arg2)
        }
@@ -1669,6 +1673,66 @@
 long as the callee might evaluate it. And if it is evaluated on
 most code paths anyway, we get to turn the unknown eval in the
 callee into a known call at the call site.
+
+However, we must be very careful not to speculate recursive calls!
+Doing so might well change termination behavior.
+
+That comes up in practice for DFuns, which are considered ok-for-spec,
+because they always immediately return a constructor.
+Not so if you speculate the recursive call, as #20836 shows:
+
+  class Foo m => Foo m where
+    runFoo :: m a -> m a
+  newtype Trans m a = Trans { runTrans :: m a }
+  instance Monad m => Foo (Trans m) where
+    runFoo = id
+
+(NB: class Foo m => Foo m` looks weird and needs -XUndecidableSuperClasses. The
+example in #20836 is more compelling, but boils down to the same thing.)
+This program compiles to the following DFun for the `Trans` instance:
+
+  Rec {
+  $fFooTrans
+    = \ @m $dMonad -> C:Foo ($fFooTrans $dMonad) (\ @a -> id)
+  end Rec }
+
+Note that the DFun immediately terminates and produces a dictionary, just
+like DFuns ought to, but it calls itself recursively to produce the `Foo m`
+dictionary. But alas, if we treat `$fFooTrans` as always-terminating, so
+that we can speculate its calls, and hence use call-by-value, we get:
+
+  $fFooTrans
+    = \ @m $dMonad -> case ($fFooTrans $dMonad) of sc ->
+                      C:Foo sc (\ @a -> id)
+
+and that's an infinite loop!
+Note that this bad-ness only happens in `$fFooTrans`'s own RHS. In the
+*body* of the letrec, it's absolutely fine to use call-by-value on
+`foo ($fFooTrans d)`.
+
+Our solution is this: we track in cpe_rec_ids the set of enclosing
+recursively-bound Ids, the RHSs of which we are currently transforming and then
+in 'exprOkForSpecEval' (a special entry point to 'exprOkForSpeculation',
+basically) we'll say that any binder in this set is not ok-for-spec.
+
+Note if we have a letrec group `Rec { f1 = rhs1; ...; fn = rhsn }`, and we
+prep up `rhs1`, we have to include not only `f1`, but all binders of the group
+`f1..fn` in this set, otherwise our fix is not robust wrt. mutual recursive
+DFuns.
+
+NB: If at some point we decide to have a termination analysis for general
+functions (#8655, !1866), we need to take similar precautions for (guarded)
+recursive functions:
+
+  repeat x = x : repeat x
+
+Same problem here: As written, repeat evaluates rapidly to WHNF. So `repeat x`
+is a cheap call that we are willing to speculate, but *not* in repeat's RHS.
+Fortunately, pce_rec_ids already has all the information we need in that case.
+
+The problem is very similar to Note [Eta reduction in recursive RHSs].
+Here as well as there it is *unsound* to change the termination properties
+of the very function whose termination properties we are exploiting.
 -}
 
 data FloatingBind
@@ -1715,8 +1779,8 @@
                         -- ok-to-speculate unlifted bindings
    | NotOkToSpec        -- Some not-ok-to-speculate unlifted bindings
 
-mkFloat :: Demand -> Bool -> Id -> CpeRhs -> FloatingBind
-mkFloat dmd is_unlifted bndr rhs
+mkFloat :: CorePrepEnv -> Demand -> Bool -> Id -> CpeRhs -> FloatingBind
+mkFloat env dmd is_unlifted bndr rhs
   | is_strict || ok_for_spec -- See Note [Speculative evaluation]
   , not is_hnf  = FloatCase rhs bndr DEFAULT [] ok_for_spec
     -- Don't make a case for a HNF binding, even if it's strict
@@ -1743,7 +1807,8 @@
   where
     is_hnf      = exprIsHNF rhs
     is_strict   = isStrUsedDmd dmd
-    ok_for_spec = exprOkForSpeculation rhs
+    ok_for_spec = exprOkForSpecEval (not . is_rec_call) rhs
+    is_rec_call = (`elemUnVarSet` cpe_rec_ids env)
 
 emptyFloats :: Floats
 emptyFloats = Floats OkToSpec nilOL
@@ -1941,6 +2006,7 @@
         , cpe_convertNumLit   :: LitNumType -> Integer -> Maybe CoreExpr
         -- ^ Convert some numeric literals (Integer, Natural) into their
         -- final Core form
+        , cpe_rec_ids         :: UnVarSet -- Faster OutIdSet; See Note [Speculative evaluation]
     }
 
 mkInitialCorePrepEnv :: HscEnv -> IO CorePrepEnv
@@ -1951,6 +2017,7 @@
       , cpe_env           = emptyVarEnv
       , cpe_tyco_env      = Nothing
       , cpe_convertNumLit = convertNumLit
+      , cpe_rec_ids       = emptyUnVarSet
       }
 
 extendCorePrepEnv :: CorePrepEnv -> Id -> Id -> CorePrepEnv
@@ -1971,6 +2038,10 @@
   = case lookupVarEnv (cpe_env cpe) id of
         Nothing  -> Var id
         Just exp -> exp
+
+enterRecGroupRHSs :: CorePrepEnv -> [OutId] -> CorePrepEnv
+enterRecGroupRHSs env grp
+  = env { cpe_rec_ids = extendUnVarSetList grp (cpe_rec_ids env) }
 
 ------------------------------------------------------------------------------
 --           CpeTyCoEnv
diff --git a/compiler/GHC/Data/Graph/UnVar.hs b/compiler/GHC/Data/Graph/UnVar.hs
deleted file mode 100644
--- a/compiler/GHC/Data/Graph/UnVar.hs
+++ /dev/null
@@ -1,181 +0,0 @@
-{-
-
-Copyright (c) 2014 Joachim Breitner
-
-A data structure for undirected graphs of variables
-(or in plain terms: Sets of unordered pairs of numbers)
-
-
-This is very specifically tailored for the use in CallArity. In particular it
-stores the graph as a union of complete and complete bipartite graph, which
-would be very expensive to store as sets of edges or as adjanceny lists.
-
-It does not normalize the graphs. This means that g `unionUnVarGraph` g is
-equal to g, but twice as expensive and large.
-
--}
-module GHC.Data.Graph.UnVar
-    ( UnVarSet
-    , emptyUnVarSet, mkUnVarSet, varEnvDom, unionUnVarSet, unionUnVarSets
-    , extendUnVarSet, delUnVarSet
-    , elemUnVarSet, isEmptyUnVarSet
-    , UnVarGraph
-    , emptyUnVarGraph
-    , unionUnVarGraph, unionUnVarGraphs
-    , completeGraph, completeBipartiteGraph
-    , neighbors
-    , hasLoopAt
-    , delNode
-    ) where
-
-import GHC.Prelude
-
-import GHC.Types.Id
-import GHC.Types.Var.Env
-import GHC.Types.Unique.FM
-import GHC.Utils.Outputable
-import GHC.Types.Unique
-
-import qualified Data.IntSet as S
-
--- We need a type for sets of variables (UnVarSet).
--- We do not use VarSet, because for that we need to have the actual variable
--- at hand, and we do not have that when we turn the domain of a VarEnv into a UnVarSet.
--- Therefore, use a IntSet directly (which is likely also a bit more efficient).
-
--- Set of uniques, i.e. for adjancet nodes
-newtype UnVarSet = UnVarSet (S.IntSet)
-    deriving Eq
-
-k :: Var -> Int
-k v = getKey (getUnique v)
-
-emptyUnVarSet :: UnVarSet
-emptyUnVarSet = UnVarSet S.empty
-
-elemUnVarSet :: Var -> UnVarSet -> Bool
-elemUnVarSet v (UnVarSet s) = k v `S.member` s
-
-
-isEmptyUnVarSet :: UnVarSet -> Bool
-isEmptyUnVarSet (UnVarSet s) = S.null s
-
-delUnVarSet :: UnVarSet -> Var -> UnVarSet
-delUnVarSet (UnVarSet s) v = UnVarSet $ k v `S.delete` s
-
-minusUnVarSet :: UnVarSet -> UnVarSet -> UnVarSet
-minusUnVarSet (UnVarSet s) (UnVarSet s') = UnVarSet $ s `S.difference` s'
-
-sizeUnVarSet :: UnVarSet -> Int
-sizeUnVarSet (UnVarSet s) = S.size s
-
-mkUnVarSet :: [Var] -> UnVarSet
-mkUnVarSet vs = UnVarSet $ S.fromList $ map k vs
-
-varEnvDom :: VarEnv a -> UnVarSet
-varEnvDom ae = UnVarSet $ ufmToSet_Directly ae
-
-extendUnVarSet :: Var -> UnVarSet -> UnVarSet
-extendUnVarSet v (UnVarSet s) = UnVarSet $ S.insert (k v) s
-
-unionUnVarSet :: UnVarSet -> UnVarSet -> UnVarSet
-unionUnVarSet (UnVarSet set1) (UnVarSet set2) = UnVarSet (set1 `S.union` set2)
-
-unionUnVarSets :: [UnVarSet] -> UnVarSet
-unionUnVarSets = foldl' (flip unionUnVarSet) emptyUnVarSet
-
-instance Outputable UnVarSet where
-    ppr (UnVarSet s) = braces $
-        hcat $ punctuate comma [ ppr (getUnique i) | i <- S.toList s]
-
-data UnVarGraph = CBPG  !UnVarSet !UnVarSet -- ^ complete bipartite graph
-                | CG    !UnVarSet           -- ^ complete graph
-                | Union UnVarGraph UnVarGraph
-                | Del   !UnVarSet UnVarGraph
-
-emptyUnVarGraph :: UnVarGraph
-emptyUnVarGraph = CG emptyUnVarSet
-
-unionUnVarGraph :: UnVarGraph -> UnVarGraph -> UnVarGraph
-{-
-Premature optimisation, it seems.
-unionUnVarGraph (UnVarGraph [CBPG s1 s2]) (UnVarGraph [CG s3, CG s4])
-    | s1 == s3 && s2 == s4
-    = pprTrace "unionUnVarGraph fired" empty $
-      completeGraph (s1 `unionUnVarSet` s2)
-unionUnVarGraph (UnVarGraph [CBPG s1 s2]) (UnVarGraph [CG s3, CG s4])
-    | s2 == s3 && s1 == s4
-    = pprTrace "unionUnVarGraph fired2" empty $
-      completeGraph (s1 `unionUnVarSet` s2)
--}
-unionUnVarGraph a b
-  | is_null a = b
-  | is_null b = a
-  | otherwise = Union a b
-
-unionUnVarGraphs :: [UnVarGraph] -> UnVarGraph
-unionUnVarGraphs = foldl' unionUnVarGraph emptyUnVarGraph
-
--- completeBipartiteGraph A B = { {a,b} | a ∈ A, b ∈ B }
-completeBipartiteGraph :: UnVarSet -> UnVarSet -> UnVarGraph
-completeBipartiteGraph s1 s2 = prune $ CBPG s1 s2
-
-completeGraph :: UnVarSet -> UnVarGraph
-completeGraph s = prune $ CG s
-
--- (v' ∈ neighbors G v) <=> v--v' ∈ G
-neighbors :: UnVarGraph -> Var -> UnVarSet
-neighbors = go
-  where
-    go (Del d g) v
-      | v `elemUnVarSet` d = emptyUnVarSet
-      | otherwise          = go g v `minusUnVarSet` d
-    go (Union g1 g2) v     = go g1 v `unionUnVarSet` go g2 v
-    go (CG s) v            = if v `elemUnVarSet` s then s else emptyUnVarSet
-    go (CBPG s1 s2) v      = (if v `elemUnVarSet` s1 then s2 else emptyUnVarSet) `unionUnVarSet`
-                             (if v `elemUnVarSet` s2 then s1 else emptyUnVarSet)
-
--- hasLoopAt G v <=> v--v ∈ G
-hasLoopAt :: UnVarGraph -> Var -> Bool
-hasLoopAt = go
-  where
-    go (Del d g) v
-      | v `elemUnVarSet` d  = False
-      | otherwise           = go g v
-    go (Union g1 g2) v      = go g1 v || go g2 v
-    go (CG s) v             = v `elemUnVarSet` s
-    go (CBPG s1 s2) v       = v `elemUnVarSet` s1 && v `elemUnVarSet` s2
-
-delNode :: UnVarGraph -> Var -> UnVarGraph
-delNode (Del d g) v = Del (extendUnVarSet v d) g
-delNode g         v
-  | is_null g       = emptyUnVarGraph
-  | otherwise       = Del (mkUnVarSet [v]) g
-
--- | Resolves all `Del`, by pushing them in, and simplifies `∅ ∪ … = …`
-prune :: UnVarGraph -> UnVarGraph
-prune = go emptyUnVarSet
-  where
-    go :: UnVarSet -> UnVarGraph -> UnVarGraph
-    go dels (Del dels' g) = go (dels `unionUnVarSet` dels') g
-    go dels (Union g1 g2)
-      | is_null g1' = g2'
-      | is_null g2' = g1'
-      | otherwise   = Union g1' g2'
-      where
-        g1' = go dels g1
-        g2' = go dels g2
-    go dels (CG s)        = CG (s `minusUnVarSet` dels)
-    go dels (CBPG s1 s2)  = CBPG (s1 `minusUnVarSet` dels) (s2 `minusUnVarSet` dels)
-
--- | Shallow empty check.
-is_null :: UnVarGraph -> Bool
-is_null (CBPG s1 s2)  = isEmptyUnVarSet s1 || isEmptyUnVarSet s2
-is_null (CG   s)      = isEmptyUnVarSet s
-is_null _             = False
-
-instance Outputable UnVarGraph where
-    ppr (Del d g) = text "Del" <+> ppr (sizeUnVarSet d) <+> parens (ppr g)
-    ppr (Union a b) = text "Union" <+> parens (ppr a) <+> parens (ppr b)
-    ppr (CG s) = text "CG" <+> ppr (sizeUnVarSet s)
-    ppr (CBPG a b) = text "CBPG" <+> ppr (sizeUnVarSet a) <+> ppr (sizeUnVarSet b)
diff --git a/compiler/GHC/Driver/CodeOutput.hs b/compiler/GHC/Driver/CodeOutput.hs
--- a/compiler/GHC/Driver/CodeOutput.hs
+++ b/compiler/GHC/Driver/CodeOutput.hs
@@ -370,26 +370,17 @@
   :: Bool            -- is Opt_InfoTableMap enabled or not
   -> Platform
   -> Module
-  -> [InfoProvEnt]
   -> CStub
-ipInitCode do_info_table platform this_mod ents
+ipInitCode do_info_table platform this_mod
   | not do_info_table = mempty
-  | otherwise = initializerCStub platform fn_nm decls body
+  | otherwise = initializerCStub platform fn_nm ipe_buffer_decl body
  where
    fn_nm = mkInitializerStubLabel this_mod "ip_init"
-   decls = vcat
-        $  map emit_ipe_decl ents
-        ++ [emit_ipe_list ents]
-   body = text "registerInfoProvList" <> parens local_ipe_list_label <> semi
-   emit_ipe_decl ipe =
-       text "extern InfoProvEnt" <+> ipe_lbl <> text "[];"
-     where ipe_lbl = pprCLabel platform CStyle (mkIPELabel ipe)
-   local_ipe_list_label = text "local_ipe_" <> ppr this_mod
-   emit_ipe_list ipes =
-      text "static InfoProvEnt *" <> local_ipe_list_label <> text "[] ="
-      <+> braces (vcat $ [ pprCLabel platform CStyle (mkIPELabel ipe) <> comma
-                         | ipe <- ipes
-                         ] ++ [text "NULL"])
-      <> semi
 
+   body = text "registerInfoProvList" <> parens (text "&" <> ipe_buffer_label) <> semi
+
+   ipe_buffer_label = pprCLabel platform CStyle (mkIPELabel this_mod)
+
+   ipe_buffer_decl =
+       text "extern IpeBufferListNode" <+> ipe_buffer_label <> text ";"
 
diff --git a/compiler/GHC/Driver/Main.hs b/compiler/GHC/Driver/Main.hs
--- a/compiler/GHC/Driver/Main.hs
+++ b/compiler/GHC/Driver/Main.hs
@@ -1770,7 +1770,7 @@
         -- lest we reproduce #11784.
         mod_name = mkModuleName $ "Cmm$" ++ original_filename
         cmm_mod = mkHomeModule home_unit mod_name
-    (cmm, ents) <- ioMsgMaybe
+    (cmm, ipe_ents) <- ioMsgMaybe
                $ do
                   (warns,errs,cmm) <- withTiming logger (text "ParseCmm"<+>brackets (text filename)) (\_ -> ())
                                        $ parseCmmFile dflags cmm_mod home_unit filename
@@ -1796,10 +1796,11 @@
           Nothing -> cmmToRawCmm logger profile (Stream.yield cmmgroup)
           Just h  -> h           dflags Nothing (Stream.yield cmmgroup)
 
-        let foreign_stubs _ =
-              let ip_init   = ipInitCode do_info_table platform cmm_mod ents
-              in NoStubs `appendStubC` ip_init
-
+        let foreign_stubs _
+              | not $ null ipe_ents =
+                  let ip_init = ipInitCode do_info_table platform cmm_mod
+                  in NoStubs `appendStubC` ip_init
+              | otherwise     = NoStubs
         (_output_filename, (_stub_h_exists, stub_c_exists), _foreign_fps, _caf_infos)
           <- codeOutput logger tmpfs dflags (hsc_units hsc_env) cmm_mod output_filename no_loc foreign_stubs [] S.empty
              rawCmms
diff --git a/compiler/GHC/Hs/Syn/Type.hs b/compiler/GHC/Hs/Syn/Type.hs
--- a/compiler/GHC/Hs/Syn/Type.hs
+++ b/compiler/GHC/Hs/Syn/Type.hs
@@ -133,9 +133,9 @@
 hsExprType (HsUntypedBracket (HsBracketTc _ ty _wrap _pending) _) = ty
 hsExprType e@(HsSpliceE{}) = pprPanic "hsExprType: Unexpected HsSpliceE"
                                       (ppr e)
-                                      -- Typed splices should have been eliminated during zonking, but we
-                                      -- can't use `dataConCantHappen` since they are still present before
-                                      -- than in the typechecked AST.
+                               -- Typed splices should have been eliminated during zonking, but we
+                               -- can't use `dataConCantHappen` since they are still present before
+                               -- than in the typechecked AST
 hsExprType (HsProc _ _ lcmd_top) = lhsCmdTopType lcmd_top
 hsExprType (HsStatic (_, ty) _s) = ty
 hsExprType (HsPragE _ _ e) = lhsExprType e
diff --git a/compiler/GHC/Iface/Ext/Ast.hs b/compiler/GHC/Iface/Ext/Ast.hs
--- a/compiler/GHC/Iface/Ext/Ast.hs
+++ b/compiler/GHC/Iface/Ext/Ast.hs
@@ -744,6 +744,9 @@
         RecordCon con_expr _ _ -> computeType con_expr
         ExprWithTySig _ e _ -> computeLType e
         HsPragE _ _ e -> computeLType e
+        -- By this point all splices are lifted into splice environments so
+        -- the remaining HsSpliceE in the syntax tree contain bogus information.
+        HsSpliceE {} -> Nothing
         XExpr (ExpansionExpr (HsExpanded (HsGetField _ _ _) e)) -> Just (hsExprType e) -- for record-dot-syntax
         XExpr (ExpansionExpr (HsExpanded _ e)) -> computeType e
         XExpr (HsTick _ e) -> computeLType e
@@ -1873,10 +1876,10 @@
   toHie _ = pure []
 
 instance ToHie PendingRnSplice where
-  toHie _ = pure []
+  toHie (PendingRnSplice _ _ e) = toHie e
 
 instance ToHie PendingTcSplice where
-  toHie _ = pure []
+  toHie (PendingTcSplice _ e) = toHie e
 
 instance ToHie (LBooleanFormula (LocatedN Name)) where
   toHie (L span form) = concatM $ makeNode form (locA span) : case form of
diff --git a/compiler/GHC/Iface/Ext/Types.hs b/compiler/GHC/Iface/Ext/Types.hs
--- a/compiler/GHC/Iface/Ext/Types.hs
+++ b/compiler/GHC/Iface/Ext/Types.hs
@@ -781,5 +781,5 @@
   | isKnownKeyName name = KnownKeyName (nameUnique name)
   | isExternalName name = ExternalName (nameModule name)
                                        (nameOccName name)
-                                       (nameSrcSpan name)
-  | otherwise = LocalName (nameOccName name) (nameSrcSpan name)
+                                       (removeBufSpan $ nameSrcSpan name)
+  | otherwise = LocalName (nameOccName name) (removeBufSpan $ nameSrcSpan name)
diff --git a/compiler/GHC/Iface/Tidy.hs b/compiler/GHC/Iface/Tidy.hs
--- a/compiler/GHC/Iface/Tidy.hs
+++ b/compiler/GHC/Iface/Tidy.hs
@@ -24,13 +24,12 @@
 
 import GHC.Core
 import GHC.Core.Unfold
-import GHC.Core.Unfold.Make
 import GHC.Core.FVs
 import GHC.Core.Tidy
 import GHC.Core.Seq     (seqBinds)
-import GHC.Core.Opt.Arity   ( exprArity, exprBotStrictness_maybe )
+import GHC.Core.Opt.Arity   ( exprArity, exprBotStrictness_maybe, typeArity )
 import GHC.Core.InstEnv
-import GHC.Core.Type     ( tidyTopType )
+import GHC.Core.Type     ( tidyTopType, Type )
 import GHC.Core.DataCon
 import GHC.Core.TyCon
 import GHC.Core.Class
@@ -74,6 +73,7 @@
 import Data.List        ( sortBy, mapAccumL )
 import qualified Data.Set as S
 import GHC.Types.CostCentre
+import GHC.Core.Opt.OccurAnal (occurAnalyseExpr)
 
 {-
 Constructing the TypeEnv, Instances, Rules from which the
@@ -384,8 +384,7 @@
   (unfold_env, tidy_occ_env) <- chooseExternalIds opts mod binds implicit_binds imp_rules
   let (trimmed_binds, trimmed_rules) = findExternalRules opts binds imp_rules unfold_env
 
-  let uf_opts = opt_unfolding_opts opts
-  (tidy_env, tidy_binds) <- tidyTopBinds uf_opts unfold_env boot_exports tidy_occ_env trimmed_binds
+  (tidy_env, tidy_binds) <- tidyTopBinds unfold_env boot_exports tidy_occ_env trimmed_binds
 
   -- See Note [Grand plan for static forms] in GHC.Iface.Tidy.StaticPtrTable.
   (spt_entries, mcstub, tidy_binds') <- case opt_static_ptr_opts opts of
@@ -1146,60 +1145,49 @@
 --
 --   * subst_env: A Var->Var mapping that substitutes the new Var for the old
 
-tidyTopBinds :: UnfoldingOpts
-             -> UnfoldEnv
+tidyTopBinds :: UnfoldEnv
              -> NameSet
              -> TidyOccEnv
              -> CoreProgram
              -> IO (TidyEnv, CoreProgram)
 
-tidyTopBinds uf_opts unfold_env boot_exports init_occ_env binds
+tidyTopBinds unfold_env boot_exports init_occ_env binds
   = do let result = tidy init_env binds
        seqBinds (snd result) `seq` return result
        -- This seqBinds avoids a spike in space usage (see #13564)
   where
     init_env = (init_occ_env, emptyVarEnv)
 
-    tidy = mapAccumL (tidyTopBind uf_opts unfold_env boot_exports)
+    tidy = mapAccumL (tidyTopBind unfold_env boot_exports)
 
 ------------------------
-tidyTopBind  :: UnfoldingOpts
-             -> UnfoldEnv
+tidyTopBind  :: UnfoldEnv
              -> NameSet
              -> TidyEnv
              -> CoreBind
              -> (TidyEnv, CoreBind)
 
-tidyTopBind uf_opts unfold_env boot_exports
+tidyTopBind unfold_env boot_exports
             (occ_env,subst1) (NonRec bndr rhs)
   = (tidy_env2,  NonRec bndr' rhs')
   where
-    Just (name',show_unfold) = lookupVarEnv unfold_env bndr
-    (bndr', rhs') = tidyTopPair uf_opts show_unfold boot_exports tidy_env2 name' (bndr, rhs)
+    (bndr', rhs') = tidyTopPair unfold_env boot_exports tidy_env2 (bndr, rhs)
     subst2        = extendVarEnv subst1 bndr bndr'
     tidy_env2     = (occ_env, subst2)
 
-tidyTopBind uf_opts unfold_env boot_exports (occ_env, subst1) (Rec prs)
+tidyTopBind unfold_env boot_exports (occ_env, subst1) (Rec prs)
   = (tidy_env2, Rec prs')
   where
-    prs' = [ tidyTopPair uf_opts show_unfold boot_exports tidy_env2 name' (id,rhs)
-           | (id,rhs) <- prs,
-             let (name',show_unfold) =
-                    expectJust "tidyTopBind" $ lookupVarEnv unfold_env id
-           ]
-
-    subst2    = extendVarEnvList subst1 (bndrs `zip` map fst prs')
+    prs'      = map (tidyTopPair unfold_env boot_exports tidy_env2) prs
+    subst2    = extendVarEnvList subst1 (map fst prs `zip` map fst prs')
     tidy_env2 = (occ_env, subst2)
-
-    bndrs = map fst prs
+    -- This is where we "tie the knot": tidy_env2 is fed into tidyTopPair
 
 -----------------------------------------------------------
-tidyTopPair :: UnfoldingOpts
-            -> Bool  -- show unfolding
+tidyTopPair :: UnfoldEnv
             -> NameSet
             -> TidyEnv  -- The TidyEnv is used to tidy the IdInfo
                         -- It is knot-tied: don't look at it!
-            -> Name             -- New name
             -> (Id, CoreExpr)   -- Binder and RHS before tidying
             -> (Id, CoreExpr)
         -- This function is the heart of Step 2
@@ -1208,18 +1196,19 @@
         -- group, a variable late in the group might be mentioned
         -- in the IdInfo of one early in the group
 
-tidyTopPair uf_opts show_unfold boot_exports rhs_tidy_env name' (bndr, rhs)
+tidyTopPair unfold_env boot_exports rhs_tidy_env (bndr, rhs)
   = -- pprTrace "tidyTop" (ppr name' <+> ppr details <+> ppr rhs) $
     (bndr1, rhs1)
 
   where
+    Just (name',show_unfold) = lookupVarEnv unfold_env bndr
     !cbv_bndr = tidyCbvInfoTop boot_exports bndr rhs
     bndr1    = mkGlobalId details name' ty' idinfo'
     details  = idDetails cbv_bndr -- Preserve the IdDetails
     ty'      = tidyTopType (idType cbv_bndr)
     rhs1     = tidyExpr rhs_tidy_env rhs
-    idinfo'  = tidyTopIdInfo uf_opts rhs_tidy_env name' rhs rhs1 (idInfo cbv_bndr)
-                             show_unfold
+    idinfo'  = tidyTopIdInfo rhs_tidy_env name' ty'
+                             rhs rhs1 (idInfo cbv_bndr) show_unfold
 
 -- tidyTopIdInfo creates the final IdInfo for top-level
 -- binders.  The delicate piece:
@@ -1228,9 +1217,9 @@
 --      Indeed, CorePrep must eta expand where necessary to make
 --      the manifest arity equal to the claimed arity.
 --
-tidyTopIdInfo :: UnfoldingOpts -> TidyEnv -> Name -> CoreExpr -> CoreExpr
+tidyTopIdInfo :: TidyEnv -> Name -> Type -> CoreExpr -> CoreExpr
               -> IdInfo -> Bool -> IdInfo
-tidyTopIdInfo uf_opts rhs_tidy_env name orig_rhs tidy_rhs idinfo show_unfold
+tidyTopIdInfo rhs_tidy_env name rhs_ty orig_rhs tidy_rhs idinfo show_unfold
   | not is_external     -- For internal Ids (not externally visible)
   = vanillaIdInfo       -- we only need enough info for code generation
                         -- Arity and strictness info are enough;
@@ -1281,13 +1270,17 @@
 
     --------- Unfolding ------------
     unf_info = realUnfoldingInfo idinfo
-    unfold_info
-      | isCompulsoryUnfolding unf_info || show_unfold
-      = tidyUnfolding rhs_tidy_env unf_info unf_from_rhs
-      | otherwise
-      = minimal_unfold_info
-    minimal_unfold_info = trimUnfolding unf_info
-    unf_from_rhs = mkFinalUnfolding uf_opts InlineRhs final_sig tidy_rhs
+    !minimal_unfold_info = trimUnfolding unf_info
+
+    !unfold_info | isCompulsoryUnfolding unf_info || show_unfold
+                 = tidyTopUnfolding rhs_tidy_env tidy_rhs unf_info
+                 | otherwise
+                 = minimal_unfold_info
+
+     -- NB: use `orig_rhs` not `tidy_rhs` in this call to mkFinalUnfolding
+     -- else you get a black hole (#22122). Reason: mkFinalUnfolding
+     -- looks at IdInfo, and that is knot-tied in tidyTopBind (the Rec case)
+
     -- NB: do *not* expose the worker if show_unfold is off,
     --     because that means this thing is a loop breaker or
     --     marked NOINLINE or something like that
@@ -1311,4 +1304,54 @@
     -- did was to let-bind a non-atomic argument and then float
     -- it to the top level. So it seems more robust just to
     -- fix it here.
-    arity = exprArity orig_rhs
+    arity = exprArity orig_rhs `min` (length $ typeArity rhs_ty)
+
+
+------------ Unfolding  --------------
+tidyTopUnfolding :: TidyEnv -> CoreExpr -> Unfolding -> Unfolding
+tidyTopUnfolding _ _ NoUnfolding   = NoUnfolding
+tidyTopUnfolding _ _ BootUnfolding = BootUnfolding
+tidyTopUnfolding _ _ (OtherCon {}) = evaldUnfolding
+
+tidyTopUnfolding tidy_env _ df@(DFunUnfolding { df_bndrs = bndrs, df_args = args })
+  = df { df_bndrs = bndrs', df_args = map (tidyExpr tidy_env') args }
+  where
+    (tidy_env', bndrs') = tidyBndrs tidy_env bndrs
+
+tidyTopUnfolding tidy_env tidy_rhs
+     unf@(CoreUnfolding { uf_tmpl = unf_rhs, uf_src = src  })
+  = -- See Note [tidyTopUnfolding: avoiding black holes]
+    unf { uf_tmpl = tidy_unf_rhs }
+  where
+    tidy_unf_rhs | isStableSource src
+                 = tidyExpr tidy_env unf_rhs    -- Preserves OccInfo in unf_rhs
+                 | otherwise
+                 = occurAnalyseExpr tidy_rhs    -- Do occ-anal
+
+{- Note [tidyTopUnfolding: avoiding black holes]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+When we are exposing all unfoldings we don't want to tidy the unfolding
+twice -- we just want to use the tidied RHS.  That tidied RHS itself
+contains fully-tidied Ids -- it is knot-tied.  So the uf_tmpl for the
+unfolding contains stuff we can't look at.  Now consider (#22112)
+   foo = foo
+If we freshly compute the uf_is_value field for foo's unfolding,
+we'll call `exprIsValue`, which will look at foo's unfolding!
+Whether or not the RHS is a value depends on whether foo is a value...
+black hole.
+
+In the Simplifier we deal with this by not giving `foo` an unfolding
+in its own RHS.  And we could do that here.  But it's qite nice
+to common everything up to a single Id for foo, used everywhere.
+
+And it's not too hard: simply leave the unfolding undisturbed, except
+tidy the uf_tmpl field. Hence tidyTopUnfolding does
+   unf { uf_tmpl = tidy_unf_rhs }
+
+Don't mess with uf_is_value, or guidance; in particular don't recompute
+them from tidy_unf_rhs.
+
+And (unlike tidyNestedUnfolding) don't deep-seq the new unfolding,
+because that'll cause a black hole (I /think/ because occurAnalyseExpr
+looks in IdInfo).
+-}
diff --git a/compiler/GHC/StgToCmm/InfoTableProv.hs b/compiler/GHC/StgToCmm/InfoTableProv.hs
new file mode 100644
--- /dev/null
+++ b/compiler/GHC/StgToCmm/InfoTableProv.hs
@@ -0,0 +1,131 @@
+module GHC.StgToCmm.InfoTableProv (emitIpeBufferListNode) where
+
+import GHC.Prelude
+import GHC.Platform
+import GHC.Unit.Module
+import GHC.Utils.Outputable
+
+import GHC.Cmm.CLabel
+import GHC.Cmm.Expr
+import GHC.Cmm.Utils
+import GHC.StgToCmm.Config
+import GHC.StgToCmm.Lit (newByteStringCLit)
+import GHC.StgToCmm.Monad
+import GHC.StgToCmm.Utils
+
+import GHC.Data.ShortText (ShortText)
+import qualified GHC.Data.ShortText as ST
+
+import Data.Bifunctor (first)
+import qualified Data.Map.Strict as M
+import Control.Monad.Trans.State.Strict
+import qualified Data.ByteString as BS
+import qualified Data.ByteString.Builder as BSB
+import qualified Data.ByteString.Lazy as BSL
+
+emitIpeBufferListNode :: Module
+                      -> [InfoProvEnt]
+                      -> FCode ()
+emitIpeBufferListNode _ [] = return ()
+emitIpeBufferListNode this_mod ents = do
+    cfg <- getStgToCmmConfig
+    let ctx      = stgToCmmContext  cfg
+        platform = stgToCmmPlatform cfg
+
+    let (cg_ipes, strtab) = flip runState emptyStringTable $ do
+            module_name <- lookupStringTable $ ST.pack $ renderWithContext ctx (ppr this_mod)
+            mapM (toCgIPE platform ctx module_name) ents
+
+    let -- Emit the fields of an IpeBufferEntry struct.
+        toIpeBufferEntry :: CgInfoProvEnt -> [CmmLit]
+        toIpeBufferEntry cg_ipe =
+            [ CmmLabel (ipeInfoTablePtr cg_ipe)
+            , strtab_offset (ipeTableName cg_ipe)
+            , strtab_offset (ipeClosureDesc cg_ipe)
+            , strtab_offset (ipeTypeDesc cg_ipe)
+            , strtab_offset (ipeLabel cg_ipe)
+            , strtab_offset (ipeModuleName cg_ipe)
+            , strtab_offset (ipeSrcLoc cg_ipe)
+            ]
+
+        int n = mkIntCLit platform n
+        int32 n = CmmInt n W32
+        strtab_offset (StrTabOffset n) = int32 (fromIntegral n)
+
+    strings <- newByteStringCLit (getStringTableStrings strtab)
+    let lits = [ zeroCLit platform     -- 'next' field
+               , strings               -- 'strings' field
+               , int $ length cg_ipes  -- 'count' field
+               ] ++ concatMap toIpeBufferEntry cg_ipes
+    emitDataLits (mkIPELabel this_mod) lits
+
+toCgIPE :: Platform -> SDocContext -> StrTabOffset -> InfoProvEnt -> State StringTable CgInfoProvEnt
+toCgIPE platform ctx module_name ipe = do
+    table_name <- lookupStringTable $ ST.pack $ renderWithContext ctx (pprCLabel platform CStyle (infoTablePtr ipe))
+    closure_desc <- lookupStringTable $ ST.pack $ show (infoProvEntClosureType ipe)
+    type_desc <- lookupStringTable $ ST.pack $ infoTableType ipe
+    let (src_loc_str, label_str) = maybe ("", "") (first (renderWithContext ctx . ppr)) (infoTableProv ipe)
+    label <- lookupStringTable $ ST.pack label_str
+    src_loc <- lookupStringTable $ ST.pack src_loc_str
+    return $ CgInfoProvEnt { ipeInfoTablePtr = infoTablePtr ipe
+                           , ipeTableName = table_name
+                           , ipeClosureDesc = closure_desc
+                           , ipeTypeDesc = type_desc
+                           , ipeLabel = label
+                           , ipeModuleName = module_name
+                           , ipeSrcLoc = src_loc
+                           }
+
+data CgInfoProvEnt = CgInfoProvEnt
+                               { ipeInfoTablePtr :: !CLabel
+                               , ipeTableName :: !StrTabOffset
+                               , ipeClosureDesc :: !StrTabOffset
+                               , ipeTypeDesc :: !StrTabOffset
+                               , ipeLabel :: !StrTabOffset
+                               , ipeModuleName :: !StrTabOffset
+                               , ipeSrcLoc :: !StrTabOffset
+                               }
+
+data StringTable = StringTable { stStrings :: DList ShortText
+                               , stLength :: !Int
+                               , stLookup :: !(M.Map ShortText StrTabOffset)
+                               }
+
+newtype StrTabOffset = StrTabOffset Int
+
+emptyStringTable :: StringTable
+emptyStringTable =
+    StringTable { stStrings = emptyDList
+                , stLength = 0
+                , stLookup = M.empty
+                }
+
+getStringTableStrings :: StringTable -> BS.ByteString
+getStringTableStrings st =
+    BSL.toStrict $ BSB.toLazyByteString
+    $ foldMap f $ dlistToList (stStrings st)
+  where
+    f x = BSB.shortByteString (ST.contents x) `mappend` BSB.word8 0
+
+lookupStringTable :: ShortText -> State StringTable StrTabOffset
+lookupStringTable str = state $ \st ->
+    case M.lookup str (stLookup st) of
+      Just off -> (off, st)
+      Nothing ->
+          let !st' = st { stStrings = stStrings st `snoc` str
+                        , stLength  = stLength st + ST.byteLength str + 1
+                        , stLookup  = M.insert str res (stLookup st)
+                        }
+              res = StrTabOffset (stLength st)
+          in (res, st')
+
+newtype DList a = DList ([a] -> [a])
+
+emptyDList :: DList a
+emptyDList = DList id
+
+snoc :: DList a -> a -> DList a
+snoc (DList f) x = DList (f . (x:))
+
+dlistToList :: DList a -> [a]
+dlistToList (DList f) = f []
diff --git a/compiler/GHC/StgToCmm/Prof.hs b/compiler/GHC/StgToCmm/Prof.hs
--- a/compiler/GHC/StgToCmm/Prof.hs
+++ b/compiler/GHC/StgToCmm/Prof.hs
@@ -11,7 +11,7 @@
         mkCCostCentre, mkCCostCentreStack,
 
         -- infoTablePRov
-        initInfoTableProv, emitInfoTableProv,
+        initInfoTableProv,
 
         -- Cost-centre Profiling
         dynProfHdr, profDynAlloc, profAlloc, staticProfHdr, initUpdFrameProf,
@@ -32,6 +32,7 @@
 import GHC.Platform.Profile
 import GHC.StgToCmm.Closure
 import GHC.StgToCmm.Config
+import GHC.StgToCmm.InfoTableProv
 import GHC.StgToCmm.Utils
 import GHC.StgToCmm.Monad
 import GHC.StgToCmm.Lit
@@ -55,7 +56,6 @@
 
 import Control.Monad
 import Data.Char       (ord)
-import Data.Bifunctor  (first)
 import GHC.Utils.Monad (whenM)
 
 -----------------------------------------------------------------------------
@@ -274,9 +274,8 @@
   where
    (ws,ms) = pc_SIZEOF_CostCentreStack (platformConstants platform) `divMod` platformWordSizeInBytes platform
 
-
+-- | Emit info-table provenance declarations
 initInfoTableProv ::  [CmmInfoTable] -> InfoTableProvMap -> FCode CStub
--- Emit the declarations
 initInfoTableProv infos itmap
   = do
        cfg <- getStgToCmmConfig
@@ -284,42 +283,16 @@
            info_table = stgToCmmInfoTableMap cfg
            platform   = stgToCmmPlatform     cfg
            this_mod   = stgToCmmThisModule   cfg
-       -- Output the actual IPE data
-       mapM_ emitInfoTableProv ents
-       -- Create the C stub which initialises the IPE map
-       return (ipInitCode info_table platform this_mod ents)
 
---- Info Table Prov stuff
-emitInfoTableProv :: InfoProvEnt  -> FCode ()
-emitInfoTableProv ip = do
-  { cfg <- getStgToCmmConfig
-  ; let mod      = infoProvModule ip
-        ctx      = stgToCmmContext  cfg
-        platform = stgToCmmPlatform cfg
-  ; let (src, label) = maybe ("", "") (first (renderWithContext ctx . ppr)) (infoTableProv ip)
-        mk_string    = newByteStringCLit . utf8EncodeString
-  ; label <- mk_string label
-  ; modl  <- newByteStringCLit (bytesFS $ moduleNameFS
-                                        $ moduleName mod)
+       case ents of
+         [] -> return mempty
+         _  -> do
+           -- Emit IPE buffer
+           emitIpeBufferListNode this_mod ents
 
-  ; ty_string  <- mk_string (infoTableType ip)
-  ; loc        <- mk_string src
-  ; table_name <- mk_string (renderWithContext ctx
-                             (pprCLabel platform CStyle (infoTablePtr ip)))
-  ; closure_type <- mk_string (renderWithContext ctx
-                               (text $ show $ infoProvEntClosureType ip))
-  ; let
-     lits = [ CmmLabel (infoTablePtr ip), -- Info table pointer
-              table_name,     -- char *table_name
-              closure_type,   -- char *closure_desc -- Filled in from the InfoTable
-              ty_string,      -- char *ty_string
-              label,          -- char *label,
-              modl,           -- char *module,
-              loc,            -- char *srcloc,
-              zero platform   -- struct _InfoProvEnt *link
-            ]
-  ; emitDataLits (mkIPELabel ip) lits
-  }
+           -- Create the C stub which initialises the IPE map
+           return (ipInitCode info_table platform this_mod)
+
 -- ---------------------------------------------------------------------------
 -- Set the current cost centre stack
 
diff --git a/compiler/GHC/Tc/Deriv/Functor.hs b/compiler/GHC/Tc/Deriv/Functor.hs
--- a/compiler/GHC/Tc/Deriv/Functor.hs
+++ b/compiler/GHC/Tc/Deriv/Functor.hs
@@ -538,8 +538,36 @@
 
     go _ _ = (caseTrivial,False)
 
--- Return all syntactic subterms of ty that contain var somewhere
--- These are the things that should appear in instance constraints
+-- | Return all syntactic subterms of a 'Type' that are applied to the 'TyVar'
+-- argument. This determines what constraints should be inferred for derived
+-- 'Functor', 'Foldable', and 'Traversable' instances in "GHC.Tc.Deriv.Infer".
+-- For instance, if we have:
+--
+-- @
+-- data Foo a = MkFoo Int a (Maybe a) (Either Int (Maybe a))
+-- @
+--
+-- Then the following would hold:
+--
+-- * @'deepSubtypesContaining' a Int@ would return @[]@, since @Int@ does not
+--   contain the type variable @a@ at all.
+--
+-- * @'deepSubtypesContaining' a a@ would return @[]@. Although the type @a@
+--   contains the type variable @a@, it is not /applied/ to @a@, which is the
+--   criterion that 'deepSubtypesContaining' checks for.
+--
+-- * @'deepSubtypesContaining' a (Maybe a)@ would return @[Maybe]@, as @Maybe@
+--   is applied to @a@.
+--
+-- * @'deepSubtypesContaining' a (Either Int (Maybe a))@ would return
+--   @[Either Int, Maybe]@. Both of these types are applied to @a@ through
+--   composition.
+--
+-- As used in "GHC.Tc.Deriv.Infer", the 'Type' argument will always come from
+-- 'derivDataConInstArgTys', so it is important that the 'TyVar' comes from
+-- 'dataConUnivTyVars' to match. Make sure /not/ to take the 'TyVar' from
+-- 'tyConTyVars', as these differ from the 'dataConUnivTyVars' when the data
+-- type is a GADT. (See #22167 for what goes wrong if 'tyConTyVars' is used.)
 deepSubtypesContaining :: TyVar -> Type -> [TcType]
 deepSubtypesContaining tv
   = functorLikeTraverse tv
diff --git a/compiler/GHC/Tc/Deriv/Generics.hs b/compiler/GHC/Tc/Deriv/Generics.hs
--- a/compiler/GHC/Tc/Deriv/Generics.hs
+++ b/compiler/GHC/Tc/Deriv/Generics.hs
@@ -91,10 +91,25 @@
 ************************************************************************
 -}
 
+-- | Called by 'GHC.Tc.Deriv.Infer.inferConstraints'; generates a list of
+-- types, each of which must be a 'Functor' in order for the 'Generic1'
+-- instance to work. For instance, if we have:
+--
+-- @
+-- data Foo a = MkFoo Int a (Maybe a) (Either Int (Maybe a))
+-- @
+--
+-- Then @'get_gen1_constrained_tys' a (f (g a))@ would return @[Either Int]@,
+-- as a derived 'Generic1' instance would need to call 'fmap' at that type.
+-- Invoking @'get_gen1_constrained_tys' a@ on any of the other fields would
+-- return @[]@.
+--
+-- 'get_gen1_constrained_tys' is very similar in spirit to
+-- 'deepSubtypesContaining' in "GHC.Tc.Deriv.Functor". Just like with
+-- 'deepSubtypesContaining', it is important that the 'TyVar' argument come
+-- from 'dataConUnivTyVars'. (See #22167 for what goes wrong if 'tyConTyVars'
+-- is used.)
 get_gen1_constrained_tys :: TyVar -> Type -> [Type]
--- called by GHC.Tc.Deriv.Infer.inferConstraints; generates a list of
--- types, each of which must be a Functor in order for the Generic1 instance to
--- work.
 get_gen1_constrained_tys argVar
   = argTyFold argVar $ ArgTyAlg { ata_rec0 = const []
                                 , ata_par1 = [], ata_rec1 = const []
diff --git a/compiler/GHC/Tc/Deriv/Infer.hs b/compiler/GHC/Tc/Deriv/Infer.hs
--- a/compiler/GHC/Tc/Deriv/Infer.hs
+++ b/compiler/GHC/Tc/Deriv/Infer.hs
@@ -176,9 +176,10 @@
 
               -- Constraints arising from the arguments of each constructor
            con_arg_constraints
-             :: (CtOrigin -> TypeOrKind
-                          -> Type
-                          -> [(ThetaSpec, Maybe TCvSubst)])
+             :: ([TyVar] -> CtOrigin
+                         -> TypeOrKind
+                         -> Type
+                         -> [(ThetaSpec, Maybe TCvSubst)])
              -> (ThetaSpec, [TyVar], [TcType], DerivInstTys)
            con_arg_constraints get_arg_constraints
              = let -- Constraints from the fields of each data constructor.
@@ -193,7 +194,8 @@
                      , not (isUnliftedType arg_ty)
                      , let orig = DerivOriginDC data_con arg_n wildcard
                      , preds_and_mbSubst
-                         <- get_arg_constraints orig arg_t_or_k arg_ty
+                         <- get_arg_constraints (dataConUnivTyVars data_con)
+                                                orig arg_t_or_k arg_ty
                      ]
                    -- Stupid constraints from DatatypeContexts. Note that we
                    -- must gather these constraints from the data constructors,
@@ -235,21 +237,39 @@
            is_functor_like = tcTypeKind inst_ty `tcEqKind` typeToTypeKind
                           || is_generic1
 
-           get_gen1_constraints :: Class -> CtOrigin -> TypeOrKind -> Type
-                                -> [(ThetaSpec, Maybe TCvSubst)]
-           get_gen1_constraints functor_cls orig t_or_k ty
+           get_gen1_constraints ::
+                Class
+             -> [TyVar] -- The universally quantified type variables for the
+                        -- data constructor
+             -> CtOrigin -> TypeOrKind -> Type
+             -> [(ThetaSpec, Maybe TCvSubst)]
+           get_gen1_constraints functor_cls dc_univs orig t_or_k ty
               = mk_functor_like_constraints orig t_or_k functor_cls $
-                get_gen1_constrained_tys last_tv ty
+                get_gen1_constrained_tys last_dc_univ ty
+             where
+               -- If we are deriving an instance of 'Generic1' and have made
+               -- it this far, then there should be at least one universal type
+               -- variable, making this use of 'last' safe.
+               last_dc_univ = assert (not (null dc_univs)) $
+                              last dc_univs
 
-           get_std_constrained_tys :: CtOrigin -> TypeOrKind -> Type
-                                   -> [(ThetaSpec, Maybe TCvSubst)]
-           get_std_constrained_tys orig t_or_k ty
+           get_std_constrained_tys ::
+                [TyVar] -- The universally quantified type variables for the
+                        -- data constructor
+             -> CtOrigin -> TypeOrKind -> Type
+             -> [(ThetaSpec, Maybe TCvSubst)]
+           get_std_constrained_tys dc_univs orig t_or_k ty
                | is_functor_like
                = mk_functor_like_constraints orig t_or_k main_cls $
-                 deepSubtypesContaining last_tv ty
+                 deepSubtypesContaining last_dc_univ ty
                | otherwise
                = [( [mk_cls_pred orig t_or_k main_cls ty]
                   , Nothing )]
+             where
+               -- If 'is_functor_like' holds, then there should be at least one
+               -- universal type variable, making this use of 'last' safe.
+               last_dc_univ = assert (not (null dc_univs)) $
+                              last dc_univs
 
            mk_functor_like_constraints :: CtOrigin -> TypeOrKind
                                        -> Class -> [Type]
@@ -277,9 +297,6 @@
                              , tcUnifyTy ki typeToTypeKind
                              )
 
-           rep_tc_tvs      = tyConTyVars rep_tc
-           last_tv         = last rep_tc_tvs
-
            -- Extra Data constraints
            -- The Data class (only) requires that for
            --    instance (...) => Data (T t1 t2)
@@ -318,7 +335,7 @@
              -- Generic1 needs Functor
              -- See Note [Getting base classes]
           |  is_generic1
-           -> assert (rep_tc_tvs `lengthExceeds` 0) $
+           -> assert (tyConTyVars rep_tc `lengthExceeds` 0) $
               -- Generic1 has a single kind variable
               assert (cls_tys `lengthIs` 1) $
               do { functorClass <- lift $ tcLookupClass functorClassName
diff --git a/ghc-lib.cabal b/ghc-lib.cabal
--- a/ghc-lib.cabal
+++ b/ghc-lib.cabal
@@ -1,7 +1,7 @@
 cabal-version: 2.0
 build-type: Simple
 name: ghc-lib
-version: 9.4.2.20220822
+version: 9.4.3.20221104
 license: BSD3
 license-file: LICENSE
 category: Development
@@ -83,7 +83,7 @@
         stm,
         rts,
         hpc == 0.6.*,
-        ghc-lib-parser == 9.4.2.20220822
+        ghc-lib-parser == 9.4.3.20221104
     build-tool-depends: alex:alex >= 3.1, happy:happy >= 1.19.4
     other-extensions:
         BangPatterns
@@ -210,6 +210,7 @@
         GHC.Data.FastString.Env,
         GHC.Data.FiniteMap,
         GHC.Data.Graph.Directed,
+        GHC.Data.Graph.UnVar,
         GHC.Data.IOEnv,
         GHC.Data.List.SetOps,
         GHC.Data.Maybe,
@@ -605,7 +606,6 @@
         GHC.Data.Graph.Color
         GHC.Data.Graph.Ops
         GHC.Data.Graph.Ppr
-        GHC.Data.Graph.UnVar
         GHC.Data.UnionFind
         GHC.Driver.Backpack
         GHC.Driver.CodeOutput
@@ -733,6 +733,7 @@
         GHC.StgToCmm.Foreign
         GHC.StgToCmm.Heap
         GHC.StgToCmm.Hpc
+        GHC.StgToCmm.InfoTableProv
         GHC.StgToCmm.Layout
         GHC.StgToCmm.Lit
         GHC.StgToCmm.Monad