X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Frts%2FInterpreter.c;h=3fc838810534c51ac19da57a8217cbb4b47d360a;hb=6e9ec12de7a723ac6334228dd30f84b5125554d9;hp=cbbbc29bc5637576fbafe5e446237587445dd067;hpb=0bffc410964e1688ad80d277d53400659e697ab5;p=ghc-hetmet.git

diff --git a/ghc/rts/Interpreter.c b/ghc/rts/Interpreter.c
index cbbbc29..3fc8388 100644
--- a/ghc/rts/Interpreter.c
+++ b/ghc/rts/Interpreter.c
@@ -274,7 +274,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 +576,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
@@ -672,12 +672,8 @@ run_BCO_return:
 	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:
@@ -685,11 +681,8 @@ 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:
@@ -709,8 +702,8 @@ 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
@@ -725,7 +718,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**)
@@ -766,15 +759,19 @@ run_BCO:
 
 	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: {
@@ -1161,15 +1158,62 @@ run_BCO:
 	    int o_itbl                = BCO_NEXT;
 	    void(*marshall_fn)(void*) = (void (*)(void*))BCO_LIT(o_itbl);
 
-	    // Shift the stack pointer down to the next relevant stack
-	    // frame during the call.  See comment in ByteCodeGen.lhs.
-	    Sp += stk_offset;
+#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
+		
+	    // There are a bunch of non-ptr words on the stack (the
+	    // ccall args, the ccall fun address and space for the
+	    // result), which we need to cover with an info table
+	    // since we might GC during this call.
+	    //
+	    // We know how many (non-ptr) words there are before the
+	    // next valid stack frame: it is the stk_offset arg to 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);
+	    ((StgRetDyn *)Sp)->info = (StgInfoTable *)&stg_gc_gen_info;
+
 	    SAVE_STACK_POINTERS;
 	    tok = suspendThread(&cap->r,rtsFalse);
-	    marshall_fn ( (void*)(& Sp[-stk_offset] ) );
+
+#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)) );
+#else
+	    // Threaded RTS:
+	    // We already made a malloced 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 -= stk_offset;
+	    Sp += RET_DYN_SIZE + sizeofW(StgRetDyn);
+
+	    
+#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;
 	}