X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=blobdiff_plain;f=compiler%2Fiface%2FIfaceEnv.lhs;h=84a6474077ada74fa9b8836cdcf9216af9e30267;hp=3c3a34d6d84f53461145566f9d413b1cfdac8dc7;hb=7fc01c4671980ea3c66d549c0ece4d82fd3f5ade;hpb=49c98d143c382a1341e1046f5ca00819a25691ba diff --git a/compiler/iface/IfaceEnv.lhs b/compiler/iface/IfaceEnv.lhs index 3c3a34d..84a6474 100644 --- a/compiler/iface/IfaceEnv.lhs +++ b/compiler/iface/IfaceEnv.lhs @@ -7,13 +7,14 @@ module IfaceEnv ( lookupOrig, lookupOrigNameCache, extendNameCache, newIfaceName, newIfaceNames, extendIfaceIdEnv, extendIfaceTyVarEnv, - tcIfaceLclId, tcIfaceTyVar, + tcIfaceLclId, tcIfaceTyVar, lookupIfaceTyVar, + tcIfaceTick, ifaceExportNames, -- Name-cache stuff allocateGlobalBinder, initNameCache, - getNameCache, setNameCache + getNameCache, mkNameCacheUpdater, NameCacheUpdater ) where #include "HsVersions.h" @@ -25,7 +26,6 @@ import TyCon import DataCon import Var import Name -import OccName import PrelNames import Module import UniqFM @@ -34,8 +34,12 @@ import UniqSupply import FiniteMap import BasicTypes import SrcLoc +import MkId import Outputable +import Exception ( evaluate ) + +import Data.IORef ( atomicModifyIORef, readIORef ) \end{code} @@ -46,7 +50,7 @@ import Outputable %********************************************************* \begin{code} -newGlobalBinder :: Module -> OccName -> SrcLoc -> TcRnIf a b Name +newGlobalBinder :: Module -> OccName -> SrcSpan -> TcRnIf a b Name -- Used for source code and interface files, to make the -- Name for a thing, given its Module and OccName -- @@ -55,18 +59,14 @@ newGlobalBinder :: Module -> OccName -> SrcLoc -> 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 - -> Module -> OccName -> SrcLoc + -> Module -> OccName -> SrcSpan -> (NameCache, Name) allocateGlobalBinder name_supply mod occ loc = case lookupOrigNameCache (nsNames name_supply) mod occ of @@ -112,9 +112,16 @@ newImplicitBinder :: Name -- Base name -- For source type/class decls, this is the first occurrence -- For iface ones, the LoadIface has alrady allocated a suitable name in the cache newImplicitBinder base_name mk_sys_occ - = newGlobalBinder (nameModule base_name) - (mk_sys_occ (nameOccName base_name)) - (nameSrcLoc base_name) + | Just mod <- nameModule_maybe base_name + = newGlobalBinder mod occ loc + | otherwise -- When typechecking a [d| decl bracket |], + -- TH generates types, classes etc with Internal names, + -- so we follow suit for the implicit binders + = do { uniq <- newUnique + ; return (mkInternalName uniq occ loc) } + where + occ = mk_sys_occ (nameOccName base_name) + loc = nameSrcSpan base_name ifaceExportNames :: [IfaceExport] -> TcRnIf gbl lcl [AvailInfo] ifaceExportNames exports = do @@ -130,7 +137,7 @@ lookupAvail mod (AvailTC p_occ occs) = do p_name <- lookupOrig mod p_occ let lookup_sub occ | occ == p_occ = return p_name | otherwise = lookupOrig mod occ - subs <- mappM lookup_sub occs + subs <- mapM lookup_sub occs return (AvailTC p_name subs) -- Remember that 'occs' is all the exported things, including -- the parent. It's possible to export just class ops without @@ -146,49 +153,51 @@ lookupOrig mod occ -- which does some stuff that modifies the name cache -- 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 -> returnM name; +-- ; traceIf (text "lookup_orig" <+> ppr mod <+> ppr occ) + + ; 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 noSrcLoc + 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 + (name_cache{ nsUniqs = us', nsNames = new_cache }, name) }}} newIPName :: IPName OccName -> TcRnIf m n (IPName Name) -newIPName occ_name_ip - = getNameCache `thenM` \ name_supply -> +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 -> returnM name_ip - Nothing -> setNameCache new_ns `thenM_` - returnM 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} - Local helper functions (not exported) +%************************************************************************ +%* * + Name cache access +%* * +%************************************************************************ \begin{code} lookupOrigNameCache :: OrigNameCache -> Module -> OccName -> Maybe Name -lookupOrigNameCache nc mod occ - | mod == dATA_TUP || mod == gHC_PRIM, -- Boxed tuples from one, +lookupOrigNameCache _ mod occ + -- XXX Why is gHC_UNIT not mentioned here? + | mod == gHC_TUPLE || mod == gHC_PRIM, -- Boxed tuples from one, Just tup_info <- isTupleOcc_maybe occ -- unboxed from the other = -- Special case for tuples; there are too many -- of them to pre-populate the original-name cache @@ -206,7 +215,8 @@ lookupOrigNameCache nc mod occ -- The normal case extendOrigNameCache :: OrigNameCache -> Name -> OrigNameCache extendOrigNameCache nc name - = extendNameCache nc (nameModule name) (nameOccName name) name + = ASSERT2( isExternalName name, ppr name ) + extendNameCache nc (nameModule name) (nameOccName name) name extendNameCache :: OrigNameCache -> Module -> OccName -> Name -> OrigNameCache extendNameCache nc mod occ name @@ -218,9 +228,24 @@ 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} @@ -268,6 +293,11 @@ tcIfaceTyVar occ Nothing -> failIfM (text "Iface type variable out of scope: " <+> ppr occ) } +lookupIfaceTyVar :: FastString -> IfL (Maybe TyVar) +lookupIfaceTyVar occ + = do { lcl <- getLclEnv + ; return (lookupUFM (if_tv_env lcl) occ) } + extendIfaceTyVarEnv :: [TyVar] -> IfL a -> IfL a extendIfaceTyVarEnv tyvars thing_inside = do { env <- getLclEnv @@ -292,11 +322,27 @@ lookupIfaceTop occ newIfaceName :: OccName -> IfL Name newIfaceName occ = do { uniq <- newUnique - ; return $! mkInternalName uniq occ noSrcLoc } + ; return $! mkInternalName uniq occ noSrcSpan } newIfaceNames :: [OccName] -> IfL [Name] newIfaceNames occs = do { uniqs <- newUniqueSupply - ; return [ mkInternalName uniq occ noSrcLoc + ; return [ mkInternalName uniq occ noSrcSpan | (occ,uniq) <- occs `zip` uniqsFromSupply uniqs] } \end{code} + +%************************************************************************ +%* * + (Re)creating tick boxes +%* * +%************************************************************************ + +\begin{code} +tcIfaceTick :: Module -> Int -> IfL Id +tcIfaceTick modName tickNo + = do { uniq <- newUnique + ; return $ mkTickBoxOpId uniq modName tickNo + } +\end{code} + +