Use a uniform return convention in bytecode for unary results

fixes #22958

5 files changed, 49 insertions, 66 deletions

diff --git a/compiler/GHC/StgToByteCode.hs b/compiler/GHC/StgToByteCode.hs
index 554f575571..6b8038672c 100644
--- a/compiler/GHC/StgToByteCode.hs
+++ b/compiler/GHC/StgToByteCode.hs
@@ -836,8 +836,6 @@ doCase d s p scrut bndr alts
           (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
@@ -862,7 +860,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)
@@ -1058,7 +1055,7 @@ doCase d s p scrut bndr alts
               return (PUSH_ALTS_TUPLE alt_bco' call_info tuple_bco
                       `consOL` scrut_code)
        else let push_alts
-                  | not ubx_frame
+                  | usePlainReturn bndr_ty
                   = PUSH_ALTS alt_bco'
                   | otherwise
                   = let unlifted_rep =
@@ -1694,13 +1691,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.
 -}
 
 
@@ -1726,14 +1716,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/rts/Interpreter.c b/rts/Interpreter.c
index f8885cdbce..5038279fe1 100644
--- a/rts/Interpreter.c
+++ b/rts/Interpreter.c
@@ -705,8 +705,9 @@ 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);
@@ -973,6 +974,9 @@ run_BCO_return_unlifted:
     }
 #endif
 
+    if (SpW(0) != (W_)&stg_ret_t_info) {
+      Sp_addW(1);
+    }
     goto run_BCO;
 
 run_BCO_fun:
@@ -1721,60 +1725,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 +1780,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 +1790,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 +1800,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 +1810,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 +1820,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 +1875,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 +1885,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 +1895,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 +1905,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 +1915,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 +1927,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 +1939,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 +1951,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;
diff --git a/testsuite/tests/ghci/should_run/T22958.hs b/testsuite/tests/ghci/should_run/T22958.hs
new file mode 100644
index 0000000000..7ec94bc4c7
--- /dev/null
+++ b/testsuite/tests/ghci/should_run/T22958.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/T22958.stdout b/testsuite/tests/ghci/should_run/T22958.stdout
new file mode 100644
index 0000000000..6a452c185a
--- /dev/null
+++ b/testsuite/tests/ghci/should_run/T22958.stdout
@@ -0,0 +1 @@
+()
diff --git a/testsuite/tests/ghci/should_run/all.T b/testsuite/tests/ghci/should_run/all.T
index 331ffdb726..f216d0bd99 100644
--- a/testsuite/tests/ghci/should_run/all.T
+++ b/testsuite/tests/ghci/should_run/all.T
@@ -87,3 +87,4 @@ test('T21300', just_ghci, ghci_script, ['T21300.script'])
 test('UnliftedDataType2', just_ghci, compile_and_run, [''])
 test('SizedLiterals', [req_interp, extra_files(["SizedLiteralsA.hs"]),extra_hc_opts("-O -fbyte-code-and-object-code -fprefer-byte-code")], compile_and_run, [''])
 
+test('T22958', just_ghci, compile_and_run, [''])