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>

benchmarks/Makefile

@@ -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

benchmarks/ThreadDelay.hs

@@ -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

event.cabal

@@ -40,6 +40,7 @@ library
 
   build-depends:
     base >= 4 && < 5,
+    stm,
     ghc-prim
 
   ghc-prof-options: -auto-all

src/System/Event/Unique.hs

@@ -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 #-}