[commit: ghc] ghc-lwc2: Fixed a bug in forkOn implementation. The capability number suggested is modded with the numCapability from the RTS. Added an assertion in rts/Threads.c to catch such a error early. (9609029)

[Sivaramakrishnan Krishnamoorthy Chandrasekaran]

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

On branch  : ghc-lwc2

https://github.com/ghc/ghc/commit/9609029a6c6388b07a9d71c73a711ed2a0ee44df

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

commit 9609029a6c6388b07a9d71c73a711ed2a0ee44df
Author: KC Sivaramakrishnan <chandras at cs.purdue.edu>
Date:   Wed Apr 24 12:18:40 2013 -0400

    Fixed a bug in forkOn implementation. The capability number suggested is
    modded with the numCapability from the RTS. Added an assertion in
    rts/Threads.c to catch such a error early.
    
    Added separate profile.h to ease profiling ChameneosRedux. Changes to
    Makefile.

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

 libraries/lwconc/LwConc/ConcurrentList.hs         |  2 +-
 rts/Threads.c                                     |  3 ++-
 tests/Benchmarks/ChameneosRedux/ConcurrentList.hs | 19 +++++++++----------
 tests/Benchmarks/ChameneosRedux/MVarList.hs       |  2 +-
 tests/Benchmarks/ChameneosRedux/Makefile          |  5 +++++
 tests/Benchmarks/ChameneosRedux/profile.h         |  5 +++++
 6 files changed, 23 insertions(+), 13 deletions(-)

diff --git a/libraries/lwconc/LwConc/ConcurrentList.hs b/libraries/lwconc/LwConc/ConcurrentList.hs
index dc7daba..951d11d 100644
--- a/libraries/lwconc/LwConc/ConcurrentList.hs
+++ b/libraries/lwconc/LwConc/ConcurrentList.hs
@@ -160,7 +160,7 @@ fork task on kind = do
   -- Set SCont Affinity
   case on of
     Nothing -> setSContCapability newSC t
-    Just t' -> setSContCapability newSC t'
+    Just t' -> setSContCapability newSC $ t' `mod` nc
   -- Schedule new Scont
   atomically $ do {
     ssa <- getScheduleSContAction;
diff --git a/rts/Threads.c b/rts/Threads.c
index 25ebfc5..e1fec18 100644
--- a/rts/Threads.c
+++ b/rts/Threads.c
@@ -245,9 +245,10 @@ void
 setOwningCapability (Capability *cap USED_IF_DEBUG,
                      StgTSO *tso,
                      nat target) {
-  ASSERT (cap == tso->cap);
   debugTrace (DEBUG_sched, "cap %d: Setting the capability of thread %d to %d",
               cap->no, tso->id, target);
+  ASSERT (cap == tso->cap);
+  ASSERT (target < enabled_capabilities);
   tso->cap = &capabilities[target];
 }
 
diff --git a/tests/Benchmarks/ChameneosRedux/ConcurrentList.hs b/tests/Benchmarks/ChameneosRedux/ConcurrentList.hs
index 733b687..f08898c 100644
--- a/tests/Benchmarks/ChameneosRedux/ConcurrentList.hs
+++ b/tests/Benchmarks/ChameneosRedux/ConcurrentList.hs
@@ -36,7 +36,7 @@ import LwConc.Substrate
 import Data.Array.IArray
 import Data.Dynamic
 
-#define _INL_(x) {-# INLINE x #-}
+#include "profile.h"
 
 -- The scheduler data structure has one (PVar [SCont], PVar [SCont]) for every
 -- capability.
@@ -86,7 +86,7 @@ newSched = do
   -- This token will be used to spawn in a round-robin fashion on different
   -- capabilities.
   token <- newPVarIO (0::Int)
-  -- Save the token in the Thread-local State (TLS)
+  -- Save the token in the Thread-local State (SLS)
   s <- getSContIO
   setSLS s $ toDyn token
   -- Create the scheduler data structure
@@ -123,14 +123,13 @@ newCapability = do
    setYieldControlAction s yca
    ssa <- getScheduleSContAction
    setScheduleSContAction s ssa
-
  scheduleSContOnFreeCap s
 
 data SContKind = Bound | Unbound
 
 _INL_(fork)
 fork :: IO () -> Maybe Int -> SContKind -> IO SCont
-fork !task !on kind = do
+fork !task !on !kind = do
   currentSC <- getSContIO
   nc <- getNumCapabilities
   -- epilogue: Switch to next thread after completion
@@ -144,11 +143,11 @@ fork !task !on kind = do
                     Bound -> newBoundSCont
                     Unbound -> newSCont
   newSC <- makeSCont (task >> epilogue)
-  -- Initialize TLS
-  tls <- atomically $ getSLS currentSC
-  setSLS newSC $ tls
-  let token::PVar Int = case fromDynamic tls of
-                          Nothing -> error "TLS"
+  -- Initialize SLS
+  sls <- atomically $ getSLS currentSC
+  setSLS newSC $ sls
+  let token::PVar Int = case fromDynamic sls of
+                          Nothing -> error "SLS"
                           Just x -> x
   t <- atomically $ do {
     -- Initialize scheduler actions
@@ -163,7 +162,7 @@ fork !task !on kind = do
   -- Set SCont Affinity
   case on of
     Nothing -> setSContCapability newSC t
-    Just t' -> setSContCapability newSC t'
+    Just t' -> setSContCapability newSC (t' `mod` nc)
   -- Schedule new Scont
   atomically $ do {
     ssa <- getScheduleSContAction;
diff --git a/tests/Benchmarks/ChameneosRedux/MVarList.hs b/tests/Benchmarks/ChameneosRedux/MVarList.hs
index 9490949..f4299b2 100644
--- a/tests/Benchmarks/ChameneosRedux/MVarList.hs
+++ b/tests/Benchmarks/ChameneosRedux/MVarList.hs
@@ -37,7 +37,7 @@ module MVarList
 import LwConc.Substrate
 import GHC.IORef
 
-#define _INL_(x) {-# INLINE x #-}
+#include "profile.h"
 
 data Queue a = Queue ![a] ![a]
 
diff --git a/tests/Benchmarks/ChameneosRedux/Makefile b/tests/Benchmarks/ChameneosRedux/Makefile
index 624f6cd..3601228 100644
--- a/tests/Benchmarks/ChameneosRedux/Makefile
+++ b/tests/Benchmarks/ChameneosRedux/Makefile
@@ -5,4 +5,9 @@ include ../../config.mk
 TOP := ../../../
 GHC_OPTS_EXTRA=-O2 -threaded -XBangPatterns -XCPP -XGeneralizedNewtypeDeriving -funbox-strict-fields -optc-O3
 
+PROFILE_FLAGS := -DPROFILE_ENABLED -prof -auto-all -fprof-auto
+
+#Uncomment the following line to enable profiled compilation
+#GHC_OPTS_EXTRA += $(PROFILE_FLAGS)
+
 all: $(TARGET)
diff --git a/tests/Benchmarks/ChameneosRedux/profile.h b/tests/Benchmarks/ChameneosRedux/profile.h
new file mode 100644
index 0000000..da8b314
--- /dev/null
+++ b/tests/Benchmarks/ChameneosRedux/profile.h
@@ -0,0 +1,5 @@
+#ifdef PROFILE_ENABLED
+#define _INL_(x)
+#else
+#define _INL_(x) {-# INLINE x #-}
+#endif