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, setNameCache
20 #include "HsVersions.h"
43 %*********************************************************
45 Allocating new Names in the Name Cache
47 %*********************************************************
50 newGlobalBinder :: Module -> OccName -> SrcSpan -> TcRnIf a b Name
51 -- Used for source code and interface files, to make the
52 -- Name for a thing, given its Module and OccName
54 -- The cache may already already have a binding for this thing,
55 -- because we may have seen an occurrence before, but now is the
56 -- moment when we know its Module and SrcLoc in their full glory
58 newGlobalBinder mod occ loc
59 = do { mod `seq` occ `seq` return () -- See notes with lookupOrig_help
60 -- ; traceIf (text "newGlobalBinder" <+> ppr mod <+> ppr occ <+> ppr loc)
61 ; name_supply <- getNameCache
62 ; let (name_supply', name) = allocateGlobalBinder
65 ; setNameCache name_supply'
70 -> Module -> OccName -> SrcSpan
72 allocateGlobalBinder name_supply mod occ loc
73 = case lookupOrigNameCache (nsNames name_supply) mod occ of
74 -- A hit in the cache! We are at the binding site of the name.
75 -- This is the moment when we know the SrcLoc
76 -- of the Name, so we set this field in the Name we return.
78 -- Then (bogus) multiple bindings of the same Name
79 -- get different SrcLocs can can be reported as such.
81 -- Possible other reason: it might be in the cache because we
82 -- encountered an occurrence before the binding site for an
83 -- implicitly-imported Name. Perhaps the current SrcLoc is
84 -- better... but not really: it'll still just say 'imported'
86 -- IMPORTANT: Don't mess with wired-in names.
87 -- Their wired-in-ness is in their NameSort
88 -- and their Module is correct.
90 Just name | isWiredInName name -> (name_supply, name)
91 | otherwise -> (new_name_supply, name')
93 uniq = nameUnique name
94 name' = mkExternalName uniq mod occ loc
95 new_cache = extendNameCache (nsNames name_supply) mod occ name'
96 new_name_supply = name_supply {nsNames = new_cache}
99 -- Build a completely new Name, and put it in the cache
100 Nothing -> (new_name_supply, name)
102 (us', us1) = splitUniqSupply (nsUniqs name_supply)
103 uniq = uniqFromSupply us1
104 name = mkExternalName uniq mod occ loc
105 new_cache = extendNameCache (nsNames name_supply) mod occ name
106 new_name_supply = name_supply {nsUniqs = us', nsNames = new_cache}
109 newImplicitBinder :: Name -- Base name
110 -> (OccName -> OccName) -- Occurrence name modifier
111 -> TcRnIf m n Name -- Implicit name
112 -- Called in BuildTyCl to allocate the implicit binders of type/class decls
113 -- For source type/class decls, this is the first occurrence
114 -- For iface ones, the LoadIface has alrady allocated a suitable name in the cache
115 newImplicitBinder base_name mk_sys_occ
116 | Just mod <- nameModule_maybe base_name
117 = newGlobalBinder mod occ loc
118 | otherwise -- When typechecking a [d| decl bracket |],
119 -- TH generates types, classes etc with Internal names,
120 -- so we follow suit for the implicit binders
121 = do { uniq <- newUnique
122 ; return (mkInternalName uniq occ loc) }
124 occ = mk_sys_occ (nameOccName base_name)
125 loc = nameSrcSpan base_name
127 ifaceExportNames :: [IfaceExport] -> TcRnIf gbl lcl [AvailInfo]
128 ifaceExportNames exports = do
129 mod_avails <- mapM (\(mod,avails) -> mapM (lookupAvail mod) avails) exports
130 return (concat mod_avails)
132 -- Convert OccNames in GenAvailInfo to Names.
133 lookupAvail :: Module -> GenAvailInfo OccName -> TcRnIf a b AvailInfo
134 lookupAvail mod (Avail n) = do
135 n' <- lookupOrig mod n
137 lookupAvail mod (AvailTC p_occ occs) = do
138 p_name <- lookupOrig mod p_occ
139 let lookup_sub occ | occ == p_occ = return p_name
140 | otherwise = lookupOrig mod occ
141 subs <- mapM lookup_sub occs
142 return (AvailTC p_name subs)
143 -- Remember that 'occs' is all the exported things, including
144 -- the parent. It's possible to export just class ops without
145 -- the class, which shows up as C( op ) here. If the class was
146 -- exported too we'd have C( C, op )
148 lookupOrig :: Module -> OccName -> TcRnIf a b Name
150 = do { -- First ensure that mod and occ are evaluated
151 -- If not, chaos can ensue:
152 -- we read the name-cache
153 -- then pull on mod (say)
154 -- which does some stuff that modifies the name cache
155 -- This did happen, with tycon_mod in TcIface.tcIfaceAlt (DataAlt..)
156 mod `seq` occ `seq` return ()
157 -- ; traceIf (text "lookup_orig" <+> ppr mod <+> ppr occ)
159 ; name_cache <- getNameCache
160 ; case lookupOrigNameCache (nsNames name_cache) mod occ of {
161 Just name -> return name;
164 us = nsUniqs name_cache
165 uniq = uniqFromSupply us
166 name = mkExternalName uniq mod occ noSrcSpan
167 new_cache = extendNameCache (nsNames name_cache) mod occ name
169 case splitUniqSupply us of { (us',_) -> do
170 setNameCache name_cache{ nsUniqs = us', nsNames = new_cache }
174 newIPName :: IPName OccName -> TcRnIf m n (IPName Name)
175 newIPName occ_name_ip = do
176 name_supply <- getNameCache
178 ipcache = nsIPs name_supply
179 case lookupFM ipcache key of
180 Just name_ip -> return name_ip
181 Nothing -> do setNameCache new_ns
184 (us', us1) = splitUniqSupply (nsUniqs name_supply)
185 uniq = uniqFromSupply us1
186 name_ip = mapIPName (mkIPName uniq) occ_name_ip
187 new_ipcache = addToFM ipcache key name_ip
188 new_ns = name_supply {nsUniqs = us', nsIPs = new_ipcache}
190 key = occ_name_ip -- Ensures that ?x and %x get distinct Names
193 %************************************************************************
197 %************************************************************************
200 lookupOrigNameCache :: OrigNameCache -> Module -> OccName -> Maybe Name
201 lookupOrigNameCache _ mod occ
202 -- XXX Why is gHC_UNIT not mentioned here?
203 | mod == gHC_TUPLE || mod == gHC_PRIM, -- Boxed tuples from one,
204 Just tup_info <- isTupleOcc_maybe occ -- unboxed from the other
205 = -- Special case for tuples; there are too many
206 -- of them to pre-populate the original-name cache
207 Just (mk_tup_name tup_info)
209 mk_tup_name (ns, boxity, arity)
210 | ns == tcName = tyConName (tupleTyCon boxity arity)
211 | ns == dataName = dataConName (tupleCon boxity arity)
212 | otherwise = Var.varName (dataConWorkId (tupleCon boxity arity))
214 lookupOrigNameCache nc mod occ -- The normal case
215 = case lookupModuleEnv nc mod of
217 Just occ_env -> lookupOccEnv occ_env occ
219 extendOrigNameCache :: OrigNameCache -> Name -> OrigNameCache
220 extendOrigNameCache nc name
221 = ASSERT2( isExternalName name, ppr name )
222 extendNameCache nc (nameModule name) (nameOccName name) name
224 extendNameCache :: OrigNameCache -> Module -> OccName -> Name -> OrigNameCache
225 extendNameCache nc mod occ name
226 = extendModuleEnv_C combine nc mod (unitOccEnv occ name)
228 combine occ_env _ = extendOccEnv occ_env occ name
230 getNameCache :: TcRnIf a b NameCache
231 getNameCache = do { HscEnv { hsc_NC = nc_var } <- getTopEnv;
234 setNameCache :: NameCache -> TcRnIf a b ()
235 setNameCache nc = do { HscEnv { hsc_NC = nc_var } <- getTopEnv;
236 writeMutVar nc_var nc }
241 initNameCache :: UniqSupply -> [Name] -> NameCache
242 initNameCache us names
243 = NameCache { nsUniqs = us,
244 nsNames = initOrigNames names,
247 initOrigNames :: [Name] -> OrigNameCache
248 initOrigNames names = foldl extendOrigNameCache emptyModuleEnv names
253 %************************************************************************
255 Type variables and local Ids
257 %************************************************************************
260 tcIfaceLclId :: FastString -> IfL Id
262 = do { lcl <- getLclEnv
263 ; case (lookupUFM (if_id_env lcl) occ) of
264 Just ty_var -> return ty_var
265 Nothing -> failIfM (text "Iface id out of scope: " <+> ppr occ)
268 extendIfaceIdEnv :: [Id] -> IfL a -> IfL a
269 extendIfaceIdEnv ids thing_inside
270 = do { env <- getLclEnv
271 ; let { id_env' = addListToUFM (if_id_env env) pairs
272 ; pairs = [(occNameFS (getOccName id), id) | id <- ids] }
273 ; setLclEnv (env { if_id_env = id_env' }) thing_inside }
276 tcIfaceTyVar :: FastString -> IfL TyVar
278 = do { lcl <- getLclEnv
279 ; case (lookupUFM (if_tv_env lcl) occ) of
280 Just ty_var -> return ty_var
281 Nothing -> failIfM (text "Iface type variable out of scope: " <+> ppr occ)
284 lookupIfaceTyVar :: FastString -> IfL (Maybe TyVar)
286 = do { lcl <- getLclEnv
287 ; return (lookupUFM (if_tv_env lcl) occ) }
289 extendIfaceTyVarEnv :: [TyVar] -> IfL a -> IfL a
290 extendIfaceTyVarEnv tyvars thing_inside
291 = do { env <- getLclEnv
292 ; let { tv_env' = addListToUFM (if_tv_env env) pairs
293 ; pairs = [(occNameFS (getOccName tv), tv) | tv <- tyvars] }
294 ; setLclEnv (env { if_tv_env = tv_env' }) thing_inside }
298 %************************************************************************
300 Getting from RdrNames to Names
302 %************************************************************************
305 lookupIfaceTop :: OccName -> IfL Name
306 -- Look up a top-level name from the current Iface module
308 = do { env <- getLclEnv; lookupOrig (if_mod env) occ }
310 newIfaceName :: OccName -> IfL Name
312 = do { uniq <- newUnique
313 ; return $! mkInternalName uniq occ noSrcSpan }
315 newIfaceNames :: [OccName] -> IfL [Name]
317 = do { uniqs <- newUniqueSupply
318 ; return [ mkInternalName uniq occ noSrcSpan
319 | (occ,uniq) <- occs `zip` uniqsFromSupply uniqs] }
322 %************************************************************************
324 (Re)creating tick boxes
326 %************************************************************************
329 tcIfaceTick :: Module -> Int -> IfL Id
330 tcIfaceTick modName tickNo
331 = do { uniq <- newUnique
332 ; return $ mkTickBoxOpId uniq modName tickNo