X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=blobdiff_plain;f=compiler%2Fiface%2FIfaceEnv.lhs;h=0e30f312804c1c7694ae6af6c12ca34fa9e58b90;hp=05c628995011598913202b7ef4f9e62a33630f55;hb=86add45dbfb6f962b65e371143dd467ae783f9e7;hpb=703ca1542c8e0983cc9d8eebce6e9f3dd3fd71e2 diff --git a/compiler/iface/IfaceEnv.lhs b/compiler/iface/IfaceEnv.lhs index 05c6289..0e30f31 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, mkNameCacheUpdater, NameCacheUpdater ) where #include "HsVersions.h" @@ -28,15 +28,18 @@ import Var import Name import PrelNames import Module -import LazyUniqFM +import UniqFM import FastString import UniqSupply -import FiniteMap import BasicTypes import SrcLoc import MkId import Outputable +import Exception ( evaluate ) + +import Data.IORef ( atomicModifyIORef, readIORef ) +import qualified Data.Map as Map \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 @@ -99,8 +98,7 @@ allocateGlobalBinder name_supply mod occ loc -- Build a completely new Name, and put it in the cache Nothing -> (new_name_supply, name) where - (us', us1) = splitUniqSupply (nsUniqs name_supply) - uniq = uniqFromSupply us1 + (uniq, us') = takeUniqFromSupply (nsUniqs name_supply) name = mkExternalName uniq mod occ loc new_cache = extendNameCache (nsNames name_supply) mod occ name new_name_supply = name_supply {nsUniqs = us', nsNames = new_cache} @@ -155,39 +153,34 @@ 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 - uniq = uniqFromSupply us - name = mkExternalName uniq mod occ noSrcSpan - 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 + case takeUniqFromSupply (nsUniqs name_cache) of { + (uniq, us) -> + let + name = mkExternalName uniq mod occ noSrcSpan + new_cache = extendNameCache (nsNames name_cache) mod occ name + in (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 - 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 + ipcache = nsIPs name_cache + key = occ_name_ip -- Ensures that ?x and %x get distinct Names + in + case Map.lookup key ipcache of + Just name_ip -> (name_cache, name_ip) + Nothing -> (new_ns, name_ip) + where + (uniq, us') = takeUniqFromSupply (nsUniqs name_cache) + name_ip = mapIPName (mkIPName uniq) occ_name_ip + new_ipcache = Map.insert key name_ip ipcache + new_ns = name_cache {nsUniqs = us', nsIPs = new_ipcache} \end{code} %************************************************************************ @@ -223,17 +216,32 @@ extendOrigNameCache nc name extendNameCache :: OrigNameCache -> Module -> OccName -> Name -> OrigNameCache extendNameCache nc mod occ name - = extendModuleEnv_C combine nc mod (unitOccEnv occ name) + = extendModuleEnvWith combine nc mod (unitOccEnv occ name) where - combine occ_env _ = extendOccEnv occ_env occ name + combine _ occ_env = extendOccEnv occ_env occ name 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 + +-- | 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 + let update_nc f = do r <- atomicModifyIORef nc_var f + _ <- evaluate =<< readIORef nc_var + return r + return update_nc \end{code} @@ -242,7 +250,7 @@ initNameCache :: UniqSupply -> [Name] -> NameCache initNameCache us names = NameCache { nsUniqs = us, nsNames = initOrigNames names, - nsIPs = emptyFM } + nsIPs = Map.empty } initOrigNames :: [Name] -> OrigNameCache initOrigNames names = foldl extendOrigNameCache emptyModuleEnv names