X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=blobdiff_plain;f=compiler%2Futils%2FIOEnv.hs;h=1f1dd8fec40b361a7e4e4db5a6bd3f48299b7804;hp=305e30eed7fded9287b8d1ebaef3811ca9b7d215;hb=e2e0785eb7f4efd9f7791d913cdfdfd03148cd86;hpb=893a3c0ad6c39caf71ac28af900733513e1f153e

diff --git a/compiler/utils/IOEnv.hs b/compiler/utils/IOEnv.hs
index 305e30e..1f1dd8f 100644
--- a/compiler/utils/IOEnv.hs
+++ b/compiler/utils/IOEnv.hs
@@ -22,13 +22,15 @@ module IOEnv (
         tryM, tryAllM, tryMostM, fixM,
 
         -- I/O operations
-        IORef, newMutVar, readMutVar, writeMutVar, updMutVar
+        IORef, newMutVar, readMutVar, writeMutVar, updMutVar,
+        atomicUpdMutVar, atomicUpdMutVar'
   ) where
 
 import Exception
 import Panic
 
-import Data.IORef       ( IORef, newIORef, readIORef, writeIORef, modifyIORef )
+import Data.IORef       ( IORef, newIORef, readIORef, writeIORef, modifyIORef,
+                          atomicModifyIORef )
 import Data.Typeable
 import System.IO.Unsafe ( unsafeInterleaveIO )
 import System.IO        ( fixIO )
@@ -66,7 +68,7 @@ thenM (IOEnv m) f = IOEnv (\ env -> do { r <- m env ;
                                          unIOEnv (f r) env })
 
 thenM_ :: IOEnv env a -> IOEnv env b -> IOEnv env b
-thenM_ (IOEnv m) f = IOEnv (\ env -> do { m env ; unIOEnv f env })
+thenM_ (IOEnv m) f = IOEnv (\ env -> do { _ <- m env ; unIOEnv f env })
 
 failM :: IOEnv env a
 failM = IOEnv (\ _ -> throwIO IOEnvFailure)
@@ -162,6 +164,17 @@ readMutVar var = liftIO (readIORef var)
 updMutVar :: IORef a -> (a -> a) -> IOEnv env ()
 updMutVar var upd = liftIO (modifyIORef var upd)
 
+-- | Atomically update the reference.  Does not force the evaluation of the
+-- new variable contents.  For strict update, use 'atomicUpdMutVar''.
+atomicUpdMutVar :: IORef a -> (a -> (a, b)) -> IOEnv env b
+atomicUpdMutVar var upd = liftIO (atomicModifyIORef var upd)
+
+-- | Strict variant of 'atomicUpdMutVar'.
+atomicUpdMutVar' :: IORef a -> (a -> (a, b)) -> IOEnv env b
+atomicUpdMutVar' var upd = do
+  r <- atomicUpdMutVar var upd
+  _ <- liftIO . evaluate =<< readMutVar var
+  return r
 
 ----------------------------------------------------------------------
 -- Accessing the environment