X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Frts%2FInterpreter.c;h=888f3b8f2dcd7f34c33de578fb420a312aa4b0c5;hb=85aa72b9dc6803685595936c61f3cab6faab815a;hp=d39becb8001926959d33726b9b75adba12497758;hpb=c3fb6ff19bae7b0f0f0368244ca1a386b7f57ca6;p=ghc-hetmet.git

diff --git a/ghc/rts/Interpreter.c b/ghc/rts/Interpreter.c
index d39becb..888f3b8 100644
--- a/ghc/rts/Interpreter.c
+++ b/ghc/rts/Interpreter.c
@@ -26,6 +26,11 @@
 #include "Disassembler.h"
 #include "Interpreter.h"
 
+#include <string.h>     /* for memcpy */
+#ifdef HAVE_ERRNO_H
+#include <errno.h>
+#endif
+
 
 /* --------------------------------------------------------------------------
  * The bytecode interpreter
@@ -274,7 +279,7 @@ eval_obj:
 	break;
 	
     case BCO:
-	ASSERT(BCO_ARITY(obj) > 0);
+	ASSERT(((StgBCO *)obj)->arity > 0);
 	break;
 
     case AP:	/* Copied from stg_AP_entry. */
@@ -576,7 +581,7 @@ do_apply:
 	    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
@@ -718,7 +723,7 @@ run_BCO:
     {
 	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**)
@@ -926,7 +931,7 @@ run_BCO:
 
 	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;
@@ -939,7 +944,7 @@ run_BCO:
 	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;
@@ -953,7 +958,7 @@ run_BCO:
 	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];
@@ -1157,6 +1162,23 @@ run_BCO:
 	    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
@@ -1168,23 +1190,43 @@ run_BCO:
 	    // 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);
+	    Sp -= ret_dyn_size;
 	    ((StgRetDyn *)Sp)->liveness = ALL_NON_PTRS | N_NONPTRS(stk_offset);
 	    ((StgRetDyn *)Sp)->info = (StgInfoTable *)&stg_gc_gen_info;
 
 	    SAVE_STACK_POINTERS;
 	    tok = suspendThread(&cap->r,rtsFalse);
 
-	    // 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));
 	    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;
 	}