diff options
-rw-r--r-- | compiler/GHC/StgToByteCode.hs | 18 | ||||
-rw-r--r-- | rts/Interpreter.c | 80 | ||||
-rw-r--r-- | testsuite/tests/ghci/should_run/T22958.hs | 15 | ||||
-rw-r--r-- | testsuite/tests/ghci/should_run/T22958.stdout | 1 | ||||
-rw-r--r-- | testsuite/tests/ghci/should_run/all.T | 1 |
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, ['']) |