[commit: ghc] ghc-lwc2: Fixed swapMVar. Added INLINE directives for LwConc functions. (acd3898)
Sivaramakrishnan Krishnamoorthy Chandrasekaran
t-sichan at microsoft.com
Sun Mar 3 22:34:38 CET 2013
Repository : http://darcs.haskell.org/ghc.git/
On branch : ghc-lwc2
http://hackage.haskell.org/trac/ghc/changeset/acd3898860711483070574a1d8a108f26ee8ff16
>---------------------------------------------------------------
commit acd3898860711483070574a1d8a108f26ee8ff16
Author: KC Sivaramakrishnan <chandras at cs.purdue.edu>
Date: Sat Mar 2 19:32:44 2013 -0500
Fixed swapMVar. Added INLINE directives for LwConc functions.
>---------------------------------------------------------------
libraries/base/LwConc/Substrate.hs | 5 +++++
libraries/lwconc/LwConc/Concurrent.hs | 5 ++++-
libraries/lwconc/LwConc/MVar.hs | 38 ++++++++++++++++++++++++++---------
rts/PrimOps.cmm | 4 ++++
tests/Benchmarks/Sieve/Makefile | 2 +-
tests/Benchmarks/Sieve/sieve-lwc.hs | 11 ++++------
6 files changed, 46 insertions(+), 19 deletions(-)
diff --git a/libraries/base/LwConc/Substrate.hs b/libraries/base/LwConc/Substrate.hs
index dab0b48..93c3f1c 100644
--- a/libraries/base/LwConc/Substrate.hs
+++ b/libraries/base/LwConc/Substrate.hs
@@ -279,11 +279,13 @@ writePVar (PVar tvar#) val = PTM $ \s1# ->
newtype ResumeToken = ResumeToken (PVar Bool)
+{-# INLINE newResumeToken #-}
newResumeToken :: PTM ResumeToken
newResumeToken = do
t <- newPVar True
return $ ResumeToken t
+{-# INLINE isResumeTokenValid #-}
isResumeTokenValid :: ResumeToken -> PTM Bool
isResumeTokenValid (ResumeToken t) = do
v <- readPVar t
@@ -329,6 +331,7 @@ setSContSwitchReason :: SCont -> SContSwitchReason -> PTM ()
setSContSwitchReason s reason = do
setSContStatus s $ SContSwitched reason
+{-# INLINE initSContStatus #-}
initSContStatus :: SContStatus
initSContStatus = SContSwitched Yielded
@@ -388,10 +391,12 @@ getSContId (SCont sc) = PTM $ \s ->
-- SCont-local Storage (SLS)
-----------------------------------------------------------------------------------
+{-# INLINE setSLS #-}
setSLS :: SCont -> Dynamic -> IO ()
setSLS (SCont sc) v = IO $ \s ->
case setSLS# sc v s of s -> (# s, () #)
+{-# INLINE getSLS #-}
getSLS :: SCont -> PTM Dynamic
getSLS (SCont sc) = PTM $ \s -> getSLS# sc s
diff --git a/libraries/lwconc/LwConc/Concurrent.hs b/libraries/lwconc/LwConc/Concurrent.hs
index 2e05e1c..b0a5333 100644
--- a/libraries/lwconc/LwConc/Concurrent.hs
+++ b/libraries/lwconc/LwConc/Concurrent.hs
@@ -39,6 +39,7 @@ import Data.Dynamic
-- The scheduler data structure has one (PVar (Seq SCont)) for every capability.
newtype Sched = Sched (Array Int (PVar (Seq SCont)))
+{-# INLINE yieldControlAction #-}
yieldControlAction :: Sched -> PTM ()
yieldControlAction (Sched pa) = do
-- Fetch current capability's scheduler
@@ -54,6 +55,7 @@ yieldControlAction (Sched pa) = do
writePVar ref tl
switchTo x
+{-# INLINE scheduleSContAction #-}
scheduleSContAction :: Sched -> SCont -> PTM ()
scheduleSContAction (Sched pa) sc = do
-- Since we are making the given scont runnable, update its status to Yielded.
@@ -66,7 +68,6 @@ scheduleSContAction (Sched pa) sc = do
writePVar ref $ contents |> sc
-
newSched :: IO (Sched)
newSched = do
-- This token will be used to spawn in a round-robin fashion on different
@@ -114,6 +115,7 @@ newCapability = do
data SContKind = Bound | Unbound
+{-# INLINE fork #-}
fork :: IO () -> SContKind -> IO SCont
fork task kind = do
currentSC <- getSContIO
@@ -154,6 +156,7 @@ fork task kind = do
}
return newSC
+{-# INLINE forkOS #-}
forkIO :: IO () -> IO SCont
forkIO task = fork task Unbound
diff --git a/libraries/lwconc/LwConc/MVar.hs b/libraries/lwconc/LwConc/MVar.hs
index e8305ae..9b76f50 100644
--- a/libraries/lwconc/LwConc/MVar.hs
+++ b/libraries/lwconc/LwConc/MVar.hs
@@ -31,6 +31,7 @@ module LwConc.MVar
, putMVar -- MVar a -> a -> IO ()
, asyncPutMVar -- MVar a -> a -> PTM ()
, takeMVar -- MVar a -> IO a
+, takeMVarWithHole -- MVar a -> IORef a -> IO a
, readMVar -- MVar a -> a
, swapMVar -- MVar a -> a -> IO a
@@ -41,8 +42,8 @@ import qualified Data.Sequence as Seq
import GHC.IORef
newtype MVar a = MVar (PVar (MVPState a)) deriving (Eq)
-data MVPState a = Full a (Seq.Seq (a, PTM()))
- | Empty (Seq.Seq (IORef a, PTM()))
+data MVPState a = Full a !(Seq.Seq (a, PTM()))
+ | Empty !(Seq.Seq (IORef a, PTM()))
newMVar :: a -> IO (MVar a)
@@ -97,8 +98,9 @@ swapMVar (MVar ref) newValue = do
unblockAct <- getScheduleSContAction
token <- newResumeToken
let wakeup = do {
- oldValue <- unsafeIOToPTM $ readIORef hole;
- -- put value back into the MVar
+ -- put new value into the MVar. MVar behavior assures that the
+ -- MVar ref will be empty with 0 or more pending readers. Hence,
+ -- this call wouldn't block.
putMVarPTM (MVar ref) newValue;
-- Should I resume?
v <- isResumeTokenValid token;
@@ -110,7 +112,19 @@ swapMVar (MVar ref) newValue = do
writePVar ref $ Empty $ ts Seq.|> (hole, wakeup)
setSContSwitchReason sc $ BlockedInHaskell token
blockAct
- Full x _ -> unsafeIOToPTM $ writeIORef hole x
+ Full x (Seq.viewl -> Seq.EmptyL) -> do
+ -- First take the old value
+ writePVar ref $ Empty Seq.empty
+ unsafeIOToPTM $ writeIORef hole x
+ -- Now put the new value in
+ putMVarPTM (MVar ref) newValue
+ Full x (Seq.viewl -> (x', wakeup) Seq.:< ts) -> do
+ -- First take the old value
+ writePVar ref $ Full x' ts
+ unsafeIOToPTM $ writeIORef hole x
+ wakeup
+ -- Now put the new value in
+ putMVarPTM (MVar ref) newValue
readIORef hole
@@ -160,11 +174,9 @@ putMVarPTM (MVar ref) x = do
putMVar :: MVar a -> a -> IO ()
putMVar mv x = atomically $ putMVarPTM mv x
-
-{-# INLINE takeMVar #-}
-takeMVar :: MVar a -> IO a
-takeMVar (MVar ref) = do
- hole <- newIORef undefined
+{-# INLINE takeMVarWithHole #-}
+takeMVarWithHole :: MVar a -> IORef a -> IO a
+takeMVarWithHole (MVar ref) hole = do
atomically $ do
st <- readPVar ref
case st of
@@ -191,3 +203,9 @@ takeMVar (MVar ref) = do
unsafeIOToPTM $ writeIORef hole x
wakeup
readIORef hole
+
+{-# INLINE takeMVar #-}
+takeMVar :: MVar a -> IO a
+takeMVar m = do
+ hole <- newIORef undefined
+ takeMVarWithHole m hole
diff --git a/rts/PrimOps.cmm b/rts/PrimOps.cmm
index d341c8e..6f78bd4 100644
--- a/rts/PrimOps.cmm
+++ b/rts/PrimOps.cmm
@@ -865,6 +865,10 @@ stg_newSContzh ( gcptr closure )
closure "ptr");
StgTSO_why_blocked (threadid) = Yielded::I16;
+ // context switch soon, but not immediately: we don't want every
+ // newSCont to force a context-switch.
+ Capability_context_switch(MyCapability()) = 1 :: CInt;
+
return (threadid);
}
diff --git a/tests/Benchmarks/Sieve/Makefile b/tests/Benchmarks/Sieve/Makefile
index 2b8ba3d..fb82a68 100644
--- a/tests/Benchmarks/Sieve/Makefile
+++ b/tests/Benchmarks/Sieve/Makefile
@@ -3,6 +3,6 @@ TARGET := sieve-vanilla.bin sieve-lwc.bin
include ../../config.mk
TOP := ../../../
-GHC_OPTS_EXTRA=-threaded -XBangPatterns -prof
+GHC_OPTS_EXTRA=-XBangPatterns -O2 -prof -threaded
all: $(TARGET)
diff --git a/tests/Benchmarks/Sieve/sieve-lwc.hs b/tests/Benchmarks/Sieve/sieve-lwc.hs
index c837b6c..6c46282 100644
--- a/tests/Benchmarks/Sieve/sieve-lwc.hs
+++ b/tests/Benchmarks/Sieve/sieve-lwc.hs
@@ -5,16 +5,12 @@ import LwConc.Concurrent
import LwConc.Substrate
import LwConc.MVar
import System.Environment
+import Data.IORef
initSched = do
newSched
n <- getNumCapabilities
- spawnScheds $ n-1
- where
- spawnScheds 0 = return ()
- spawnScheds n = do
- newCapability
- spawnScheds (n-1)
+ replicateM_ (n-1) newCapability
-- Map over [2..] (2 until infinity), putting the value in mOut. The putting operation will block until
-- mOut is empty. mOut will become empty when some other thread executes takeMVar (getting its value).
@@ -23,7 +19,8 @@ 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
+ forever $ do
i <- takeMVar mIn
when (i `mod` prime /= 0) (putMVar mOut i)
More information about the ghc-commits
mailing list