Commit cadba810 authored by Thomas Schilling's avatar Thomas Schilling

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.
parent c5cafbcc
......@@ -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)
......
......@@ -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}
......
......@@ -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,
......
......@@ -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),
......
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment