Permalink
Browse files

Replace some uses of atomicModifyIORef with STM

This seems to cure the problem of the thread-delay benchmark behaving
pathologically due to contention on IORef blackholes at times.

Committer: Bryan O'Sullivan <bos@serpentine.com>
  • Loading branch information...
1 parent f54920e commit a0b1a192e58e6f1132c11d1d9f6907aa84660bb6 @simonmar simonmar committed Feb 18, 2010
Showing with 23 additions and 14 deletions.
  1. +1 −1 benchmarks/Makefile
  2. +13 −8 benchmarks/ThreadDelay.hs
  3. +1 −0 event.cabal
  4. +8 −5 src/System/Event/Unique.hs
View
@@ -5,7 +5,7 @@ cc-opt-flags = -O2
include ../tests/common.mk
ghc-bench-flags := -package network -package network-bytestring \
- -package attoparsec -package bytestring-show -package mtl
+ -package attoparsec -package bytestring-show -package mtl -package stm
ifdef USE_GHC_IO_MANAGER
ghc-bench-flags += -DUSE_GHC_IO_MANAGER
View
@@ -5,14 +5,13 @@
import Args (ljust, parseArgs, positive, theLast)
import Control.Concurrent (forkIO, runInUnboundThread)
-import Control.Concurrent.MVar (newEmptyMVar, putMVar, takeMVar)
import Control.Monad (when)
import Data.Function (on)
import Data.Monoid (Monoid(..), Last(..))
-import Data.IORef (atomicModifyIORef, newIORef)
import System.Console.GetOpt (ArgDescr(ReqArg), OptDescr(..))
import System.Environment (getArgs)
import System.Event.Thread (ensureIOManagerIsRunning)
+import Control.Concurrent.STM
#ifdef USE_GHC_IO_MANAGER
import Control.Concurrent (threadDelay)
@@ -25,18 +24,24 @@ main = do
let numThreads = theLast cfgNumThreads cfg
ensureIOManagerIsRunning
- done <- newEmptyMVar
- ref <- newIORef 0
+ done <- newTVarIO False
+ ref <- newTVarIO 0
let loop :: Int -> IO ()
loop i = do
when (i < numThreads) $ do
_ <- forkIO $ do
threadDelay 1000
- a <- atomicModifyIORef ref $ \a ->
- let !b = a+1 in (b,b)
- when (a == numThreads) $ putMVar done ()
+ atomically $ do
+ a <- readTVar ref
+ let !b = a+1
+ writeTVar ref b
+ when (b == numThreads) $ writeTVar done True
loop (i + 1)
- runInUnboundThread $ loop 0 >> takeMVar done
+ runInUnboundThread $ do
+ loop 0
+ atomically $ do
+ b <- readTVar done
+ when (not b) retry
------------------------------------------------------------------------
-- Configuration
View
@@ -40,6 +40,7 @@ library
build-depends:
base >= 4 && < 5,
+ stm,
ghc-prim
ghc-prof-options: -auto-all
View
@@ -7,10 +7,10 @@ module System.Event.Unique
, newUnique
) where
-import Data.IORef (IORef, atomicModifyIORef, newIORef)
import Data.Int (Int64)
+import Control.Concurrent.STM
-newtype UniqueSource = US (IORef Int64)
+newtype UniqueSource = US (TVar Int64)
newtype Unique = Unique { asInt64 :: Int64 }
deriving (Eq, Ord, Num)
@@ -19,10 +19,13 @@ instance Show Unique where
show = show . asInt64
newSource :: IO UniqueSource
-newSource = US `fmap` newIORef 0
+newSource = US `fmap` newTVarIO 0
newUnique :: UniqueSource -> IO Unique
newUnique (US ref) = do
- !v <- atomicModifyIORef ref $ \u -> let !u' = u+1 in (u', Unique u)
- return v -- be careful with modify functions!
+ atomically $ do
+ u <- readTVar ref
+ let !u' = u+1
+ writeTVar ref u'
+ return (Unique u')
{-# INLINE newUnique #-}

0 comments on commit a0b1a19

Please sign in to comment.