diff options
| -rw-r--r-- | compiler/iface/BinIface.hs | 5 | ||||
| -rw-r--r-- | compiler/iface/IfaceEnv.lhs | 88 | ||||
| -rw-r--r-- | compiler/main/HscMain.lhs | 3 | ||||
| -rw-r--r-- | 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 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), |