[commit: ghc] ghc-lwc2: Disabled labelling upcall threads. The hashtable used for storing the meta-data appears not to be thread-safe. Setting tso->is_sleeping to false just before a thread runs in the Scheudler (under run_thread label in the main scheduler loop). This avoids errors associated with sleeping threads (see stg_sleepCapability for more info). (8dc2f20)

[Sivaramakrishnan Krishnamoorthy Chandrasekaran]

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

On branch  : ghc-lwc2

https://github.com/ghc/ghc/commit/8dc2f205559a9abc201f7c1b933bc85daa69a73b

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

commit 8dc2f205559a9abc201f7c1b933bc85daa69a73b
Author: KC Sivaramakrishnan <chandras at cs.purdue.edu>
Date:   Mon Apr 29 14:01:10 2013 -0400

    Disabled labelling upcall threads. The hashtable used for storing the meta-data appears not to be thread-safe. Setting tso->is_sleeping to false just before a thread runs in the Scheudler (under run_thread label in the main scheduler loop). This avoids errors associated with sleeping threads (see stg_sleepCapability for more info).

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

 rts/Capability.c                        | 3 +--
 rts/Schedule.c                          | 2 ++
 rts/Threads.c                           | 6 +++---
 tests/Benchmarks/Sieve/Makefile         | 2 +-
 tests/Benchmarks/Sieve/sieve-vanilla.hs | 7 +++++--
 5 files changed, 12 insertions(+), 8 deletions(-)

diff --git a/rts/Capability.c b/rts/Capability.c
index f92a3af..9be497d 100644
--- a/rts/Capability.c
+++ b/rts/Capability.c
@@ -389,9 +389,8 @@ moreCapabilities (nat from USED_IF_THREADS, nat to USED_IF_THREADS)
 void initUpcallThreadOnCapability (Capability* cap) {
   cap->upcall_thread = createThread (cap, RtsFlags.GcFlags.initialStkSize);
   cap->upcall_thread->what_next = ThreadComplete; //Default state of upcall
-  //thread is ThreadComplete
   cap->upcall_thread->is_upcall_thread = rtsTrue;
-  labelThread (cap, cap->upcall_thread, "Upcall thread");
+  //labelThread (cap, cap->upcall_thread, "Upcall thread");
   debugTrace (DEBUG_sched, "allocated upcall thread (%d) for capability %d",
               cap->upcall_thread->id, cap->no);
 }
diff --git a/rts/Schedule.c b/rts/Schedule.c
index 8be1390..a626ef7 100644
--- a/rts/Schedule.c
+++ b/rts/Schedule.c
@@ -438,6 +438,8 @@ run_thread:
         ASSERT_FULL_CAPABILITY_INVARIANTS(cap,task);
         ASSERT(t->cap == cap);
         ASSERT(t->bound ? t->bound->task->cap == cap : 1);
+        t->is_sleeping = rtsFalse;
+
 
         prev_what_next = t->what_next;
 
diff --git a/rts/Threads.c b/rts/Threads.c
index c30b3da..703bb8d 100644
--- a/rts/Threads.c
+++ b/rts/Threads.c
@@ -109,7 +109,7 @@ createThread(Capability *cap, W_ size)
   tso->flags = 0;
   tso->dirty = 1;
   tso->is_upcall_thread = 0;
-  tso->is_sleeping = 0;
+  tso->is_sleeping = rtsFalse;
   tso->_link = END_TSO_QUEUE;
 
   tso->saved_errno = 0;
@@ -315,7 +315,7 @@ tryWakeupThread (Capability *cap, StgTSO *tso)
 
     case BlockedOnBlackHole:
       if (tso->is_sleeping) {
-        tso->is_sleeping = 0;
+        tso->is_sleeping = rtsFalse;
         goto unblock2;
       }
       else if (hasHaskellScheduler (tso)) //Note: Upcall threads do not have a user-level scheduler
@@ -325,7 +325,7 @@ tryWakeupThread (Capability *cap, StgTSO *tso)
 
     case BlockedOnSTM:
       if (tso->is_sleeping) {
-        tso->is_sleeping = 0;
+        tso->is_sleeping = rtsFalse;
         goto unblock2;
       }
       else if (hasHaskellScheduler (tso))
diff --git a/tests/Benchmarks/Sieve/Makefile b/tests/Benchmarks/Sieve/Makefile
index 96e57da..d662f80 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 -debug
+GHC_OPTS_EXTRA=-O2 -threaded -XBangPatterns -XCPP -XGeneralizedNewtypeDeriving -funbox-strict-fields -optc-O3
 
 PROFILE_FLAGS := -DPROFILE_ENABLED -prof -auto-all -fprof-auto
 
diff --git a/tests/Benchmarks/Sieve/sieve-vanilla.hs b/tests/Benchmarks/Sieve/sieve-vanilla.hs
index 54af576..ef6cc94 100644
--- a/tests/Benchmarks/Sieve/sieve-vanilla.hs
+++ b/tests/Benchmarks/Sieve/sieve-vanilla.hs
@@ -1,6 +1,6 @@
 import Control.Concurrent
 import Control.Monad
-
+import GHC.Conc
 import System.Environment
 
 -- Map over [2..] (2 until infinity), putting the value in mOut. The putting operation will block until
@@ -10,7 +10,10 @@ generate mOut = mapM_ (putMVar mOut) [2..]
 
 -- Take a value from mIn, divide it by a prime, if the remainder is not 0, put the value in mOut.
 primeFilter :: MVar Int -> MVar Int -> Int -> IO ()
-primeFilter mIn mOut prime = forever $ do
+primeFilter mIn mOut prime = do
+  tid <- myThreadId
+  labelThread tid $ "ThrPrime:" ++ show prime
+  forever $ do
     i <- takeMVar mIn
     when (i `mod` prime /= 0) (putMVar mOut i)