Interruptible FFI calls with pthread_kill and CancelSynchronousIO. v4
[ghc-hetmet.git] / rts / Interpreter.c
index 1b2d730..da7ee21 100644 (file)
@@ -7,27 +7,34 @@
 #include "PosixSource.h"
 #include "Rts.h"
 #include "RtsAPI.h"
+#include "rts/Bytecodes.h"
+
+// internal headers
+#include "sm/Storage.h"
+#include "sm/Sanity.h"
 #include "RtsUtils.h"
-#include "Closures.h"
-#include "TSO.h"
 #include "Schedule.h"
-#include "RtsFlags.h"
-#include "LdvProfile.h"
 #include "Updates.h"
-#include "Sanity.h"
-#include "Liveness.h"
 #include "Prelude.h"
-
-#include "Bytecodes.h"
+#include "Stable.h"
 #include "Printer.h"
 #include "Disassembler.h"
 #include "Interpreter.h"
+#include "ThreadPaused.h"
+#include "Threads.h"
 
 #include <string.h>     /* for memcpy */
 #ifdef HAVE_ERRNO_H
 #include <errno.h>
 #endif
 
+// When building the RTS in the non-dyn way on Windows, we don't
+//     want declspec(__dllimport__) on the front of function prototypes
+//     from libffi.
+#if defined(mingw32_HOST_OS) && !defined(__PIC__)
+# define LIBFFI_NOT_DLL
+#endif
+
 #include "ffi.h"
 
 /* --------------------------------------------------------------------------
@@ -81,9 +88,9 @@
 
 
 STATIC_INLINE StgPtr
-allocate_NONUPD (int n_words)
+allocate_NONUPD (Capability *cap, int n_words)
 {
-    return allocate(stg_max(sizeofW(StgHeader)+MIN_PAYLOAD_SIZE, n_words));
+    return allocate(cap, stg_max(sizeofW(StgHeader)+MIN_PAYLOAD_SIZE, n_words));
 }
 
 int rts_stop_next_breakpoint = 0;
@@ -196,6 +203,9 @@ interpretBCO (Capability* cap)
 
     LOAD_STACK_POINTERS;
 
+    cap->r.rHpLim = (P_)1; // HpLim is the context-switch flag; when it
+                           // goes to zero we must return to the scheduler.
+
     // ------------------------------------------------------------------------
     // Case 1:
     // 
@@ -260,14 +270,13 @@ eval_obj:
              debugBelch("\n\n");
             );
 
-    IF_DEBUG(sanity,checkStackChunk(Sp, cap->r.rCurrentTSO->stack+cap->r.rCurrentTSO->stack_size));
+//    IF_DEBUG(sanity,checkStackChunk(Sp, cap->r.rCurrentTSO->stack+cap->r.rCurrentTSO->stack_size));
+    IF_DEBUG(sanity,checkStackFrame(Sp));
 
     switch ( get_itbl(obj)->type ) {
 
     case IND:
-    case IND_OLDGEN:
     case IND_PERM:
-    case IND_OLDGEN_PERM:
     case IND_STATIC:
     { 
        tagged_obj = ((StgInd*)obj)->indirectee;
@@ -433,7 +442,8 @@ do_return:
         // to a PAP by the GC, violating the invariant that PAPs
         // always contain a tagged pointer to the function.
        INTERP_TICK(it_retto_UPDATE);
-       UPD_IND(((StgUpdateFrame *)Sp)->updatee, tagged_obj); 
+        updateThunk(cap, cap->r.rCurrentTSO, 
+                    ((StgUpdateFrame *)Sp)->updatee, tagged_obj);
        Sp += sizeofW(StgUpdateFrame);
        goto do_return;
 
@@ -595,7 +605,7 @@ do_apply:
            else /* arity > n */ {
                // build a new PAP and return it.
                StgPAP *new_pap;
-               new_pap = (StgPAP *)allocate(PAP_sizeW(pap->n_args + m));
+               new_pap = (StgPAP *)allocate(cap, 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;
@@ -640,7 +650,7 @@ do_apply:
                // build a PAP and return it.
                StgPAP *pap;
                nat i;
-               pap = (StgPAP *)allocate(PAP_sizeW(m));
+               pap = (StgPAP *)allocate(cap, PAP_sizeW(m));
                SET_HDR(pap, &stg_PAP_info,CCCS);
                pap->arity = arity - n;
                pap->fun = obj;
@@ -709,7 +719,7 @@ do_apply:
 
 run_BCO_return:
     // Heap check
-    if (doYouWantToGC()) {
+    if (doYouWantToGC(cap)) {
        Sp--; Sp[0] = (W_)&stg_enter_info;
        RETURN_TO_SCHEDULER(ThreadInterpret, HeapOverflow);
     }
@@ -720,7 +730,7 @@ run_BCO_return:
     
 run_BCO_return_unboxed:
     // Heap check
-    if (doYouWantToGC()) {
+    if (doYouWantToGC(cap)) {
        RETURN_TO_SCHEDULER(ThreadInterpret, HeapOverflow);
     }
     // Stack checks aren't necessary at return points, the stack use
@@ -738,7 +748,7 @@ run_BCO_fun:
        );
 
     // Heap check
-    if (doYouWantToGC()) {
+    if (doYouWantToGC(cap)) {
        Sp -= 2; 
        Sp[1] = (W_)obj; 
        Sp[0] = (W_)&stg_apply_interp_info; // placeholder, really
@@ -760,19 +770,22 @@ run_BCO_fun:
 run_BCO:
     INTERP_TICK(it_BCO_entries);
     {
-       register int       bciPtr     = 1; /* instruction pointer */
+       register int       bciPtr = 0; /* instruction pointer */
         register StgWord16 bci;
        register StgBCO*   bco        = (StgBCO*)obj;
        register StgWord16* instrs    = (StgWord16*)(bco->instrs->payload);
        register StgWord*  literals   = (StgWord*)(&bco->literals->payload[0]);
        register StgPtr*   ptrs       = (StgPtr*)(&bco->ptrs->payload[0]);
+       int bcoSize;
+    bcoSize = BCO_NEXT_WORD;
+       IF_DEBUG(interpreter,debugBelch("bcoSize = %d\n", bcoSize));
 
 #ifdef INTERP_STATS
        it_lastopc = 0; /* no opcode */
 #endif
 
     nextInsn:
-       ASSERT(bciPtr <= instrs[0]);
+       ASSERT(bciPtr < bcoSize);
        IF_DEBUG(interpreter,
                 //if (do_print_stack) {
                 //debugBelch("\n-- BEGIN stack\n");
@@ -851,7 +864,7 @@ run_BCO:
                   // stg_apply_interp_info pointer and a pointer to
                   // the BCO
                   size_words = BCO_BITMAP_SIZE(obj) + 2;
-                  new_aps = (StgAP_STACK *) allocate (AP_STACK_sizeW(size_words));
+                  new_aps = (StgAP_STACK *) allocate(cap, AP_STACK_sizeW(size_words));
                   SET_HDR(new_aps,&stg_AP_STACK_info,CCS_SYSTEM); 
                   new_aps->size = size_words;
                   new_aps->fun = &stg_dummy_ret_closure; 
@@ -871,21 +884,15 @@ run_BCO:
                   // in a reasonable state for the GC and so that
                   // execution of this BCO can continue when we resume
                   ioAction = (StgClosure *) deRefStablePtr (rts_breakpoint_io_action);
-                  Sp -= 9;
-                  Sp[8] = (W_)obj;   
-                  Sp[7] = (W_)&stg_apply_interp_info;
-                  Sp[6] = (W_)&stg_noforceIO_info;     // see [unreg] below
+                  Sp -= 8;
+                  Sp[7] = (W_)obj;
+                  Sp[6] = (W_)&stg_apply_interp_info;
                   Sp[5] = (W_)new_aps;                 // the AP_STACK
                   Sp[4] = (W_)BCO_PTR(arg3_freeVars);  // the info about local vars of the breakpoint
                   Sp[3] = (W_)False_closure;            // True <=> a breakpoint
                   Sp[2] = (W_)&stg_ap_pppv_info;
                   Sp[1] = (W_)ioAction;                // apply the IO action to its two arguments above
                   Sp[0] = (W_)&stg_enter_info;         // get ready to run the IO action
-                  // Note [unreg]: in unregisterised mode, the return
-                  // convention for IO is different.  The
-                  // stg_noForceIO_info stack frame is necessary to
-                  // account for this difference.
-
                   // set the flag in the TSO to say that we are now
                   // stopping at a breakpoint so that when we resume
                   // we don't stop on the same breakpoint that we
@@ -1070,7 +1077,7 @@ run_BCO:
        case bci_ALLOC_AP: {
            StgAP* ap; 
            int n_payload = BCO_NEXT;
-           ap = (StgAP*)allocate(AP_sizeW(n_payload));
+           ap = (StgAP*)allocate(cap, AP_sizeW(n_payload));
            Sp[-1] = (W_)ap;
            ap->n_args = n_payload;
            SET_HDR(ap, &stg_AP_info, CCS_SYSTEM/*ToDo*/)
@@ -1081,7 +1088,7 @@ run_BCO:
        case bci_ALLOC_AP_NOUPD: {
            StgAP* ap; 
            int n_payload = BCO_NEXT;
-           ap = (StgAP*)allocate(AP_sizeW(n_payload));
+           ap = (StgAP*)allocate(cap, AP_sizeW(n_payload));
            Sp[-1] = (W_)ap;
            ap->n_args = n_payload;
            SET_HDR(ap, &stg_AP_NOUPD_info, CCS_SYSTEM/*ToDo*/)
@@ -1093,7 +1100,7 @@ run_BCO:
            StgPAP* pap; 
            int arity = BCO_NEXT;
            int n_payload = BCO_NEXT;
-           pap = (StgPAP*)allocate(PAP_sizeW(n_payload));
+           pap = (StgPAP*)allocate(cap, PAP_sizeW(n_payload));
            Sp[-1] = (W_)pap;
            pap->n_args = n_payload;
            pap->arity = arity;
@@ -1165,7 +1172,7 @@ run_BCO:
            StgInfoTable* itbl = INFO_PTR_TO_STRUCT(BCO_LIT(o_itbl));
            int request        = CONSTR_sizeW( itbl->layout.payload.ptrs, 
                                               itbl->layout.payload.nptrs );
-           StgClosure* con = (StgClosure*)allocate_NONUPD(request);
+           StgClosure* con = (StgClosure*)allocate_NONUPD(cap,request);
            ASSERT( itbl->layout.payload.ptrs + itbl->layout.payload.nptrs > 0);
            SET_HDR(con, (StgInfoTable*)BCO_LIT(o_itbl), CCS_SYSTEM/*ToDo*/);
            for (i = 0; i < n_words; i++) {
@@ -1183,7 +1190,7 @@ run_BCO:
 
        case bci_TESTLT_P: {
            unsigned int discr  = BCO_NEXT;
-           int failto = BCO_NEXT;
+           int failto = BCO_GET_LARGE_ARG;
            StgClosure* con = (StgClosure*)Sp[0];
            if (GET_TAG(con) >= discr) {
                bciPtr = failto;
@@ -1193,7 +1200,7 @@ run_BCO:
 
        case bci_TESTEQ_P: {
            unsigned int discr  = BCO_NEXT;
-           int failto = BCO_NEXT;
+           int failto = BCO_GET_LARGE_ARG;
            StgClosure* con = (StgClosure*)Sp[0];
            if (GET_TAG(con) != discr) {
                bciPtr = failto;
@@ -1204,7 +1211,7 @@ run_BCO:
        case bci_TESTLT_I: {
            // There should be an Int at Sp[1], and an info table at Sp[0].
            int discr   = BCO_NEXT;
-           int failto  = BCO_NEXT;
+           int failto  = BCO_GET_LARGE_ARG;
            I_ stackInt = (I_)Sp[1];
            if (stackInt >= (I_)BCO_LIT(discr))
                bciPtr = failto;
@@ -1214,7 +1221,7 @@ run_BCO:
        case bci_TESTEQ_I: {
            // There should be an Int at Sp[1], and an info table at Sp[0].
            int discr   = BCO_NEXT;
-           int failto  = BCO_NEXT;
+           int failto  = BCO_GET_LARGE_ARG;
            I_ stackInt = (I_)Sp[1];
            if (stackInt != (I_)BCO_LIT(discr)) {
                bciPtr = failto;
@@ -1222,10 +1229,31 @@ run_BCO:
            goto nextInsn;
        }
 
+       case bci_TESTLT_W: {
+           // There should be an Int at Sp[1], and an info table at Sp[0].
+           int discr   = BCO_NEXT;
+           int failto  = BCO_GET_LARGE_ARG;
+           W_ stackWord = (W_)Sp[1];
+           if (stackWord >= (W_)BCO_LIT(discr))
+               bciPtr = failto;
+           goto nextInsn;
+       }
+
+       case bci_TESTEQ_W: {
+           // There should be an Int at Sp[1], and an info table at Sp[0].
+           int discr   = BCO_NEXT;
+           int failto  = BCO_GET_LARGE_ARG;
+           W_ stackWord = (W_)Sp[1];
+           if (stackWord != (W_)BCO_LIT(discr)) {
+               bciPtr = failto;
+           }
+           goto nextInsn;
+       }
+
        case bci_TESTLT_D: {
            // There should be a Double at Sp[1], and an info table at Sp[0].
            int discr   = BCO_NEXT;
-           int failto  = BCO_NEXT;
+           int failto  = BCO_GET_LARGE_ARG;
            StgDouble stackDbl, discrDbl;
            stackDbl = PK_DBL( & Sp[1] );
            discrDbl = PK_DBL( & BCO_LIT(discr) );
@@ -1238,7 +1266,7 @@ run_BCO:
        case bci_TESTEQ_D: {
            // There should be a Double at Sp[1], and an info table at Sp[0].
            int discr   = BCO_NEXT;
-           int failto  = BCO_NEXT;
+           int failto  = BCO_GET_LARGE_ARG;
            StgDouble stackDbl, discrDbl;
            stackDbl = PK_DBL( & Sp[1] );
            discrDbl = PK_DBL( & BCO_LIT(discr) );
@@ -1251,7 +1279,7 @@ run_BCO:
        case bci_TESTLT_F: {
            // There should be a Float at Sp[1], and an info table at Sp[0].
            int discr   = BCO_NEXT;
-           int failto  = BCO_NEXT;
+           int failto  = BCO_GET_LARGE_ARG;
            StgFloat stackFlt, discrFlt;
            stackFlt = PK_FLT( & Sp[1] );
            discrFlt = PK_FLT( & BCO_LIT(discr) );
@@ -1264,7 +1292,7 @@ run_BCO:
        case bci_TESTEQ_F: {
            // There should be a Float at Sp[1], and an info table at Sp[0].
            int discr   = BCO_NEXT;
-           int failto  = BCO_NEXT;
+           int failto  = BCO_GET_LARGE_ARG;
            StgFloat stackFlt, discrFlt;
            stackFlt = PK_FLT( & Sp[1] );
            discrFlt = PK_FLT( & BCO_LIT(discr) );
@@ -1281,7 +1309,7 @@ run_BCO:
            // context switching: sometimes the scheduler can invoke
            // the interpreter with context_switch == 1, particularly
            // if the -C0 flag has been given on the cmd line.
-           if (cap->context_switch) {
+           if (cap->r.rHpLim == NULL) {
                Sp--; Sp[0] = (W_)&stg_enter_info;
                RETURN_TO_SCHEDULER(ThreadInterpret, ThreadYielding);
            }
@@ -1328,6 +1356,7 @@ run_BCO:
            void *tok;
            int stk_offset            = BCO_NEXT;
            int o_itbl                = BCO_NEXT;
+           int interruptible         = 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
@@ -1416,13 +1445,13 @@ run_BCO:
             ((StgRetDyn *)Sp)->payload[0] = (StgClosure *)obj;
 
            SAVE_STACK_POINTERS;
-           tok = suspendThread(&cap->r);
+           tok = suspendThread(&cap->r, interruptible ? rtsTrue : rtsFalse);
 
            // We already made a copy of the arguments above.
             ffi_call(cif, fn, ret, argptrs);
 
            // And restart the thread again, popping the RET_DYN frame.
-           cap = (Capability *)((void *)((unsigned char*)resumeThread(tok) - FIELD_OFFSET(Capability,r)));
+           cap = (Capability *)((void *)((unsigned char*)resumeThread(tok) - STG_FIELD_OFFSET(Capability,r)));
            LOAD_STACK_POINTERS;
 
             // Re-load the pointer to the BCO from the RET_DYN frame,
@@ -1448,7 +1477,7 @@ run_BCO:
 
        case bci_JMP: {
            /* BCO_NEXT modifies bciPtr, so be conservative. */
-           int nextpc = BCO_NEXT;
+           int nextpc = BCO_GET_LARGE_ARG;
            bciPtr     = nextpc;
            goto nextInsn;
        }