* Copyright (c) The GHC Team, 1994-2002.
* ---------------------------------------------------------------------------*/
-#if !defined(SMP)
#include "PosixSource.h"
-#else
-/* Hack and slash.. */
-#include "Stg.h"
-#endif
#include "Rts.h"
#include "RtsAPI.h"
#include "RtsUtils.h"
#include "Storage.h"
#include "Updates.h"
#include "Sanity.h"
+#include "Liveness.h"
#include "Bytecodes.h"
#include "Printer.h"
#include "Disassembler.h"
#include "Interpreter.h"
+#include <string.h> /* for memcpy */
+#ifdef HAVE_ERRNO_H
+#include <errno.h>
+#endif
+
/* --------------------------------------------------------------------------
* The bytecode interpreter
return (retcode);
-static inline StgPtr
+STATIC_INLINE StgPtr
allocate_UPD (int n_words)
{
return allocate(stg_max(sizeofW(StgHeader)+MIN_UPD_SIZE, n_words));
}
-static inline StgPtr
+STATIC_INLINE StgPtr
allocate_NONUPD (int n_words)
{
return allocate(stg_max(sizeofW(StgHeader)+MIN_NONUPD_SIZE, n_words));
(W_)&stg_ap_pppp_info,
(W_)&stg_ap_ppppp_info,
(W_)&stg_ap_pppppp_info,
- (W_)&stg_ap_ppppppp_info
};
StgThreadReturnCode
break;
case BCO:
- ASSERT(BCO_ARITY(obj) > 0);
+ ASSERT(((StgBCO *)obj)->arity > 0);
break;
case AP: /* Copied from stg_AP_entry. */
if (info == (StgInfoTable *)&stg_ap_pppppp_info) {
n = 6; m = 6; goto do_apply;
}
- if (info == (StgInfoTable *)&stg_ap_ppppppp_info) {
- n = 7; m = 7; goto do_apply;
- }
goto do_return_unrecognised;
}
nat arity, i;
Sp++;
- arity = BCO_ARITY(obj);
+ arity = ((StgBCO *)obj)->arity;
ASSERT(arity > 0);
if (arity < n) {
// n must be greater than 1, and the only kinds of
Sp--; Sp[0] = (W_)&stg_enter_info;
RETURN_TO_SCHEDULER(ThreadInterpret, HeapOverflow);
}
-
- // "Standard" stack check
- if (Sp - (INTERP_STACK_CHECK_THRESH+1) < SpLim) {
- Sp--; Sp[0] = (W_)&stg_enter_info;
- RETURN_TO_SCHEDULER(ThreadInterpret, StackOverflow);
- }
+ // Stack checks aren't necessary at return points, the stack use
+ // is aggregated into the enclosing function entry point.
goto run_BCO;
run_BCO_return_unboxed:
if (doYouWantToGC()) {
RETURN_TO_SCHEDULER(ThreadInterpret, HeapOverflow);
}
-
- // "Standard" stack check
- if (Sp - (INTERP_STACK_CHECK_THRESH+1) < SpLim) {
- RETURN_TO_SCHEDULER(ThreadInterpret, StackOverflow);
- }
+ // Stack checks aren't necessary at return points, the stack use
+ // is aggregated into the enclosing function entry point.
goto run_BCO;
run_BCO_fun:
RETURN_TO_SCHEDULER(ThreadInterpret, HeapOverflow);
}
- // "Standard" stack check
- if (Sp - (INTERP_STACK_CHECK_THRESH+1) < SpLim) {
+ // Stack check
+ if (Sp - INTERP_STACK_CHECK_THRESH < SpLim) {
Sp -= 2;
Sp[1] = (W_)obj;
Sp[0] = (W_)&stg_apply_interp_info; // placeholder, really
{
register int bciPtr = 1; /* instruction pointer */
register StgBCO* bco = (StgBCO*)obj;
- register StgWord16* instrs = (StgWord16*)(BCO_INSTRS(bco));
+ register StgWord16* instrs = (StgWord16*)(bco->instrs->payload);
register StgWord* literals = (StgWord*)(&bco->literals->payload[0]);
register StgPtr* ptrs = (StgPtr*)(&bco->ptrs->payload[0]);
register StgInfoTable** itbls = (StgInfoTable**)
switch (BCO_NEXT) {
- case bci_STKCHECK:
- {
- // An explicit stack check; we hope these will be rare.
+ case bci_STKCHECK: {
+ // Explicit stack check at the beginning of a function
+ // *only* (stack checks in case alternatives are
+ // propagated to the enclosing function).
int stk_words_reqd = BCO_NEXT + 1;
if (Sp - stk_words_reqd < SpLim) {
- Sp--; Sp[0] = (W_)obj;
+ Sp -= 2;
+ Sp[1] = (W_)obj;
+ Sp[0] = (W_)&stg_apply_interp_info;
RETURN_TO_SCHEDULER(ThreadInterpret, StackOverflow);
+ } else {
+ goto nextInsn;
}
- goto nextInsn;
}
case bci_PUSH_L: {
case bci_PUSH_ALTS: {
int o_bco = BCO_NEXT;
- Sp[-2] = (W_)&stg_ctoi_ret_R1p_info;
+ Sp[-2] = (W_)&stg_ctoi_R1p_info;
Sp[-1] = BCO_PTR(o_bco);
Sp -= 2;
goto nextInsn;
case bci_PUSH_ALTS_P: {
int o_bco = BCO_NEXT;
- Sp[-2] = (W_)&stg_ctoi_ret_R1unpt_info;
+ Sp[-2] = (W_)&stg_ctoi_R1unpt_info;
Sp[-1] = BCO_PTR(o_bco);
Sp -= 2;
goto nextInsn;
case bci_PUSH_ALTS_N: {
int o_bco = BCO_NEXT;
- Sp[-2] = (W_)&stg_ctoi_ret_R1n_info;
+ Sp[-2] = (W_)&stg_ctoi_R1n_info;
Sp[-1] = BCO_PTR(o_bco);
Sp -= 2;
goto nextInsn;
case bci_PUSH_ALTS_F: {
int o_bco = BCO_NEXT;
- Sp[-2] = (W_)&stg_ctoi_ret_F1_info;
+ Sp[-2] = (W_)&stg_ctoi_F1_info;
Sp[-1] = BCO_PTR(o_bco);
Sp -= 2;
goto nextInsn;
case bci_PUSH_ALTS_D: {
int o_bco = BCO_NEXT;
- Sp[-2] = (W_)&stg_ctoi_ret_D1_info;
+ Sp[-2] = (W_)&stg_ctoi_D1_info;
Sp[-1] = BCO_PTR(o_bco);
Sp -= 2;
goto nextInsn;
case bci_PUSH_ALTS_L: {
int o_bco = BCO_NEXT;
- Sp[-2] = (W_)&stg_ctoi_ret_L1_info;
+ Sp[-2] = (W_)&stg_ctoi_L1_info;
Sp[-1] = BCO_PTR(o_bco);
Sp -= 2;
goto nextInsn;
case bci_PUSH_ALTS_V: {
int o_bco = BCO_NEXT;
- Sp[-2] = (W_)&stg_ctoi_ret_V_info;
+ Sp[-2] = (W_)&stg_ctoi_V_info;
Sp[-1] = BCO_PTR(o_bco);
Sp -= 2;
goto nextInsn;
case bci_PUSH_APPLY_PPPPPP:
Sp--; Sp[0] = (W_)&stg_ap_pppppp_info;
goto nextInsn;
- case bci_PUSH_APPLY_PPPPPPP:
- Sp--; Sp[0] = (W_)&stg_ap_ppppppp_info;
- goto nextInsn;
case bci_PUSH_UBX: {
int i;
case bci_ALLOC_AP: {
StgAP* ap;
- int n_payload = BCO_NEXT - 1;
+ int n_payload = BCO_NEXT;
int request = PAP_sizeW(n_payload);
ap = (StgAP*)allocate_UPD(request);
Sp[-1] = (W_)ap;
case bci_ALLOC_PAP: {
StgPAP* pap;
int arity = BCO_NEXT;
- int n_payload = BCO_NEXT - 1;
+ int n_payload = BCO_NEXT;
int request = PAP_sizeW(n_payload);
pap = (StgPAP*)allocate_NONUPD(request);
Sp[-1] = (W_)pap;
case bci_MKAP: {
int i;
int stkoff = BCO_NEXT;
- int n_payload = BCO_NEXT - 1;
+ int n_payload = BCO_NEXT;
StgAP* ap = (StgAP*)Sp[stkoff];
ASSERT((int)ap->n_args == n_payload);
ap->fun = (StgClosure*)Sp[0];
int discr = BCO_NEXT;
int failto = BCO_NEXT;
StgClosure* con = (StgClosure*)Sp[0];
- if (constrTag(con) >= discr) {
+ if (GET_TAG(con) >= discr) {
bciPtr = failto;
}
goto nextInsn;
int discr = BCO_NEXT;
int failto = BCO_NEXT;
StgClosure* con = (StgClosure*)Sp[0];
- if (constrTag(con) != discr) {
+ if (GET_TAG(con) != discr) {
bciPtr = failto;
}
goto nextInsn;
int stk_offset = BCO_NEXT;
int o_itbl = 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
+ + sizeofW(StgRetDyn);
+
+#ifdef RTS_SUPPORTS_THREADS
+ // Threaded RTS:
+ // Arguments on the TSO stack are not good, because garbage
+ // collection might move the TSO as soon as we call
+ // suspendThread below.
+
+ 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;
// There are a bunch of non-ptr words on the stack (the
// ccall args, the ccall fun address and space for the
// CCALL instruction. So we build a RET_DYN stack frame
// on the stack frame to describe this chunk of stack.
//
- Sp -= RET_DYN_SIZE + sizeofW(StgRetDyn);
- ((StgRetDyn *)Sp)->liveness = ALL_NON_PTRS | N_NONPTRS(stk_offset);
+ Sp -= ret_dyn_size;
+ ((StgRetDyn *)Sp)->liveness = NO_PTRS | N_NONPTRS(stk_offset);
((StgRetDyn *)Sp)->info = (StgInfoTable *)&stg_gc_gen_info;
SAVE_STACK_POINTERS;
- tok = suspendThread(&cap->r,rtsFalse);
+ tok = suspendThread(&cap->r);
- // Careful: suspendThread might have shifted the stack
+#ifndef RTS_SUPPORTS_THREADS
+ // Careful:
+ // suspendThread might have shifted the stack
// around (stack squeezing), so we have to grab the real
- // Sp out of the TSO to find the ccall args again:
- marshall_fn ( (void*)(cap->r.rCurrentTSO->sp + RET_DYN_SIZE
- + sizeofW(StgRetDyn)) );
+ // Sp out of the TSO to find the ccall args again.
+
+ marshall_fn ( (void*)(cap->r.rCurrentTSO->sp + ret_dyn_size) );
+#else
+ // Threaded RTS:
+ // We already made a copy of the arguments above.
+
+ marshall_fn ( arguments );
+#endif
// And restart the thread again, popping the RET_DYN frame.
- cap = (Capability *)((void *)resumeThread(tok,rtsFalse) - sizeof(StgFunTable));
+ cap = (Capability *)((void *)((unsigned char*)resumeThread(tok) - sizeof(StgFunTable)));
LOAD_STACK_POINTERS;
- Sp += RET_DYN_SIZE + sizeofW(StgRetDyn);
+ Sp += ret_dyn_size;
+
+ // Save the Haskell thread's current value of errno
+ cap->r.rCurrentTSO->saved_errno = errno;
+
+#ifdef RTS_SUPPORTS_THREADS
+ // Threaded RTS:
+ // Copy the "arguments", which might include a return value,
+ // back to the TSO stack. It would of course be enough to
+ // just copy the return value, but we don't know the offset.
+ memcpy(Sp, arguments, sizeof(W_) * stk_offset);
+#endif
+
goto nextInsn;
}
projects / ghc-hetmet.git / blobdiff