[commit: ghc] ghc-lwc2: Fixed an error with sleepCapability. tso->is_sleeping variable is set to 0 if the thread does not actually block on the STM. (77dff34)

[Sivaramakrishnan Krishnamoorthy Chandrasekaran]

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

On branch  : ghc-lwc2

https://github.com/ghc/ghc/commit/77dff342f1c5361378ba17f2ce5d0c60c75ec3be

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

commit 77dff342f1c5361378ba17f2ce5d0c60c75ec3be
Author: KC Sivaramakrishnan <chandras at cs.purdue.edu>
Date:   Mon Apr 29 12:43:44 2013 -0400

    Fixed an error with sleepCapability. tso->is_sleeping variable is set to 0 if the thread does not actually block on the STM.

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

 libraries/base/GHC/Event/TimerManager.hs | 18 ++++++++++++++++++
 rts/PrimOps.cmm                          | 10 +++++++++-
 rts/Threads.c                            |  6 +++++-
 tests/Benchmarks/Sieve/MVarList.hs       |  4 ++--
 tests/Benchmarks/Sieve/sieve-TMVar.hs    |  1 -
 5 files changed, 34 insertions(+), 5 deletions(-)

diff --git a/libraries/base/GHC/Event/TimerManager.hs b/libraries/base/GHC/Event/TimerManager.hs
index dd55355..5ba82a4 100644
--- a/libraries/base/GHC/Event/TimerManager.hs
+++ b/libraries/base/GHC/Event/TimerManager.hs
@@ -54,6 +54,10 @@ import GHC.Event.Control
 import GHC.Event.Internal (Backend, Event, evtRead, Timeout(..))
 import GHC.Event.Unique (Unique, UniqueSource, newSource, newUnique)
 import System.Posix.Types (Fd)
+import System.Posix.Internals hiding (FD)
+
+import Foreign.Safe (castPtr)
+import Foreign.C
 
 import qualified GHC.Event.Internal as I
 import qualified GHC.Event.PSQ as Q
@@ -124,6 +128,20 @@ data TimerManager = TimerManager
 ------------------------------------------------------------------------
 -- Creation
 
+c_DEBUG_DUMP :: Bool
+c_DEBUG_DUMP = True
+
+debugIO :: String -> IO ()
+debugIO s
+ | c_DEBUG_DUMP
+    = do _ <- withCStringLen (s ++ "\n") $
+                  \(p, len) -> c_write 1 (castPtr p) (fromIntegral len)
+         return ()
+ | otherwise = return ()
+
+------------------------------------------------------------------------
+-- Creation
+
 handleControlEvent :: TimerManager -> Fd -> Event -> IO ()
 handleControlEvent mgr fd _evt = do
   msg <- readControlMessage (emControl mgr) fd
diff --git a/rts/PrimOps.cmm b/rts/PrimOps.cmm
index 2eee6c2..850fef9 100644
--- a/rts/PrimOps.cmm
+++ b/rts/PrimOps.cmm
@@ -633,7 +633,7 @@ again: MAYBE_GC(again);
       	}
 			}
     }
-  })
+  } )
 
   #endif
 
@@ -1375,6 +1375,14 @@ retry_pop_stack:
     jump stg_block_stmwait [R3];
   } else {
     // Transaction was not valid: retry immediately
+
+		/* KC thread is no longer considered sleeping since the transaction is being
+		 * retried. See stg_sleepCapability. The correct solution is to make the
+		 * tso->is_sleeping variable into a TVar. This would avoid having to reason
+		 * explicitly about the states being manipulated.
+		 */
+  	StgTSO_is_sleeping (CurrentTSO) = 0::I32;
+
     ("ptr" trec) = ccall stmStartTransaction(MyCapability() "ptr", outer "ptr");
     StgTSO_trec(CurrentTSO) = trec;
     Sp = frame;
diff --git a/rts/Threads.c b/rts/Threads.c
index e1fec18..c30b3da 100644
--- a/rts/Threads.c
+++ b/rts/Threads.c
@@ -314,7 +314,11 @@ tryWakeupThread (Capability *cap, StgTSO *tso)
       }
 
     case BlockedOnBlackHole:
-      if (hasHaskellScheduler (tso)) //Note: Upcall threads do not have a user-level scheduler
+      if (tso->is_sleeping) {
+        tso->is_sleeping = 0;
+        goto unblock2;
+      }
+      else if (hasHaskellScheduler (tso)) //Note: Upcall threads do not have a user-level scheduler
         goto unblock1;
       else
         goto unblock2;
diff --git a/tests/Benchmarks/Sieve/MVarList.hs b/tests/Benchmarks/Sieve/MVarList.hs
index 106bafd..10ac5f9 100644
--- a/tests/Benchmarks/Sieve/MVarList.hs
+++ b/tests/Benchmarks/Sieve/MVarList.hs
@@ -62,8 +62,8 @@ deque (TwoListQueue !front !back) =
     x:tl -> (TwoListQueue tl back, Just x)
 
 newtype MVar a = MVar (PVar (MVPState a)) deriving (Eq)
-data MVPState a = Full a (TwoListQueue (a, PTM()))
-                | Empty (TwoListQueue (IORef a, PTM()))
+data MVPState a = Full a {-# UNPACK #-} !(TwoListQueue (a, PTM()))
+                | Empty {-# UNPACK #-} !(TwoListQueue (IORef a, PTM()))
 
 
 _INL_(newMVar)
diff --git a/tests/Benchmarks/Sieve/sieve-TMVar.hs b/tests/Benchmarks/Sieve/sieve-TMVar.hs
index dd000a0..a8df0c2 100644
--- a/tests/Benchmarks/Sieve/sieve-TMVar.hs
+++ b/tests/Benchmarks/Sieve/sieve-TMVar.hs
@@ -43,7 +43,6 @@ main = do
 linkFilter :: TMVar Int -> TMVar Int -> IO (TMVar Int)
 linkFilter mIn mOut = do
   prime <- atomically $ takeTMVar mIn
-  traceIO $ show prime
   putStrLn $ show prime
   forkIO $ primeFilter mIn mOut prime
   return mOut