[commit: ghc] ghc-lwc2: Disabled migration of threads running a user-level scheduler, without which sieve program seems to deadlock while running on a high core count. Enabling debug messages seems to make the bug disapper (Grr..). The error most probably is in RtsMessaging subsystem. Needs a different/better testcase. (2fa44a8)

[Sivaramakrishnan Krishnamoorthy Chandrasekaran]

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

On branch  : ghc-lwc2

https://github.com/ghc/ghc/commit/2fa44a8ab9d6c68c14ccb25ac26a556d1d82d70d

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

commit 2fa44a8ab9d6c68c14ccb25ac26a556d1d82d70d
Author: KC Sivaramakrishnan <chandras at cs.purdue.edu>
Date:   Mon Apr 29 20:04:28 2013 -0400

    Disabled migration of threads running a user-level scheduler, without
    which sieve program seems to deadlock while running on a high core
    count. Enabling debug messages seems to make the bug disapper (Grr..).
    The error most probably is in RtsMessaging subsystem. Needs a
    different/better testcase.

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

 rts/PrimOps.cmm                          |  3 ++-
 rts/STM.c                                |  0
 rts/Schedule.c                           |  7 +++++--
 tests/Benchmarks/Sieve/ConcurrentList.hs | 12 ++++++------
 tests/Benchmarks/Sieve/Makefile          |  2 +-
 tests/Benchmarks/Sieve/sieve-TMVar.hs    |  6 ++++--
 tests/Benchmarks/Sieve/sieve-lwc.hs      |  1 +
 7 files changed, 19 insertions(+), 12 deletions(-)

diff --git a/rts/PrimOps.cmm b/rts/PrimOps.cmm
index 850fef9..d5cc41c 100644
--- a/rts/PrimOps.cmm
+++ b/rts/PrimOps.cmm
@@ -633,7 +633,7 @@ again: MAYBE_GC(again);
       	}
 			}
     }
-  } )
+  })
 
   #endif
 
@@ -887,6 +887,7 @@ stg_sleepCapabilityzh ()
 {
 	IF_DEBUG (scheduler,
 		ccall debugBelch ("stg_sleepCapability: thread %d\n", StgTSO_id(CurrentTSO)));
+  ASSERT (StgTSO_is_sleeping (CurrentTSO) == 0::I32);
   StgTSO_is_sleeping (CurrentTSO) = 1::I32;
   jump stg_retryzh [];
 }
diff --git a/rts/Schedule.c b/rts/Schedule.c
index a626ef7..1bebbe5 100644
--- a/rts/Schedule.c
+++ b/rts/Schedule.c
@@ -523,7 +523,6 @@ run_thread:
         t->saved_winerror = GetLastError();
 #endif
 
-
         if (ret == ThreadBlocked) {
             if (t->why_blocked == BlockedOnBlackHole) {
                 StgTSO *owner = blackHoleOwner(t->block_info.bh->bh);
@@ -835,6 +834,9 @@ schedulePushWork(Capability *cap USED_IF_THREADS,
                 t->_link = END_TSO_QUEUE;
                 if (t->bound == task->incall // don't move my bound thread
                     || t->is_upcall_thread // don't move upcall thread
+                    // XXX the following is inplace to avoid a hard to debug
+                    // deadlock that occurs in sieve-lwc. Should be fixed!
+                    || hasHaskellScheduler(t) //don't move user-level schedulers
                     || tsoLocked(t)) {  // don't move a locked thread
                     setTSOLink(cap, prev, t);
                     setTSOPrev(cap, t, prev);
@@ -958,7 +960,8 @@ scheduleResumeBlockedOnForeignCall(Capability *cap USED_IF_THREADS)
     //Safely work
     ACQUIRE_LOCK (&cap->lock);
     incall = cap->suspended_ccalls_hd;
-    if (rtsFalse && //XXX disable
+    if (rtsFalse && //XXX KC: disabled! causes an IOError (Bad address) on
+                    //sieve-TMVar.hs. Should be fixed!
         incall && //incall is not NULL
         incall->uls_stat == UserLevelSchedulerBlocked) {
 
diff --git a/tests/Benchmarks/Sieve/ConcurrentList.hs b/tests/Benchmarks/Sieve/ConcurrentList.hs
index 6de9fc3..741bf55 100644
--- a/tests/Benchmarks/Sieve/ConcurrentList.hs
+++ b/tests/Benchmarks/Sieve/ConcurrentList.hs
@@ -44,10 +44,10 @@ newtype Sched = Sched (Array Int (PVar [SCont], PVar [SCont]))
 
 _INL_(yieldControlAction)
 yieldControlAction :: Sched -> PTM ()
-yieldControlAction (Sched pa) = do
+yieldControlAction !(Sched pa) = do
   -- Fetch current capability's scheduler
   cc <- getCurrentCapability
-  let (frontRef, backRef)= pa ! cc
+  let !(frontRef, backRef)= pa ! cc
   front <- readPVar frontRef
   case front of
     [] -> do
@@ -64,14 +64,14 @@ yieldControlAction (Sched pa) = do
 
 _INL_(scheduleSContAction)
 scheduleSContAction :: Sched -> SCont -> PTM ()
-scheduleSContAction (Sched pa) sc = do
+scheduleSContAction !(Sched pa) !sc = do
   -- Since we are making the given scont runnable, update its status to Yielded.
   setSContSwitchReason sc Yielded
   -- Fetch the given SCont's scheduler.
-  cap <- getSContCapability sc
+  !cap <- getSContCapability sc
   let (_,backRef) = pa ! cap
-  back <- readPVar backRef
-  writePVar backRef $ sc:back
+  !back <- readPVar backRef
+  writePVar backRef $! sc:back
 
 
 _INL_(newSched)
diff --git a/tests/Benchmarks/Sieve/Makefile b/tests/Benchmarks/Sieve/Makefile
index d662f80..dee0445 100644
--- a/tests/Benchmarks/Sieve/Makefile
+++ b/tests/Benchmarks/Sieve/Makefile
@@ -3,7 +3,7 @@ TARGET := sieve-vanilla.bin sieve-lwc.bin sieve-TMVar.bin sieve-vanilla-TMVar.bi
 include ../../config.mk
 
 TOP := ../../../
-GHC_OPTS_EXTRA=-O2 -threaded -XBangPatterns -XCPP -XGeneralizedNewtypeDeriving -funbox-strict-fields -optc-O3
+GHC_OPTS_EXTRA=-O2 -threaded -XBangPatterns -XCPP -XGeneralizedNewtypeDeriving -funbox-strict-fields -eventlog -optc-O3 -debug
 
 PROFILE_FLAGS := -DPROFILE_ENABLED -prof -auto-all -fprof-auto
 
diff --git a/tests/Benchmarks/Sieve/sieve-TMVar.hs b/tests/Benchmarks/Sieve/sieve-TMVar.hs
index a8df0c2..bfbed63 100644
--- a/tests/Benchmarks/Sieve/sieve-TMVar.hs
+++ b/tests/Benchmarks/Sieve/sieve-TMVar.hs
@@ -32,9 +32,10 @@ primeFilter mIn mOut prime = do
 main = do
   initSched
   numArg:_ <- getArgs
-  mIn <- atomically $ newEmptyTMVar
+  let n = read numArg
+  mIn <- newEmptyTMVarIO
   forkIO $ generate mIn
-  out <- replicateM (read numArg) (atomically newEmptyTMVar)
+  out <- replicateM n newEmptyTMVarIO
   foldM_ linkFilter mIn out
 
 -- Take a value from mIn, and call it prime. Then show that prime. Make a new thread that
@@ -44,5 +45,6 @@ linkFilter :: TMVar Int -> TMVar Int -> IO (TMVar Int)
 linkFilter mIn mOut = do
   prime <- atomically $ takeTMVar mIn
   putStrLn $ show prime
+  -- debugPrint $ show prime
   forkIO $ primeFilter mIn mOut prime
   return mOut
diff --git a/tests/Benchmarks/Sieve/sieve-lwc.hs b/tests/Benchmarks/Sieve/sieve-lwc.hs
index 48e12d4..1260ebf 100644
--- a/tests/Benchmarks/Sieve/sieve-lwc.hs
+++ b/tests/Benchmarks/Sieve/sieve-lwc.hs
@@ -20,6 +20,7 @@ primeFilter :: MVar Int -> MVar Int -> Int -> IO ()
 primeFilter mIn mOut prime = do
   forever $ do
     i <- takeMVar mIn
+    yield
     when (i `mod` prime /= 0) (putMVar mOut i)
 
 -- Take the first commandline argument and call it numArg.