1 (c) The University of Glasgow 2002
5 newGlobalBinder, newIPName, newImplicitBinder,
6 lookupIfaceTop, lookupIfaceExt,
7 lookupOrig, lookupImplicitOrig, lookupIfaceTc,
8 newIfaceName, newIfaceNames,
9 extendIfaceIdEnv, extendIfaceTyVarEnv,
10 tcIfaceGlobal, tcIfaceTyCon, tcIfaceClass, tcIfaceExtId,
11 tcIfaceTyVar, tcIfaceDataCon, tcIfaceLclId,
14 allocateGlobalBinder, extendOrigNameCache, initNameCache
17 #include "HsVersions.h"
19 import {-# SOURCE #-} TcIface( tcImportDecl )
22 import IfaceType ( IfaceExtName(..), IfaceTyCon(..), ifaceTyConName )
23 import HscTypes ( NameCache(..), HscEnv(..),
24 TyThing, tyThingClass, tyThingTyCon,
25 ExternalPackageState(..), OrigNameCache, lookupType )
26 import TyCon ( TyCon, tyConName )
27 import Class ( Class )
28 import DataCon ( DataCon, dataConWorkId, dataConName )
29 import Var ( TyVar, Id, varName )
30 import Name ( Name, nameUnique, nameModule, nameModuleName,
31 nameOccName, nameSrcLoc,
32 getOccName, nameParent_maybe,
33 isWiredInName, nameIsLocalOrFrom, mkIPName,
34 mkExternalName, mkInternalName )
36 import OccName ( OccName, isTupleOcc_maybe, tcName, dataName,
37 lookupOccEnv, unitOccEnv, extendOccEnv, extendOccEnvList )
38 import PrelNames ( gHC_PRIM_Name, pREL_TUP_Name )
39 import TysWiredIn ( intTyCon, boolTyCon, charTyCon, listTyCon, parrTyCon,
40 tupleTyCon, tupleCon )
41 import HscTypes ( ExternalPackageState, NameCache, TyThing(..) )
42 import Module ( Module, ModuleName, moduleName, mkPackageModule,
43 emptyModuleEnv, lookupModuleEnvByName, extendModuleEnv_C )
44 import UniqSupply ( UniqSupply, splitUniqSupply, uniqFromSupply, uniqsFromSupply )
45 import FiniteMap ( emptyFM, lookupFM, addToFM )
46 import BasicTypes ( IPName(..), mapIPName )
47 import SrcLoc ( SrcLoc, noSrcLoc )
48 import Maybes ( orElse )
54 %*********************************************************
56 Allocating new Names in the Name Cache
58 %*********************************************************
61 newGlobalBinder :: Module -> OccName -> Maybe Name -> SrcLoc -> TcRnIf a b Name
62 -- Used for source code and interface files, to make the
63 -- Name for a thing, given its Module and OccName
65 -- The cache may already already have a binding for this thing,
66 -- because we may have seen an occurrence before, but now is the
67 -- moment when we know its Module and SrcLoc in their full glory
69 newGlobalBinder mod occ mb_parent loc
70 = do { mod `seq` occ `seq` return () -- See notes with lookupOrig_help
71 ; name_supply <- getNameCache
72 ; let (name_supply', name) = allocateGlobalBinder
75 ; setNameCache name_supply'
80 -> Module -> OccName -> Maybe Name -> SrcLoc
82 allocateGlobalBinder name_supply mod occ mb_parent loc
83 = case lookupOrigNameCache (nsNames name_supply) (moduleName mod) occ of
84 -- A hit in the cache! We are at the binding site of the name.
85 -- This is the moment when we know the defining Module and SrcLoc
86 -- of the Name, so we set these fields in the Name we return.
88 -- This is essential, to get the right Module in a Name.
89 -- Also: then (bogus) multiple bindings of the same Name
90 -- get different SrcLocs can can be reported as such.
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'
97 -- IMPORTANT: Don't mess with wired-in names.
98 -- Their wired-in-ness is in their NameSort
99 -- and their Module is correct.
101 Just name | isWiredInName name -> (name_supply, name)
102 | otherwise -> (new_name_supply, name')
104 uniq = nameUnique name
105 name' = mkExternalName uniq mod occ mb_parent loc
106 new_cache = extend_name_cache (nsNames name_supply) mod occ name'
107 new_name_supply = name_supply {nsNames = new_cache}
109 -- Miss in the cache!
110 -- Build a completely new Name, and put it in the cache
111 Nothing -> (new_name_supply, name)
113 (us', us1) = splitUniqSupply (nsUniqs name_supply)
114 uniq = uniqFromSupply us1
115 name = mkExternalName uniq mod occ mb_parent loc
116 new_cache = extend_name_cache (nsNames name_supply) mod occ name
117 new_name_supply = name_supply {nsUniqs = us', nsNames = new_cache}
120 newImplicitBinder :: Name -- Base name
121 -> (OccName -> OccName) -- Occurrence name modifier
122 -> TcRnIf m n Name -- Implicit name
123 -- Called in BuildTyCl to allocate the implicit binders of type/class decls
124 -- For source type/class decls, this is the first occurrence
125 -- For iface ones, the LoadIface has alrady allocated a suitable name in the cache
127 -- An *implicit* name has the base-name as parent
128 newImplicitBinder base_name mk_sys_occ
129 = newGlobalBinder (nameModule base_name)
130 (mk_sys_occ (nameOccName base_name))
132 (nameSrcLoc base_name)
134 parent_name = case nameParent_maybe base_name of
135 Just parent_name -> parent_name
138 lookupOrig :: ModuleName -> OccName -> TcRnIf a b Name
139 -- This one starts with a ModuleName, not a Module, because
140 -- we may be simply looking at an occurrence M.x in an interface file.
141 -- We may enounter this well before finding the binding site for M.x
143 -- So, even if we get a miss in the original-name cache, we
144 -- make a new External Name.
146 -- Module to AnotherPackage
147 -- SrcLoc to noSrcLoc
148 -- They'll be overwritten, in due course, by LoadIface.loadDecl.
149 lookupOrig mod_name occ = lookupOrig_help mod_name occ Nothing
151 lookupImplicitOrig :: Name -> OccName -> TcRnIf m n Name
152 -- Same as lookupOrig, but install (Just parent) as the
153 -- parent Name. This is used when looking at the exports
155 -- Suppose module M exports type A.T, and constructor A.MkT
156 -- Then, we know that A.MkT is an implicit name of A.T,
157 -- even though we aren't at the binding site of A.T
158 -- And it's important, because we may simply re-export A.T
159 -- without ever sucking in the declaration itself.
160 lookupImplicitOrig name occ
161 = lookupOrig_help (nameModuleName name) occ (Just name)
163 lookupOrig_help :: ModuleName -> OccName -> Maybe Name -> TcRnIf a b Name
164 -- Local helper, not exported
165 lookupOrig_help mod_name occ mb_parent
166 = do { -- First ensure that mod_name and occ are evaluated
167 -- If not, chaos can ensue:
168 -- we read the name-cache
169 -- then pull on mod (say)
170 -- which does some stuff that modifies the name cache
171 -- This did happen, with tycon_mod in TcIface.tcIfaceAlt (DataAlt..)
172 mod `seq` occ `seq` return ()
174 ; name_supply <- getNameCache
175 ; case lookupOrigNameCache (nsNames name_supply) mod_name occ of {
176 Just name -> returnM name ;
179 { let { (us', us1) = splitUniqSupply (nsUniqs name_supply)
180 ; uniq = uniqFromSupply us1
181 ; name = mkExternalName uniq tmp_mod occ mb_parent noSrcLoc
182 ; new_cache = extend_name_cache (nsNames name_supply) tmp_mod occ name
183 ; new_name_supply = name_supply {nsUniqs = us', nsNames = new_cache}
184 ; tmp_mod = mkPackageModule mod_name
185 -- Guess at the package-ness for now, becuase we don't know whether
186 -- this imported module is from the home package or not.
187 -- If we ever need it, we'll open its interface, and update the cache
188 -- with a better name (newGlobalBinder)
190 ; setNameCache new_name_supply
194 newIPName :: IPName OccName -> TcRnIf m n (IPName Name)
195 newIPName occ_name_ip
196 = getNameCache `thenM` \ name_supply ->
198 ipcache = nsIPs name_supply
200 case lookupFM ipcache key of
201 Just name_ip -> returnM name_ip
202 Nothing -> setNameCache new_ns `thenM_`
205 (us', us1) = splitUniqSupply (nsUniqs name_supply)
206 uniq = uniqFromSupply us1
207 name_ip = mapIPName (mkIPName uniq) occ_name_ip
208 new_ipcache = addToFM ipcache key name_ip
209 new_ns = name_supply {nsUniqs = us', nsIPs = new_ipcache}
211 key = occ_name_ip -- Ensures that ?x and %x get distinct Names
214 Local helper functions (not exported)
217 lookupOrigNameCache :: OrigNameCache -> ModuleName -> OccName -> Maybe Name
218 lookupOrigNameCache nc mod_name occ
219 | mod_name == pREL_TUP_Name || mod_name == gHC_PRIM_Name, -- Boxed tuples from one,
220 Just tup_info <- isTupleOcc_maybe occ -- unboxed from the other
221 = -- Special case for tuples; there are too many
222 -- of them to pre-populate the original-name cache
223 Just (mk_tup_name tup_info)
225 mk_tup_name (ns, boxity, arity)
226 | ns == tcName = tyConName (tupleTyCon boxity arity)
227 | ns == dataName = dataConName (tupleCon boxity arity)
228 | otherwise = varName (dataConWorkId (tupleCon boxity arity))
230 lookupOrigNameCache nc mod_name occ -- The normal case
231 = case lookupModuleEnvByName nc mod_name of
233 Just occ_env -> lookupOccEnv occ_env occ
235 extendOrigNameCache :: OrigNameCache -> Name -> OrigNameCache
236 extendOrigNameCache nc name
237 = extend_name_cache nc (nameModule name) (nameOccName name) name
239 extend_name_cache :: OrigNameCache -> Module -> OccName -> Name -> OrigNameCache
240 extend_name_cache nc mod occ name
241 = extendModuleEnv_C combine nc mod (unitOccEnv occ name)
243 combine occ_env _ = extendOccEnv occ_env occ name
245 getNameCache :: TcRnIf a b NameCache
246 getNameCache = do { HscEnv { hsc_NC = nc_var } <- getTopEnv;
249 setNameCache :: NameCache -> TcRnIf a b ()
250 setNameCache nc = do { HscEnv { hsc_NC = nc_var } <- getTopEnv;
251 writeMutVar nc_var nc }
256 initNameCache :: UniqSupply -> [Name] -> NameCache
257 initNameCache us names
258 = NameCache { nsUniqs = us,
259 nsNames = initOrigNames names,
262 initOrigNames :: [Name] -> OrigNameCache
263 initOrigNames names = foldl extendOrigNameCache emptyModuleEnv names
267 %************************************************************************
269 Getting from Names to TyThings
271 %************************************************************************
274 tcIfaceGlobal :: Name -> IfM a TyThing
278 ; case lookupType hpt (eps_PTE eps) name of {
279 Just thing -> return thing ;
282 setLclEnv () $ do -- This gets us back to IfG, mainly to
283 -- pacify get_type_env; rather untidy
285 ; case if_rec_types env of
286 Just (mod, get_type_env)
287 | nameIsLocalOrFrom mod name
288 -> do -- It's defined in the module being compiled
289 { type_env <- get_type_env
290 ; case lookupNameEnv type_env name of
291 Just thing -> return thing
292 Nothing -> pprPanic "tcIfaceGlobal (local): not found:"
293 (ppr name $$ ppr type_env) }
295 other -> tcImportDecl name -- It's imported; go get it
298 tcIfaceTyCon :: IfaceTyCon -> IfL TyCon
299 tcIfaceTyCon IfaceIntTc = return intTyCon
300 tcIfaceTyCon IfaceBoolTc = return boolTyCon
301 tcIfaceTyCon IfaceCharTc = return charTyCon
302 tcIfaceTyCon IfaceListTc = return listTyCon
303 tcIfaceTyCon IfacePArrTc = return parrTyCon
304 tcIfaceTyCon (IfaceTupTc bx ar) = return (tupleTyCon bx ar)
305 tcIfaceTyCon (IfaceTc ext_nm) = do { name <- lookupIfaceExt ext_nm
306 ; thing <- tcIfaceGlobal name
307 ; return (tyThingTyCon thing) }
309 tcIfaceClass :: IfaceExtName -> IfL Class
310 tcIfaceClass rdr_name = do { name <- lookupIfaceExt rdr_name
311 ; thing <- tcIfaceGlobal name
312 ; return (tyThingClass thing) }
314 tcIfaceDataCon :: IfaceExtName -> IfL DataCon
315 tcIfaceDataCon gbl = do { name <- lookupIfaceExt gbl
316 ; thing <- tcIfaceGlobal name
318 ADataCon dc -> return dc
319 other -> pprPanic "tcIfaceExtDC" (ppr gbl $$ ppr name$$ ppr thing) }
321 tcIfaceExtId :: IfaceExtName -> IfL Id
322 tcIfaceExtId gbl = do { name <- lookupIfaceExt gbl
323 ; thing <- tcIfaceGlobal name
326 other -> pprPanic "tcIfaceExtId" (ppr gbl $$ ppr name$$ ppr thing) }
328 ------------------------------------------
329 tcIfaceLclId :: OccName -> IfL Id
331 = do { lcl <- getLclEnv
332 ; return (lookupOccEnv (if_id_env lcl) occ
334 pprPanic "tcIfaceLclId" (ppr occ)) }
336 tcIfaceTyVar :: OccName -> IfL TyVar
338 = do { lcl <- getLclEnv
339 ; return (lookupOccEnv (if_tv_env lcl) occ
341 pprPanic "tcIfaceTyVar" (ppr occ)) }
343 extendIfaceIdEnv :: [Id] -> IfL a -> IfL a
344 extendIfaceIdEnv ids thing_inside
345 = do { env <- getLclEnv
346 ; let { id_env' = extendOccEnvList (if_id_env env) pairs
347 ; pairs = [(getOccName id, id) | id <- ids] }
348 ; setLclEnv (env { if_id_env = id_env' }) thing_inside }
350 extendIfaceTyVarEnv :: [TyVar] -> IfL a -> IfL a
351 extendIfaceTyVarEnv tyvars thing_inside
352 = do { env <- getLclEnv
353 ; let { tv_env' = extendOccEnvList (if_tv_env env) pairs
354 ; pairs = [(getOccName tv, tv) | tv <- tyvars] }
355 ; setLclEnv (env { if_tv_env = tv_env' }) thing_inside }
359 %************************************************************************
361 Getting from RdrNames to Names
363 %************************************************************************
365 IfaceDecls etc are populated with RdrNames. The RdrNames may either be
367 Orig or Unqual when the interface is read from a file
369 Exact when the interface is kept by GHCi, and is now
370 being re-linked with the type environment
372 At an occurrence site, to convert the RdrName to Name:
373 Unqual look up in LocalRdrEnv
374 Orig look up in OrigNameCache
375 Exact return the Name
377 At a binding site, to bind the RdrName
378 Unqual we extend the LocalRdrEnv
379 Orig or Unqual we don't extend the LocalRdrEnv (no need)
381 First, we deal with the RdrName -> Name mapping
384 lookupIfaceTc :: IfaceTyCon -> IfL Name
385 lookupIfaceTc (IfaceTc ext) = lookupIfaceExt ext
386 lookupIfaceTc other_tc = return (ifaceTyConName other_tc)
388 lookupIfaceExt :: IfaceExtName -> IfL Name
389 lookupIfaceExt (ExtPkg mod occ) = lookupOrig mod occ
390 lookupIfaceExt (HomePkg mod occ _) = lookupOrig mod occ
391 lookupIfaceExt (LocalTop occ) = lookupIfaceTop occ
392 lookupIfaceExt (LocalTopSub occ _) = lookupIfaceTop occ
394 lookupIfaceTop :: OccName -> IfL Name
395 -- Look up a top-level name from the current Iface module
397 = do { env <- getLclEnv; lookupOrig (if_mod env) occ }
399 newIfaceName :: OccName -> IfL Name
401 = do { uniq <- newUnique
402 ; return (mkInternalName uniq occ noSrcLoc) }
404 newIfaceNames :: [OccName] -> IfL [Name]
406 = do { uniqs <- newUniqueSupply
407 ; return [ mkInternalName uniq occ noSrcLoc
408 | (occ,uniq) <- occs `zip` uniqsFromSupply uniqs] }