[commit: ghc] ghc-lwc2: Handling corner-cases in resuming schedulers that were blocked on foreign call and blackholes. (cfb7a56)

[Sivaramakrishnan Krishnamoorthy Chandrasekaran]

Repository : http://darcs.haskell.org/ghc.git/

On branch  : ghc-lwc2

https://github.com/ghc/ghc/commit/cfb7a56f658459cc8fed5cc524fdf3bc7951cbe0

>---------------------------------------------------------------

commit cfb7a56f658459cc8fed5cc524fdf3bc7951cbe0
Author: KC Sivaramakrishnan <chandras at cs.purdue.edu>
Date:   Sat May 11 17:37:47 2013 -0400

    Handling corner-cases in resuming schedulers that were blocked on foreign call and blackholes.

>---------------------------------------------------------------

 libraries/base/LwConc/Substrate.hs | 16 +++++++++++-----
 rts/RaiseAsync.c                   | 10 +++++++---
 2 files changed, 18 insertions(+), 8 deletions(-)

diff --git a/libraries/base/LwConc/Substrate.hs b/libraries/base/LwConc/Substrate.hs
index 9147e36..3058a3a 100644
--- a/libraries/base/LwConc/Substrate.hs
+++ b/libraries/base/LwConc/Substrate.hs
@@ -416,7 +416,7 @@ switchTo targetSCont = do
   let (I# intStatus) = getIntFromStatus status
   let SCont targetSCont# = targetSCont
   PTM $ \s ->
-    case (atomicSwitch# targetSCont# intStatus s) of s1 -> (# s1, () #)
+    case (atomicSwitch# targetSCont# intStatus s) of s1 -> (# s1, undefined #)
 
 {-# INLINE getSCont #-}
 getSCont :: PTM SCont
@@ -482,7 +482,6 @@ yieldControlActionRts sc = Exception.catch (atomically $ do
   setSContSwitchReason mySC Completed
   stat <- getSContStatus sc
   case stat of
-
       -- SCont hasn't been unblocked yet. This occurs if the SCont is blocked
       -- on a blackhole, throwTo, RTS MVar, safe foreign call etc,. In such
       -- cases, we are likely to perform yieldControlAction (and give up
@@ -496,10 +495,18 @@ yieldControlActionRts sc = Exception.catch (atomically $ do
       -- sets the SCont status to Yielded.
       SContSwitched Yielded -> return ()
 
-      otherwise -> error "yieldControlAction: Impossible status"
+			-- This is a corner case, but is very well possible. Consider that the
+			-- Scont (sc), was blocked on a foreign call, while its scheduler was
+			-- resumed (See rts/Schedule.c:resumeThread). When sc wakes up it has to
+			-- voluntarily give up control. But sc runs to completion and marks the
+			-- thread it is switching to that is should give up the scheduler (See
+			-- rts/PrimOps.cmm:stg_atomicSwitch). Now, the status of sc is set to
+			-- "SContSwitched Completed". Hence, this branch.
+      otherwise -> return ()
+
   switch <- getYieldControlActionSCont sc
   switch sc) (\e -> do {
-                      hPutStrLn stderr ("ERROR:" ++ show (e::IOException));
+                      debugPrint $ "ERROR:" ++ show (e::IOException);
                       error "LwConc.Substrate.yieldControlActionRTS"
                       })
 
@@ -554,7 +561,6 @@ defaultExceptionHandler :: Exception.SomeException -> IO ()
 defaultExceptionHandler e = do
   s <- getSContIO
   debugPrint ("defaultExceptionHandler: " ++ show s ++ " " ++ show (e::Exception.SomeException))
-  defaultUpcall
   atomically $ do
     setSContStatus s SContKilled
     yca <- getYieldControlAction
diff --git a/rts/RaiseAsync.c b/rts/RaiseAsync.c
index b888c4f..3698935 100644
--- a/rts/RaiseAsync.c
+++ b/rts/RaiseAsync.c
@@ -188,7 +188,7 @@ findLastUpdateFrame (StgTSO* tso) {
  * RETURN:
  *
  *  - rtsTrue       if blackhole owner is on current capability and we
- *                  successfully suspended.
+ *                  successfully suspended, or the blackhole has been updated.
  *  - rtsFalse      otherwise
  *---------------------------------------------------------------------------- */
 
@@ -200,9 +200,13 @@ suspendAllComputation (Capability *cap, StgClosure* bh) {
     bh = UNTAG_CLOSURE (bh);
     owner = blackHoleOwner (bh);
 
+    if (owner == NULL)
+      return rtsTrue;
+
     if (owner->cap != cap)
         return rtsFalse;
-    ASSERT (owner->why_blocked != NotBlocked);
+    ASSERT (cap->r.rCurrentTSO->is_upcall_thread ||
+            owner->why_blocked != NotBlocked);
 
     stop_here = findLastUpdateFrame (owner);
     ASSERT (stop_here);
@@ -210,9 +214,9 @@ suspendAllComputation (Capability *cap, StgClosure* bh) {
         barf ("suspendAllComputation: cannot find update frame\n");
     }
 
-    suspendComputationIncluding (cap, owner, stop_here);
     debugTrace (DEBUG_sched, "cap %d: thread %d inheriting work from thread %d",
                 cap->no, cap->r.rCurrentTSO->id, owner->id);
+    suspendComputationIncluding (cap, owner, stop_here);
     return rtsTrue;
 }