1 (c) The University of Glasgow 2002
5 newGlobalBinder, newIPName, newImplicitBinder,
6 lookupIfaceTop, lookupIfaceExt,
7 lookupOrig, lookupIfaceTc,
8 newIfaceName, newIfaceNames,
9 extendIfaceIdEnv, extendIfaceTyVarEnv, refineIfaceIdEnv,
10 tcIfaceLclId, tcIfaceTyVar,
12 lookupAvail, ifaceExportNames,
15 allocateGlobalBinder, initNameCache,
18 #include "HsVersions.h"
21 import IfaceType ( IfaceExtName(..), IfaceTyCon(..), ifaceTyConName )
22 import TysWiredIn ( tupleTyCon, tupleCon )
23 import HscTypes ( NameCache(..), HscEnv(..), GenAvailInfo(..),
24 IfaceExport, OrigNameCache )
25 import Type ( mkOpenTvSubst, substTy )
26 import TyCon ( TyCon, tyConName )
27 import Unify ( TypeRefinement )
28 import DataCon ( dataConWorkId, dataConName )
29 import Var ( TyVar, Id, varName, setIdType, idType )
30 import Name ( Name, nameUnique, nameModule,
31 nameOccName, nameSrcLoc,
32 getOccName, nameParent_maybe,
33 isWiredInName, mkIPName,
34 mkExternalName, mkInternalName )
35 import NameSet ( NameSet, emptyNameSet, addListToNameSet )
36 import OccName ( OccName, isTupleOcc_maybe, tcName, dataName, mapOccEnv, occNameFS,
37 lookupOccEnv, unitOccEnv, extendOccEnv, extendOccEnvList )
38 import PrelNames ( gHC_PRIM, dATA_TUP )
39 import Module ( Module, emptyModuleEnv, ModuleName, modulePackageId,
40 lookupModuleEnv, extendModuleEnv_C, mkModule )
41 import UniqFM ( lookupUFM, addListToUFM )
42 import FastString ( FastString )
43 import UniqSupply ( UniqSupply, splitUniqSupply, uniqFromSupply, uniqsFromSupply )
44 import FiniteMap ( emptyFM, lookupFM, addToFM )
45 import BasicTypes ( IPName(..), mapIPName )
46 import SrcLoc ( SrcLoc, noSrcLoc )
52 %*********************************************************
54 Allocating new Names in the Name Cache
56 %*********************************************************
59 newGlobalBinder :: Module -> OccName -> Maybe Name -> SrcLoc -> TcRnIf a b Name
60 -- Used for source code and interface files, to make the
61 -- Name for a thing, given its Module and OccName
63 -- The cache may already already have a binding for this thing,
64 -- because we may have seen an occurrence before, but now is the
65 -- moment when we know its Module and SrcLoc in their full glory
67 newGlobalBinder mod occ mb_parent loc
68 = do { mod `seq` occ `seq` return () -- See notes with lookupOrig_help
69 -- ; traceIf (text "newGlobalBinder" <+> ppr mod <+> ppr occ <+> ppr loc)
70 ; name_supply <- getNameCache
71 ; let (name_supply', name) = allocateGlobalBinder
74 ; setNameCache name_supply'
79 -> Module -> OccName -> Maybe Name -> SrcLoc
81 allocateGlobalBinder name_supply mod occ mb_parent loc
82 = case lookupOrigNameCache (nsNames name_supply) mod occ of
83 -- A hit in the cache! We are at the binding site of the name.
84 -- This is the moment when we know the defining parent and SrcLoc
85 -- of the Name, so we set these fields in the Name we return.
87 -- Then (bogus) multiple bindings of the same Name
88 -- get different SrcLocs can can be reported as such.
90 -- Possible other reason: it might be in the cache because we
91 -- encountered an occurrence before the binding site for an
92 -- implicitly-imported Name. Perhaps the current SrcLoc is
93 -- better... but not really: it'll still just say 'imported'
95 -- IMPORTANT: Don't mess with wired-in names.
96 -- Their wired-in-ness is in their NameSort
97 -- and their Module is correct.
99 Just name | isWiredInName name -> (name_supply, name)
100 | otherwise -> (new_name_supply, name')
102 uniq = nameUnique name
103 name' = mkExternalName uniq mod occ mb_parent loc
104 new_cache = extend_name_cache (nsNames name_supply) mod occ name'
105 new_name_supply = name_supply {nsNames = new_cache}
107 -- Miss in the cache!
108 -- Build a completely new Name, and put it in the cache
109 Nothing -> (new_name_supply, name)
111 (us', us1) = splitUniqSupply (nsUniqs name_supply)
112 uniq = uniqFromSupply us1
113 name = mkExternalName uniq mod occ mb_parent loc
114 new_cache = extend_name_cache (nsNames name_supply) mod occ name
115 new_name_supply = name_supply {nsUniqs = us', nsNames = new_cache}
118 newImplicitBinder :: Name -- Base name
119 -> (OccName -> OccName) -- Occurrence name modifier
120 -> TcRnIf m n Name -- Implicit name
121 -- Called in BuildTyCl to allocate the implicit binders of type/class decls
122 -- For source type/class decls, this is the first occurrence
123 -- For iface ones, the LoadIface has alrady allocated a suitable name in the cache
125 -- An *implicit* name has the base-name as parent
126 newImplicitBinder base_name mk_sys_occ
127 = newGlobalBinder (nameModule base_name)
128 (mk_sys_occ (nameOccName base_name))
130 (nameSrcLoc base_name)
132 parent_name = case nameParent_maybe base_name of
133 Just parent_name -> parent_name
136 ifaceExportNames :: [IfaceExport] -> TcRnIf gbl lcl NameSet
137 ifaceExportNames exports
138 = foldlM do_one emptyNameSet exports
140 do_one acc (mod, exports) = foldlM (do_avail mod) acc exports
141 do_avail mod acc avail = do { ns <- lookupAvail mod avail
142 ; return (addListToNameSet acc ns) }
144 lookupAvail :: Module -> GenAvailInfo OccName -> TcRnIf a b [Name]
145 -- Find all the names arising from an import
146 -- Make sure the parent info is correct, even though we may not
147 -- yet have read the interface for this module
148 lookupAvail mod (Avail n) = do { n' <- lookupOrig mod n;
150 lookupAvail mod (AvailTC p_occ occs)
151 = do { p_name <- lookupOrig mod p_occ
152 ; let lookup_sub occ | occ == p_occ = return p_name
153 | otherwise = lookup_orig mod occ (Just p_name)
154 ; mappM lookup_sub occs }
155 -- Remember that 'occs' is all the exported things, including
156 -- the parent. It's possible to export just class ops without
157 -- the class, via C( op ). If the class was exported too we'd
160 -- The use of lookupOrigSub here (rather than lookupOrig)
161 -- ensures that the subordinate names record their parent;
162 -- and that in turn ensures that the GlobalRdrEnv
163 -- has the correct parent for all the names in its range.
164 -- For imported things, we may only suck in the interface later, if ever.
165 -- Reason for all this:
166 -- Suppose module M exports type A.T, and constructor A.MkT
167 -- Then, we know that A.MkT is a subordinate name of A.T,
168 -- even though we aren't at the binding site of A.T
169 -- And it's important, because we may simply re-export A.T
170 -- without ever sucking in the declaration itself.
173 lookupOrig :: Module -> OccName -> TcRnIf a b Name
174 -- Even if we get a miss in the original-name cache, we
175 -- make a new External Name.
177 -- SrcLoc to noSrcLoc
179 -- They'll be overwritten, in due course, by LoadIface.loadDecl.
180 lookupOrig mod occ = lookup_orig mod occ Nothing
182 lookup_orig :: Module -> OccName -> Maybe Name -> TcRnIf a b Name
183 -- Used when we know the parent of the thing we are looking up
184 lookup_orig mod occ mb_parent
185 = do { -- First ensure that mod and occ are evaluated
186 -- If not, chaos can ensue:
187 -- we read the name-cache
188 -- then pull on mod (say)
189 -- which does some stuff that modifies the name cache
190 -- This did happen, with tycon_mod in TcIface.tcIfaceAlt (DataAlt..)
191 mod `seq` occ `seq` return ()
193 ; name_supply <- getNameCache
194 ; case lookupOrigNameCache (nsNames name_supply) mod occ of {
195 Just name -> returnM name ;
198 { let { (us', us1) = splitUniqSupply (nsUniqs name_supply)
199 ; uniq = uniqFromSupply us1
200 ; name = mkExternalName uniq mod occ mb_parent noSrcLoc
201 ; new_cache = extend_name_cache (nsNames name_supply) mod occ name
202 ; new_name_supply = name_supply {nsUniqs = us', nsNames = new_cache}
204 ; setNameCache new_name_supply
208 newIPName :: IPName OccName -> TcRnIf m n (IPName Name)
209 newIPName occ_name_ip
210 = getNameCache `thenM` \ name_supply ->
212 ipcache = nsIPs name_supply
214 case lookupFM ipcache key of
215 Just name_ip -> returnM name_ip
216 Nothing -> setNameCache new_ns `thenM_`
219 (us', us1) = splitUniqSupply (nsUniqs name_supply)
220 uniq = uniqFromSupply us1
221 name_ip = mapIPName (mkIPName uniq) occ_name_ip
222 new_ipcache = addToFM ipcache key name_ip
223 new_ns = name_supply {nsUniqs = us', nsIPs = new_ipcache}
225 key = occ_name_ip -- Ensures that ?x and %x get distinct Names
228 Local helper functions (not exported)
231 lookupOrigNameCache :: OrigNameCache -> Module -> OccName -> Maybe Name
232 lookupOrigNameCache nc mod occ
233 | mod == dATA_TUP || mod == gHC_PRIM, -- Boxed tuples from one,
234 Just tup_info <- isTupleOcc_maybe occ -- unboxed from the other
235 = -- Special case for tuples; there are too many
236 -- of them to pre-populate the original-name cache
237 Just (mk_tup_name tup_info)
239 mk_tup_name (ns, boxity, arity)
240 | ns == tcName = tyConName (tupleTyCon boxity arity)
241 | ns == dataName = dataConName (tupleCon boxity arity)
242 | otherwise = varName (dataConWorkId (tupleCon boxity arity))
244 lookupOrigNameCache nc mod occ -- The normal case
245 = case lookupModuleEnv nc mod of
247 Just occ_env -> lookupOccEnv occ_env occ
249 extendOrigNameCache :: OrigNameCache -> Name -> OrigNameCache
250 extendOrigNameCache nc name
251 = extend_name_cache nc (nameModule name) (nameOccName name) name
253 extend_name_cache :: OrigNameCache -> Module -> OccName -> Name -> OrigNameCache
254 extend_name_cache nc mod occ name
255 = extendModuleEnv_C combine nc mod (unitOccEnv occ name)
257 combine occ_env _ = extendOccEnv occ_env occ name
259 getNameCache :: TcRnIf a b NameCache
260 getNameCache = do { HscEnv { hsc_NC = nc_var } <- getTopEnv;
263 setNameCache :: NameCache -> TcRnIf a b ()
264 setNameCache nc = do { HscEnv { hsc_NC = nc_var } <- getTopEnv;
265 writeMutVar nc_var nc }
270 initNameCache :: UniqSupply -> [Name] -> NameCache
271 initNameCache us names
272 = NameCache { nsUniqs = us,
273 nsNames = initOrigNames names,
276 initOrigNames :: [Name] -> OrigNameCache
277 initOrigNames names = foldl extendOrigNameCache emptyModuleEnv names
282 %************************************************************************
284 Type variables and local Ids
286 %************************************************************************
289 tcIfaceLclId :: FastString -> IfL Id
291 = do { lcl <- getLclEnv
292 ; case (lookupUFM (if_id_env lcl) occ) of
293 Just ty_var -> return ty_var
294 Nothing -> failIfM (text "Iface id out of scope: " <+> ppr occ)
297 refineIfaceIdEnv :: TypeRefinement -> IfL a -> IfL a
298 refineIfaceIdEnv (tv_subst, _) thing_inside
299 = do { env <- getLclEnv
300 ; let { id_env' = mapOccEnv refine_id (if_id_env env)
301 ; refine_id id = setIdType id (substTy subst (idType id))
302 ; subst = mkOpenTvSubst tv_subst }
303 ; setLclEnv (env { if_id_env = id_env' }) thing_inside }
305 extendIfaceIdEnv :: [Id] -> IfL a -> IfL a
306 extendIfaceIdEnv ids thing_inside
307 = do { env <- getLclEnv
308 ; let { id_env' = addListToUFM (if_id_env env) pairs
309 ; pairs = [(occNameFS (getOccName id), id) | id <- ids] }
310 ; setLclEnv (env { if_id_env = id_env' }) thing_inside }
313 tcIfaceTyVar :: FastString -> IfL TyVar
315 = do { lcl <- getLclEnv
316 ; case (lookupUFM (if_tv_env lcl) occ) of
317 Just ty_var -> return ty_var
318 Nothing -> failIfM (text "Iface type variable out of scope: " <+> ppr occ)
321 extendIfaceTyVarEnv :: [TyVar] -> IfL a -> IfL a
322 extendIfaceTyVarEnv tyvars thing_inside
323 = do { env <- getLclEnv
324 ; let { tv_env' = addListToUFM (if_tv_env env) pairs
325 ; pairs = [(occNameFS (getOccName tv), tv) | tv <- tyvars] }
326 ; setLclEnv (env { if_tv_env = tv_env' }) thing_inside }
330 %************************************************************************
332 Getting from RdrNames to Names
334 %************************************************************************
337 lookupIfaceTc :: IfaceTyCon -> IfL Name
338 lookupIfaceTc (IfaceTc ext) = lookupIfaceExt ext
339 lookupIfaceTc other_tc = return (ifaceTyConName other_tc)
341 lookupIfaceExt :: IfaceExtName -> IfL Name
342 lookupIfaceExt (ExtPkg mod occ) = lookupOrig mod occ
343 lookupIfaceExt (HomePkg mod occ _) = lookupHomePackage mod occ
344 lookupIfaceExt (LocalTop occ) = lookupIfaceTop occ
345 lookupIfaceExt (LocalTopSub occ _) = lookupIfaceTop occ
347 lookupIfaceTop :: OccName -> IfL Name
348 -- Look up a top-level name from the current Iface module
350 = do { env <- getLclEnv; lookupOrig (if_mod env) occ }
352 lookupHomePackage :: ModuleName -> OccName -> IfL Name
353 lookupHomePackage mod_name occ
354 = do { env <- getLclEnv;
355 ; let this_pkg = modulePackageId (if_mod env)
356 ; lookupOrig (mkModule this_pkg mod_name) occ }
358 newIfaceName :: OccName -> IfL Name
360 = do { uniq <- newUnique
361 ; return $! mkInternalName uniq occ noSrcLoc }
363 newIfaceNames :: [OccName] -> IfL [Name]
365 = do { uniqs <- newUniqueSupply
366 ; return [ mkInternalName uniq occ noSrcLoc
367 | (occ,uniq) <- occs `zip` uniqsFromSupply uniqs] }