Fix Trac #4841: behave right with TypeSynonymInstances and NoFlexibleInstances

[ghc-hetmet.git] / rts / RaiseAsync.c

diff --git a/rts/RaiseAsync.c b/rts/RaiseAsync.c
index d8ab08a..7abccde 100644 (file)
--- a/rts/RaiseAsync.c
+++ b/rts/RaiseAsync.c
@@ -57,15 +57,9 @@ static void throwToSendMsg (Capability *cap USED_IF_THREADS,
    has been raised.
    -------------------------------------------------------------------------- */
 
-void
-throwToSingleThreaded(Capability *cap, StgTSO *tso, StgClosure *exception)
-{
-    throwToSingleThreaded_(cap, tso, exception, rtsFalse);
-}
-
-void
-throwToSingleThreaded_(Capability *cap, StgTSO *tso, StgClosure *exception, 
-                      rtsBool stop_at_atomically)
+static void
+throwToSingleThreaded__ (Capability *cap, StgTSO *tso, StgClosure *exception, 
+                         rtsBool stop_at_atomically, StgUpdateFrame *stop_here)
 {
     tso = deRefTSO(tso);
 
@@ -77,23 +71,26 @@ throwToSingleThreaded_(Capability *cap, StgTSO *tso, StgClosure *exception,
     // Remove it from any blocking queues
     removeFromQueues(cap,tso);
 
-    raiseAsync(cap, tso, exception, stop_at_atomically, NULL);
+    raiseAsync(cap, tso, exception, stop_at_atomically, stop_here);
 }
 
 void
-suspendComputation(Capability *cap, StgTSO *tso, StgUpdateFrame *stop_here)
+throwToSingleThreaded (Capability *cap, StgTSO *tso, StgClosure *exception)
 {
-    tso = deRefTSO(tso);
-
-    // Thread already dead?
-    if (tso->what_next == ThreadComplete || tso->what_next == ThreadKilled) {
-       return;
-    }
+    throwToSingleThreaded__(cap, tso, exception, rtsFalse, NULL);
+}
 
-    // Remove it from any blocking queues
-    removeFromQueues(cap,tso);
+void
+throwToSingleThreaded_ (Capability *cap, StgTSO *tso, StgClosure *exception, 
+                        rtsBool stop_at_atomically)
+{
+    throwToSingleThreaded__ (cap, tso, exception, stop_at_atomically, NULL);
+}
 
-    raiseAsync(cap, tso, NULL, rtsFalse, stop_here);
+void
+suspendComputation (Capability *cap, StgTSO *tso, StgUpdateFrame *stop_here)
+{
+    throwToSingleThreaded__ (cap, tso, NULL, rtsFalse, stop_here);
 }
 
 /* -----------------------------------------------------------------------------
@@ -127,7 +124,7 @@ suspendComputation(Capability *cap, StgTSO *tso, StgUpdateFrame *stop_here)
    Capability, and it is
 
      - NotBlocked, BlockedOnMsgThrowTo,
-       BlockedOnCCall
+       BlockedOnCCall_Interruptible
 
      - or it is masking exceptions (TSO_BLOCKEX)
 
@@ -392,8 +389,32 @@ check_target:
            return THROWTO_SUCCESS;
        }
 
+    case BlockedOnCCall_Interruptible:
+#ifdef THREADED_RTS
+    {
+        Task *task = NULL;
+        // walk suspended_ccalls to find the correct worker thread
+        InCall *incall;
+        for (incall = cap->suspended_ccalls; incall != NULL; incall = incall->next) {
+            if (incall->suspended_tso == target) {
+                task = incall->task;
+                break;
+            }
+        }
+        if (task != NULL) {
+            blockedThrowTo(cap, target, msg);
+            if (!((target->flags & TSO_BLOCKEX) &&
+                  ((target->flags & TSO_INTERRUPTIBLE) == 0))) {
+                interruptWorkerTask(task);
+            }
+            return THROWTO_BLOCKED;
+        } else {
+            debugTraceCap(DEBUG_sched, cap, "throwTo: could not find worker thread to kill");
+        }
+        // fall to next
+    }
+#endif
     case BlockedOnCCall:
-    case BlockedOnCCall_NoUnblockExc:
        blockedThrowTo(cap,target,msg);
        return THROWTO_BLOCKED;
 
@@ -415,8 +436,20 @@ check_target:
        }
 #endif
 
+    case ThreadMigrating:
+        // if is is ThreadMigrating and tso->cap is ours, then it
+        // *must* be migrating *to* this capability.  If it were
+        // migrating away from the capability, then tso->cap would
+        // point to the destination.
+        //
+        // There is a MSG_WAKEUP in the message queue for this thread,
+        // but we can just do it preemptively:
+        tryWakeupThread(cap, target);
+        // and now retry, the thread should be runnable.
+        goto retry;
+
     default:
-       barf("throwTo: unrecognised why_blocked value");
+        barf("throwTo: unrecognised why_blocked (%d)", target->why_blocked);
     }
     barf("throwTo");
 }
@@ -840,9 +873,7 @@ raiseAsync(Capability *cap, StgTSO *tso, StgClosure *exception,
            // top of the CATCH_FRAME ready to enter.
            //
        {
-#ifdef PROFILING
            StgCatchFrame *cf = (StgCatchFrame *)frame;
-#endif
            StgThunk *raise;
            
            if (exception == NULL) break;
@@ -863,7 +894,12 @@ raiseAsync(Capability *cap, StgTSO *tso, StgClosure *exception,
             * a surprise exception before we get around to executing the
             * handler.
             */
-           tso->flags |= TSO_BLOCKEX | TSO_INTERRUPTIBLE;
+            tso->flags |= TSO_BLOCKEX;
+            if ((cf->exceptions_blocked & TSO_INTERRUPTIBLE) == 0) {
+                tso->flags &= ~TSO_INTERRUPTIBLE;
+            } else {
+                tso->flags |= TSO_INTERRUPTIBLE;
+            }
 
            /* Put the newly-built THUNK on top of the stack, ready to execute
             * when the thread restarts.