X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Frts%2FInterpreter.c;h=56e9bb67cea7c43ec25d9bc8c4ffe8c6c27123b9;hb=45252b35151fc55aa19fb6770df5ed8267639083;hp=45995520dcfee4ae6b64563a53670f65d35e3679;hpb=b2c6611739821c725899d57c5a4dc90d5cbb0662;p=ghc-hetmet.git diff --git a/ghc/rts/Interpreter.c b/ghc/rts/Interpreter.c index 4599552..56e9bb6 100644 --- a/ghc/rts/Interpreter.c +++ b/ghc/rts/Interpreter.c @@ -57,25 +57,21 @@ #define RETURN_TO_SCHEDULER(todo,retcode) \ SAVE_STACK_POINTERS; \ cap->r.rCurrentTSO->what_next = (todo); \ - threadPaused(cap->r.rCurrentTSO); \ - return (retcode); + 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); \ - return (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)); } @@ -170,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 @@ -514,7 +510,7 @@ do_apply: case PAP: { StgPAP *pap; - nat arity, i; + nat i, arity; pap = (StgPAP *)obj; @@ -534,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--; @@ -557,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; @@ -577,8 +572,7 @@ do_apply: } case BCO: { - nat arity; - int i; // arithmetic involving i might go negative below + nat arity, i; Sp++; arity = ((StgBCO *)obj)->arity; @@ -591,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--; @@ -603,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; @@ -929,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*/) @@ -942,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; @@ -959,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; @@ -976,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; @@ -1155,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); @@ -1163,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 @@ -1194,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 @@ -1216,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