1-- (c) The University of Glasgow 2002-2006 2 3{-# LANGUAGE CPP, RankNTypes, BangPatterns #-} 4 5module IfaceEnv ( 6 newGlobalBinder, newInteractiveBinder, 7 externaliseName, 8 lookupIfaceTop, 9 lookupOrig, lookupOrigIO, lookupOrigNameCache, extendNameCache, 10 newIfaceName, newIfaceNames, 11 extendIfaceIdEnv, extendIfaceTyVarEnv, 12 tcIfaceLclId, tcIfaceTyVar, lookupIfaceVar, 13 lookupIfaceTyVar, extendIfaceEnvs, 14 setNameModule, 15 16 ifaceExportNames, 17 18 -- Name-cache stuff 19 allocateGlobalBinder, updNameCacheTc, 20 mkNameCacheUpdater, NameCacheUpdater(..), 21 ) where 22 23#include "HsVersions.h" 24 25import GhcPrelude 26 27import TcRnMonad 28import HscTypes 29import Type 30import Var 31import Name 32import Avail 33import Module 34import FastString 35import FastStringEnv 36import IfaceType 37import NameCache 38import UniqSupply 39import SrcLoc 40 41import Outputable 42import Data.List ( partition ) 43 44{- 45********************************************************* 46* * 47 Allocating new Names in the Name Cache 48* * 49********************************************************* 50 51See Also: Note [The Name Cache] in NameCache 52-} 53 54newGlobalBinder :: Module -> OccName -> SrcSpan -> TcRnIf a b Name 55-- Used for source code and interface files, to make the 56-- Name for a thing, given its Module and OccName 57-- See Note [The Name Cache] 58-- 59-- The cache may already already have a binding for this thing, 60-- because we may have seen an occurrence before, but now is the 61-- moment when we know its Module and SrcLoc in their full glory 62 63newGlobalBinder mod occ loc 64 = do { name <- updNameCacheTc mod occ $ \name_cache -> 65 allocateGlobalBinder name_cache mod occ loc 66 ; traceIf (text "newGlobalBinder" <+> 67 (vcat [ ppr mod <+> ppr occ <+> ppr loc, ppr name])) 68 ; return name } 69 70newInteractiveBinder :: HscEnv -> OccName -> SrcSpan -> IO Name 71-- Works in the IO monad, and gets the Module 72-- from the interactive context 73newInteractiveBinder hsc_env occ loc 74 = do { let mod = icInteractiveModule (hsc_IC hsc_env) 75 ; updNameCacheIO hsc_env mod occ $ \name_cache -> 76 allocateGlobalBinder name_cache mod occ loc } 77 78allocateGlobalBinder 79 :: NameCache 80 -> Module -> OccName -> SrcSpan 81 -> (NameCache, Name) 82-- See Note [The Name Cache] 83allocateGlobalBinder name_supply mod occ loc 84 = case lookupOrigNameCache (nsNames name_supply) mod occ of 85 -- A hit in the cache! We are at the binding site of the name. 86 -- This is the moment when we know the SrcLoc 87 -- of the Name, so we set this field in the Name we return. 88 -- 89 -- Then (bogus) multiple bindings of the same Name 90 -- get different SrcLocs can can be reported as such. 91 -- 92 -- Possible other reason: it might be in the cache because we 93 -- encountered an occurrence before the binding site for an 94 -- implicitly-imported Name. Perhaps the current SrcLoc is 95 -- better... but not really: it'll still just say 'imported' 96 -- 97 -- IMPORTANT: Don't mess with wired-in names. 98 -- Their wired-in-ness is in their NameSort 99 -- and their Module is correct. 100 101 Just name | isWiredInName name 102 -> (name_supply, name) 103 | otherwise 104 -> (new_name_supply, name') 105 where 106 uniq = nameUnique name 107 name' = mkExternalName uniq mod occ loc 108 -- name' is like name, but with the right SrcSpan 109 new_cache = extendNameCache (nsNames name_supply) mod occ name' 110 new_name_supply = name_supply {nsNames = new_cache} 111 112 -- Miss in the cache! 113 -- Build a completely new Name, and put it in the cache 114 _ -> (new_name_supply, name) 115 where 116 (uniq, us') = takeUniqFromSupply (nsUniqs name_supply) 117 name = mkExternalName uniq mod occ loc 118 new_cache = extendNameCache (nsNames name_supply) mod occ name 119 new_name_supply = name_supply {nsUniqs = us', nsNames = new_cache} 120 121ifaceExportNames :: [IfaceExport] -> TcRnIf gbl lcl [AvailInfo] 122ifaceExportNames exports = return exports 123 124-- | A function that atomically updates the name cache given a modifier 125-- function. The second result of the modifier function will be the result 126-- of the IO action. 127newtype NameCacheUpdater 128 = NCU { updateNameCache :: forall c. (NameCache -> (NameCache, c)) -> IO c } 129 130mkNameCacheUpdater :: TcRnIf a b NameCacheUpdater 131mkNameCacheUpdater = do { hsc_env <- getTopEnv 132 ; let !ncRef = hsc_NC hsc_env 133 ; return (NCU (updNameCache ncRef)) } 134 135updNameCacheTc :: Module -> OccName -> (NameCache -> (NameCache, c)) 136 -> TcRnIf a b c 137updNameCacheTc mod occ upd_fn = do { 138 hsc_env <- getTopEnv 139 ; liftIO $ updNameCacheIO hsc_env mod occ upd_fn } 140 141 142updNameCacheIO :: HscEnv -> Module -> OccName 143 -> (NameCache -> (NameCache, c)) 144 -> IO c 145updNameCacheIO hsc_env mod occ upd_fn = do { 146 147 -- First ensure that mod and occ are evaluated 148 -- If not, chaos can ensue: 149 -- we read the name-cache 150 -- then pull on mod (say) 151 -- which does some stuff that modifies the name cache 152 -- This did happen, with tycon_mod in TcIface.tcIfaceAlt (DataAlt..) 153 154 mod `seq` occ `seq` return () 155 ; updNameCache (hsc_NC hsc_env) upd_fn } 156 157 158{- 159************************************************************************ 160* * 161 Name cache access 162* * 163************************************************************************ 164-} 165 166-- | Look up the 'Name' for a given 'Module' and 'OccName'. 167-- Consider alternatively using 'lookupIfaceTop' if you're in the 'IfL' monad 168-- and 'Module' is simply that of the 'ModIface' you are typechecking. 169lookupOrig :: Module -> OccName -> TcRnIf a b Name 170lookupOrig mod occ 171 = do { traceIf (text "lookup_orig" <+> ppr mod <+> ppr occ) 172 173 ; updNameCacheTc mod occ $ lookupNameCache mod occ } 174 175lookupOrigIO :: HscEnv -> Module -> OccName -> IO Name 176lookupOrigIO hsc_env mod occ 177 = updNameCacheIO hsc_env mod occ $ lookupNameCache mod occ 178 179lookupNameCache :: Module -> OccName -> NameCache -> (NameCache, Name) 180-- Lookup up the (Module,OccName) in the NameCache 181-- If you find it, return it; if not, allocate a fresh original name and extend 182-- the NameCache. 183-- Reason: this may the first occurrence of (say) Foo.bar we have encountered. 184-- If we need to explore its value we will load Foo.hi; but meanwhile all we 185-- need is a Name for it. 186lookupNameCache mod occ name_cache = 187 case lookupOrigNameCache (nsNames name_cache) mod occ of { 188 Just name -> (name_cache, name); 189 Nothing -> 190 case takeUniqFromSupply (nsUniqs name_cache) of { 191 (uniq, us) -> 192 let 193 name = mkExternalName uniq mod occ noSrcSpan 194 new_cache = extendNameCache (nsNames name_cache) mod occ name 195 in (name_cache{ nsUniqs = us, nsNames = new_cache }, name) }} 196 197externaliseName :: Module -> Name -> TcRnIf m n Name 198-- Take an Internal Name and make it an External one, 199-- with the same unique 200externaliseName mod name 201 = do { let occ = nameOccName name 202 loc = nameSrcSpan name 203 uniq = nameUnique name 204 ; occ `seq` return () -- c.f. seq in newGlobalBinder 205 ; updNameCacheTc mod occ $ \ ns -> 206 let name' = mkExternalName uniq mod occ loc 207 ns' = ns { nsNames = extendNameCache (nsNames ns) mod occ name' } 208 in (ns', name') } 209 210-- | Set the 'Module' of a 'Name'. 211setNameModule :: Maybe Module -> Name -> TcRnIf m n Name 212setNameModule Nothing n = return n 213setNameModule (Just m) n = 214 newGlobalBinder m (nameOccName n) (nameSrcSpan n) 215 216{- 217************************************************************************ 218* * 219 Type variables and local Ids 220* * 221************************************************************************ 222-} 223 224tcIfaceLclId :: FastString -> IfL Id 225tcIfaceLclId occ 226 = do { lcl <- getLclEnv 227 ; case (lookupFsEnv (if_id_env lcl) occ) of 228 Just ty_var -> return ty_var 229 Nothing -> failIfM (text "Iface id out of scope: " <+> ppr occ) 230 } 231 232extendIfaceIdEnv :: [Id] -> IfL a -> IfL a 233extendIfaceIdEnv ids thing_inside 234 = do { env <- getLclEnv 235 ; let { id_env' = extendFsEnvList (if_id_env env) pairs 236 ; pairs = [(occNameFS (getOccName id), id) | id <- ids] } 237 ; setLclEnv (env { if_id_env = id_env' }) thing_inside } 238 239 240tcIfaceTyVar :: FastString -> IfL TyVar 241tcIfaceTyVar occ 242 = do { lcl <- getLclEnv 243 ; case (lookupFsEnv (if_tv_env lcl) occ) of 244 Just ty_var -> return ty_var 245 Nothing -> failIfM (text "Iface type variable out of scope: " <+> ppr occ) 246 } 247 248lookupIfaceTyVar :: IfaceTvBndr -> IfL (Maybe TyVar) 249lookupIfaceTyVar (occ, _) 250 = do { lcl <- getLclEnv 251 ; return (lookupFsEnv (if_tv_env lcl) occ) } 252 253lookupIfaceVar :: IfaceBndr -> IfL (Maybe TyCoVar) 254lookupIfaceVar (IfaceIdBndr (occ, _)) 255 = do { lcl <- getLclEnv 256 ; return (lookupFsEnv (if_id_env lcl) occ) } 257lookupIfaceVar (IfaceTvBndr (occ, _)) 258 = do { lcl <- getLclEnv 259 ; return (lookupFsEnv (if_tv_env lcl) occ) } 260 261extendIfaceTyVarEnv :: [TyVar] -> IfL a -> IfL a 262extendIfaceTyVarEnv tyvars thing_inside 263 = do { env <- getLclEnv 264 ; let { tv_env' = extendFsEnvList (if_tv_env env) pairs 265 ; pairs = [(occNameFS (getOccName tv), tv) | tv <- tyvars] } 266 ; setLclEnv (env { if_tv_env = tv_env' }) thing_inside } 267 268extendIfaceEnvs :: [TyCoVar] -> IfL a -> IfL a 269extendIfaceEnvs tcvs thing_inside 270 = extendIfaceTyVarEnv tvs $ 271 extendIfaceIdEnv cvs $ 272 thing_inside 273 where 274 (tvs, cvs) = partition isTyVar tcvs 275 276{- 277************************************************************************ 278* * 279 Getting from RdrNames to Names 280* * 281************************************************************************ 282-} 283 284-- | Look up a top-level name from the current Iface module 285lookupIfaceTop :: OccName -> IfL Name 286lookupIfaceTop occ 287 = do { env <- getLclEnv; lookupOrig (if_mod env) occ } 288 289newIfaceName :: OccName -> IfL Name 290newIfaceName occ 291 = do { uniq <- newUnique 292 ; return $! mkInternalName uniq occ noSrcSpan } 293 294newIfaceNames :: [OccName] -> IfL [Name] 295newIfaceNames occs 296 = do { uniqs <- newUniqueSupply 297 ; return [ mkInternalName uniq occ noSrcSpan 298 | (occ,uniq) <- occs `zip` uniqsFromSupply uniqs] } 299