1 (c) The University of Glasgow 2002
5 newGlobalBinder, newIPName, newImplicitBinder,
6 lookupIfaceTop, lookupIfaceExt,
7 lookupOrig, lookupIfaceTc,
8 newIfaceName, newIfaceNames,
9 extendIfaceIdEnv, extendIfaceTyVarEnv,
10 tcIfaceLclId, tcIfaceTyVar,
13 allocateGlobalBinder, initNameCache
16 #include "HsVersions.h"
19 import IfaceType ( IfaceExtName(..), IfaceTyCon(..), ifaceTyConName )
20 import TysWiredIn ( tupleTyCon, tupleCon )
21 import HscTypes ( NameCache(..), HscEnv(..),
22 TyThing, ExternalPackageState(..), OrigNameCache )
23 import TyCon ( TyCon, tyConName )
24 import Class ( Class )
25 import DataCon ( dataConWorkId, dataConName )
26 import Var ( TyVar, Id, varName )
27 import Name ( Name, nameUnique, nameModule,
28 nameOccName, nameSrcLoc,
29 getOccName, nameParent_maybe,
30 isWiredInName, mkIPName,
31 mkExternalName, mkInternalName )
33 import OccName ( OccName, isTupleOcc_maybe, tcName, dataName,
34 lookupOccEnv, unitOccEnv, extendOccEnv, extendOccEnvList )
35 import PrelNames ( gHC_PRIM_Name, pREL_TUP_Name )
36 import HscTypes ( ExternalPackageState, NameCache, TyThing(..) )
37 import Module ( Module, ModuleName, moduleName, mkPackageModule,
38 emptyModuleEnv, lookupModuleEnvByName, extendModuleEnv_C )
39 import UniqSupply ( UniqSupply, splitUniqSupply, uniqFromSupply, uniqsFromSupply )
40 import FiniteMap ( emptyFM, lookupFM, addToFM )
41 import BasicTypes ( IPName(..), mapIPName )
42 import SrcLoc ( SrcLoc, noSrcLoc )
43 import Maybes ( orElse )
49 %*********************************************************
51 Allocating new Names in the Name Cache
53 %*********************************************************
56 newGlobalBinder :: Module -> OccName -> Maybe Name -> SrcLoc -> TcRnIf a b Name
57 -- Used for source code and interface files, to make the
58 -- Name for a thing, given its Module and OccName
60 -- The cache may already already have a binding for this thing,
61 -- because we may have seen an occurrence before, but now is the
62 -- moment when we know its Module and SrcLoc in their full glory
64 newGlobalBinder mod occ mb_parent loc
65 = do { mod `seq` occ `seq` return () -- See notes with lookupOrig_help
66 ; name_supply <- getNameCache
67 ; let (name_supply', name) = allocateGlobalBinder
70 ; setNameCache name_supply'
75 -> Module -> OccName -> Maybe Name -> SrcLoc
77 allocateGlobalBinder name_supply mod occ mb_parent loc
78 = case lookupOrigNameCache (nsNames name_supply) (moduleName mod) occ of
79 -- A hit in the cache! We are at the binding site of the name.
80 -- This is the moment when we know the defining Module and SrcLoc
81 -- of the Name, so we set these fields in the Name we return.
83 -- This is essential, to get the right Module in a Name.
84 -- Also: then (bogus) multiple bindings of the same Name
85 -- get different SrcLocs can can be reported as such.
87 -- Possible other reason: it might be in the cache because we
88 -- encountered an occurrence before the binding site for an
89 -- implicitly-imported Name. Perhaps the current SrcLoc is
90 -- better... but not really: it'll still just say 'imported'
92 -- IMPORTANT: Don't mess with wired-in names.
93 -- Their wired-in-ness is in their NameSort
94 -- and their Module is correct.
96 Just name | isWiredInName name -> (name_supply, name)
97 | otherwise -> (new_name_supply, name')
99 uniq = nameUnique name
100 name' = mkExternalName uniq mod occ mb_parent loc
101 new_cache = extend_name_cache (nsNames name_supply) mod occ name'
102 new_name_supply = name_supply {nsNames = new_cache}
104 -- Miss in the cache!
105 -- Build a completely new Name, and put it in the cache
106 Nothing -> (new_name_supply, name)
108 (us', us1) = splitUniqSupply (nsUniqs name_supply)
109 uniq = uniqFromSupply us1
110 name = mkExternalName uniq mod occ mb_parent loc
111 new_cache = extend_name_cache (nsNames name_supply) mod occ name
112 new_name_supply = name_supply {nsUniqs = us', nsNames = new_cache}
115 newImplicitBinder :: Name -- Base name
116 -> (OccName -> OccName) -- Occurrence name modifier
117 -> TcRnIf m n Name -- Implicit name
118 -- Called in BuildTyCl to allocate the implicit binders of type/class decls
119 -- For source type/class decls, this is the first occurrence
120 -- For iface ones, the LoadIface has alrady allocated a suitable name in the cache
122 -- An *implicit* name has the base-name as parent
123 newImplicitBinder base_name mk_sys_occ
124 = newGlobalBinder (nameModule base_name)
125 (mk_sys_occ (nameOccName base_name))
127 (nameSrcLoc base_name)
129 parent_name = case nameParent_maybe base_name of
130 Just parent_name -> parent_name
133 lookupOrig :: ModuleName -> OccName -> TcRnIf a b Name
134 -- This one starts with a ModuleName, not a Module, because
135 -- we may be simply looking at an occurrence M.x in an interface file.
136 -- We may enounter this well before finding the binding site for M.x
138 -- So, even if we get a miss in the original-name cache, we
139 -- make a new External Name.
141 -- Module to AnotherPackage
142 -- SrcLoc to noSrcLoc
144 -- They'll be overwritten, in due course, by LoadIface.loadDecl.
146 lookupOrig mod_name occ
147 = do { -- First ensure that mod_name 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 mod `seq` occ `seq` return ()
155 ; name_supply <- getNameCache
156 ; case lookupOrigNameCache (nsNames name_supply) mod_name occ of {
157 Just name -> returnM name ;
160 { let { (us', us1) = splitUniqSupply (nsUniqs name_supply)
161 ; uniq = uniqFromSupply us1
162 ; name = mkExternalName uniq tmp_mod occ Nothing noSrcLoc
163 ; new_cache = extend_name_cache (nsNames name_supply) tmp_mod occ name
164 ; new_name_supply = name_supply {nsUniqs = us', nsNames = new_cache}
165 ; tmp_mod = mkPackageModule mod_name
166 -- Guess at the package-ness for now, becuase we don't know whether
167 -- this imported module is from the home package or not.
168 -- If we ever need it, we'll open its interface, and update the cache
169 -- with a better name (newGlobalBinder)
171 ; setNameCache new_name_supply
175 newIPName :: IPName OccName -> TcRnIf m n (IPName Name)
176 newIPName occ_name_ip
177 = getNameCache `thenM` \ name_supply ->
179 ipcache = nsIPs name_supply
181 case lookupFM ipcache key of
182 Just name_ip -> returnM name_ip
183 Nothing -> setNameCache new_ns `thenM_`
186 (us', us1) = splitUniqSupply (nsUniqs name_supply)
187 uniq = uniqFromSupply us1
188 name_ip = mapIPName (mkIPName uniq) occ_name_ip
189 new_ipcache = addToFM ipcache key name_ip
190 new_ns = name_supply {nsUniqs = us', nsIPs = new_ipcache}
192 key = occ_name_ip -- Ensures that ?x and %x get distinct Names
195 Local helper functions (not exported)
198 lookupOrigNameCache :: OrigNameCache -> ModuleName -> OccName -> Maybe Name
199 lookupOrigNameCache nc mod_name occ
200 | mod_name == pREL_TUP_Name || mod_name == gHC_PRIM_Name, -- 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 = varName (dataConWorkId (tupleCon boxity arity))
211 lookupOrigNameCache nc mod_name occ -- The normal case
212 = case lookupModuleEnvByName nc mod_name of
214 Just occ_env -> lookupOccEnv occ_env occ
216 extendOrigNameCache :: OrigNameCache -> Name -> OrigNameCache
217 extendOrigNameCache nc name
218 = extend_name_cache nc (nameModule name) (nameOccName name) name
220 extend_name_cache :: OrigNameCache -> Module -> OccName -> Name -> OrigNameCache
221 extend_name_cache nc mod occ name
222 = extendModuleEnv_C combine nc mod (unitOccEnv occ name)
224 combine occ_env _ = extendOccEnv occ_env occ name
226 getNameCache :: TcRnIf a b NameCache
227 getNameCache = do { HscEnv { hsc_NC = nc_var } <- getTopEnv;
230 setNameCache :: NameCache -> TcRnIf a b ()
231 setNameCache nc = do { HscEnv { hsc_NC = nc_var } <- getTopEnv;
232 writeMutVar nc_var nc }
237 initNameCache :: UniqSupply -> [Name] -> NameCache
238 initNameCache us names
239 = NameCache { nsUniqs = us,
240 nsNames = initOrigNames names,
243 initOrigNames :: [Name] -> OrigNameCache
244 initOrigNames names = foldl extendOrigNameCache emptyModuleEnv names
249 %************************************************************************
251 Type variables and local Ids
253 %************************************************************************
256 tcIfaceLclId :: OccName -> IfL Id
258 = do { lcl <- getLclEnv
259 ; return (lookupOccEnv (if_id_env lcl) occ
261 pprPanic "tcIfaceLclId" (ppr occ)) }
263 extendIfaceIdEnv :: [Id] -> IfL a -> IfL a
264 extendIfaceIdEnv ids thing_inside
265 = do { env <- getLclEnv
266 ; let { id_env' = extendOccEnvList (if_id_env env) pairs
267 ; pairs = [(getOccName id, id) | id <- ids] }
268 ; setLclEnv (env { if_id_env = id_env' }) thing_inside }
271 tcIfaceTyVar :: OccName -> IfL TyVar
273 = do { lcl <- getLclEnv
274 ; return (lookupOccEnv (if_tv_env lcl) occ
276 pprPanic "tcIfaceTyVar" (ppr occ)) }
278 extendIfaceTyVarEnv :: [TyVar] -> IfL a -> IfL a
279 extendIfaceTyVarEnv tyvars thing_inside
280 = do { env <- getLclEnv
281 ; let { tv_env' = extendOccEnvList (if_tv_env env) pairs
282 ; pairs = [(getOccName tv, tv) | tv <- tyvars] }
283 ; setLclEnv (env { if_tv_env = tv_env' }) thing_inside }
287 %************************************************************************
289 Getting from RdrNames to Names
291 %************************************************************************
294 lookupIfaceTc :: IfaceTyCon -> IfL Name
295 lookupIfaceTc (IfaceTc ext) = lookupIfaceExt ext
296 lookupIfaceTc other_tc = return (ifaceTyConName other_tc)
298 lookupIfaceExt :: IfaceExtName -> IfL Name
299 lookupIfaceExt (ExtPkg mod occ) = lookupOrig mod occ
300 lookupIfaceExt (HomePkg mod occ _) = lookupOrig mod occ
301 lookupIfaceExt (LocalTop occ) = lookupIfaceTop occ
302 lookupIfaceExt (LocalTopSub occ _) = lookupIfaceTop occ
304 lookupIfaceTop :: OccName -> IfL Name
305 -- Look up a top-level name from the current Iface module
307 = do { env <- getLclEnv; lookupOrig (if_mod env) occ }
309 newIfaceName :: OccName -> IfL Name
311 = do { uniq <- newUnique
312 ; return (mkInternalName uniq occ noSrcLoc) }
314 newIfaceNames :: [OccName] -> IfL [Name]
316 = do { uniqs <- newUniqueSupply
317 ; return [ mkInternalName uniq occ noSrcLoc
318 | (occ,uniq) <- occs `zip` uniqsFromSupply uniqs] }