Make access to NameCache atomic. Sometimes needs a lock.

'readBinIface' updates the name cache in a way that is hard to use
with atomicModifyIORef, so this patch introduces a lock for this case.
All other updates use atomicModifyIORef.

Having a single lock is quite pessimistic, so it remains to be seen
whether this will become a problem.  In principle we only need to make
sure that we do not load the same file concurrently (or that it's
idempotent).  In practice we also need to ensure that concurrent reads
do not cancel each other out (since the new NameCache may be based on
an outdated version).

4 files changed, 64 insertions, 36 deletions

diff --git a/compiler/iface/BinIface.hs b/compiler/iface/BinIface.hs
index 15cefe8cdf..e9d7394343 100644
--- a/compiler/iface/BinIface.hs
+++ b/compiler/iface/BinIface.hs
@@ -57,11 +57,8 @@ data TraceBinIFaceReading = TraceBinIFaceReading | QuietBinIFaceReading
 readBinIface :: CheckHiWay -> TraceBinIFaceReading -> FilePath
              -> TcRnIf a b ModIface
 readBinIface checkHiWay traceBinIFaceReading hi_path = do
-  nc <- getNameCache
-  (new_nc, iface) <- liftIO $
+  lockedUpdNameCache $ \nc ->
     readBinIface_ checkHiWay traceBinIFaceReading hi_path nc
-  setNameCache new_nc
-  return iface
 
 readBinIface_ :: CheckHiWay -> TraceBinIFaceReading -> FilePath -> NameCache
               -> IO (NameCache, ModIface)
diff --git a/compiler/iface/IfaceEnv.lhs b/compiler/iface/IfaceEnv.lhs
index 05c6289950..313424fadf 100644
--- a/compiler/iface/IfaceEnv.lhs
+++ b/compiler/iface/IfaceEnv.lhs
@@ -14,7 +14,7 @@ module IfaceEnv (
 
 	-- Name-cache stuff
 	allocateGlobalBinder, initNameCache, 
-        getNameCache, setNameCache
+        getNameCache, lockedUpdNameCache,
    ) where
 
 #include "HsVersions.h"
@@ -37,6 +37,9 @@ import SrcLoc
 import MkId
 
 import Outputable
+import Exception     ( onException )
+
+import Control.Concurrent.MVar ( tryTakeMVar, takeMVar, putMVar )
 \end{code}
 
 
@@ -56,14 +59,10 @@ newGlobalBinder :: Module -> OccName -> SrcSpan -> TcRnIf a b Name
 -- moment when we know its Module and SrcLoc in their full glory
 
 newGlobalBinder mod occ loc
-  = do	{ mod `seq` occ `seq` return ()	-- See notes with lookupOrig_help
---	; traceIf (text "newGlobalBinder" <+> ppr mod <+> ppr occ <+> ppr loc)
-    	; name_supply <- getNameCache
-	; let (name_supply', name) = allocateGlobalBinder 
-					name_supply mod occ
-					loc
-	; setNameCache name_supply'
-	; return name }
+  = do mod `seq` occ `seq` return ()	-- See notes with lookupOrig
+--     traceIf (text "newGlobalBinder" <+> ppr mod <+> ppr occ <+> ppr loc)
+       updNameCache $ \name_cache ->
+         allocateGlobalBinder name_cache mod occ loc
 
 allocateGlobalBinder
   :: NameCache 
@@ -155,10 +154,10 @@ lookupOrig mod occ
 		-- This did happen, with tycon_mod in TcIface.tcIfaceAlt (DataAlt..)
 	  mod `seq` occ `seq` return ()	
 --	; traceIf (text "lookup_orig" <+> ppr mod <+> ppr occ)
-    
-	; name_cache <- getNameCache
-    	; case lookupOrigNameCache (nsNames name_cache) mod occ of {
-	      Just name -> return name;
+
+        ; updNameCache $ \name_cache ->
+            case lookupOrigNameCache (nsNames name_cache) mod occ of {
+	      Just name -> (name_cache, name);
 	      Nothing   ->
               let
                 us        = nsUniqs name_cache
@@ -167,27 +166,25 @@ lookupOrig mod occ
                 new_cache = extendNameCache (nsNames name_cache) mod occ name
               in
               case splitUniqSupply us of { (us',_) -> do
-                setNameCache name_cache{ nsUniqs = us', nsNames = new_cache }
-                return name
+                (name_cache{ nsUniqs = us', nsNames = new_cache }, name)
     }}}
 
 newIPName :: IPName OccName -> TcRnIf m n (IPName Name)
-newIPName occ_name_ip = do
-    name_supply <- getNameCache
+newIPName occ_name_ip =
+  updNameCache $ \name_cache ->
     let
-	ipcache = nsIPs name_supply
+	ipcache = nsIPs name_cache
+        key = occ_name_ip  -- Ensures that ?x and %x get distinct Names
+    in
     case lookupFM ipcache key of
-	Just name_ip -> return name_ip
-	Nothing      -> do setNameCache new_ns
-		           return name_ip
-		  where
-		     (us', us1)  = splitUniqSupply (nsUniqs name_supply)
-		     uniq   	 = uniqFromSupply us1
-		     name_ip	 = mapIPName (mkIPName uniq) occ_name_ip
-		     new_ipcache = addToFM ipcache key name_ip
-		     new_ns	 = name_supply {nsUniqs = us', nsIPs = new_ipcache}
-    where 
-	key = occ_name_ip	-- Ensures that ?x and %x get distinct Names
+      Just name_ip -> (name_cache, name_ip)
+      Nothing      -> (new_ns, name_ip)
+	  where
+	    (us', us1)  = splitUniqSupply (nsUniqs name_cache)
+	    uniq        = uniqFromSupply us1
+	    name_ip     = mapIPName (mkIPName uniq) occ_name_ip
+	    new_ipcache = addToFM ipcache key name_ip
+	    new_ns      = name_cache {nsUniqs = us', nsIPs = new_ipcache}
 \end{code}
 
 %************************************************************************
@@ -231,9 +228,36 @@ getNameCache :: TcRnIf a b NameCache
 getNameCache = do { HscEnv { hsc_NC = nc_var } <- getTopEnv; 
 		    readMutVar nc_var }
 
-setNameCache :: NameCache -> TcRnIf a b ()
-setNameCache nc = do { HscEnv { hsc_NC = nc_var } <- getTopEnv; 
-		       writeMutVar nc_var nc }
+updNameCache :: (NameCache -> (NameCache, c)) -> TcRnIf a b c
+updNameCache upd_fn = do
+  HscEnv { hsc_NC = nc_var } <- getTopEnv
+  atomicUpdMutVar' nc_var upd_fn
+
+-- | Update the name cache, but takes a lock while the update function is
+-- running.  If the update function throws an exception the lock is released
+-- and the exception propagated.
+lockedUpdNameCache :: (NameCache -> IO (NameCache, c)) -> TcRnIf a b c
+lockedUpdNameCache upd_fn = do
+  lock <- hsc_NC_lock `fmap` getTopEnv
+  -- Non-blocking "takeMVar" so we can show diagnostics if we didn't get the
+  -- lock.
+  mb_ok <- liftIO $ tryTakeMVar lock
+  case mb_ok of
+    Nothing -> do
+      traceIf (text "lockedUpdNameCache: failed to take lock.  blocking..")
+      _ <- liftIO $ takeMVar lock
+      traceIf (text "lockedUpdNameCache: got lock")
+    Just _ -> return ()
+
+  name_cache <- getNameCache
+  (name_cache', rslt) <- liftIO (upd_fn name_cache
+                                   `onException` putMVar lock ())
+
+  nc_var <- hsc_NC `fmap` getTopEnv
+  writeMutVar nc_var $! name_cache'
+
+  liftIO (putMVar lock ())
+  return rslt
 \end{code}
 
 
diff --git a/compiler/main/HscMain.lhs b/compiler/main/HscMain.lhs
index 26247b143a..fec3f6cb6b 100644
--- a/compiler/main/HscMain.lhs
+++ b/compiler/main/HscMain.lhs
@@ -115,6 +115,7 @@ import Exception
 -- import MonadUtils
 
 import Control.Monad
+import Control.Concurrent.MVar ( newMVar )
 -- import System.IO
 import Data.IORef
 \end{code}
@@ -133,6 +134,7 @@ newHscEnv callbacks dflags
   = do 	{ eps_var <- newIORef initExternalPackageState
 	; us      <- mkSplitUniqSupply 'r'
 	; nc_var  <- newIORef (initNameCache us knownKeyNames)
+        ; nc_lock <- newMVar ()
 	; fc_var  <- newIORef emptyUFM
 	; mlc_var <- newIORef emptyModuleEnv
         ; optFuel <- initOptFuelState
@@ -144,6 +146,7 @@ newHscEnv callbacks dflags
 			   hsc_HPT     = emptyHomePackageTable,
 			   hsc_EPS     = eps_var,
 			   hsc_NC      = nc_var,
+			   hsc_NC_lock = nc_lock,
 			   hsc_FC      = fc_var,
 			   hsc_MLC     = mlc_var,
 			   hsc_OptFuel = optFuel,
diff --git a/compiler/main/HscTypes.lhs b/compiler/main/HscTypes.lhs
index 05c17abeb9..962c7a3fd5 100644
--- a/compiler/main/HscTypes.lhs
+++ b/compiler/main/HscTypes.lhs
@@ -164,6 +164,7 @@ import Data.Array       ( Array, array )
 import Data.List
 import Control.Monad    ( mplus, guard, liftM, when )
 import Exception
+import Control.Concurrent.MVar ( MVar )
 \end{code}
 
 
@@ -544,6 +545,9 @@ data HscEnv
 		-- reflect sucking in interface files.  They cache the state of
 		-- external interface files, in effect.
 
+        hsc_NC_lock :: !(MVar ()),
+                -- ^ A lock used for updating the name cache.
+
 	hsc_FC   :: {-# UNPACK #-} !(IORef FinderCache),
 	        -- ^ The cached result of performing finding in the file system
 	hsc_MLC  :: {-# UNPACK #-} !(IORef ModLocationCache),