#include "PosixSource.h"
#include "Rts.h"
#include "RtsAPI.h"
+#include "rts/Bytecodes.h"
+
+// internal headers
+#include "sm/Storage.h"
+#include "sm/Sanity.h"
#include "RtsUtils.h"
-#include "Closures.h"
-#include "TSO.h"
#include "Schedule.h"
-#include "RtsFlags.h"
-#include "LdvProfile.h"
#include "Updates.h"
-#include "Sanity.h"
-#include "Liveness.h"
#include "Prelude.h"
-
-#include "Bytecodes.h"
+#include "Stable.h"
#include "Printer.h"
#include "Disassembler.h"
#include "Interpreter.h"
+#include "ThreadPaused.h"
+#include "Threads.h"
#include <string.h> /* for memcpy */
#ifdef HAVE_ERRNO_H
#include <errno.h>
#endif
-#ifdef USE_LIBFFI
-#include <ffi.h>
+// When building the RTS in the non-dyn way on Windows, we don't
+// want declspec(__dllimport__) on the front of function prototypes
+// from libffi.
+#if defined(mingw32_HOST_OS) && !defined(__PIC__)
+# define LIBFFI_NOT_DLL
#endif
+#include "ffi.h"
+
/* --------------------------------------------------------------------------
* The bytecode interpreter
* ------------------------------------------------------------------------*/
#define BCO_LIT(n) literals[n]
#define LOAD_STACK_POINTERS \
- Sp = cap->r.rCurrentTSO->sp; \
+ Sp = cap->r.rCurrentTSO->stackobj->sp; \
/* We don't change this ... */ \
- SpLim = cap->r.rCurrentTSO->stack + RESERVED_STACK_WORDS;
+ SpLim = tso_SpLim(cap->r.rCurrentTSO);
#define SAVE_STACK_POINTERS \
- cap->r.rCurrentTSO->sp = Sp
+ ASSERT(Sp > SpLim); \
+ cap->r.rCurrentTSO->stackobj->sp = Sp
#define RETURN_TO_SCHEDULER(todo,retcode) \
SAVE_STACK_POINTERS; \
STATIC_INLINE StgPtr
-allocate_NONUPD (int n_words)
+allocate_NONUPD (Capability *cap, int n_words)
{
- return allocate(stg_max(sizeofW(StgHeader)+MIN_PAYLOAD_SIZE, n_words));
+ return allocate(cap, stg_max(sizeofW(StgHeader)+MIN_PAYLOAD_SIZE, n_words));
}
int rts_stop_next_breakpoint = 0;
LOAD_STACK_POINTERS;
+ cap->r.rHpLim = (P_)1; // HpLim is the context-switch flag; when it
+ // goes to zero we must return to the scheduler.
+
// ------------------------------------------------------------------------
// Case 1:
//
debugBelch("Sp = %p\n", Sp);
debugBelch("\n" );
- printStackChunk(Sp,cap->r.rCurrentTSO->stack+cap->r.rCurrentTSO->stack_size);
+ printStackChunk(Sp,cap->r.rCurrentTSO->stackobj->stack+cap->r.rCurrentTSO->stackobj->stack_size);
debugBelch("\n\n");
);
- IF_DEBUG(sanity,checkStackChunk(Sp, cap->r.rCurrentTSO->stack+cap->r.rCurrentTSO->stack_size));
+// IF_DEBUG(sanity,checkStackChunk(Sp, cap->r.rCurrentTSO->stack+cap->r.rCurrentTSO->stack_size));
+ IF_DEBUG(sanity,checkStackFrame(Sp));
switch ( get_itbl(obj)->type ) {
case IND:
- case IND_OLDGEN:
case IND_PERM:
- case IND_OLDGEN_PERM:
case IND_STATIC:
{
tagged_obj = ((StgInd*)obj)->indirectee;
debugBelch("Returning: "); printObj(obj);
debugBelch("Sp = %p\n", Sp);
debugBelch("\n" );
- printStackChunk(Sp,cap->r.rCurrentTSO->stack+cap->r.rCurrentTSO->stack_size);
+ printStackChunk(Sp,cap->r.rCurrentTSO->stackobj->stack+cap->r.rCurrentTSO->stackobj->stack_size);
debugBelch("\n\n");
);
- IF_DEBUG(sanity,checkStackChunk(Sp, cap->r.rCurrentTSO->stack+cap->r.rCurrentTSO->stack_size));
+ IF_DEBUG(sanity,checkStackChunk(Sp, cap->r.rCurrentTSO->stackobj->stack+cap->r.rCurrentTSO->stackobj->stack_size));
switch (get_itbl((StgClosure *)Sp)->type) {
// to a PAP by the GC, violating the invariant that PAPs
// always contain a tagged pointer to the function.
INTERP_TICK(it_retto_UPDATE);
- UPD_IND(((StgUpdateFrame *)Sp)->updatee, tagged_obj);
+ updateThunk(cap, cap->r.rCurrentTSO,
+ ((StgUpdateFrame *)Sp)->updatee, tagged_obj);
Sp += sizeofW(StgUpdateFrame);
goto do_return;
INTERP_TICK(it_retto_other);
IF_DEBUG(interpreter,
debugBelch("returning to unknown frame -- yielding to sched\n");
- printStackChunk(Sp,cap->r.rCurrentTSO->stack+cap->r.rCurrentTSO->stack_size);
+ printStackChunk(Sp,cap->r.rCurrentTSO->stackobj->stack+cap->r.rCurrentTSO->stackobj->stack_size);
);
Sp -= 2;
Sp[1] = (W_)tagged_obj;
INTERP_TICK(it_retto_other);
IF_DEBUG(interpreter,
debugBelch("returning to unknown frame -- yielding to sched\n");
- printStackChunk(Sp,cap->r.rCurrentTSO->stack+cap->r.rCurrentTSO->stack_size);
- );
+ printStackChunk(Sp,cap->r.rCurrentTSO->stackobj->stack+cap->r.rCurrentTSO->stackobj->stack_size);
+ );
RETURN_TO_SCHEDULER_NO_PAUSE(ThreadRunGHC, ThreadYielding);
}
}
goto defer_apply_to_sched;
}
+ // Stack check: we're about to unpack the PAP onto the
+ // stack. The (+1) is for the (arity < n) case, where we
+ // also need space for an extra info pointer.
+ if (Sp - (pap->n_args + 1) < SpLim) {
+ Sp -= 2;
+ Sp[1] = (W_)tagged_obj;
+ Sp[0] = (W_)&stg_enter_info;
+ RETURN_TO_SCHEDULER(ThreadInterpret, StackOverflow);
+ }
+
Sp++;
arity = pap->arity;
ASSERT(arity > 0);
else /* arity > n */ {
// build a new PAP and return it.
StgPAP *new_pap;
- new_pap = (StgPAP *)allocate(PAP_sizeW(pap->n_args + m));
+ new_pap = (StgPAP *)allocate(cap, PAP_sizeW(pap->n_args + m));
SET_HDR(new_pap,&stg_PAP_info,CCCS);
new_pap->arity = pap->arity - n;
new_pap->n_args = pap->n_args + m;
// build a PAP and return it.
StgPAP *pap;
nat i;
- pap = (StgPAP *)allocate(PAP_sizeW(m));
+ pap = (StgPAP *)allocate(cap, PAP_sizeW(m));
SET_HDR(pap, &stg_PAP_info,CCCS);
pap->arity = arity - n;
pap->fun = obj;
run_BCO_return:
// Heap check
- if (doYouWantToGC()) {
+ if (doYouWantToGC(cap)) {
Sp--; Sp[0] = (W_)&stg_enter_info;
RETURN_TO_SCHEDULER(ThreadInterpret, HeapOverflow);
}
run_BCO_return_unboxed:
// Heap check
- if (doYouWantToGC()) {
+ if (doYouWantToGC(cap)) {
RETURN_TO_SCHEDULER(ThreadInterpret, HeapOverflow);
}
// Stack checks aren't necessary at return points, the stack use
);
// Heap check
- if (doYouWantToGC()) {
+ if (doYouWantToGC(cap)) {
Sp -= 2;
Sp[1] = (W_)obj;
Sp[0] = (W_)&stg_apply_interp_info; // placeholder, really
run_BCO:
INTERP_TICK(it_BCO_entries);
{
- register int bciPtr = 1; /* instruction pointer */
+ register int bciPtr = 0; /* instruction pointer */
register StgWord16 bci;
register StgBCO* bco = (StgBCO*)obj;
register StgWord16* instrs = (StgWord16*)(bco->instrs->payload);
register StgWord* literals = (StgWord*)(&bco->literals->payload[0]);
register StgPtr* ptrs = (StgPtr*)(&bco->ptrs->payload[0]);
+ int bcoSize;
+ bcoSize = BCO_NEXT_WORD;
+ IF_DEBUG(interpreter,debugBelch("bcoSize = %d\n", bcoSize));
#ifdef INTERP_STATS
it_lastopc = 0; /* no opcode */
#endif
nextInsn:
- ASSERT(bciPtr <= instrs[0]);
+ ASSERT(bciPtr < bcoSize);
IF_DEBUG(interpreter,
//if (do_print_stack) {
//debugBelch("\n-- BEGIN stack\n");
// stg_apply_interp_info pointer and a pointer to
// the BCO
size_words = BCO_BITMAP_SIZE(obj) + 2;
- new_aps = (StgAP_STACK *) allocate (AP_STACK_sizeW(size_words));
+ new_aps = (StgAP_STACK *) allocate(cap, AP_STACK_sizeW(size_words));
SET_HDR(new_aps,&stg_AP_STACK_info,CCS_SYSTEM);
new_aps->size = size_words;
new_aps->fun = &stg_dummy_ret_closure;
// in a reasonable state for the GC and so that
// execution of this BCO can continue when we resume
ioAction = (StgClosure *) deRefStablePtr (rts_breakpoint_io_action);
- Sp -= 9;
- Sp[8] = (W_)obj;
- Sp[7] = (W_)&stg_apply_interp_info;
- Sp[6] = (W_)&stg_noforceIO_info; // see [unreg] below
+ Sp -= 8;
+ Sp[7] = (W_)obj;
+ Sp[6] = (W_)&stg_apply_interp_info;
Sp[5] = (W_)new_aps; // the AP_STACK
Sp[4] = (W_)BCO_PTR(arg3_freeVars); // the info about local vars of the breakpoint
Sp[3] = (W_)False_closure; // True <=> a breakpoint
Sp[2] = (W_)&stg_ap_pppv_info;
Sp[1] = (W_)ioAction; // apply the IO action to its two arguments above
Sp[0] = (W_)&stg_enter_info; // get ready to run the IO action
- // Note [unreg]: in unregisterised mode, the return
- // convention for IO is different. The
- // stg_noForceIO_info stack frame is necessary to
- // account for this difference.
-
// set the flag in the TSO to say that we are now
// stopping at a breakpoint so that when we resume
// we don't stop on the same breakpoint that we
case bci_ALLOC_AP: {
StgAP* ap;
int n_payload = BCO_NEXT;
- ap = (StgAP*)allocate(AP_sizeW(n_payload));
+ ap = (StgAP*)allocate(cap, AP_sizeW(n_payload));
Sp[-1] = (W_)ap;
ap->n_args = n_payload;
SET_HDR(ap, &stg_AP_info, CCS_SYSTEM/*ToDo*/)
case bci_ALLOC_AP_NOUPD: {
StgAP* ap;
int n_payload = BCO_NEXT;
- ap = (StgAP*)allocate(AP_sizeW(n_payload));
+ ap = (StgAP*)allocate(cap, AP_sizeW(n_payload));
Sp[-1] = (W_)ap;
ap->n_args = n_payload;
SET_HDR(ap, &stg_AP_NOUPD_info, CCS_SYSTEM/*ToDo*/)
StgPAP* pap;
int arity = BCO_NEXT;
int n_payload = BCO_NEXT;
- pap = (StgPAP*)allocate(PAP_sizeW(n_payload));
+ pap = (StgPAP*)allocate(cap, PAP_sizeW(n_payload));
Sp[-1] = (W_)pap;
pap->n_args = n_payload;
pap->arity = arity;
StgInfoTable* itbl = INFO_PTR_TO_STRUCT(BCO_LIT(o_itbl));
int request = CONSTR_sizeW( itbl->layout.payload.ptrs,
itbl->layout.payload.nptrs );
- StgClosure* con = (StgClosure*)allocate_NONUPD(request);
+ StgClosure* con = (StgClosure*)allocate_NONUPD(cap,request);
ASSERT( itbl->layout.payload.ptrs + itbl->layout.payload.nptrs > 0);
SET_HDR(con, (StgInfoTable*)BCO_LIT(o_itbl), CCS_SYSTEM/*ToDo*/);
for (i = 0; i < n_words; i++) {
case bci_TESTLT_P: {
unsigned int discr = BCO_NEXT;
- int failto = BCO_NEXT;
+ int failto = BCO_GET_LARGE_ARG;
StgClosure* con = (StgClosure*)Sp[0];
if (GET_TAG(con) >= discr) {
bciPtr = failto;
case bci_TESTEQ_P: {
unsigned int discr = BCO_NEXT;
- int failto = BCO_NEXT;
+ int failto = BCO_GET_LARGE_ARG;
StgClosure* con = (StgClosure*)Sp[0];
if (GET_TAG(con) != discr) {
bciPtr = failto;
case bci_TESTLT_I: {
// There should be an Int at Sp[1], and an info table at Sp[0].
int discr = BCO_NEXT;
- int failto = BCO_NEXT;
+ int failto = BCO_GET_LARGE_ARG;
I_ stackInt = (I_)Sp[1];
if (stackInt >= (I_)BCO_LIT(discr))
bciPtr = failto;
case bci_TESTEQ_I: {
// There should be an Int at Sp[1], and an info table at Sp[0].
int discr = BCO_NEXT;
- int failto = BCO_NEXT;
+ int failto = BCO_GET_LARGE_ARG;
I_ stackInt = (I_)Sp[1];
if (stackInt != (I_)BCO_LIT(discr)) {
bciPtr = failto;
goto nextInsn;
}
+ case bci_TESTLT_W: {
+ // There should be an Int at Sp[1], and an info table at Sp[0].
+ int discr = BCO_NEXT;
+ int failto = BCO_GET_LARGE_ARG;
+ W_ stackWord = (W_)Sp[1];
+ if (stackWord >= (W_)BCO_LIT(discr))
+ bciPtr = failto;
+ goto nextInsn;
+ }
+
+ case bci_TESTEQ_W: {
+ // There should be an Int at Sp[1], and an info table at Sp[0].
+ int discr = BCO_NEXT;
+ int failto = BCO_GET_LARGE_ARG;
+ W_ stackWord = (W_)Sp[1];
+ if (stackWord != (W_)BCO_LIT(discr)) {
+ bciPtr = failto;
+ }
+ goto nextInsn;
+ }
+
case bci_TESTLT_D: {
// There should be a Double at Sp[1], and an info table at Sp[0].
int discr = BCO_NEXT;
- int failto = BCO_NEXT;
+ int failto = BCO_GET_LARGE_ARG;
StgDouble stackDbl, discrDbl;
stackDbl = PK_DBL( & Sp[1] );
discrDbl = PK_DBL( & BCO_LIT(discr) );
case bci_TESTEQ_D: {
// There should be a Double at Sp[1], and an info table at Sp[0].
int discr = BCO_NEXT;
- int failto = BCO_NEXT;
+ int failto = BCO_GET_LARGE_ARG;
StgDouble stackDbl, discrDbl;
stackDbl = PK_DBL( & Sp[1] );
discrDbl = PK_DBL( & BCO_LIT(discr) );
case bci_TESTLT_F: {
// There should be a Float at Sp[1], and an info table at Sp[0].
int discr = BCO_NEXT;
- int failto = BCO_NEXT;
+ int failto = BCO_GET_LARGE_ARG;
StgFloat stackFlt, discrFlt;
stackFlt = PK_FLT( & Sp[1] );
discrFlt = PK_FLT( & BCO_LIT(discr) );
case bci_TESTEQ_F: {
// There should be a Float at Sp[1], and an info table at Sp[0].
int discr = BCO_NEXT;
- int failto = BCO_NEXT;
+ int failto = BCO_GET_LARGE_ARG;
StgFloat stackFlt, discrFlt;
stackFlt = PK_FLT( & Sp[1] );
discrFlt = PK_FLT( & BCO_LIT(discr) );
// context switching: sometimes the scheduler can invoke
// the interpreter with context_switch == 1, particularly
// if the -C0 flag has been given on the cmd line.
- if (context_switch) {
+ if (cap->r.rHpLim == NULL) {
Sp--; Sp[0] = (W_)&stg_enter_info;
RETURN_TO_SCHEDULER(ThreadInterpret, ThreadYielding);
}
void *tok;
int stk_offset = BCO_NEXT;
int o_itbl = BCO_NEXT;
+ int interruptible = BCO_NEXT;
void(*marshall_fn)(void*) = (void (*)(void*))BCO_LIT(o_itbl);
int ret_dyn_size =
RET_DYN_BITMAP_SIZE + RET_DYN_NONPTR_REGS_SIZE
So we make a copy of the argument block.
*/
-#ifdef USE_LIBFFI
#define ROUND_UP_WDS(p) ((((StgWord)(p)) + sizeof(W_)-1)/sizeof(W_))
ffi_cif *cif = (ffi_cif *)marshall_fn;
// this is the function we're going to call
fn = (void(*)(void))Sp[ret_size];
-#else
- W_ arguments[stk_offset];
- memcpy(arguments, Sp, sizeof(W_) * stk_offset);
-#endif
// Restore the Haskell thread's current value of errno
errno = cap->r.rCurrentTSO->saved_errno;
((StgRetDyn *)Sp)->payload[0] = (StgClosure *)obj;
SAVE_STACK_POINTERS;
- tok = suspendThread(&cap->r);
+ tok = suspendThread(&cap->r, interruptible ? rtsTrue : rtsFalse);
// We already made a copy of the arguments above.
-#ifdef USE_LIBFFI
ffi_call(cif, fn, ret, argptrs);
-#else
- marshall_fn ( arguments );
-#endif
// And restart the thread again, popping the RET_DYN frame.
- cap = (Capability *)((void *)((unsigned char*)resumeThread(tok) - sizeof(StgFunTable)));
+ cap = (Capability *)((void *)((unsigned char*)resumeThread(tok) - STG_FIELD_OFFSET(Capability,r)));
LOAD_STACK_POINTERS;
+ if (Sp[0] != (W_)&stg_gc_gen_info) {
+ // the stack is not how we left it. This probably
+ // means that an exception got raised on exit from the
+ // foreign call, so we should just continue with
+ // whatever is on top of the stack now.
+ RETURN_TO_SCHEDULER_NO_PAUSE(ThreadRunGHC, ThreadYielding);
+ }
+
// Re-load the pointer to the BCO from the RET_DYN frame,
// it might have moved during the call. Also reload the
// pointers to the components of the BCO.
// Copy the return value back to the TSO stack. It is at
// most 2 words large, and resides at arguments[0].
-#ifdef USE_LIBFFI
memcpy(Sp, ret, sizeof(W_) * stg_min(stk_offset,ret_size));
-#else
- memcpy(Sp, arguments, sizeof(W_) * stg_min(stk_offset,2));
-#endif
goto nextInsn;
}
case bci_JMP: {
/* BCO_NEXT modifies bciPtr, so be conservative. */
- int nextpc = BCO_NEXT;
+ int nextpc = BCO_GET_LARGE_ARG;
bciPtr = nextpc;
goto nextInsn;
}