[commit: ghc] ghc-lwc2: schedulePushWork eagerly releases the capability if there are pending upcall actions. Standardized MVar interface in chameneos-redux benchmark -- explicit use of resume tokens and result holes (for takeMVar) does not seem to buy much. (f00fac6)
git at git.haskell.org
git at git.haskell.org
Fri Sep 27 20:13:19 CEST 2013
Repository : ssh://git@git.haskell.org/ghc
On branch : ghc-lwc2
Link : http://ghc.haskell.org/trac/ghc/changeset/f00fac6f1d89d7410e9a8267f39c61d06571343b/ghc
>---------------------------------------------------------------
commit f00fac6f1d89d7410e9a8267f39c61d06571343b
Author: KC Sivaramakrishnan <chandras at cs.purdue.edu>
Date: Tue May 14 12:36:13 2013 -0400
schedulePushWork eagerly releases the capability if there are pending
upcall actions. Standardized MVar interface in chameneos-redux benchmark
-- explicit use of resume tokens and result holes (for takeMVar) does
not seem to buy much.
>---------------------------------------------------------------
f00fac6f1d89d7410e9a8267f39c61d06571343b
rts/Schedule.c | 1 +
tests/Benchmarks/ChameneosRedux/Makefile | 2 +-
.../ChameneosRedux/chameneos-redux-lwc.hs | 40 +++++++++-----------
3 files changed, 20 insertions(+), 23 deletions(-)
diff --git a/rts/Schedule.c b/rts/Schedule.c
index eb57408..3e5ca08 100644
--- a/rts/Schedule.c
+++ b/rts/Schedule.c
@@ -796,6 +796,7 @@ schedulePushWork(Capability *cap USED_IF_THREADS,
cap0 = &capabilities[i];
if (cap != cap0 && !cap0->disabled && tryGrabCapability(cap0,task)) {
if (!emptyRunQueue(cap0)
+ || !emptyUpcallQueue(cap0)
|| cap0->returning_tasks_hd != NULL
|| cap0->inbox != (Message*)END_TSO_QUEUE) {
// it already has some work, we just grabbed it at
diff --git a/tests/Benchmarks/ChameneosRedux/Makefile b/tests/Benchmarks/ChameneosRedux/Makefile
index 0fd7851..d8330de 100644
--- a/tests/Benchmarks/ChameneosRedux/Makefile
+++ b/tests/Benchmarks/ChameneosRedux/Makefile
@@ -4,7 +4,7 @@ include ../../config.mk
TOP := ../../../
EXTRA_LIBS=/scratch/chandras/install
-GHC_OPTS_EXTRA=-threaded -XDeriveDataTypeable -XBangPatterns -XCPP -XGeneralizedNewtypeDeriving -funbox-strict-fields -ipqueue-1.2.1 -O2
+GHC_OPTS_EXTRA=-XDeriveDataTypeable -XBangPatterns -XCPP -XGeneralizedNewtypeDeriving -funbox-strict-fields -ipqueue-1.2.1 -O2 -threaded
PROFILE_FLAGS := -DPROFILE_ENABLED -prof -fprof-auto -auto -auto-all
diff --git a/tests/Benchmarks/ChameneosRedux/chameneos-redux-lwc.hs b/tests/Benchmarks/ChameneosRedux/chameneos-redux-lwc.hs
index ffbedd6..d301c51 100644
--- a/tests/Benchmarks/ChameneosRedux/chameneos-redux-lwc.hs
+++ b/tests/Benchmarks/ChameneosRedux/chameneos-redux-lwc.hs
@@ -5,14 +5,14 @@
Modified by Péter Diviánszky, 19 May 2010
Modified by Louis Wasserman, 14 June 2010
- Should be compiled with -O2 -threaded -fvia-c -optc-O3 and run with +RTS
- -N<number of cores>.
+ Should be compiled with -O2 -threaded -fvia-c -optc-O3 and run with +RTS
+ -N<number of cores>. Disable thread migration <+RTS -qm> for predictable
+ performance.
- XXX KC: The user of withArrayLen is unsafe. We obtain pointers to
- addresses inside the array but not the byte array itself. This is a
- recipie for disaster. See
- http://hackage.haskell.org/trac/ghc/ticket/7012. Solution?
- -}
+ XXX KC: The user of withArrayLen is unsafe. We obtain pointers to addresses
+ inside the array but not the byte array itself. This is a recipe for
+ disaster. See http://hackage.haskell.org/trac/ghc/ticket/7012. Solution?
+-}
import LwConc.Substrate
@@ -28,9 +28,10 @@ import ConcurrentList
-------------------------------------------------------------------------------
-- MVars
-------------------------------------------------------------------------------
-import MVarList
--- import LwConc.MVarList
+-- import MVarList
+import LwConc.MVarList
-- import LwConc.MVar
+-- import Control.Concurrent (MVar, newEmptyMVar, newMVar, takeMVar, putMVar)
-------------------------------------------------------------------------------
@@ -67,27 +68,24 @@ arrive :: MVar MP -> MVar (Int, Int) -> Chameneous -> IO ()
arrive !mpv !finish !ch = do
sc <- getSContIO
!waker <- newEmptyMVar
- !hole1 <- newIORef undefined
- !hole2 <- newIORef undefined
- !tk <- atomically $ newResumeToken
let inc x = (fromEnum (ch == x) +)
go !t !b = do
-- peek ch >>= debugPrint . (\s -> show sc ++ " " ++ show s ++ " " ++ show ch)
- w <- takeMVarWithHole mpv hole1 tk
+ w <- takeMVar mpv
-- peek ch >>= debugPrint . (\s -> show sc ++ " " ++ show s ++ " " ++ show ch)
case w of
Nobody 0 -> do
-- peek ch >>= debugPrint . (\s -> show sc ++ " " ++ show s ++ " " ++ show ch)
- putMVar mpv w tk
+ putMVar mpv w
-- peek ch >>= debugPrint . (\s -> show sc ++ " " ++ show s ++ " " ++ show ch)
- putMVar finish (t, b) tk
+ putMVar finish (t, b)
-- peek ch >>= debugPrint . (\s -> show sc ++ " " ++ show s ++ " " ++ show ch)
return ()
Nobody q -> do
-- peek ch >>= debugPrint . (\s -> show sc ++ " " ++ show s ++ " " ++ show ch)
- putMVar mpv (Somebody q ch waker) tk
+ putMVar mpv (Somebody q ch waker)
-- peek ch >>= debugPrint . (\s -> show sc ++ " " ++ show s ++ " " ++ show ch)
- ch' <- takeMVarWithHole waker hole2 tk
+ ch' <- takeMVar waker
-- peek ch >>= debugPrint . (\s -> show sc ++ " " ++ show s ++ " " ++ show ch)
go (t+1) $ inc ch' b
Somebody q ch' waker' -> do
@@ -104,9 +102,9 @@ arrive !mpv !finish !ch = do
-- peek ch >>= debugPrint . (\s -> show sc ++ " " ++ show s ++ " " ++ show ch)
let !q' = q-1
-- peek ch >>= debugPrint . (\s -> show sc ++ " " ++ show s ++ " " ++ show ch)
- putMVar waker' ch tk
+ putMVar waker' ch
-- peek ch >>= debugPrint . (\s -> show sc ++ " " ++ show s ++ " " ++ show ch)
- putMVar mpv (Nobody q') tk
+ putMVar mpv (Nobody q')
go (t+1) $ inc ch' b
go 0 0
@@ -118,13 +116,11 @@ run :: Int -> Int -> [Color] -> IO (IO ())
run n cpu cs = do
fs <- replicateM (length cs) newEmptyMVar
mpv <- newMVar (Nobody n)
- hole <- newIORef undefined
- tk <- atomically $ newResumeToken
withArrayLen cs $ \ n cols -> do
zipWithM_ ((forkOn cpu .) . arrive mpv) fs (take n (iterate (`advancePtr` 1) cols))
return $ do
putStrLn . map toLower . unwords . ([]:) . map show $ cs
- ns <- mapM (\m -> takeMVarWithHole m hole tk) fs
+ ns <- mapM (\m -> takeMVar m) fs
putStr . map toLower . unlines $ [unwords [show n, showN b] | (n, b) <- ns]
putStrLn . (" "++) . showN . sum . map fst $ ns
putStrLn ""
More information about the ghc-commits
mailing list