1 (c) The University of Glasgow 2002-2006
5 newGlobalBinder, newIPName, newImplicitBinder,
7 lookupOrig, lookupOrigNameCache, extendNameCache,
8 newIfaceName, newIfaceNames,
9 extendIfaceIdEnv, extendIfaceTyVarEnv,
10 tcIfaceLclId, tcIfaceTyVar, lookupIfaceTyVar,
16 allocateGlobalBinder, initNameCache,
17 getNameCache, mkNameCacheUpdater, NameCacheUpdater
20 #include "HsVersions.h"
40 import Exception ( evaluate )
42 import Data.IORef ( atomicModifyIORef, readIORef )
46 %*********************************************************
48 Allocating new Names in the Name Cache
50 %*********************************************************
53 newGlobalBinder :: Module -> OccName -> SrcSpan -> TcRnIf a b Name
54 -- Used for source code and interface files, to make the
55 -- Name for a thing, given its Module and OccName
57 -- The cache may already already have a binding for this thing,
58 -- because we may have seen an occurrence before, but now is the
59 -- moment when we know its Module and SrcLoc in their full glory
61 newGlobalBinder mod occ loc
62 = do mod `seq` occ `seq` return () -- See notes with lookupOrig
63 -- traceIf (text "newGlobalBinder" <+> ppr mod <+> ppr occ <+> ppr loc)
64 updNameCache $ \name_cache ->
65 allocateGlobalBinder name_cache mod occ loc
69 -> Module -> OccName -> SrcSpan
71 allocateGlobalBinder name_supply mod occ loc
72 = case lookupOrigNameCache (nsNames name_supply) mod occ of
73 -- A hit in the cache! We are at the binding site of the name.
74 -- This is the moment when we know the SrcLoc
75 -- of the Name, so we set this field in the Name we return.
77 -- Then (bogus) multiple bindings of the same Name
78 -- get different SrcLocs can can be reported as such.
80 -- Possible other reason: it might be in the cache because we
81 -- encountered an occurrence before the binding site for an
82 -- implicitly-imported Name. Perhaps the current SrcLoc is
83 -- better... but not really: it'll still just say 'imported'
85 -- IMPORTANT: Don't mess with wired-in names.
86 -- Their wired-in-ness is in their NameSort
87 -- and their Module is correct.
89 Just name | isWiredInName name -> (name_supply, name)
90 | otherwise -> (new_name_supply, name')
92 uniq = nameUnique name
93 name' = mkExternalName uniq mod occ loc
94 new_cache = extendNameCache (nsNames name_supply) mod occ name'
95 new_name_supply = name_supply {nsNames = new_cache}
98 -- Build a completely new Name, and put it in the cache
99 Nothing -> (new_name_supply, name)
101 (us', us1) = splitUniqSupply (nsUniqs name_supply)
102 uniq = uniqFromSupply us1
103 name = mkExternalName uniq mod occ loc
104 new_cache = extendNameCache (nsNames name_supply) mod occ name
105 new_name_supply = name_supply {nsUniqs = us', nsNames = new_cache}
108 newImplicitBinder :: Name -- Base name
109 -> (OccName -> OccName) -- Occurrence name modifier
110 -> TcRnIf m n Name -- Implicit name
111 -- Called in BuildTyCl to allocate the implicit binders of type/class decls
112 -- For source type/class decls, this is the first occurrence
113 -- For iface ones, the LoadIface has alrady allocated a suitable name in the cache
114 newImplicitBinder base_name mk_sys_occ
115 | Just mod <- nameModule_maybe base_name
116 = newGlobalBinder mod occ loc
117 | otherwise -- When typechecking a [d| decl bracket |],
118 -- TH generates types, classes etc with Internal names,
119 -- so we follow suit for the implicit binders
120 = do { uniq <- newUnique
121 ; return (mkInternalName uniq occ loc) }
123 occ = mk_sys_occ (nameOccName base_name)
124 loc = nameSrcSpan base_name
126 ifaceExportNames :: [IfaceExport] -> TcRnIf gbl lcl [AvailInfo]
127 ifaceExportNames exports = do
128 mod_avails <- mapM (\(mod,avails) -> mapM (lookupAvail mod) avails) exports
129 return (concat mod_avails)
131 -- Convert OccNames in GenAvailInfo to Names.
132 lookupAvail :: Module -> GenAvailInfo OccName -> TcRnIf a b AvailInfo
133 lookupAvail mod (Avail n) = do
134 n' <- lookupOrig mod n
136 lookupAvail mod (AvailTC p_occ occs) = do
137 p_name <- lookupOrig mod p_occ
138 let lookup_sub occ | occ == p_occ = return p_name
139 | otherwise = lookupOrig mod occ
140 subs <- mapM lookup_sub occs
141 return (AvailTC p_name subs)
142 -- Remember that 'occs' is all the exported things, including
143 -- the parent. It's possible to export just class ops without
144 -- the class, which shows up as C( op ) here. If the class was
145 -- exported too we'd have C( C, op )
147 lookupOrig :: Module -> OccName -> TcRnIf a b Name
149 = do { -- First ensure that mod and occ are evaluated
150 -- If not, chaos can ensue:
151 -- we read the name-cache
152 -- then pull on mod (say)
153 -- which does some stuff that modifies the name cache
154 -- This did happen, with tycon_mod in TcIface.tcIfaceAlt (DataAlt..)
155 mod `seq` occ `seq` return ()
156 -- ; traceIf (text "lookup_orig" <+> ppr mod <+> ppr occ)
158 ; updNameCache $ \name_cache ->
159 case lookupOrigNameCache (nsNames name_cache) mod occ of {
160 Just name -> (name_cache, name);
163 us = nsUniqs name_cache
164 uniq = uniqFromSupply us
165 name = mkExternalName uniq mod occ noSrcSpan
166 new_cache = extendNameCache (nsNames name_cache) mod occ name
168 case splitUniqSupply us of { (us',_) -> do
169 (name_cache{ nsUniqs = us', nsNames = new_cache }, name)
172 newIPName :: IPName OccName -> TcRnIf m n (IPName Name)
173 newIPName occ_name_ip =
174 updNameCache $ \name_cache ->
176 ipcache = nsIPs name_cache
177 key = occ_name_ip -- Ensures that ?x and %x get distinct Names
179 case lookupFM ipcache key of
180 Just name_ip -> (name_cache, name_ip)
181 Nothing -> (new_ns, name_ip)
183 (us', us1) = splitUniqSupply (nsUniqs name_cache)
184 uniq = uniqFromSupply us1
185 name_ip = mapIPName (mkIPName uniq) occ_name_ip
186 new_ipcache = addToFM ipcache key name_ip
187 new_ns = name_cache {nsUniqs = us', nsIPs = new_ipcache}
190 %************************************************************************
194 %************************************************************************
197 lookupOrigNameCache :: OrigNameCache -> Module -> OccName -> Maybe Name
198 lookupOrigNameCache _ mod occ
199 -- XXX Why is gHC_UNIT not mentioned here?
200 | mod == gHC_TUPLE || mod == gHC_PRIM, -- Boxed tuples from one,
201 Just tup_info <- isTupleOcc_maybe occ -- unboxed from the other
202 = -- Special case for tuples; there are too many
203 -- of them to pre-populate the original-name cache
204 Just (mk_tup_name tup_info)
206 mk_tup_name (ns, boxity, arity)
207 | ns == tcName = tyConName (tupleTyCon boxity arity)
208 | ns == dataName = dataConName (tupleCon boxity arity)
209 | otherwise = Var.varName (dataConWorkId (tupleCon boxity arity))
211 lookupOrigNameCache nc mod occ -- The normal case
212 = case lookupModuleEnv nc mod of
214 Just occ_env -> lookupOccEnv occ_env occ
216 extendOrigNameCache :: OrigNameCache -> Name -> OrigNameCache
217 extendOrigNameCache nc name
218 = ASSERT2( isExternalName name, ppr name )
219 extendNameCache nc (nameModule name) (nameOccName name) name
221 extendNameCache :: OrigNameCache -> Module -> OccName -> Name -> OrigNameCache
222 extendNameCache nc mod occ name
223 = extendModuleEnv_C combine nc mod (unitOccEnv occ name)
225 combine occ_env _ = extendOccEnv occ_env occ name
227 getNameCache :: TcRnIf a b NameCache
228 getNameCache = do { HscEnv { hsc_NC = nc_var } <- getTopEnv;
231 updNameCache :: (NameCache -> (NameCache, c)) -> TcRnIf a b c
232 updNameCache upd_fn = do
233 HscEnv { hsc_NC = nc_var } <- getTopEnv
234 atomicUpdMutVar' nc_var upd_fn
236 -- | A function that atomically updates the name cache given a modifier
237 -- function. The second result of the modifier function will be the result
239 type NameCacheUpdater c = (NameCache -> (NameCache, c)) -> IO c
241 -- | Return a function to atomically update the name cache.
242 mkNameCacheUpdater :: TcRnIf a b (NameCacheUpdater c)
243 mkNameCacheUpdater = do
244 nc_var <- hsc_NC `fmap` getTopEnv
245 let update_nc f = do r <- atomicModifyIORef nc_var f
246 _ <- evaluate =<< readIORef nc_var
253 initNameCache :: UniqSupply -> [Name] -> NameCache
254 initNameCache us names
255 = NameCache { nsUniqs = us,
256 nsNames = initOrigNames names,
259 initOrigNames :: [Name] -> OrigNameCache
260 initOrigNames names = foldl extendOrigNameCache emptyModuleEnv names
265 %************************************************************************
267 Type variables and local Ids
269 %************************************************************************
272 tcIfaceLclId :: FastString -> IfL Id
274 = do { lcl <- getLclEnv
275 ; case (lookupUFM (if_id_env lcl) occ) of
276 Just ty_var -> return ty_var
277 Nothing -> failIfM (text "Iface id out of scope: " <+> ppr occ)
280 extendIfaceIdEnv :: [Id] -> IfL a -> IfL a
281 extendIfaceIdEnv ids thing_inside
282 = do { env <- getLclEnv
283 ; let { id_env' = addListToUFM (if_id_env env) pairs
284 ; pairs = [(occNameFS (getOccName id), id) | id <- ids] }
285 ; setLclEnv (env { if_id_env = id_env' }) thing_inside }
288 tcIfaceTyVar :: FastString -> IfL TyVar
290 = do { lcl <- getLclEnv
291 ; case (lookupUFM (if_tv_env lcl) occ) of
292 Just ty_var -> return ty_var
293 Nothing -> failIfM (text "Iface type variable out of scope: " <+> ppr occ)
296 lookupIfaceTyVar :: FastString -> IfL (Maybe TyVar)
298 = do { lcl <- getLclEnv
299 ; return (lookupUFM (if_tv_env lcl) occ) }
301 extendIfaceTyVarEnv :: [TyVar] -> IfL a -> IfL a
302 extendIfaceTyVarEnv tyvars thing_inside
303 = do { env <- getLclEnv
304 ; let { tv_env' = addListToUFM (if_tv_env env) pairs
305 ; pairs = [(occNameFS (getOccName tv), tv) | tv <- tyvars] }
306 ; setLclEnv (env { if_tv_env = tv_env' }) thing_inside }
310 %************************************************************************
312 Getting from RdrNames to Names
314 %************************************************************************
317 lookupIfaceTop :: OccName -> IfL Name
318 -- Look up a top-level name from the current Iface module
320 = do { env <- getLclEnv; lookupOrig (if_mod env) occ }
322 newIfaceName :: OccName -> IfL Name
324 = do { uniq <- newUnique
325 ; return $! mkInternalName uniq occ noSrcSpan }
327 newIfaceNames :: [OccName] -> IfL [Name]
329 = do { uniqs <- newUniqueSupply
330 ; return [ mkInternalName uniq occ noSrcSpan
331 | (occ,uniq) <- occs `zip` uniqsFromSupply uniqs] }
334 %************************************************************************
336 (Re)creating tick boxes
338 %************************************************************************
341 tcIfaceTick :: Module -> Int -> IfL Id
342 tcIfaceTick modName tickNo
343 = do { uniq <- newUnique
344 ; return $ mkTickBoxOpId uniq modName tickNo