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(..), OrigNameCache )
22 import TyCon ( TyCon, tyConName )
23 import DataCon ( dataConWorkId, dataConName )
24 import Var ( TyVar, Id, varName )
25 import Name ( Name, nameUnique, nameModule,
26 nameOccName, nameSrcLoc,
27 getOccName, nameParent_maybe,
28 isWiredInName, mkIPName,
29 mkExternalName, mkInternalName )
31 import OccName ( OccName, isTupleOcc_maybe, tcName, dataName,
32 lookupOccEnv, unitOccEnv, extendOccEnv, extendOccEnvList )
33 import PrelNames ( gHC_PRIM, pREL_TUP )
34 import Module ( Module, emptyModuleEnv,
35 lookupModuleEnv, extendModuleEnv_C )
36 import UniqSupply ( UniqSupply, splitUniqSupply, uniqFromSupply, uniqsFromSupply )
37 import FiniteMap ( emptyFM, lookupFM, addToFM )
38 import BasicTypes ( IPName(..), mapIPName )
39 import SrcLoc ( SrcLoc, noSrcLoc )
40 import Maybes ( orElse )
46 %*********************************************************
48 Allocating new Names in the Name Cache
50 %*********************************************************
53 newGlobalBinder :: Module -> OccName -> Maybe Name -> SrcLoc -> 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 mb_parent loc
62 = do { mod `seq` occ `seq` return () -- See notes with lookupOrig_help
63 ; name_supply <- getNameCache
64 ; let (name_supply', name) = allocateGlobalBinder
67 ; setNameCache name_supply'
72 -> Module -> OccName -> Maybe Name -> SrcLoc
74 allocateGlobalBinder name_supply mod occ mb_parent loc
75 = case lookupOrigNameCache (nsNames name_supply) mod occ of
76 -- A hit in the cache! We are at the binding site of the name.
77 -- This is the moment when we know the defining Module and SrcLoc
78 -- of the Name, so we set these fields in the Name we return.
80 -- This is essential, to get the right Module in a Name.
81 -- Also: then (bogus) multiple bindings of the same Name
82 -- get different SrcLocs can can be reported as such.
84 -- Possible other reason: it might be in the cache because we
85 -- encountered an occurrence before the binding site for an
86 -- implicitly-imported Name. Perhaps the current SrcLoc is
87 -- better... but not really: it'll still just say 'imported'
89 -- IMPORTANT: Don't mess with wired-in names.
90 -- Their wired-in-ness is in their NameSort
91 -- and their Module is correct.
93 Just name | isWiredInName name -> (name_supply, name)
94 | otherwise -> (new_name_supply, name')
96 uniq = nameUnique name
97 name' = mkExternalName uniq mod occ mb_parent loc
98 new_cache = extend_name_cache (nsNames name_supply) mod occ name'
99 new_name_supply = name_supply {nsNames = new_cache}
101 -- Miss in the cache!
102 -- Build a completely new Name, and put it in the cache
103 Nothing -> (new_name_supply, name)
105 (us', us1) = splitUniqSupply (nsUniqs name_supply)
106 uniq = uniqFromSupply us1
107 name = mkExternalName uniq mod occ mb_parent loc
108 new_cache = extend_name_cache (nsNames name_supply) mod occ name
109 new_name_supply = name_supply {nsUniqs = us', nsNames = new_cache}
112 newImplicitBinder :: Name -- Base name
113 -> (OccName -> OccName) -- Occurrence name modifier
114 -> TcRnIf m n Name -- Implicit name
115 -- Called in BuildTyCl to allocate the implicit binders of type/class decls
116 -- For source type/class decls, this is the first occurrence
117 -- For iface ones, the LoadIface has alrady allocated a suitable name in the cache
119 -- An *implicit* name has the base-name as parent
120 newImplicitBinder base_name mk_sys_occ
121 = newGlobalBinder (nameModule base_name)
122 (mk_sys_occ (nameOccName base_name))
124 (nameSrcLoc base_name)
126 parent_name = case nameParent_maybe base_name of
127 Just parent_name -> parent_name
130 lookupOrig :: Module -> OccName -> TcRnIf a b Name
131 -- Even if we get a miss in the original-name cache, we
132 -- make a new External Name.
134 -- SrcLoc to noSrcLoc
136 -- They'll be overwritten, in due course, by LoadIface.loadDecl.
139 = do { -- First ensure that mod and occ are evaluated
140 -- If not, chaos can ensue:
141 -- we read the name-cache
142 -- then pull on mod (say)
143 -- which does some stuff that modifies the name cache
144 -- This did happen, with tycon_mod in TcIface.tcIfaceAlt (DataAlt..)
145 mod `seq` occ `seq` return ()
147 ; name_supply <- getNameCache
148 ; case lookupOrigNameCache (nsNames name_supply) mod occ of {
149 Just name -> returnM name ;
152 { let { (us', us1) = splitUniqSupply (nsUniqs name_supply)
153 ; uniq = uniqFromSupply us1
154 ; name = mkExternalName uniq mod occ Nothing noSrcLoc
155 ; new_cache = extend_name_cache (nsNames name_supply) mod occ name
156 ; new_name_supply = name_supply {nsUniqs = us', nsNames = new_cache}
158 ; setNameCache new_name_supply
162 newIPName :: IPName OccName -> TcRnIf m n (IPName Name)
163 newIPName occ_name_ip
164 = getNameCache `thenM` \ name_supply ->
166 ipcache = nsIPs name_supply
168 case lookupFM ipcache key of
169 Just name_ip -> returnM name_ip
170 Nothing -> setNameCache new_ns `thenM_`
173 (us', us1) = splitUniqSupply (nsUniqs name_supply)
174 uniq = uniqFromSupply us1
175 name_ip = mapIPName (mkIPName uniq) occ_name_ip
176 new_ipcache = addToFM ipcache key name_ip
177 new_ns = name_supply {nsUniqs = us', nsIPs = new_ipcache}
179 key = occ_name_ip -- Ensures that ?x and %x get distinct Names
182 Local helper functions (not exported)
185 lookupOrigNameCache :: OrigNameCache -> Module -> OccName -> Maybe Name
186 lookupOrigNameCache nc mod occ
187 | mod == pREL_TUP || mod == gHC_PRIM, -- Boxed tuples from one,
188 Just tup_info <- isTupleOcc_maybe occ -- unboxed from the other
189 = -- Special case for tuples; there are too many
190 -- of them to pre-populate the original-name cache
191 Just (mk_tup_name tup_info)
193 mk_tup_name (ns, boxity, arity)
194 | ns == tcName = tyConName (tupleTyCon boxity arity)
195 | ns == dataName = dataConName (tupleCon boxity arity)
196 | otherwise = varName (dataConWorkId (tupleCon boxity arity))
198 lookupOrigNameCache nc mod occ -- The normal case
199 = case lookupModuleEnv nc mod of
201 Just occ_env -> lookupOccEnv occ_env occ
203 extendOrigNameCache :: OrigNameCache -> Name -> OrigNameCache
204 extendOrigNameCache nc name
205 = extend_name_cache nc (nameModule name) (nameOccName name) name
207 extend_name_cache :: OrigNameCache -> Module -> OccName -> Name -> OrigNameCache
208 extend_name_cache nc mod occ name
209 = extendModuleEnv_C combine nc mod (unitOccEnv occ name)
211 combine occ_env _ = extendOccEnv occ_env occ name
213 getNameCache :: TcRnIf a b NameCache
214 getNameCache = do { HscEnv { hsc_NC = nc_var } <- getTopEnv;
217 setNameCache :: NameCache -> TcRnIf a b ()
218 setNameCache nc = do { HscEnv { hsc_NC = nc_var } <- getTopEnv;
219 writeMutVar nc_var nc }
224 initNameCache :: UniqSupply -> [Name] -> NameCache
225 initNameCache us names
226 = NameCache { nsUniqs = us,
227 nsNames = initOrigNames names,
230 initOrigNames :: [Name] -> OrigNameCache
231 initOrigNames names = foldl extendOrigNameCache emptyModuleEnv names
236 %************************************************************************
238 Type variables and local Ids
240 %************************************************************************
243 tcIfaceLclId :: OccName -> IfL Id
245 = do { lcl <- getLclEnv
246 ; return (lookupOccEnv (if_id_env lcl) occ
248 pprPanic "tcIfaceLclId" (ppr occ)) }
250 extendIfaceIdEnv :: [Id] -> IfL a -> IfL a
251 extendIfaceIdEnv ids thing_inside
252 = do { env <- getLclEnv
253 ; let { id_env' = extendOccEnvList (if_id_env env) pairs
254 ; pairs = [(getOccName id, id) | id <- ids] }
255 ; setLclEnv (env { if_id_env = id_env' }) thing_inside }
258 tcIfaceTyVar :: OccName -> IfL TyVar
260 = do { lcl <- getLclEnv
261 ; return (lookupOccEnv (if_tv_env lcl) occ
263 pprPanic "tcIfaceTyVar" (ppr occ)) }
265 extendIfaceTyVarEnv :: [TyVar] -> IfL a -> IfL a
266 extendIfaceTyVarEnv tyvars thing_inside
267 = do { env <- getLclEnv
268 ; let { tv_env' = extendOccEnvList (if_tv_env env) pairs
269 ; pairs = [(getOccName tv, tv) | tv <- tyvars] }
270 ; setLclEnv (env { if_tv_env = tv_env' }) thing_inside }
274 %************************************************************************
276 Getting from RdrNames to Names
278 %************************************************************************
281 lookupIfaceTc :: IfaceTyCon -> IfL Name
282 lookupIfaceTc (IfaceTc ext) = lookupIfaceExt ext
283 lookupIfaceTc other_tc = return (ifaceTyConName other_tc)
285 lookupIfaceExt :: IfaceExtName -> IfL Name
286 lookupIfaceExt (ExtPkg mod occ) = lookupOrig mod occ
287 lookupIfaceExt (HomePkg mod occ _) = lookupOrig mod occ
288 lookupIfaceExt (LocalTop occ) = lookupIfaceTop occ
289 lookupIfaceExt (LocalTopSub occ _) = lookupIfaceTop occ
291 lookupIfaceTop :: OccName -> IfL Name
292 -- Look up a top-level name from the current Iface module
294 = do { env <- getLclEnv; lookupOrig (if_mod env) occ }
296 newIfaceName :: OccName -> IfL Name
298 = do { uniq <- newUnique
299 ; return (mkInternalName uniq occ noSrcLoc) }
301 newIfaceNames :: [OccName] -> IfL [Name]
303 = do { uniqs <- newUniqueSupply
304 ; return [ mkInternalName uniq occ noSrcLoc
305 | (occ,uniq) <- occs `zip` uniqsFromSupply uniqs] }