Make updates to the external package state atomic.

2 files changed, 32 insertions, 20 deletions

diff --git a/compiler/typecheck/TcRnMonad.lhs b/compiler/typecheck/TcRnMonad.lhs
index 386eae8bf3..8d9273750e 100644
--- a/compiler/typecheck/TcRnMonad.lhs
+++ b/compiler/typecheck/TcRnMonad.lhs
@@ -257,29 +257,28 @@ getEpsVar = do { env <- getTopEnv; return (hsc_EPS env) }
 getEps :: TcRnIf gbl lcl ExternalPackageState
 getEps = do { env <- getTopEnv; readMutVar (hsc_EPS env) }
 
--- Updating the EPS.  This should be an atomic operation.
--- Note the delicate 'seq' which forces the EPS before putting it in the
--- variable.  Otherwise what happens is that we get
---	write eps_var (....(unsafeRead eps_var)....)
--- and if the .... is strict, that's obviously bottom.  By forcing it beforehand
--- we make the unsafeRead happen before we update the variable.
-
+-- | Update the external package state.  Returns the second result of the
+-- modifier function.
+--
+-- This is an atomic operation and forces evaluation of the modified EPS in
+-- order to avoid space leaks.
 updateEps :: (ExternalPackageState -> (ExternalPackageState, a))
 	  -> TcRnIf gbl lcl a
-updateEps upd_fn = do	{ traceIf (text "updating EPS")
-			; eps_var <- getEpsVar
-			; eps <- readMutVar eps_var
-			; let { (eps', val) = upd_fn eps }
-			; seq eps' (writeMutVar eps_var eps')
-			; return val }
+updateEps upd_fn = do
+  traceIf (text "updating EPS")
+  eps_var <- getEpsVar
+  atomicUpdMutVar' eps_var upd_fn
 
+-- | Update the external package state.
+--
+-- This is an atomic operation and forces evaluation of the modified EPS in
+-- order to avoid space leaks.
 updateEps_ :: (ExternalPackageState -> ExternalPackageState)
 	   -> TcRnIf gbl lcl ()
-updateEps_ upd_fn = do	{ traceIf (text "updating EPS_")
-			; eps_var <- getEpsVar
-			; eps <- readMutVar eps_var
-			; let { eps' = upd_fn eps }
-			; seq eps' (writeMutVar eps_var eps') }
+updateEps_ upd_fn = do
+  traceIf (text "updating EPS_")
+  eps_var <- getEpsVar
+  atomicUpdMutVar' eps_var (\eps -> (upd_fn eps, ()))
 
 getHpt :: TcRnIf gbl lcl HomePackageTable
 getHpt = do { env <- getTopEnv; return (hsc_HPT env) }
diff --git a/compiler/utils/IOEnv.hs b/compiler/utils/IOEnv.hs
index b81b2e8fde..1f1dd8fec4 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 )
@@ -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