Fix crash in nested callbacks (#4038)
[ghc.git] / rts / Interpreter.c
index 3962856..5a564ba 100644 (file)
@@ -7,31 +7,36 @@
 #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
 
-#ifdef USE_LIBFFI
-#include <ffi.h>
+// 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"
+
 /* --------------------------------------------------------------------------
  * The bytecode interpreter
  * ------------------------------------------------------------------------*/
@@ -65,6 +70,7 @@
     SpLim = cap->r.rCurrentTSO->stack + RESERVED_STACK_WORDS;
 
 #define SAVE_STACK_POINTERS                    \
+    ASSERT(Sp > SpLim); \
     cap->r.rCurrentTSO->sp = Sp
 
 #define RETURN_TO_SCHEDULER(todo,retcode)      \
@@ -82,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;
@@ -197,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:
     // 
@@ -261,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;
@@ -434,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;
 
@@ -551,6 +560,16 @@ do_apply:
                goto defer_apply_to_sched;
            }
 
+            // Stack check: we're about to unpack the PAP onto the
+            // stack.  The (+1) is for the (arity < n) case, where we
+            // also need space for an extra info pointer.
+            if (Sp - (pap->n_args + 1) < SpLim) {
+                Sp -= 2;
+                Sp[1] = (W_)tagged_obj;
+                Sp[0] = (W_)&stg_enter_info;
+                RETURN_TO_SCHEDULER(ThreadInterpret, StackOverflow);
+            }
+
            Sp++;
            arity = pap->arity;
            ASSERT(arity > 0);
@@ -586,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;
@@ -631,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;
@@ -700,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);
     }
@@ -711,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
@@ -729,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
@@ -751,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");
@@ -842,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; 
@@ -1061,7 +1083,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*/)
@@ -1072,7 +1094,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*/)
@@ -1084,7 +1106,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;
@@ -1156,7 +1178,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++) {
@@ -1174,7 +1196,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;
@@ -1184,7 +1206,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;
@@ -1195,7 +1217,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;
@@ -1205,7 +1227,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;
@@ -1213,10 +1235,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) );
@@ -1229,7 +1272,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) );
@@ -1242,7 +1285,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) );
@@ -1255,7 +1298,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) );
@@ -1272,7 +1315,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 (context_switch) {
+           if (cap->r.rHpLim == NULL) {
                Sp--; Sp[0] = (W_)&stg_enter_info;
                RETURN_TO_SCHEDULER(ThreadInterpret, ThreadYielding);
            }
@@ -1347,7 +1390,6 @@ run_BCO:
                So we make a copy of the argument block.
             */
 
-#ifdef USE_LIBFFI
 #define ROUND_UP_WDS(p)  ((((StgWord)(p)) + sizeof(W_)-1)/sizeof(W_))
 
             ffi_cif *cif = (ffi_cif *)marshall_fn;
@@ -1384,10 +1426,6 @@ run_BCO:
 
             // this is the function we're going to call
             fn = (void(*)(void))Sp[ret_size];
-#else
-           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;
@@ -1415,14 +1453,10 @@ run_BCO:
            tok = suspendThread(&cap->r);
 
            // We already made a copy of the arguments above.
-#ifdef USE_LIBFFI
             ffi_call(cif, fn, ret, argptrs);
-#else
-           marshall_fn ( arguments );
-#endif
 
            // And restart the thread again, popping the RET_DYN frame.
-           cap = (Capability *)((void *)((unsigned char*)resumeThread(tok) - sizeof(StgFunTable)));
+           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,
@@ -1441,18 +1475,14 @@ run_BCO:
                
            // Copy the return value back to the TSO stack.  It is at
             // most 2 words large, and resides at arguments[0].
-#ifdef USE_LIBFFI
             memcpy(Sp, ret, sizeof(W_) * stg_min(stk_offset,ret_size));
-#else
-           memcpy(Sp, arguments, sizeof(W_) * stg_min(stk_offset,2));
-#endif
 
            goto nextInsn;
        }
 
        case bci_JMP: {
            /* BCO_NEXT modifies bciPtr, so be conservative. */
-           int nextpc = BCO_NEXT;
+           int nextpc = BCO_GET_LARGE_ARG;
            bciPtr     = nextpc;
            goto nextInsn;
        }