From: Thomas Schilling Date: Tue, 18 Aug 2009 21:32:43 +0000 (+0000) Subject: Remove the lock around NameCache for readBinIface. X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=commitdiff_plain;h=cadba81047f6188fad2fe07004c3cb36316c36d1 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 --- 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 --- 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 --- 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 --- 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),