Refactor mkRuntimeError

This patch fixes #22634.  Because we don't have TYPE/CONSTRAINT
polymorphism, we need two error functions rather than one.

I took the opportunity to rname runtimeError to impossibleError,
to line up with mkImpossibleExpr, and avoid confusion with the
genuine runtime-error-constructing functions.

12 files changed, 182 insertions, 102 deletions

diff --git a/compiler/GHC/Builtin/Names.hs b/compiler/GHC/Builtin/Names.hs
index acc402b4a3..0b2ace3dfb 100644
--- a/compiler/GHC/Builtin/Names.hs
+++ b/compiler/GHC/Builtin/Names.hs
@@ -2282,7 +2282,8 @@ wildCardKey, absentErrorIdKey, absentConstraintErrorIdKey, augmentIdKey, appendI
     buildIdKey, foldrIdKey, recSelErrorIdKey,
     seqIdKey, eqStringIdKey,
     noMethodBindingErrorIdKey, nonExhaustiveGuardsErrorIdKey,
-    runtimeErrorIdKey, patErrorIdKey, voidPrimIdKey,
+    impossibleErrorIdKey, impossibleConstraintErrorIdKey,
+    patErrorIdKey, voidPrimIdKey,
     realWorldPrimIdKey, recConErrorIdKey,
     unpackCStringUtf8IdKey, unpackCStringAppendUtf8IdKey, unpackCStringFoldrUtf8IdKey,
     unpackCStringIdKey, unpackCStringAppendIdKey, unpackCStringFoldrIdKey,
@@ -2290,37 +2291,38 @@ wildCardKey, absentErrorIdKey, absentConstraintErrorIdKey, augmentIdKey, appendI
     absentSumFieldErrorIdKey, cstringLengthIdKey
     :: Unique
 
-wildCardKey                   = mkPreludeMiscIdUnique  0  -- See Note [WildCard binders]
-absentErrorIdKey              = mkPreludeMiscIdUnique  1
-augmentIdKey                  = mkPreludeMiscIdUnique  2
-appendIdKey                   = mkPreludeMiscIdUnique  3
-buildIdKey                    = mkPreludeMiscIdUnique  4
-absentConstraintErrorIdKey    = mkPreludeMiscIdUnique  5
-foldrIdKey                    = mkPreludeMiscIdUnique  6
-recSelErrorIdKey              = mkPreludeMiscIdUnique  7
-seqIdKey                      = mkPreludeMiscIdUnique  8
-absentSumFieldErrorIdKey      = mkPreludeMiscIdUnique  9
-eqStringIdKey                 = mkPreludeMiscIdUnique 10
-noMethodBindingErrorIdKey     = mkPreludeMiscIdUnique 11
-nonExhaustiveGuardsErrorIdKey = mkPreludeMiscIdUnique 12
-runtimeErrorIdKey             = mkPreludeMiscIdUnique 13
-patErrorIdKey                 = mkPreludeMiscIdUnique 14
-realWorldPrimIdKey            = mkPreludeMiscIdUnique 15
-recConErrorIdKey              = mkPreludeMiscIdUnique 16
-
-unpackCStringUtf8IdKey        = mkPreludeMiscIdUnique 17
-unpackCStringAppendUtf8IdKey  = mkPreludeMiscIdUnique 18
-unpackCStringFoldrUtf8IdKey   = mkPreludeMiscIdUnique 19
-
-unpackCStringIdKey            = mkPreludeMiscIdUnique 20
-unpackCStringAppendIdKey      = mkPreludeMiscIdUnique 21
-unpackCStringFoldrIdKey       = mkPreludeMiscIdUnique 22
-
-voidPrimIdKey                 = mkPreludeMiscIdUnique 23
-typeErrorIdKey                = mkPreludeMiscIdUnique 24
-divIntIdKey                   = mkPreludeMiscIdUnique 25
-modIntIdKey                   = mkPreludeMiscIdUnique 26
-cstringLengthIdKey            = mkPreludeMiscIdUnique 27
+wildCardKey                    = mkPreludeMiscIdUnique  0  -- See Note [WildCard binders]
+absentErrorIdKey               = mkPreludeMiscIdUnique  1
+absentConstraintErrorIdKey     = mkPreludeMiscIdUnique  2
+augmentIdKey                   = mkPreludeMiscIdUnique  3
+appendIdKey                    = mkPreludeMiscIdUnique  4
+buildIdKey                     = mkPreludeMiscIdUnique  5
+foldrIdKey                     = mkPreludeMiscIdUnique  6
+recSelErrorIdKey               = mkPreludeMiscIdUnique  7
+seqIdKey                       = mkPreludeMiscIdUnique  8
+absentSumFieldErrorIdKey       = mkPreludeMiscIdUnique  9
+eqStringIdKey                  = mkPreludeMiscIdUnique 10
+noMethodBindingErrorIdKey      = mkPreludeMiscIdUnique 11
+nonExhaustiveGuardsErrorIdKey  = mkPreludeMiscIdUnique 12
+impossibleErrorIdKey           = mkPreludeMiscIdUnique 13
+impossibleConstraintErrorIdKey = mkPreludeMiscIdUnique 14
+patErrorIdKey                  = mkPreludeMiscIdUnique 15
+realWorldPrimIdKey             = mkPreludeMiscIdUnique 16
+recConErrorIdKey               = mkPreludeMiscIdUnique 17
+
+unpackCStringUtf8IdKey        = mkPreludeMiscIdUnique 18
+unpackCStringAppendUtf8IdKey  = mkPreludeMiscIdUnique 19
+unpackCStringFoldrUtf8IdKey   = mkPreludeMiscIdUnique 20
+
+unpackCStringIdKey            = mkPreludeMiscIdUnique 21
+unpackCStringAppendIdKey      = mkPreludeMiscIdUnique 22
+unpackCStringFoldrIdKey       = mkPreludeMiscIdUnique 23
+
+voidPrimIdKey                 = mkPreludeMiscIdUnique 24
+typeErrorIdKey                = mkPreludeMiscIdUnique 25
+divIntIdKey                   = mkPreludeMiscIdUnique 26
+modIntIdKey                   = mkPreludeMiscIdUnique 27
+cstringLengthIdKey            = mkPreludeMiscIdUnique 28
 
 concatIdKey, filterIdKey, zipIdKey,
     bindIOIdKey, returnIOIdKey, newStablePtrIdKey,
diff --git a/compiler/GHC/Core/Make.hs b/compiler/GHC/Core/Make.hs
index 08d08b5008..2d567786ea 100644
--- a/compiler/GHC/Core/Make.hs
+++ b/compiler/GHC/Core/Make.hs
@@ -44,7 +44,7 @@ module GHC.Core.Make (
 
         -- * Error Ids
         mkRuntimeErrorApp, mkImpossibleExpr, mkAbsentErrorApp, errorIds,
-        rEC_CON_ERROR_ID, rUNTIME_ERROR_ID,
+        rEC_CON_ERROR_ID,
         nON_EXHAUSTIVE_GUARDS_ERROR_ID, nO_METHOD_BINDING_ERROR_ID,
         pAT_ERROR_ID, rEC_SEL_ERROR_ID,
         tYPE_ERROR_ID, aBSENT_SUM_FIELD_ERROR_ID
@@ -58,6 +58,7 @@ import GHC.Types.Var  ( EvVar, setTyVarUnique, visArgConstraintLike )
 import GHC.Types.TyThing
 import GHC.Types.Id.Info
 import GHC.Types.Cpr
+import GHC.Types.Basic( TypeOrConstraint(..) )
 import GHC.Types.Demand
 import GHC.Types.Name      hiding ( varName )
 import GHC.Types.Literal
@@ -847,7 +848,9 @@ mkJustExpr ty val = mkConApp justDataCon [Type ty, val]
 -}
 
 mkRuntimeErrorApp
-        :: Id           -- Should be of type (forall a. Addr# -> a)
+        :: Id           -- Should be of type
+                        --   forall (r::RuntimeRep) (a::TYPE r). Addr# -> a
+                        --      or (a :: CONSTRAINT r)
                         --      where Addr# points to a UTF8 encoded string
         -> Type         -- The type to instantiate 'a'
         -> String       -- The string to print
@@ -859,10 +862,6 @@ mkRuntimeErrorApp err_id res_ty err_msg
   where
     err_string = Lit (mkLitString err_msg)
 
-mkImpossibleExpr :: Type -> CoreExpr
-mkImpossibleExpr res_ty
-  = mkRuntimeErrorApp rUNTIME_ERROR_ID res_ty "Impossible case alternative"
-
 {-
 ************************************************************************
 *                                                                      *
@@ -884,25 +883,23 @@ crash).
 
 errorIds :: [Id]
 errorIds
-  = [ rUNTIME_ERROR_ID,
-      nON_EXHAUSTIVE_GUARDS_ERROR_ID,
+  = [ nON_EXHAUSTIVE_GUARDS_ERROR_ID,
       nO_METHOD_BINDING_ERROR_ID,
       pAT_ERROR_ID,
       rEC_CON_ERROR_ID,
       rEC_SEL_ERROR_ID,
-      aBSENT_ERROR_ID, aBSENT_CONSTRAINT_ERROR_ID,
+      iMPOSSIBLE_ERROR_ID, iMPOSSIBLE_CONSTRAINT_ERROR_ID,
+      aBSENT_ERROR_ID,  aBSENT_CONSTRAINT_ERROR_ID,
       aBSENT_SUM_FIELD_ERROR_ID,
       tYPE_ERROR_ID   -- Used with Opt_DeferTypeErrors, see #10284
       ]
 
-recSelErrorName, runtimeErrorName :: Name
-recConErrorName, patErrorName :: Name
+recSelErrorName, recConErrorName, patErrorName :: Name
 nonExhaustiveGuardsErrorName, noMethodBindingErrorName :: Name
 typeErrorName :: Name
 absentSumFieldErrorName :: Name
 
 recSelErrorName     = err_nm "recSelError"     recSelErrorIdKey     rEC_SEL_ERROR_ID
-runtimeErrorName    = err_nm "runtimeError"    runtimeErrorIdKey    rUNTIME_ERROR_ID
 recConErrorName     = err_nm "recConError"     recConErrorIdKey     rEC_CON_ERROR_ID
 patErrorName        = err_nm "patError"        patErrorIdKey        pAT_ERROR_ID
 typeErrorName       = err_nm "typeError"       typeErrorIdKey       tYPE_ERROR_ID
@@ -915,16 +912,15 @@ nonExhaustiveGuardsErrorName = err_nm "nonExhaustiveGuardsError"
 err_nm :: String -> Unique -> Id -> Name
 err_nm str uniq id = mkWiredInIdName cONTROL_EXCEPTION_BASE (fsLit str) uniq id
 
-rEC_SEL_ERROR_ID, rUNTIME_ERROR_ID, rEC_CON_ERROR_ID :: Id
+rEC_SEL_ERROR_ID, rEC_CON_ERROR_ID :: Id
 pAT_ERROR_ID, nO_METHOD_BINDING_ERROR_ID, nON_EXHAUSTIVE_GUARDS_ERROR_ID :: Id
 tYPE_ERROR_ID, aBSENT_SUM_FIELD_ERROR_ID :: Id
-rEC_SEL_ERROR_ID                = mkRuntimeErrorId recSelErrorName
-rUNTIME_ERROR_ID                = mkRuntimeErrorId runtimeErrorName
-rEC_CON_ERROR_ID                = mkRuntimeErrorId recConErrorName
-pAT_ERROR_ID                    = mkRuntimeErrorId patErrorName
-nO_METHOD_BINDING_ERROR_ID      = mkRuntimeErrorId noMethodBindingErrorName
-nON_EXHAUSTIVE_GUARDS_ERROR_ID  = mkRuntimeErrorId nonExhaustiveGuardsErrorName
-tYPE_ERROR_ID                   = mkRuntimeErrorId typeErrorName
+rEC_SEL_ERROR_ID                = mkRuntimeErrorId TypeLike recSelErrorName
+rEC_CON_ERROR_ID                = mkRuntimeErrorId TypeLike recConErrorName
+pAT_ERROR_ID                    = mkRuntimeErrorId TypeLike patErrorName
+nO_METHOD_BINDING_ERROR_ID      = mkRuntimeErrorId TypeLike noMethodBindingErrorName
+nON_EXHAUSTIVE_GUARDS_ERROR_ID  = mkRuntimeErrorId TypeLike nonExhaustiveGuardsErrorName
+tYPE_ERROR_ID                   = mkRuntimeErrorId TypeLike typeErrorName
 
 -- Note [aBSENT_SUM_FIELD_ERROR_ID]
 -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
@@ -1038,30 +1034,6 @@ mkExceptionId name
       (divergingIdInfo [] `setCafInfo` NoCafRefs)
          -- See Note [Wired-in exceptions are not CAFfy]
 
-mkRuntimeErrorId :: Name -> Id
--- Error function
---   with type:  forall (r:RuntimeRep) (a:TYPE r). Addr# -> a
---   with arity: 1
--- which diverges after being given one argument
--- The Addr# is expected to be the address of
---   a UTF8-encoded error string
-mkRuntimeErrorId name
- = mkVanillaGlobalWithInfo name runtimeErrorTy (divergingIdInfo [evalDmd])
-     -- Do *not* mark them as NoCafRefs, because they can indeed have
-     -- CAF refs.  For example, pAT_ERROR_ID calls GHC.Err.untangle,
-     -- which has some CAFs
-     -- In due course we may arrange that these error-y things are
-     -- regarded by the GC as permanently live, in which case we
-     -- can give them NoCaf info.  As it is, any function that calls
-     -- any pc_bottoming_Id will itself have CafRefs, which bloats
-     -- SRTs.
-
-runtimeErrorTy :: Type
--- forall (rr :: RuntimeRep) (a :: rr). Addr# -> a
---   See Note [Error and friends have an "open-tyvar" forall]
-runtimeErrorTy = mkSpecForAllTys [runtimeRep1TyVar, openAlphaTyVar]
-                                 (mkVisFunTyMany addrPrimTy openAlphaTy)
-
 -- | An 'IdInfo' for an Id, such as 'aBSENT_ERROR_ID', that
 -- throws an (imprecise) exception after being supplied one value arg for every
 -- argument 'Demand' in the list. The demands end up in the demand signature.
@@ -1091,6 +1063,56 @@ This is OK because it never returns, so the return type is irrelevant.
 
 ************************************************************************
 *                                                                      *
+                     iMPOSSIBLE_ERROR_ID
+*                                                                      *
+************************************************************************
+-}
+
+iMPOSSIBLE_ERROR_ID, iMPOSSIBLE_CONSTRAINT_ERROR_ID :: Id
+iMPOSSIBLE_ERROR_ID            = mkRuntimeErrorId TypeLike       impossibleErrorName
+iMPOSSIBLE_CONSTRAINT_ERROR_ID = mkRuntimeErrorId ConstraintLike impossibleConstraintErrorName
+
+impossibleErrorName, impossibleConstraintErrorName :: Name
+impossibleErrorName           = err_nm "impossibleError"
+                                impossibleErrorIdKey iMPOSSIBLE_ERROR_ID
+impossibleConstraintErrorName = err_nm "impossibleConstraintError"
+                                impossibleConstraintErrorIdKey iMPOSSIBLE_CONSTRAINT_ERROR_ID
+
+mkImpossibleExpr :: Type -> String -> CoreExpr
+mkImpossibleExpr res_ty str
+  = mkRuntimeErrorApp err_id res_ty str
+  where    -- See Note [Type vs Constraint for error ids]
+    err_id | isConstraintLikeKind (typeKind res_ty) = iMPOSSIBLE_CONSTRAINT_ERROR_ID
+           | otherwise                              = iMPOSSIBLE_ERROR_ID
+
+{- Note [Type vs Constraint for error ids]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+We need both
+  iMPOSSIBLE_ERROR_ID            :: forall (r::RuntimeRep) (a::TYPE r).       Addr# -> a
+  iMPOSSIBLE_CONSTRAINT_ERROR_ID :: forall (r::RuntimeRep) (a::CONSTRAINT r). Addr# -> a
+
+because we don't have polymorphism over TYPE vs CONSTRAINT.  You
+might wonder if iMPOSSIBLE_CONSTRAINT_ERROR_ID is ever needed in
+practice, but it is: see #22634.  So:
+
+* In Control.Exception.Base we have
+      impossibleError           :: forall (a::Type). Addr# -> a
+      impossibleConstraintError :: forall (a::Type). Addr# -> a
+  This generates the code for `impossibleError`, but because they are wired in
+  the interface file definitions are never looked at (indeed, they don't
+  even get serialised).
+
+* In this module GHC.Core.Make we define /wired-in/ Ids for
+      iMPOSSIBLE_ERROR_ID
+      iMPOSSIBLE_CONSTRAINT_ERROR_ID
+   with the desired above types (i.e. runtime-rep polymorphic, and returning a
+   constraint for the latter.
+
+Much the same plan works for aBSENT_ERROR_ID and aBSENT_CONSTRAINT_ERROR_ID
+
+
+************************************************************************
+*                                                                      *
                      aBSENT_ERROR_ID
 *                                                                      *
 ************************************************************************
@@ -1176,6 +1198,7 @@ be relying on anything from it.
 --   absentConstraintError :: forall (a :: Constraint). Addr# -> a
 -- We don't have polymorphism over TypeOrConstraint!
 -- mkAbsentErrorApp chooses which one to use, based on the kind
+-- See Note [Type vs Constraint for error ids]
 
 mkAbsentErrorApp :: Type         -- The type to instantiate 'a'
                  -> String       -- The string to print
@@ -1193,29 +1216,69 @@ absentErrorName
    = mkWiredInIdName gHC_PRIM_PANIC (fsLit "absentError")
       absentErrorIdKey aBSENT_ERROR_ID
 
-absentConstraintErrorName
+absentConstraintErrorName   -- See Note [Type vs Constraint for error ids]
    = mkWiredInIdName gHC_PRIM_PANIC (fsLit "absentConstraintError")
       absentConstraintErrorIdKey aBSENT_CONSTRAINT_ERROR_ID
 
 aBSENT_ERROR_ID, aBSENT_CONSTRAINT_ERROR_ID :: Id
 
 aBSENT_ERROR_ID -- See Note [aBSENT_ERROR_ID]
- = mkVanillaGlobalWithInfo absentErrorName absent_ty id_info
+ = mk_runtime_error_id absentErrorName absent_ty
  where
    -- absentError :: forall (a :: Type). Addr# -> a
    absent_ty = mkSpecForAllTys [alphaTyVar] $
                mkVisFunTyMany addrPrimTy (mkTyVarTy alphaTyVar)
    -- Not runtime-rep polymorphic. aBSENT_ERROR_ID is only used for
    -- lifted-type things; see Note [Absent fillers] in GHC.Core.Opt.WorkWrap.Utils
-   id_info = divergingIdInfo [evalDmd] -- NB: CAFFY!
 
 aBSENT_CONSTRAINT_ERROR_ID -- See Note [aBSENT_ERROR_ID]
- = mkVanillaGlobalWithInfo absentConstraintErrorName absent_ty id_info
+ = mk_runtime_error_id absentConstraintErrorName absent_ty
+   -- See Note [Type vs Constraint for error ids]
  where
    -- absentConstraintError :: forall (a :: Constraint). Addr# -> a
    absent_ty = mkSpecForAllTys [alphaConstraintTyVar] $
                mkFunTy visArgConstraintLike ManyTy
                        addrPrimTy (mkTyVarTy alphaConstraintTyVar)
-   id_info = divergingIdInfo [evalDmd] -- NB: CAFFY!
 
 
+{-
+************************************************************************
+*                                                                      *
+                     mkRuntimeErrorId
+*                                                                      *
+************************************************************************
+-}
+
+mkRuntimeErrorId :: TypeOrConstraint -> Name -> Id
+-- Error function
+--   with type:  forall (r:RuntimeRep) (a:TYPE r). Addr# -> a
+--   with arity: 1
+-- which diverges after being given one argument
+-- The Addr# is expected to be the address of
+--   a UTF8-encoded error string
+mkRuntimeErrorId torc name = mk_runtime_error_id name (mkRuntimeErrorTy torc)
+
+
+mk_runtime_error_id :: Name -> Type -> Id
+mk_runtime_error_id name ty
+ = mkVanillaGlobalWithInfo name ty (divergingIdInfo [evalDmd])
+     -- Do *not* mark them as NoCafRefs, because they can indeed have
+     -- CAF refs.  For example, pAT_ERROR_ID calls GHC.Err.untangle,
+     -- which has some CAFs
+     -- In due course we may arrange that these error-y things are
+     -- regarded by the GC as permanently live, in which case we
+     -- can give them NoCaf info.  As it is, any function that calls
+     -- any pc_bottoming_Id will itself have CafRefs, which bloats
+     -- SRTs.
+
+mkRuntimeErrorTy :: TypeOrConstraint -> Type
+-- forall (rr :: RuntimeRep) (a :: rr). Addr# -> a
+--   See Note [Error and friends have an "open-tyvar" forall]
+mkRuntimeErrorTy torc = mkSpecForAllTys [runtimeRep1TyVar, tyvar] $
+                        mkFunctionType ManyTy addrPrimTy (mkTyVarTy tyvar)
+  where
+    (tyvar:_) = mkTemplateTyVars [kind]
+    kind = case torc of
+              TypeLike       -> mkTYPEapp       runtimeRep1Ty
+              ConstraintLike -> mkCONSTRAINTapp runtimeRep1Ty
+
diff --git a/compiler/GHC/Core/Opt/ConstantFold.hs b/compiler/GHC/Core/Opt/ConstantFold.hs
index 81dd594090..3d36368d5b 100644
--- a/compiler/GHC/Core/Opt/ConstantFold.hs
+++ b/compiler/GHC/Core/Opt/ConstantFold.hs
@@ -1810,7 +1810,7 @@ tagToEnumRule = do
 
     -- See Note [tagToEnum#]
     _ -> warnPprTrace True "tagToEnum# on non-enumeration type" (ppr ty) $
-         return $ mkRuntimeErrorApp rUNTIME_ERROR_ID ty "tagToEnum# on non-enumeration type"
+         return $ mkImpossibleExpr ty "tagToEnum# on non-enumeration type"
 
 ------------------------------
 dataToTagRule :: RuleM CoreExpr
diff --git a/compiler/GHC/Core/Opt/Simplify/Iteration.hs b/compiler/GHC/Core/Opt/Simplify/Iteration.hs
index 1e285dcccd..d8b95e7358 100644
--- a/compiler/GHC/Core/Opt/Simplify/Iteration.hs
+++ b/compiler/GHC/Core/Opt/Simplify/Iteration.hs
@@ -3528,7 +3528,7 @@ missingAlt env case_bndr _ cont
     -- See Note [Avoiding space leaks in OutType]
     let cont_ty = contResultType cont
     in seqType cont_ty `seq`
-       return (emptyFloats env, mkImpossibleExpr cont_ty)
+       return (emptyFloats env, mkImpossibleExpr cont_ty "Simplify.Iteration.missingAlt")
 
 {-
 ************************************************************************
diff --git a/compiler/GHC/Core/Opt/SpecConstr.hs b/compiler/GHC/Core/Opt/SpecConstr.hs
index fed1f32879..157cec6e49 100644
--- a/compiler/GHC/Core/Opt/SpecConstr.hs
+++ b/compiler/GHC/Core/Opt/SpecConstr.hs
@@ -1500,7 +1500,7 @@ scExpr' env (Case scrut b ty alts)
   where
     sc_con_app con args scrut'  -- Known constructor; simplify
      = do { let Alt _ bs rhs = findAlt con alts
-                                  `orElse` Alt DEFAULT [] (mkImpossibleExpr ty)
+                                  `orElse` Alt DEFAULT [] (mkImpossibleExpr ty "SpecConstr")
                 alt_env'     = extendScSubstList env ((b,scrut') : bs `zip` trimConArgs con args)
           ; scExpr alt_env' rhs }
 
diff --git a/compiler/GHC/Core/Type.hs b/compiler/GHC/Core/Type.hs
index fdd5edbba2..76326b6c50 100644
--- a/compiler/GHC/Core/Type.hs
+++ b/compiler/GHC/Core/Type.hs
@@ -3271,9 +3271,8 @@ mkCONSTRAINTapp_maybe :: RuntimeRepType -> Maybe Type
 -- ^ Just like mkTYPEapp_maybe
 {-# NOINLINE mkCONSTRAINTapp_maybe #-}
 mkCONSTRAINTapp_maybe (TyConApp tc args)
-  | key == liftedRepTyConKey = assert (null args) $ Just constraintKind   -- CONSTRAINT LiftedRep
-  where
-    key = tyConUnique tc
+  | tc `hasKey` liftedRepTyConKey = assert (null args) $
+                                    Just constraintKind   -- CONSTRAINT LiftedRep
 mkCONSTRAINTapp_maybe _ = Nothing
 
 ------------------
diff --git a/compiler/GHC/CoreToStg/Prep.hs b/compiler/GHC/CoreToStg/Prep.hs
index 0b9259bc0e..78ce8e16f1 100644
--- a/compiler/GHC/CoreToStg/Prep.hs
+++ b/compiler/GHC/CoreToStg/Prep.hs
@@ -868,8 +868,7 @@ cpeRhsE env (Case scrut bndr ty alts)
                , not (altsAreExhaustive alts)
                = addDefault alts (Just err)
                | otherwise = alts
-               where err = mkRuntimeErrorApp rUNTIME_ERROR_ID ty
-                                             "Bottoming expression returned"
+               where err = mkImpossibleExpr ty "cpeRhsE: missing case alternative"
        ; alts'' <- mapM (sat_alt env') alts'
 
        ; return (floats, Case scrut' bndr2 ty alts'') }
diff --git a/compiler/GHC/HsToCore/Pmc/Solver.hs b/compiler/GHC/HsToCore/Pmc/Solver.hs
index c3f57e83af..b70c868c2f 100644
--- a/compiler/GHC/HsToCore/Pmc/Solver.hs
+++ b/compiler/GHC/HsToCore/Pmc/Solver.hs
@@ -65,7 +65,7 @@ import GHC.Core.Map.Expr
 import GHC.Core.Predicate (typeDeterminesValue)
 import GHC.Core.SimpleOpt (simpleOptExpr, exprIsConApp_maybe)
 import GHC.Core.Utils     (exprType)
-import GHC.Core.Make      (mkListExpr, mkCharExpr, mkRuntimeErrorApp, rUNTIME_ERROR_ID)
+import GHC.Core.Make      (mkListExpr, mkCharExpr, mkImpossibleExpr)
 
 import GHC.Data.FastString
 import GHC.Types.SrcLoc
@@ -972,7 +972,7 @@ makeDictsCoherent :: CoreExpr -> CoreExpr
 makeDictsCoherent var@(Var v)
   | let ty = idType v
   , typeDeterminesValue ty
-  = mkRuntimeErrorApp rUNTIME_ERROR_ID ty "dictionary"
+  = mkImpossibleExpr ty "Solver.makeDictsCoherent"
   | otherwise
   = var
 makeDictsCoherent lit@(Lit {})
diff --git a/libraries/base/Control/Exception/Base.hs b/libraries/base/Control/Exception/Base.hs
index c2c675c65d..06ae041624 100644
--- a/libraries/base/Control/Exception/Base.hs
+++ b/libraries/base/Control/Exception/Base.hs
@@ -94,7 +94,8 @@ module Control.Exception.Base (
         finally,
 
         -- * Calls for GHC runtime
-        recSelError, recConError, runtimeError,
+        recSelError, recConError,
+        impossibleError, impossibleConstraintError,
         nonExhaustiveGuardsError, patError, noMethodBindingError,
         typeError,
         nonTermination, nestedAtomically, noMatchingContinuationPrompt,
@@ -409,21 +410,25 @@ instance Exception NoMatchingContinuationPrompt
 -----
 
 -- See Note [Compiler error functions] in ghc-prim:GHC.Prim.Panic
-recSelError, recConError, runtimeError,
-  nonExhaustiveGuardsError, patError, noMethodBindingError,
-  typeError
+recSelError, recConError, typeError,
+  nonExhaustiveGuardsError, patError, noMethodBindingError
         :: Addr# -> a   -- All take a UTF8-encoded C string
 
 recSelError              s = throw (RecSelError ("No match in record selector "
                                                  ++ unpackCStringUtf8# s))  -- No location info unfortunately
-runtimeError             s = errorWithoutStackTrace (unpackCStringUtf8# s)                   -- No location info unfortunately
-
 nonExhaustiveGuardsError s = throw (PatternMatchFail (untangle s "Non-exhaustive guards in"))
 recConError              s = throw (RecConError      (untangle s "Missing field in record construction"))
 noMethodBindingError     s = throw (NoMethodError    (untangle s "No instance nor default method for class operation"))
 patError                 s = throw (PatternMatchFail (untangle s "Non-exhaustive patterns in"))
 typeError                s = throw (TypeError        (unpackCStringUtf8# s))
 
+
+impossibleError, impossibleConstraintError :: Addr# -> a
+-- These two are used for impossible case alternatives, and lack location info
+impossibleError             s = errorWithoutStackTrace (unpackCStringUtf8# s)
+impossibleConstraintError   s = errorWithoutStackTrace (unpackCStringUtf8# s)
+
+
 -- GHC's RTS calls this
 nonTermination :: SomeException
 nonTermination = toException NonTermination
diff --git a/libraries/ghc-prim/GHC/Prim/Panic.hs b/libraries/ghc-prim/GHC/Prim/Panic.hs
index a24f82ee07..35bcfc42e3 100644
--- a/libraries/ghc-prim/GHC/Prim/Panic.hs
+++ b/libraries/ghc-prim/GHC/Prim/Panic.hs
@@ -111,9 +111,9 @@ absentConstraintError :: forall (a :: Type). Addr# -> a
 -- We want to give this the type
 --    forall (a :: Constraint). Addr# -> a
 -- but Haskell source code doesn't allow functions that return Constraint
--- Fortunately, absentConstraintError is a wired-in Id with the above
--- desired type. So the only purpose of this definition is to give a
--- function to call. And for that purpose, absentError will do fine.
--- It's fine to lie about about the type; it is not looked at
--- because absentConstraintError is wired-in.
+-- So in this module we lie about the type.  This is fine because
+-- absentConstraintError is a wired-in Id with the desired Constraint-kinded
+-- type; the type in the interface file is never looked at.
+-- The only purpose of this definition is to give a function to call,
+-- and for that purpose, delegating to absentError is fine.
 absentConstraintError errmsg = absentError errmsg
diff --git a/testsuite/tests/simplCore/should_compile/T22634.hs b/testsuite/tests/simplCore/should_compile/T22634.hs
new file mode 100644
index 0000000000..f4cfa38a6d
--- /dev/null
+++ b/testsuite/tests/simplCore/should_compile/T22634.hs
@@ -0,0 +1,11 @@
+module T226334 where
+
+import Data.Kind
+import Type.Reflection
+
+fromDynamic :: forall (a :: Type) (b :: Type). Typeable a => TypeRep b -> Maybe (a :~~: b)
+fromDynamic t = typeRep `eqTypeRep` t
+
+recursiveStrategy :: forall (a :: Type) (b :: Type). Typeable a
+                  => TypeRep b -> Maybe ((Bool -> a) :~~: b)
+recursiveStrategy = fromDynamic
diff --git a/testsuite/tests/simplCore/should_compile/all.T b/testsuite/tests/simplCore/should_compile/all.T
index a8c08fa688..edbefd6145 100644
--- a/testsuite/tests/simplCore/should_compile/all.T
+++ b/testsuite/tests/simplCore/should_compile/all.T
@@ -454,6 +454,7 @@ test('T21851_2', [grep_errmsg(r'wwombat') ], multimod_compile, ['T21851_2', '-O
 # Should not inline m, so there shouldn't be a single YES
 test('T22317', [grep_errmsg(r'ANSWER = YES') ], compile, ['-O -dinline-check m -ddebug-output'])
 
+test('T22634', normal, compile, ['-O -fcatch-nonexhaustive-cases'])
 test('T22494', [grep_errmsg(r'case') ], compile, ['-O -ddump-simpl -dsuppress-uniques'])
 test('T22491', normal, compile, ['-O2'])
 test('T21476', normal, compile, [''])