From 9f68c34843602e815e71ef68f43adc01da993672 Mon Sep 17 00:00:00 2001 From: Thomas Schilling Date: Mon, 17 Aug 2009 00:48:19 +0000 Subject: [PATCH] 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). --- compiler/iface/BinIface.hs | 5 +-- compiler/iface/IfaceEnv.lhs | 88 +++++++++++++++++++++++++++---------------- compiler/main/HscMain.lhs | 3 ++ compiler/main/HscTypes.lhs | 4 ++ 4 files changed, 64 insertions(+), 36 deletions(-) diff --git a/compiler/iface/BinIface.hs b/compiler/iface/BinIface.hs index 15cefe8..e9d7394 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 05c6289..313424f 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 26247b1..fec3f6c 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 05c17ab..962c7a3 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), -- 1.7.10.4