Use a uniform return convention in bytecode for unary results

fixes #22958

15 files changed, 201 insertions, 218 deletions

diff --git a/compiler/GHC/ByteCode/Asm.hs b/compiler/GHC/ByteCode/Asm.hs
index f020f0af0a..c0359cacb9 100644
--- a/compiler/GHC/ByteCode/Asm.hs
+++ b/compiler/GHC/ByteCode/Asm.hs
@@ -395,10 +395,7 @@ assembleI platform i = case i of
   PUSH_BCO proto           -> do let ul_bco = assembleBCO platform proto
                                  p <- ioptr (liftM BCOPtrBCO ul_bco)
                                  emit bci_PUSH_G [Op p]
-  PUSH_ALTS proto          -> do let ul_bco = assembleBCO platform proto
-                                 p <- ioptr (liftM BCOPtrBCO ul_bco)
-                                 emit bci_PUSH_ALTS [Op p]
-  PUSH_ALTS_UNLIFTED proto pk
+  PUSH_ALTS proto pk
                            -> do let ul_bco = assembleBCO platform proto
                                  p <- ioptr (liftM BCOPtrBCO ul_bco)
                                  emit (push_alts pk) [Op p]
@@ -504,8 +501,7 @@ assembleI platform i = case i of
   SWIZZLE   stkoff n       -> emit bci_SWIZZLE [SmallOp stkoff, SmallOp n]
   JMP       l              -> emit bci_JMP [LabelOp l]
   ENTER                    -> emit bci_ENTER []
-  RETURN                   -> emit bci_RETURN []
-  RETURN_UNLIFTED rep      -> emit (return_unlifted rep) []
+  RETURN rep               -> emit (return_non_tuple rep) []
   RETURN_TUPLE             -> emit bci_RETURN_T []
   CCALL off m_addr i       -> do np <- addr m_addr
                                  emit bci_CCALL [SmallOp off, Op np, SmallOp i]
@@ -574,16 +570,16 @@ push_alts V16 = error "push_alts: vector"
 push_alts V32 = error "push_alts: vector"
 push_alts V64 = error "push_alts: vector"
 
-return_unlifted :: ArgRep -> Word16
-return_unlifted V   = bci_RETURN_V
-return_unlifted P   = bci_RETURN_P
-return_unlifted N   = bci_RETURN_N
-return_unlifted L   = bci_RETURN_L
-return_unlifted F   = bci_RETURN_F
-return_unlifted D   = bci_RETURN_D
-return_unlifted V16 = error "return_unlifted: vector"
-return_unlifted V32 = error "return_unlifted: vector"
-return_unlifted V64 = error "return_unlifted: vector"
+return_non_tuple :: ArgRep -> Word16
+return_non_tuple V   = bci_RETURN_V
+return_non_tuple P   = bci_RETURN_P
+return_non_tuple N   = bci_RETURN_N
+return_non_tuple L   = bci_RETURN_L
+return_non_tuple F   = bci_RETURN_F
+return_non_tuple D   = bci_RETURN_D
+return_non_tuple V16 = error "return_non_tuple: vector"
+return_non_tuple V32 = error "return_non_tuple: vector"
+return_non_tuple V64 = error "return_non_tuple: vector"
 
 {-
   we can only handle up to a fixed number of words on the stack,
diff --git a/compiler/GHC/ByteCode/Instr.hs b/compiler/GHC/ByteCode/Instr.hs
index a35c4d1fd9..e8d377ed69 100644
--- a/compiler/GHC/ByteCode/Instr.hs
+++ b/compiler/GHC/ByteCode/Instr.hs
@@ -88,8 +88,7 @@ data BCInstr
    | PUSH_BCO     (ProtoBCO Name)
 
    -- Push an alt continuation
-   | PUSH_ALTS          (ProtoBCO Name)
-   | PUSH_ALTS_UNLIFTED (ProtoBCO Name) ArgRep
+   | PUSH_ALTS          (ProtoBCO Name) ArgRep
    | PUSH_ALTS_TUPLE    (ProtoBCO Name) -- continuation
                         !NativeCallInfo
                         (ProtoBCO Name) -- tuple return BCO
@@ -197,9 +196,10 @@ data BCInstr
 
    -- To Infinity And Beyond
    | ENTER
-   | RETURN                 -- return a lifted value
-   | RETURN_UNLIFTED ArgRep -- return an unlifted value, here's its rep
-   | RETURN_TUPLE           -- return an unboxed tuple (info already on stack)
+   | RETURN ArgRep -- return a non-tuple value, here's its rep; see
+                   -- Note [Return convention for non-tuple values] in GHC.StgToByteCode
+   | RETURN_TUPLE  -- return an unboxed tuple (info already on stack); see
+                   -- Note [unboxed tuple bytecodes and tuple_BCO] in GHC.StgToByteCode
 
    -- Breakpoints
    | BRK_FUN          Word16 Unique (RemotePtr CostCentre)
@@ -274,8 +274,7 @@ instance Outputable BCInstr where
                                                <> ppr op
    ppr (PUSH_BCO bco)        = hang (text "PUSH_BCO") 2 (ppr bco)
 
-   ppr (PUSH_ALTS bco)       = hang (text "PUSH_ALTS") 2 (ppr bco)
-   ppr (PUSH_ALTS_UNLIFTED bco pk) = hang (text "PUSH_ALTS_UNLIFTED" <+> ppr pk) 2 (ppr bco)
+   ppr (PUSH_ALTS bco pk)    = hang (text "PUSH_ALTS" <+> ppr pk) 2 (ppr bco)
    ppr (PUSH_ALTS_TUPLE bco call_info tuple_bco) =
                                hang (text "PUSH_ALTS_TUPLE" <+> ppr call_info)
                                     2
@@ -352,8 +351,7 @@ instance Outputable BCInstr where
    ppr (SWIZZLE stkoff n)    = text "SWIZZLE " <+> text "stkoff" <+> ppr stkoff
                                                <+> text "by" <+> ppr n
    ppr ENTER                 = text "ENTER"
-   ppr RETURN                = text "RETURN"
-   ppr (RETURN_UNLIFTED pk)  = text "RETURN_UNLIFTED  " <+> ppr pk
+   ppr (RETURN pk)           = text "RETURN  " <+> ppr pk
    ppr (RETURN_TUPLE)        = text "RETURN_TUPLE"
    ppr (BRK_FUN index uniq _cc) = text "BRK_FUN" <+> ppr index <+> mb_uniq <+> text "<cc>"
      where mb_uniq = sdocOption sdocSuppressUniques $ \case
@@ -389,10 +387,8 @@ bciStackUse PUSH32_W{}            = 1  -- takes exactly 1 word
 bciStackUse PUSH_G{}              = 1
 bciStackUse PUSH_PRIMOP{}         = 1
 bciStackUse PUSH_BCO{}            = 1
-bciStackUse (PUSH_ALTS bco)       = 2 {- profiling only, restore CCCS -} +
+bciStackUse (PUSH_ALTS bco _)     = 2 {- profiling only, restore CCCS -} +
                                     3 + protoBCOStackUse bco
-bciStackUse (PUSH_ALTS_UNLIFTED bco _) = 2 {- profiling only, restore CCCS -} +
-                                         4 + protoBCOStackUse bco
 bciStackUse (PUSH_ALTS_TUPLE bco info _) =
    -- (tuple_bco, call_info word, cont_bco, stg_ctoi_t)
    -- tuple
@@ -452,8 +448,7 @@ bciStackUse TESTEQ_P{}            = 0
 bciStackUse CASEFAIL{}            = 0
 bciStackUse JMP{}                 = 0
 bciStackUse ENTER{}               = 0
-bciStackUse RETURN{}              = 0
-bciStackUse RETURN_UNLIFTED{}     = 1 -- pushes stg_ret_X for some X
+bciStackUse RETURN{}              = 1 -- pushes stg_ret_X for some X
 bciStackUse RETURN_TUPLE{}        = 1 -- pushes stg_ret_t header
 bciStackUse CCALL{}               = 0
 bciStackUse PRIMCALL{}            = 1 -- pushes stg_primcall
diff --git a/compiler/GHC/StgToByteCode.hs b/compiler/GHC/StgToByteCode.hs
index a6eebe9bc9..33a16903c3 100644
--- a/compiler/GHC/StgToByteCode.hs
+++ b/compiler/GHC/StgToByteCode.hs
@@ -319,7 +319,7 @@ schemeTopBind (id, rhs)
         -- by just re-using the single top-level definition.  So
         -- for the worker itself, we must allocate it directly.
     -- ioToBc (putStrLn $ "top level BCO")
-    emitBc (mkProtoBCO platform (getName id) (toOL [PACK data_con 0, RETURN])
+    emitBc (mkProtoBCO platform (getName id) (toOL [PACK data_con 0, RETURN P])
                        (Right rhs) 0 0 [{-no bitmap-}] False{-not alts-})
 
   | otherwise
@@ -480,9 +480,9 @@ returnUnliftedReps d s szb reps = do
         non_void VoidRep = False
         non_void _ = True
     ret <- case filter non_void reps of
-             -- use RETURN_UBX for unary representations
-             []    -> return (unitOL $ RETURN_UNLIFTED V)
-             [rep] -> return (unitOL $ RETURN_UNLIFTED (toArgRep platform rep))
+             -- use RETURN for nullary/unary representations
+             []    -> return (unitOL $ RETURN V)
+             [rep] -> return (unitOL $ RETURN (toArgRep platform rep))
              -- otherwise use RETURN_TUPLE with a tuple descriptor
              nv_reps -> do
                let (call_info, args_offsets) = layoutNativeCall profile NativeTupleReturn 0 (primRepCmmType platform) nv_reps
@@ -526,7 +526,7 @@ schemeE
     :: StackDepth -> Sequel -> BCEnv -> CgStgExpr -> BcM BCInstrList
 schemeE d s p (StgLit lit) = returnUnliftedAtom d s p (StgLitArg lit)
 schemeE d s p (StgApp x [])
-   | not (usePlainReturn (idType x)) = returnUnliftedAtom d s p (StgVarArg x)
+   | isUnliftedType (idType x) = returnUnliftedAtom d s p (StgVarArg x)
 -- Delegate tail-calls to schemeT.
 schemeE d s p e@(StgApp {}) = schemeT d s p e
 schemeE d s p e@(StgConApp {}) = schemeT d s p e
@@ -681,8 +681,8 @@ schemeT d s p (StgOpApp (StgPrimOp op) args _ty)
 schemeT d s p (StgOpApp (StgPrimCallOp (PrimCall label unit)) args result_ty)
    = generatePrimCall d s p label (Just unit) result_ty args
 
-   -- Case 2: Unboxed tuple
 schemeT d s p (StgConApp con _cn args _tys)
+   -- Case 2: Unboxed tuple
    | isUnboxedTupleDataCon con || isUnboxedSumDataCon con
    = returnUnboxedTuple d s p args
 
@@ -691,7 +691,7 @@ schemeT d s p (StgConApp con _cn args _tys)
    = do alloc_con <- mkConAppCode d s p con args
         platform <- profilePlatform <$> getProfile
         return (alloc_con         `appOL`
-                mkSlideW 1 (bytesToWords platform $ d - s) `snocOL` RETURN)
+                mkSlideW 1 (bytesToWords platform $ d - s) `snocOL` RETURN P)
 
    -- Case 4: Tail call of function
 schemeT d s p (StgApp fn args)
@@ -831,14 +831,11 @@ doCase d s p scrut bndr alts
         -- have the same runtime rep. We have more efficient specialized
         -- return frames for the situations with one non-void element.
 
+        non_void_arg_reps = non_void (typeArgReps platform bndr_ty)
         ubx_tuple_frame =
           (isUnboxedTupleType bndr_ty || isUnboxedSumType bndr_ty) &&
           length non_void_arg_reps > 1
 
-        ubx_frame = not ubx_tuple_frame && not (usePlainReturn bndr_ty)
-
-        non_void_arg_reps = non_void (typeArgReps platform bndr_ty)
-
         profiling
           | Just interp <- hsc_interp hsc_env
           = interpreterProfiled interp
@@ -847,7 +844,8 @@ doCase d s p scrut bndr alts
         -- Top of stack is the return itbl, as usual.
         -- underneath it is the pointer to the alt_code BCO.
         -- When an alt is entered, it assumes the returned value is
-        -- on top of the itbl.
+        -- on top of the itbl; see Note [Return convention for non-tuple values]
+        -- for details.
         ret_frame_size_b :: StackDepth
         ret_frame_size_b | ubx_tuple_frame =
                              (if profiling then 5 else 4) * wordSize platform
@@ -861,7 +859,6 @@ doCase d s p scrut bndr alts
         -- The size of the return frame info table pointer if one exists
         unlifted_itbl_size_b :: StackDepth
         unlifted_itbl_size_b | ubx_tuple_frame = wordSize platform
-                             | ubx_frame       = wordSize platform
                              | otherwise       = 0
 
         (bndr_size, call_info, args_offsets)
@@ -1052,17 +1049,11 @@ doCase d s p scrut bndr alts
        then do tuple_bco <- emitBc (tupleBCO platform call_info args_offsets)
                return (PUSH_ALTS_TUPLE alt_bco' call_info tuple_bco
                        `consOL` scrut_code)
-       else let push_alts
-                  | not ubx_frame
-                  = PUSH_ALTS alt_bco'
-                  | otherwise
-                  = let unlifted_rep =
-                          case non_void_arg_reps of
-                            []    -> V
-                            [rep] -> rep
-                            _     -> panic "schemeE(StgCase).push_alts"
-                    in PUSH_ALTS_UNLIFTED alt_bco' unlifted_rep
-            in return (push_alts `consOL` scrut_code)
+       else let scrut_rep = case non_void_arg_reps of
+                  []    -> V
+                  [rep] -> rep
+                  _     -> panic "schemeE(StgCase).push_alts"
+            in return (PUSH_ALTS alt_bco' scrut_rep `consOL` scrut_code)
 
 
 -- -----------------------------------------------------------------------------
@@ -1130,21 +1121,38 @@ layoutNativeCall profile call_type start_off arg_ty reps =
                   (orig_stk_params ++ map get_byte_off new_stk_params)
      )
 
-{-
-  We use the plain return convention (ENTER/PUSH_ALTS) for
-  lifted types and unlifted algebraic types.
-
-  Other types use PUSH_ALTS_UNLIFTED/PUSH_ALTS_TUPLE which expect
-  additional data on the stack.
- -}
-usePlainReturn :: Type -> Bool
-usePlainReturn t
-  | isUnboxedTupleType t || isUnboxedSumType t = False
-  | otherwise = typePrimRep t == [LiftedRep] ||
-                (typePrimRep t == [UnliftedRep] && isAlgType t)
-
-{- Note [unboxed tuple bytecodes and tuple_BCO]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+{- Note [Return convention for non-tuple values]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+The RETURN and ENTER instructions are used to return values. RETURN directly
+returns the value at the top of the stack while ENTER evaluates it first (so
+RETURN is only used when the result is already known to be evaluated), but the
+end result is the same: control returns to the enclosing stack frame with the
+result at the top of the stack.
+
+The PUSH_ALTS instruction pushes a two-word stack frame that receives a single
+lifted value. Its payload is a BCO that is executed when control returns, with
+the stack set up as if a RETURN instruction had just been executed: the returned
+value is at the top of the stack, and beneath it is the two-word frame being
+returned to. It is the continuation BCO’s job to pop its own frame off the
+stack, so the simplest possible continuation consists of two instructions:
+
+    SLIDE 1 2   -- pop the return frame off the stack, keeping the returned value
+    RETURN P    -- return the returned value to our caller
+
+RETURN and PUSH_ALTS are not really instructions but are in fact representation-
+polymorphic *families* of instructions indexed by ArgRep. ENTER, however, is a
+single real instruction, since it is only used to return lifted values, which
+are always pointers.
+
+The RETURN, ENTER, and PUSH_ALTS instructions are only used when the returned
+value has nullary or unary representation. Returning/receiving an unboxed
+tuple (or, indirectly, an unboxed sum, since unboxed sums have been desugared to
+unboxed tuples by Unarise) containing two or more results uses the special
+RETURN_TUPLE/PUSH_ALTS_TUPLE instructions, which use a different return
+convention. See Note [unboxed tuple bytecodes and tuple_BCO] for details.
+
+Note [unboxed tuple bytecodes and tuple_BCO]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
   We have the bytecode instructions RETURN_TUPLE and PUSH_ALTS_TUPLE to
   return and receive arbitrary unboxed tuples, respectively. These
   instructions use the helper data tuple_BCO and call_info.
@@ -1580,7 +1588,7 @@ generateCCall d0 s p (CCallSpec target cconv safety) result_ty args
          -- slide and return
          d_after_r_min_s = bytesToWords platform (d_after_r - s)
          wrapup       = mkSlideW (trunc16W r_sizeW) (d_after_r_min_s - r_sizeW)
-                        `snocOL` RETURN_UNLIFTED (toArgRep platform r_rep)
+                        `snocOL` RETURN (toArgRep platform r_rep)
          --trace (show (arg1_offW, args_offW  ,  (map argRepSizeW a_reps) )) $
      return (
          push_args `appOL`
@@ -1694,7 +1702,6 @@ as a consequence.  The [Name] is a list of the constructors of this
 
 The code we generate is this:
                 push arg
-                push bogus-word
 
                 TESTEQ_I 0 L1
                   PUSH_G <lbl for first data con>
@@ -1712,13 +1719,6 @@ The code we generate is this:
 
         L_exit: SLIDE 1 n
                 ENTER
-
-The 'bogus-word' push is because TESTEQ_I expects the top of the stack
-to have an info-table, and the next word to have the value to be
-tested.  This is very weird, but it's the way it is right now.  See
-Interpreter.c.  We don't actually need an info-table here; we just
-need to have the argument to be one-from-top on the stack, hence pushing
-a 1-word null. See #8383.
 -}
 
 
@@ -1744,14 +1744,10 @@ implement_tagToId d s p arg names
            slide_ws = bytesToWords platform (d - s + arg_bytes)
 
        return (push_arg
-               `appOL` unitOL (PUSH_UBX LitNullAddr 1)
-                   -- Push bogus word (see Note [Implementing tagToEnum#])
                `appOL` concatOL steps
                `appOL` toOL [ LABEL label_fail, CASEFAIL,
                               LABEL label_exit ]
-               `appOL` mkSlideW 1 (slide_ws + 1)
-                   -- "+1" to account for bogus word
-                   --      (see Note [Implementing tagToEnum#])
+               `appOL` mkSlideW 1 slide_ws
                `appOL` unitOL ENTER)
   where
         mkStep l_exit (my_label, next_label, n, name_for_n)
diff --git a/compiler/GHC/StgToCmm/Closure.hs b/compiler/GHC/StgToCmm/Closure.hs
index fc76664d94..c9e4967be0 100644
--- a/compiler/GHC/StgToCmm/Closure.hs
+++ b/compiler/GHC/StgToCmm/Closure.hs
@@ -308,8 +308,7 @@ type DynTag = Int       -- The tag on a *pointer*
 -- Also see Note [Tagging big families] in GHC.StgToCmm.Expr
 --
 -- The interpreter also needs to be updated if we change the
--- tagging strategy. See Note [Data constructor dynamic tags] in
--- rts/Interpreter.c
+-- tagging strategy; see tagConstr in rts/Interpreter.c.
 
 isSmallFamily :: Platform -> Int -> Bool
 isSmallFamily platform fam_size = fam_size <= mAX_PTR_TAG platform
diff --git a/rts/Disassembler.c b/rts/Disassembler.c
index f8b270fa28..56be0fb775 100644
--- a/rts/Disassembler.c
+++ b/rts/Disassembler.c
@@ -123,10 +123,6 @@ disInstr ( StgBCO *bco, int pc )
          debugBelch("PUSH_G   " ); printPtr( ptrs[instrs[pc]] );
          debugBelch("\n" );
          pc += 1; break;
-      case bci_PUSH_ALTS:
-         debugBelch("PUSH_ALTS  " ); printPtr( ptrs[instrs[pc]] );
-         debugBelch("\n");
-         pc += 1; break;
       case bci_PUSH_ALTS_P:
          debugBelch("PUSH_ALTS_P  " ); printPtr( ptrs[instrs[pc]] );
          debugBelch("\n");
@@ -408,9 +404,6 @@ disInstr ( StgBCO *bco, int pc )
          debugBelch("ENTER\n");
          break;
 
-      case bci_RETURN:
-         debugBelch("RETURN\n" );
-         break;
       case bci_RETURN_P:
          debugBelch("RETURN_P\n" );
          break;
diff --git a/rts/Interpreter.c b/rts/Interpreter.c
index f8885cdbce..3b250002dc 100644
--- a/rts/Interpreter.c
+++ b/rts/Interpreter.c
@@ -283,6 +283,14 @@ StgClosure * copyPAP  (Capability *cap, StgPAP *oldpap)
 
 #endif
 
+// Compute the pointer tag for the constructor and tag the pointer;
+// see Note [Data constructor dynamic tags] in GHC.StgToCmm.Closure.
+//
+// Note: we need to update this if we change the tagging strategy.
+STATIC_INLINE StgClosure *tagConstr(StgClosure *con) {
+    return TAG_CLOSURE(stg_min(TAG_MASK, 1 + GET_TAG(con)), con);
+}
+
 static StgWord app_ptrs_itbl[] = {
     (W_)&stg_ap_p_info,
     (W_)&stg_ap_pp_info,
@@ -363,11 +371,22 @@ interpretBCO (Capability* cap)
     // ------------------------------------------------------------------------
     // Case 3:
     //
-    //       We have an unlifted value to return.  See comment before
-    //       do_return_lifted, below.
+    //       We have a pointer to return.  See comment before
+    //       do_return_pointer, below.
+    //
+    else if (SpW(0) == (W_)&stg_ret_p_info) {
+      tagged_obj = (StgClosure *)SpW(1);
+      Sp_addW(2);
+      goto do_return_pointer;
+    }
+
+    // ------------------------------------------------------------------------
+    // Case 4:
+    //
+    //       We have a nonpointer to return.
     //
     else {
-        goto do_return_unlifted;
+        goto do_return_nonpointer;
     }
 
     // Evaluate the object on top of the stack.
@@ -412,6 +431,11 @@ eval_obj:
     case CONSTR_1_1:
     case CONSTR_0_2:
     case CONSTR_NOCAF:
+        // The value is already evaluated, so we can just return it. However,
+        // before we do, we MUST ensure that the pointer is tagged, because we
+        // might return to a native `case` expression, which assumes the returned
+        // pointer is tagged so it can use the tag to select an alternative.
+        tagged_obj = tagConstr(obj);
         break;
 
     case FUN:
@@ -533,16 +557,16 @@ eval_obj:
     }
 
     // ------------------------------------------------------------------------
-    // We now have an evaluated object (tagged_obj).  The next thing to
+    // We now have a pointer to return (tagged_obj).  The next thing to
     // do is return it to the stack frame on top of the stack.
-do_return:
+do_return_pointer:
     obj = UNTAG_CLOSURE(tagged_obj);
-    ASSERT(closure_HNF(obj));
+    ASSERT(LOOKS_LIKE_CLOSURE_PTR(obj));
 
     IF_DEBUG(interpreter,
              debugBelch(
              "\n---------------------------------------------------------------\n");
-             debugBelch("Returning: "); printObj(obj);
+             debugBelch("Returning closure: "); printObj(obj);
              debugBelch("Sp = %p\n", Sp);
 #if defined(PROFILING)
              fprintCCS(stderr, cap->r.rCCCS);
@@ -567,7 +591,7 @@ do_return:
             info == (StgInfoTable *)&stg_restore_cccs_eval_info) {
             cap->r.rCCCS = (CostCentreStack*)SpW(1);
             Sp_addW(2);
-            goto do_return;
+            goto do_return_pointer;
         }
 
         if (info == (StgInfoTable *)&stg_ap_v_info) {
@@ -621,7 +645,7 @@ do_return:
         updateThunk(cap, cap->r.rCurrentTSO,
                     ((StgUpdateFrame *)Sp)->updatee, tagged_obj);
         Sp_addW(sizeofW(StgUpdateFrame));
-        goto do_return;
+        goto do_return_pointer;
 
     case RET_BCO:
         // Returning to an interpreted continuation: put the object on
@@ -631,7 +655,7 @@ do_return:
         SpW(0) = (W_)tagged_obj;
         obj = (StgClosure*)SpW(2);
         ASSERT(get_itbl(obj)->type == BCO);
-        goto run_BCO_return;
+        goto run_BCO_return_pointer;
 
     default:
     do_return_unrecognised:
@@ -644,7 +668,7 @@ do_return:
             );
         Sp_subW(2);
         SpW(1) = (W_)tagged_obj;
-        SpW(0) = (W_)&stg_enter_info;
+        SpW(0) = (W_)&stg_ret_p_info;
         RETURN_TO_SCHEDULER_NO_PAUSE(ThreadRunGHC, ThreadYielding);
     }
     }
@@ -672,12 +696,11 @@ do_return:
     // We're only interested in the case when the real return address
     // is a BCO; otherwise we'll return to the scheduler.
 
-do_return_unlifted:
+do_return_nonpointer:
     {
         int offset;
 
         ASSERT(    SpW(0) == (W_)&stg_ret_v_info
-                || SpW(0) == (W_)&stg_ret_p_info
                 || SpW(0) == (W_)&stg_ret_n_info
                 || SpW(0) == (W_)&stg_ret_f_info
                 || SpW(0) == (W_)&stg_ret_d_info
@@ -688,7 +711,7 @@ do_return_unlifted:
         IF_DEBUG(interpreter,
              debugBelch(
              "\n---------------------------------------------------------------\n");
-             debugBelch("Returning unlifted\n");
+             debugBelch("Returning nonpointer\n");
              debugBelch("Sp = %p\n", Sp);
 #if defined(PROFILING)
              fprintCCS(stderr, cap->r.rCCCS);
@@ -705,12 +728,13 @@ do_return_unlifted:
         switch (get_itbl((StgClosure*)(Sp_plusW(offset)))->type) {
 
         case RET_BCO:
-            // Returning to an interpreted continuation: put the object on
-            // the stack, and start executing the BCO.
+            // Returning to an interpreted continuation: pop the return frame
+            // so the returned value is at the top of the stack, and start
+            // executing the BCO.
             INTERP_TICK(it_retto_BCO);
             obj = (StgClosure*)SpW(offset+1);
             ASSERT(get_itbl(obj)->type == BCO);
-            goto run_BCO_return_unlifted;
+            goto run_BCO_return_nonpointer;
 
         default:
         {
@@ -815,7 +839,7 @@ do_apply:
                 SET_HDR(new_pap,&stg_PAP_info,cap->r.rCCCS);
                 tagged_obj = (StgClosure *)new_pap;
                 Sp_addW(m);
-                goto do_return;
+                goto do_return_pointer;
             }
         }
 
@@ -858,7 +882,7 @@ do_apply:
                 SET_HDR(pap, &stg_PAP_info,cap->r.rCCCS);
                 tagged_obj = (StgClosure *)pap;
                 Sp_addW(m);
-                goto do_return;
+                goto do_return_pointer;
             }
         }
 
@@ -917,10 +941,10 @@ do_apply:
     // to do:
 
 
-run_BCO_return:
+run_BCO_return_pointer:
     // Heap check
     if (doYouWantToGC(cap)) {
-        Sp_subW(1); SpW(0) = (W_)&stg_enter_info;
+        Sp_subW(1); SpW(0) = (W_)&stg_ret_p_info;
         RETURN_TO_SCHEDULER(ThreadInterpret, HeapOverflow);
     }
     // Stack checks aren't necessary at return points, the stack use
@@ -928,7 +952,7 @@ run_BCO_return:
 
     goto run_BCO;
 
-run_BCO_return_unlifted:
+run_BCO_return_nonpointer:
     // Heap check
     if (doYouWantToGC(cap)) {
         RETURN_TO_SCHEDULER(ThreadInterpret, HeapOverflow);
@@ -973,6 +997,9 @@ run_BCO_return_unlifted:
     }
 #endif
 
+    if (SpW(0) != (W_)&stg_ret_t_info) {
+      Sp_addW(1);
+    }
     goto run_BCO;
 
 run_BCO_fun:
@@ -1274,7 +1301,7 @@ run_BCO:
             goto nextInsn;
         }
 
-        case bci_PUSH_ALTS: {
+        case bci_PUSH_ALTS_P: {
             int o_bco  = BCO_GET_LARGE_ARG;
             Sp_subW(2);
             SpW(1) = BCO_PTR(o_bco);
@@ -1287,19 +1314,6 @@ run_BCO:
             goto nextInsn;
         }
 
-        case bci_PUSH_ALTS_P: {
-            int o_bco  = BCO_GET_LARGE_ARG;
-            SpW(-2) = (W_)&stg_ctoi_R1unpt_info;
-            SpW(-1) = BCO_PTR(o_bco);
-            Sp_subW(2);
-#if defined(PROFILING)
-            Sp_subW(2);
-            SpW(1) = (W_)cap->r.rCCCS;
-            SpW(0) = (W_)&stg_restore_cccs_info;
-#endif
-            goto nextInsn;
-        }
-
         case bci_PUSH_ALTS_N: {
             int o_bco  = BCO_GET_LARGE_ARG;
             SpW(-2) = (W_)&stg_ctoi_R1n_info;
@@ -1678,19 +1692,7 @@ run_BCO:
             StgInfoTable *con_itbl = (StgInfoTable*) BCO_LIT(o_itbl);
             SET_HDR(con, con_itbl, cap->r.rCCCS);
 
-            // Note [Data constructor dynamic tags]
-            // ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-            // compute the pointer tag for the constructor and tag the pointer
-            //
-            //     - 1..(TAG_MASK-1): for first TAG_MASK-1 constructors
-            //     - TAG_MASK:        look in info table
-            //
-            // Note: we need to update this if we change the tagging strategy
-            //
-            // For full details of the invariants on tagging, see
-            // https://gitlab.haskell.org/ghc/ghc/wikis/commentary/rts/haskell-execution/pointer-tagging
-
-            StgClosure* tagged_con = TAG_CLOSURE(stg_min(TAG_MASK, 1 + GET_TAG(con)), con);
+            StgClosure* tagged_con = tagConstr(con);
             SpW(0) = (W_)tagged_con;
 
             IF_DEBUG(interpreter,
@@ -1721,60 +1723,54 @@ run_BCO:
         }
 
         case bci_TESTLT_I: {
-            // There should be an Int at SpW(1), and an info table at SpW(0).
             int discr   = BCO_GET_LARGE_ARG;
             int failto  = BCO_GET_LARGE_ARG;
-            I_ stackInt = (I_)SpW(1);
+            I_ stackInt = (I_)SpW(0);
             if (stackInt >= (I_)BCO_LIT(discr))
                 bciPtr = failto;
             goto nextInsn;
         }
 
         case bci_TESTLT_I64: {
-            // There should be an Int64 at SpW(1), and an info table at SpW(0).
             int discr   = BCO_GET_LARGE_ARG;
             int failto  = BCO_GET_LARGE_ARG;
-            StgInt64 stackInt = (*(StgInt64*)Sp_plusW(1));
+            StgInt64 stackInt = (*(StgInt64*)Sp);
             if (stackInt >= BCO_LITI64(discr))
                 bciPtr = failto;
             goto nextInsn;
         }
 
         case bci_TESTLT_I32: {
-            // There should be an Int32 at SpW(1), and an info table at SpW(0).
             int discr   = BCO_GET_LARGE_ARG;
             int failto  = BCO_GET_LARGE_ARG;
-            StgInt32 stackInt = (*(StgInt32*)Sp_plusW(1));
+            StgInt32 stackInt = (*(StgInt32*)Sp);
             if (stackInt >= (StgInt32)BCO_LIT(discr))
                 bciPtr = failto;
             goto nextInsn;
         }
 
         case bci_TESTLT_I16: {
-            // There should be an Int16 at SpW(1), and an info table at SpW(0).
             int discr   = BCO_GET_LARGE_ARG;
             int failto  = BCO_GET_LARGE_ARG;
-            StgInt16 stackInt = (*(StgInt16*)Sp_plusW(1));
+            StgInt16 stackInt = (*(StgInt16*)Sp);
             if (stackInt >= (StgInt16)BCO_LIT(discr))
                 bciPtr = failto;
             goto nextInsn;
         }
 
         case bci_TESTLT_I8: {
-            // There should be an Int8 at SpW(1), and an info table at SpW(0).
             int discr   = BCO_GET_LARGE_ARG;
             int failto  = BCO_GET_LARGE_ARG;
-            StgInt8 stackInt = (*(StgInt8*)Sp_plusW(1));
+            StgInt8 stackInt = (*(StgInt8*)Sp);
             if (stackInt >= (StgInt8)BCO_LIT(discr))
                 bciPtr = failto;
             goto nextInsn;
         }
 
         case bci_TESTEQ_I: {
-            // There should be an Int at SpW(1), and an info table at SpW(0).
             int discr   = BCO_GET_LARGE_ARG;
             int failto  = BCO_GET_LARGE_ARG;
-            I_ stackInt = (I_)SpW(1);
+            I_ stackInt = (I_)SpW(0);
             if (stackInt != (I_)BCO_LIT(discr)) {
                 bciPtr = failto;
             }
@@ -1782,10 +1778,9 @@ run_BCO:
         }
 
         case bci_TESTEQ_I64: {
-            // There should be an Int64 at SpW(1), and an info table at SpW(0).
             int discr   = BCO_GET_LARGE_ARG;
             int failto  = BCO_GET_LARGE_ARG;
-            StgInt64 stackInt = (*(StgInt64*)Sp_plusW(1));
+            StgInt64 stackInt = (*(StgInt64*)Sp);
             if (stackInt != BCO_LITI64(discr)) {
                 bciPtr = failto;
             }
@@ -1793,10 +1788,9 @@ run_BCO:
         }
 
         case bci_TESTEQ_I32: {
-            // There should be an Int32 at SpW(1), and an info table at SpW(0).
             int discr   = BCO_GET_LARGE_ARG;
             int failto  = BCO_GET_LARGE_ARG;
-            StgInt32 stackInt = (*(StgInt32*)Sp_plusW(1));
+            StgInt32 stackInt = (*(StgInt32*)Sp);
             if (stackInt != (StgInt32)BCO_LIT(discr)) {
                 bciPtr = failto;
             }
@@ -1804,10 +1798,9 @@ run_BCO:
         }
 
         case bci_TESTEQ_I16: {
-            // There should be an Int16 at SpW(1), and an info table at SpW(0).
             int discr   = BCO_GET_LARGE_ARG;
             int failto  = BCO_GET_LARGE_ARG;
-            StgInt16 stackInt = (*(StgInt16*)Sp_plusW(1));
+            StgInt16 stackInt = (*(StgInt16*)Sp);
             if (stackInt != (StgInt16)BCO_LIT(discr)) {
                 bciPtr = failto;
             }
@@ -1815,10 +1808,9 @@ run_BCO:
         }
 
         case bci_TESTEQ_I8: {
-            // There should be an Int8 at SpW(1), and an info table at SpW(0).
             int discr   = BCO_GET_LARGE_ARG;
             int failto  = BCO_GET_LARGE_ARG;
-            StgInt8 stackInt = (*(StgInt8*)Sp_plusW(1));
+            StgInt8 stackInt = (*(StgInt8*)Sp);
             if (stackInt != (StgInt8)BCO_LIT(discr)) {
                 bciPtr = failto;
             }
@@ -1826,60 +1818,54 @@ run_BCO:
         }
 
         case bci_TESTLT_W: {
-            // There should be a Word at SpW(1), and an info table at SpW(0).
             int discr   = BCO_GET_LARGE_ARG;
             int failto  = BCO_GET_LARGE_ARG;
-            W_ stackWord = (W_)SpW(1);
+            W_ stackWord = (W_)SpW(0);
             if (stackWord >= (W_)BCO_LIT(discr))
                 bciPtr = failto;
             goto nextInsn;
         }
 
         case bci_TESTLT_W64: {
-            // There should be a Word64 at SpW(1), and an info table at SpW(0).
             int discr   = BCO_GET_LARGE_ARG;
             int failto  = BCO_GET_LARGE_ARG;
-            StgWord64 stackWord = (*(StgWord64*)Sp_plusW(1));
+            StgWord64 stackWord = (*(StgWord64*)Sp);
             if (stackWord >= BCO_LITW64(discr))
                 bciPtr = failto;
             goto nextInsn;
         }
 
         case bci_TESTLT_W32: {
-            // There should be a Word32 at SpW(1), and an info table at SpW(0).
             int discr   = BCO_GET_LARGE_ARG;
             int failto  = BCO_GET_LARGE_ARG;
-            StgWord32 stackWord = (*(StgWord32*)Sp_plusW(1));
+            StgWord32 stackWord = (*(StgWord32*)Sp);
             if (stackWord >= (StgWord32)BCO_LIT(discr))
                 bciPtr = failto;
             goto nextInsn;
         }
 
         case bci_TESTLT_W16: {
-            // There should be a Word16 at SpW(1), and an info table at SpW(0).
             int discr   = BCO_GET_LARGE_ARG;
             int failto  = BCO_GET_LARGE_ARG;
-            StgWord16 stackWord = (*(StgWord16*)Sp_plusW(1));
+            StgWord16 stackWord = (*(StgWord16*)Sp);
             if (stackWord >= (StgWord16)BCO_LIT(discr))
                 bciPtr = failto;
             goto nextInsn;
         }
 
         case bci_TESTLT_W8: {
-            // There should be a Word8 at SpW(1), and an info table at SpW(0).
             int discr   = BCO_GET_LARGE_ARG;
             int failto  = BCO_GET_LARGE_ARG;
-            StgWord8 stackWord = (*(StgWord8*)Sp_plusW(1));
+            StgWord8 stackWord = (*(StgWord8*)Sp);
             if (stackWord >= (StgWord8)BCO_LIT(discr))
                 bciPtr = failto;
             goto nextInsn;
         }
 
         case bci_TESTEQ_W: {
-            // There should be a Word at SpW(1), and an info table at SpW(0).
             int discr   = BCO_GET_LARGE_ARG;
             int failto  = BCO_GET_LARGE_ARG;
-            W_ stackWord = (W_)SpW(1);
+            W_ stackWord = (W_)SpW(0);
             if (stackWord != (W_)BCO_LIT(discr)) {
                 bciPtr = failto;
             }
@@ -1887,10 +1873,9 @@ run_BCO:
         }
 
         case bci_TESTEQ_W64: {
-            // There should be a Word64 at SpW(1), and an info table at SpW(0).
             int discr   = BCO_GET_LARGE_ARG;
             int failto  = BCO_GET_LARGE_ARG;
-            StgWord64 stackWord = (*(StgWord64*)Sp_plusW(1));
+            StgWord64 stackWord = (*(StgWord64*)Sp);
             if (stackWord != BCO_LITW64(discr)) {
                 bciPtr = failto;
             }
@@ -1898,10 +1883,9 @@ run_BCO:
         }
 
         case bci_TESTEQ_W32: {
-            // There should be a Word32 at SpW(1), and an info table at SpW(0).
             int discr   = BCO_GET_LARGE_ARG;
             int failto  = BCO_GET_LARGE_ARG;
-            StgWord32 stackWord = (*(StgWord32*)Sp_plusW(1));
+            StgWord32 stackWord = (*(StgWord32*)Sp);
             if (stackWord != (StgWord32)BCO_LIT(discr)) {
                 bciPtr = failto;
             }
@@ -1909,10 +1893,9 @@ run_BCO:
         }
 
         case bci_TESTEQ_W16: {
-            // There should be a Word16 at SpW(1), and an info table at SpW(0).
             int discr   = BCO_GET_LARGE_ARG;
             int failto  = BCO_GET_LARGE_ARG;
-            StgWord16 stackWord = (*(StgWord16*)Sp_plusW(1));
+            StgWord16 stackWord = (*(StgWord16*)Sp);
             if (stackWord != (StgWord16)BCO_LIT(discr)) {
                 bciPtr = failto;
             }
@@ -1920,10 +1903,9 @@ run_BCO:
         }
 
         case bci_TESTEQ_W8: {
-            // There should be a Word8 at SpW(1), and an info table at SpW(0).
             int discr   = BCO_GET_LARGE_ARG;
             int failto  = BCO_GET_LARGE_ARG;
-            StgWord8 stackWord = (*(StgWord8*)Sp_plusW(1));
+            StgWord8 stackWord = (*(StgWord8*)Sp);
             if (stackWord != (StgWord8)BCO_LIT(discr)) {
                 bciPtr = failto;
             }
@@ -1931,11 +1913,10 @@ run_BCO:
         }
 
         case bci_TESTLT_D: {
-            // There should be a Double at SpW(1), and an info table at SpW(0).
             int discr   = BCO_GET_LARGE_ARG;
             int failto  = BCO_GET_LARGE_ARG;
             StgDouble stackDbl, discrDbl;
-            stackDbl = PK_DBL( & SpW(1) );
+            stackDbl = PK_DBL( & SpW(0) );
             discrDbl = PK_DBL( & BCO_LIT(discr) );
             if (stackDbl >= discrDbl) {
                 bciPtr = failto;
@@ -1944,11 +1925,10 @@ run_BCO:
         }
 
         case bci_TESTEQ_D: {
-            // There should be a Double at SpW(1), and an info table at SpW(0).
             int discr   = BCO_GET_LARGE_ARG;
             int failto  = BCO_GET_LARGE_ARG;
             StgDouble stackDbl, discrDbl;
-            stackDbl = PK_DBL( & SpW(1) );
+            stackDbl = PK_DBL( & SpW(0) );
             discrDbl = PK_DBL( & BCO_LIT(discr) );
             if (stackDbl != discrDbl) {
                 bciPtr = failto;
@@ -1957,11 +1937,10 @@ run_BCO:
         }
 
         case bci_TESTLT_F: {
-            // There should be a Float at SpW(1), and an info table at SpW(0).
             int discr   = BCO_GET_LARGE_ARG;
             int failto  = BCO_GET_LARGE_ARG;
             StgFloat stackFlt, discrFlt;
-            stackFlt = PK_FLT( & SpW(1) );
+            stackFlt = PK_FLT( & SpW(0) );
             discrFlt = PK_FLT( & BCO_LIT(discr) );
             if (stackFlt >= discrFlt) {
                 bciPtr = failto;
@@ -1970,11 +1949,10 @@ run_BCO:
         }
 
         case bci_TESTEQ_F: {
-            // There should be a Float at SpW(1), and an info table at SpW(0).
             int discr   = BCO_GET_LARGE_ARG;
             int failto  = BCO_GET_LARGE_ARG;
             StgFloat stackFlt, discrFlt;
-            stackFlt = PK_FLT( & SpW(1) );
+            stackFlt = PK_FLT( & SpW(0) );
             discrFlt = PK_FLT( & BCO_LIT(discr) );
             if (stackFlt != discrFlt) {
                 bciPtr = failto;
@@ -1995,40 +1973,36 @@ run_BCO:
             }
             goto eval;
 
-        case bci_RETURN:
+        case bci_RETURN_P:
             tagged_obj = (StgClosure *)SpW(0);
             Sp_addW(1);
-            goto do_return;
+            goto do_return_pointer;
 
-        case bci_RETURN_P:
-            Sp_subW(1);
-            SpW(0) = (W_)&stg_ret_p_info;
-            goto do_return_unlifted;
         case bci_RETURN_N:
             Sp_subW(1);
             SpW(0) = (W_)&stg_ret_n_info;
-            goto do_return_unlifted;
+            goto do_return_nonpointer;
         case bci_RETURN_F:
             Sp_subW(1);
             SpW(0) = (W_)&stg_ret_f_info;
-            goto do_return_unlifted;
+            goto do_return_nonpointer;
         case bci_RETURN_D:
             Sp_subW(1);
             SpW(0) = (W_)&stg_ret_d_info;
-            goto do_return_unlifted;
+            goto do_return_nonpointer;
         case bci_RETURN_L:
             Sp_subW(1);
             SpW(0) = (W_)&stg_ret_l_info;
-            goto do_return_unlifted;
+            goto do_return_nonpointer;
         case bci_RETURN_V:
             Sp_subW(1);
             SpW(0) = (W_)&stg_ret_v_info;
-            goto do_return_unlifted;
+            goto do_return_nonpointer;
         case bci_RETURN_T: {
             /* tuple_info and tuple_bco must already be on the stack */
             Sp_subW(1);
             SpW(0) = (W_)&stg_ret_t_info;
-            goto do_return_unlifted;
+            goto do_return_nonpointer;
         }
 
         case bci_SWIZZLE: {
diff --git a/rts/Printer.c b/rts/Printer.c
index e2dee0984e..85e3069967 100644
--- a/rts/Printer.c
+++ b/rts/Printer.c
@@ -652,8 +652,6 @@ printStackChunk( StgPtr sp, StgPtr spBottom )
 
             if (c == (StgWord)&stg_ctoi_R1p_info) {
                 debugBelch("stg_ctoi_R1p_info" );
-            } else if (c == (StgWord)&stg_ctoi_R1unpt_info) {
-                debugBelch("stg_ctoi_R1unpt_info" );
             } else if (c == (StgWord)&stg_ctoi_R1n_info) {
                 debugBelch("stg_ctoi_R1n_info" );
             } else if (c == (StgWord)&stg_ctoi_F1_info) {
diff --git a/rts/StgMiscClosures.cmm b/rts/StgMiscClosures.cmm
index 222a12e9c6..6b54f3601f 100644
--- a/rts/StgMiscClosures.cmm
+++ b/rts/StgMiscClosures.cmm
@@ -150,18 +150,6 @@ INFO_TABLE_RET( stg_ctoi_R1p, RET_BCO)
 {
     Sp_adj(-2);
     Sp(1) = R1;
-    Sp(0) = stg_enter_info;
-    jump stg_yield_to_interpreter [];
-}
-
-/*
- * When the returned value is a pointer, but unlifted, in R1 ...
- */
-INFO_TABLE_RET( stg_ctoi_R1unpt, RET_BCO )
-    /* explicit stack */
-{
-    Sp_adj(-2);
-    Sp(1) = R1;
     Sp(0) = stg_ret_p_info;
     jump stg_yield_to_interpreter [];
 }
diff --git a/rts/include/rts/Bytecodes.h b/rts/include/rts/Bytecodes.h
index e05ab26d99..93db2e98dd 100644
--- a/rts/include/rts/Bytecodes.h
+++ b/rts/include/rts/Bytecodes.h
@@ -34,7 +34,6 @@
 #define bci_PUSH16_W                    9
 #define bci_PUSH32_W                    10
 #define bci_PUSH_G                      11
-#define bci_PUSH_ALTS                   12
 #define bci_PUSH_ALTS_P                 13
 #define bci_PUSH_ALTS_N                 14
 #define bci_PUSH_ALTS_F                 15
@@ -81,7 +80,6 @@
 #define bci_CCALL                       56
 #define bci_SWIZZLE                     57
 #define bci_ENTER                       58
-#define bci_RETURN                      59
 #define bci_RETURN_P                    60
 #define bci_RETURN_N                    61
 #define bci_RETURN_F                    62
diff --git a/rts/include/stg/MiscClosures.h b/rts/include/stg/MiscClosures.h
index 8e50336e4a..9d52d4b704 100644
--- a/rts/include/stg/MiscClosures.h
+++ b/rts/include/stg/MiscClosures.h
@@ -82,7 +82,6 @@ RTS_RET(stg_prompt_frame);
 /* Magic glue code for when compiled code returns a value in R1/F1/D1
    or a VoidRep to the interpreter. */
 RTS_RET(stg_ctoi_R1p);
-RTS_RET(stg_ctoi_R1unpt);
 RTS_RET(stg_ctoi_R1n);
 RTS_RET(stg_ctoi_F1);
 RTS_RET(stg_ctoi_D1);
diff --git a/testsuite/tests/ghci/should_run/T22958a.hs b/testsuite/tests/ghci/should_run/T22958a.hs
new file mode 100644
index 0000000000..7ec94bc4c7
--- /dev/null
+++ b/testsuite/tests/ghci/should_run/T22958a.hs
@@ -0,0 +1,15 @@
+{-# LANGUAGE MagicHash, UnboxedTuples #-}
+import GHC.Exts
+import GHC.IO
+
+unit :: ()
+unit = ()
+
+i :: State# RealWorld -> (# State# RealWorld, () #)
+i s = case seq# unit s of (# s', a #) -> (# s', a #)
+
+bad :: IO ()
+bad = IO i
+
+main :: IO ()
+main = bad >>= print
diff --git a/testsuite/tests/ghci/should_run/T22958a.stdout b/testsuite/tests/ghci/should_run/T22958a.stdout
new file mode 100644
index 0000000000..6a452c185a
--- /dev/null
+++ b/testsuite/tests/ghci/should_run/T22958a.stdout
@@ -0,0 +1 @@
+()
diff --git a/testsuite/tests/ghci/should_run/T22958b.hs b/testsuite/tests/ghci/should_run/T22958b.hs
new file mode 100644
index 0000000000..da849286aa
--- /dev/null
+++ b/testsuite/tests/ghci/should_run/T22958b.hs
@@ -0,0 +1,25 @@
+{-# LANGUAGE DataKinds #-}
+{-# LANGUAGE DerivingStrategies #-}
+{-# LANGUAGE MagicHash #-}
+{-# LANGUAGE UnliftedDatatypes #-}
+import GHC.Exts
+
+type D1 :: TYPE (BoxedRep Unlifted)
+data D1 = MkD1 !Int
+
+showD1 :: D1 -> String
+showD1 (MkD1 i) = "MkD1 " ++ show i
+
+type D2 :: TYPE (BoxedRep Lifted)
+data D2 = MkD2 !Int deriving stock Show
+
+risky :: forall {r} (a :: TYPE (BoxedRep Unlifted)) (b :: TYPE r). a -> b
+risky = unsafeCoerce#
+{-# NOINLINE risky #-}
+
+main :: IO ()
+main = do
+  putStrLn (showD1 (unsafeCoerce# (MkD1 11))) -- foo11
+  print (unsafeCoerce# (MkD1 12) :: D2)       -- foo12
+  putStrLn (showD1 (risky (MkD1 11)))         -- bar11
+  print (risky (MkD1 12) :: D2)               -- bar12
diff --git a/testsuite/tests/ghci/should_run/T22958b.stdout b/testsuite/tests/ghci/should_run/T22958b.stdout
new file mode 100644
index 0000000000..63f2383a2f
--- /dev/null
+++ b/testsuite/tests/ghci/should_run/T22958b.stdout
@@ -0,0 +1,4 @@
+MkD1 11
+MkD2 12
+MkD1 11
+MkD2 12
diff --git a/testsuite/tests/ghci/should_run/all.T b/testsuite/tests/ghci/should_run/all.T
index aaa8dfe856..a748cc9fa6 100644
--- a/testsuite/tests/ghci/should_run/all.T
+++ b/testsuite/tests/ghci/should_run/all.T
@@ -88,3 +88,5 @@ test('UnliftedDataType2', just_ghci, compile_and_run, [''])
 
 test('T22829', just_ghci + [extra_hc_opts("-Wmissing-import-lists -Werror")], compile_and_run, [''])
 test('T23229', just_ghci + [extra_hc_opts("-this-unit-id my-package -Wno-missing-methods T23229")], ghci_script, ['T23229.script'])
+test('T22958a', just_ghci, compile_and_run, [''])
+test('T22958b', just_ghci, compile_and_run, [''])