X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Frts%2FInterpreter.c;h=56e9bb67cea7c43ec25d9bc8c4ffe8c6c27123b9;hb=0dbbf1932d550293986af6244202cb735b2cd966;hp=d4a48307a2f278e57327a0b6f999630c46607a19;hpb=9392c09726a8018a447eff14f08eb76a060ec9e5;p=ghc-hetmet.git

diff --git a/ghc/rts/Interpreter.c b/ghc/rts/Interpreter.c
index d4a4830..56e9bb6 100644
--- a/ghc/rts/Interpreter.c
+++ b/ghc/rts/Interpreter.c
@@ -43,7 +43,7 @@
 
 #define BCO_NEXT      instrs[bciPtr++]
 #define BCO_PTR(n)    (W_)ptrs[n]
-#define BCO_LIT(n)    (W_)literals[n]
+#define BCO_LIT(n)    literals[n]
 #define BCO_ITBL(n)   itbls[n]
 
 #define LOAD_STACK_POINTERS					\
@@ -55,21 +55,23 @@
     cap->r.rCurrentTSO->sp = Sp
 
 #define RETURN_TO_SCHEDULER(todo,retcode)	\
-   SAVE_STACK_POINTERS; 			\
-   cap->r.rCurrentTSO->what_next = (todo);      \
-   return (retcode);
+   SAVE_STACK_POINTERS;				\
+   cap->r.rCurrentTSO->what_next = (todo);	\
+   threadPaused(cap,cap->r.rCurrentTSO);		\
+   cap->r.rRet = (retcode);			\
+   return cap;
 
+#define RETURN_TO_SCHEDULER_NO_PAUSE(todo,retcode)	\
+   SAVE_STACK_POINTERS;					\
+   cap->r.rCurrentTSO->what_next = (todo);		\
+   cap->r.rRet = (retcode);				\
+   return cap;
 
-STATIC_INLINE StgPtr
-allocate_UPD (int n_words)
-{
-   return allocate(stg_max(sizeofW(StgHeader)+MIN_UPD_SIZE, n_words));
-}
 
 STATIC_INLINE StgPtr
 allocate_NONUPD (int n_words)
 {
-    return allocate(stg_max(sizeofW(StgHeader)+MIN_NONUPD_SIZE, n_words));
+    return allocate(stg_max(sizeofW(StgHeader)+MIN_PAYLOAD_SIZE, n_words));
 }
 
 
@@ -164,7 +166,7 @@ static StgWord app_ptrs_itbl[] = {
     (W_)&stg_ap_pppppp_info,
 };
 
-StgThreadReturnCode
+Capability *
 interpretBCO (Capability* cap)
 {
     // Use of register here is primarily to make it clear to compilers
@@ -334,7 +336,7 @@ eval_obj:
 	Sp -= 2;
 	Sp[1] = (W_)obj;
 	Sp[0] = (W_)&stg_enter_info;
-	RETURN_TO_SCHEDULER(ThreadRunGHC, ThreadYielding);
+	RETURN_TO_SCHEDULER_NO_PAUSE(ThreadRunGHC, ThreadYielding);
     }
     }
 
@@ -429,7 +431,7 @@ do_return:
 	Sp -= 2;
 	Sp[1] = (W_)obj;
 	Sp[0] = (W_)&stg_enter_info;
-	RETURN_TO_SCHEDULER(ThreadRunGHC, ThreadYielding);
+	RETURN_TO_SCHEDULER_NO_PAUSE(ThreadRunGHC, ThreadYielding);
     }
     }
 
@@ -489,7 +491,7 @@ do_return_unboxed:
 		     debugBelch("returning to unknown frame -- yielding to sched\n"); 
 		     printStackChunk(Sp,cap->r.rCurrentTSO->stack+cap->r.rCurrentTSO->stack_size);
 		);
-	    RETURN_TO_SCHEDULER(ThreadRunGHC, ThreadYielding);
+	    RETURN_TO_SCHEDULER_NO_PAUSE(ThreadRunGHC, ThreadYielding);
 	}
 	}
     }
@@ -508,7 +510,7 @@ do_apply:
 
 	case PAP: {
 	    StgPAP *pap;
-	    nat arity, i;
+	    nat i, arity;
 
 	    pap = (StgPAP *)obj;
 
@@ -528,7 +530,8 @@ do_apply:
 		// Shuffle the args for this function down, and put
 		// the appropriate info table in the gap.
 		for (i = 0; i < arity; i++) {
-		    Sp[i-1] = Sp[i];
+		    Sp[(int)i-1] = Sp[i];
+		    // ^^^^^ careful, i-1 might be negative, but i in unsigned
 		}
 		Sp[arity-1] = app_ptrs_itbl[n-arity-1];
 		Sp--;
@@ -551,9 +554,7 @@ do_apply:
 	    else /* arity > n */ {
 		// build a new PAP and return it.
 		StgPAP *new_pap;
-		nat size;
-		size = PAP_sizeW(pap->n_args + m);
-		new_pap = (StgPAP *)allocate(size);
+		new_pap = (StgPAP *)allocate(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;
@@ -584,7 +585,8 @@ do_apply:
 		// Shuffle the args for this function down, and put
 		// the appropriate info table in the gap.
 		for (i = 0; i < arity; i++) {
-		    Sp[i-1] = Sp[i];
+		    Sp[(int)i-1] = Sp[i];
+		    // ^^^^^ careful, i-1 might be negative, but i in unsigned
 		}
 		Sp[arity-1] = app_ptrs_itbl[n-arity-1];
 		Sp--;
@@ -596,9 +598,8 @@ do_apply:
 	    else /* arity > n */ {
 		// build a PAP and return it.
 		StgPAP *pap;
-		nat size, i;
-		size = PAP_sizeW(m);
-		pap = (StgPAP *)allocate(size);
+		nat i;
+		pap = (StgPAP *)allocate(PAP_sizeW(m));
 		SET_HDR(pap, &stg_PAP_info,CCCS);
 		pap->arity = arity - n;
 		pap->fun = obj;
@@ -618,7 +619,7 @@ do_apply:
 	    Sp -= 2;
 	    Sp[1] = (W_)obj;
 	    Sp[0] = (W_)&stg_enter_info;
-	    RETURN_TO_SCHEDULER(ThreadRunGHC, ThreadYielding);
+	    RETURN_TO_SCHEDULER_NO_PAUSE(ThreadRunGHC, ThreadYielding);
     }
 
     // ------------------------------------------------------------------------
@@ -902,7 +903,7 @@ run_BCO:
 	    int n_words = BCO_NEXT;
 	    Sp -= n_words;
 	    for (i = 0; i < n_words; i++) {
-		Sp[i] = BCO_LIT(o_lits+i);
+		Sp[i] = (W_)BCO_LIT(o_lits+i);
 	    }
 	    goto nextInsn;
 	}
@@ -922,8 +923,7 @@ run_BCO:
 	case bci_ALLOC_AP: {
 	    StgAP* ap; 
 	    int n_payload = BCO_NEXT;
-	    int request   = PAP_sizeW(n_payload);
-	    ap = (StgAP*)allocate_UPD(request);
+	    ap = (StgAP*)allocate(AP_sizeW(n_payload));
 	    Sp[-1] = (W_)ap;
 	    ap->n_args = n_payload;
 	    SET_HDR(ap, &stg_AP_info, CCS_SYSTEM/*ToDo*/)
@@ -935,8 +935,7 @@ run_BCO:
 	    StgPAP* pap; 
 	    int arity = BCO_NEXT;
 	    int n_payload = BCO_NEXT;
-	    int request   = PAP_sizeW(n_payload);
-	    pap = (StgPAP*)allocate_NONUPD(request);
+	    pap = (StgPAP*)allocate(PAP_sizeW(n_payload));
 	    Sp[-1] = (W_)pap;
 	    pap->n_args = n_payload;
 	    pap->arity = arity;
@@ -952,13 +951,12 @@ run_BCO:
 	    StgAP* ap = (StgAP*)Sp[stkoff];
 	    ASSERT((int)ap->n_args == n_payload);
 	    ap->fun = (StgClosure*)Sp[0];
-
+	    
 	    // The function should be a BCO, and its bitmap should
 	    // cover the payload of the AP correctly.
 	    ASSERT(get_itbl(ap->fun)->type == BCO
-		   && (get_itbl(ap)->type == PAP || 
-		       BCO_BITMAP_SIZE(ap->fun) == ap->n_args));
-
+		   && BCO_BITMAP_SIZE(ap->fun) == ap->n_args);
+	    
 	    for (i = 0; i < n_payload; i++)
 		ap->payload[i] = (StgClosure*)Sp[i+1];
 	    Sp += n_payload+1;
@@ -969,6 +967,27 @@ run_BCO:
 	    goto nextInsn;
 	}
 
+	case bci_MKPAP: {
+	    int i;
+	    int stkoff = BCO_NEXT;
+	    int n_payload = BCO_NEXT;
+	    StgPAP* pap = (StgPAP*)Sp[stkoff];
+	    ASSERT((int)pap->n_args == n_payload);
+	    pap->fun = (StgClosure*)Sp[0];
+	    
+	    // The function should be a BCO
+	    ASSERT(get_itbl(pap->fun)->type == BCO);
+	    
+	    for (i = 0; i < n_payload; i++)
+		pap->payload[i] = (StgClosure*)Sp[i+1];
+	    Sp += n_payload+1;
+	    IF_DEBUG(interpreter,
+		     debugBelch("\tBuilt "); 
+		     printObj((StgClosure*)pap);
+		);
+	    goto nextInsn;
+	}
+
 	case bci_UNPACK: {
 	    /* Unpack N ptr words from t.o.s constructor */
 	    int i;
@@ -1148,7 +1167,7 @@ run_BCO:
 	}
 
 	case bci_CCALL: {
-	    StgInt tok;
+	    void *tok;
 	    int stk_offset            = BCO_NEXT;
 	    int o_itbl                = BCO_NEXT;
 	    void(*marshall_fn)(void*) = (void (*)(void*))BCO_LIT(o_itbl);
@@ -1156,7 +1175,7 @@ run_BCO:
 		RET_DYN_BITMAP_SIZE + RET_DYN_NONPTR_REGS_SIZE
 		+ sizeofW(StgRetDyn);
 
-#ifdef RTS_SUPPORTS_THREADS
+#ifdef THREADED_RTS
 	    // Threaded RTS:
 	    // Arguments on the TSO stack are not good, because garbage
 	    // collection might move the TSO as soon as we call
@@ -1187,7 +1206,7 @@ run_BCO:
 	    SAVE_STACK_POINTERS;
 	    tok = suspendThread(&cap->r);
 
-#ifndef RTS_SUPPORTS_THREADS
+#ifndef THREADED_RTS
 	    // Careful:
 	    // suspendThread might have shifted the stack
 	    // around (stack squeezing), so we have to grab the real
@@ -1209,7 +1228,7 @@ run_BCO:
 	    // Save the Haskell thread's current value of errno
 	    cap->r.rCurrentTSO->saved_errno = errno;
 		
-#ifdef RTS_SUPPORTS_THREADS
+#ifdef THREADED_RTS
 	    // Threaded RTS:
 	    // Copy the "arguments", which might include a return value,
 	    // back to the TSO stack. It would of course be enough to