Remove the lock around NameCache for readBinIface.

Turns out using atomic update instead of a full-blown lock was easier
than I thought.  It should also be safe in the case where we
concurrently read the same interface file.  Whichever thread loses the
race will simply find that all of the names are already defined and
will have no effect on the name cache.

diff --git a/compiler/iface/BinIface.hs b/compiler/iface/BinIface.hs
index e9d7394..2661326 100644 (file)
--- a/compiler/iface/BinIface.hs
+++ b/compiler/iface/BinIface.hs
@@ -57,12 +57,13 @@ data TraceBinIFaceReading = TraceBinIFaceReading | QuietBinIFaceReading
 readBinIface :: CheckHiWay -> TraceBinIFaceReading -> FilePath
              -> TcRnIf a b ModIface
 readBinIface checkHiWay traceBinIFaceReading hi_path = do
-  lockedUpdNameCache $ \nc ->
-    readBinIface_ checkHiWay traceBinIFaceReading hi_path nc
+  update_nc <- mkNameCacheUpdater
+  liftIO $ readBinIface_ checkHiWay traceBinIFaceReading hi_path update_nc
 
-readBinIface_ :: CheckHiWay -> TraceBinIFaceReading -> FilePath -> NameCache
-              -> IO (NameCache, ModIface)
-readBinIface_ checkHiWay traceBinIFaceReading hi_path nc = do
+readBinIface_ :: CheckHiWay -> TraceBinIFaceReading -> FilePath
+              -> NameCacheUpdater (Array Int Name)
+              -> IO ModIface
+readBinIface_ checkHiWay traceBinIFaceReading hi_path update_nc = do
   let printer :: SDoc -> IO ()
       printer = case traceBinIFaceReading of
                 TraceBinIFaceReading -> \sd -> printSDoc sd defaultDumpStyle
@@ -124,12 +125,12 @@ readBinIface_ checkHiWay traceBinIFaceReading hi_path nc = do
   symtab_p <- Binary.get bh     -- Get the symtab ptr
   data_p <- tellBin bh          -- Remember where we are now
   seekBin bh symtab_p
-  (nc', symtab) <- getSymbolTable bh nc
+  symtab <- getSymbolTable bh update_nc
   seekBin bh data_p             -- Back to where we were before
   let ud = getUserData bh
   bh <- return $! setUserData bh ud{ud_symtab = symtab}
   iface <- get bh
-  return (nc', iface)
+  return iface
 
 
 writeBinIface :: DynFlags -> FilePath -> ModIface -> IO ()
@@ -221,16 +222,17 @@ putSymbolTable bh next_off symtab = do
   let names = elems (array (0,next_off-1) (eltsUFM symtab))
   mapM_ (\n -> serialiseName bh n symtab) names
 
-getSymbolTable :: BinHandle -> NameCache -> IO (NameCache, Array Int Name)
-getSymbolTable bh namecache = do
+getSymbolTable :: BinHandle -> NameCacheUpdater (Array Int Name)
+               -> IO (Array Int Name)
+getSymbolTable bh update_namecache = do
   sz <- get bh
   od_names <- sequence (replicate sz (get bh))
-  let 
+  update_namecache $ \namecache ->
+    let
         arr = listArray (0,sz-1) names
         (namecache', names) =    
                 mapAccumR (fromOnDiskName arr) namecache od_names
-  --
-  return (namecache', arr)
+    in (namecache', arr)
 
 type OnDiskName = (PackageId, ModuleName, OccName)
 

diff --git a/compiler/iface/IfaceEnv.lhs b/compiler/iface/IfaceEnv.lhs
index 313424f..34a457e 100644 (file)
--- a/compiler/iface/IfaceEnv.lhs
+++ b/compiler/iface/IfaceEnv.lhs
@@ -14,7 +14,7 @@ module IfaceEnv (
 
        -- Name-cache stuff
        allocateGlobalBinder, initNameCache, 
-        getNameCache, lockedUpdNameCache,
+        getNameCache, mkNameCacheUpdater, NameCacheUpdater
    ) where
 
 #include "HsVersions.h"
@@ -37,9 +37,9 @@ import SrcLoc
 import MkId
 
 import Outputable
-import Exception     ( onException )
+import Exception     ( evaluate )
 
-import Control.Concurrent.MVar ( tryTakeMVar, takeMVar, putMVar )
+import Data.IORef    ( atomicModifyIORef, readIORef )
 \end{code}
 
 
@@ -233,31 +233,19 @@ 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 ())
+-- | A function that atomically updates the name cache given a modifier
+-- function.  The second result of the modifier function will be the result
+-- of the IO action.
+type NameCacheUpdater c = (NameCache -> (NameCache, c)) -> IO c
 
+-- | Return a function to atomically update the name cache.
+mkNameCacheUpdater :: TcRnIf a b (NameCacheUpdater c)
+mkNameCacheUpdater = do
   nc_var <- hsc_NC `fmap` getTopEnv
-  writeMutVar nc_var $! name_cache'
-
-  liftIO (putMVar lock ())
-  return rslt
+  let update_nc f = do r <- atomicModifyIORef nc_var f
+                       _ <- evaluate =<< readIORef nc_var
+                       return r
+  return update_nc
 \end{code}
 
 

diff --git a/compiler/main/HscMain.lhs b/compiler/main/HscMain.lhs
index fec3f6c..26247b1 100644 (file)
--- a/compiler/main/HscMain.lhs
+++ b/compiler/main/HscMain.lhs
@@ -115,7 +115,6 @@ import Exception
 -- import MonadUtils
 
 import Control.Monad
-import Control.Concurrent.MVar ( newMVar )
 -- import System.IO
 import Data.IORef
 \end{code}
@@ -134,7 +133,6 @@ 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
@@ -146,7 +144,6 @@ 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 962c7a3..05c17ab 100644 (file)
--- a/compiler/main/HscTypes.lhs
+++ b/compiler/main/HscTypes.lhs
@@ -164,7 +164,6 @@ import Data.Array       ( Array, array )
 import Data.List
 import Control.Monad    ( mplus, guard, liftM, when )
 import Exception
-import Control.Concurrent.MVar ( MVar )
 \end{code}
 
 
@@ -545,9 +544,6 @@ 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),