summaryrefslogtreecommitdiff
path: root/rts/Interpreter.c
diff options
context:
space:
mode:
Diffstat (limited to 'rts/Interpreter.c')
-rw-r--r--rts/Interpreter.c192
1 files changed, 83 insertions, 109 deletions
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: {
View Lorry Controller Status