X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=rts%2FInterpreter.c;h=fa4a46fd1277b72ba1be4ced6e872285b71e0156;hb=fff1f6194c3c39de53cd645bda9865fb131b1c68;hp=9a38a7ed189e0bb4579d9fbdd8479119b6539995;hpb=41bfdf710742595e6043d9b851e8dab30ffe6d2f;p=ghc-hetmet.git

diff --git a/rts/Interpreter.c b/rts/Interpreter.c
index 9a38a7e..fa4a46f 100644
--- a/rts/Interpreter.c
+++ b/rts/Interpreter.c
@@ -1356,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
@@ -1444,7 +1445,7 @@ 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);
@@ -1453,6 +1454,14 @@ run_BCO:
 	    cap = (Capability *)((void *)((unsigned char*)resumeThread(tok) - STG_FIELD_OFFSET(Capability,r)));
 	    LOAD_STACK_POINTERS;
 
+            if (Sp[0] != (W_)&stg_gc_gen_info) {
+                // the stack is not how we left it.  This probably
+                // means that an exception got raised on exit from the
+                // foreign call, so we should just continue with
+                // whatever is on top of the stack now.
+                RETURN_TO_SCHEDULER_NO_PAUSE(ThreadRunGHC, ThreadYielding);
+            }
+
             // Re-load the pointer to the BCO from the RET_DYN frame,
             // it might have moved during the call.  Also reload the
             // pointers to the components of the BCO.