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,
15 allocateGlobalBinder, initNameCache,
16 getNameCache, setNameCache
19 #include "HsVersions.h"
42 %*********************************************************
44 Allocating new Names in the Name Cache
46 %*********************************************************
49 newGlobalBinder :: Module -> OccName -> SrcLoc -> TcRnIf a b Name
50 -- Used for source code and interface files, to make the
51 -- Name for a thing, given its Module and OccName
53 -- The cache may already already have a binding for this thing,
54 -- because we may have seen an occurrence before, but now is the
55 -- moment when we know its Module and SrcLoc in their full glory
57 newGlobalBinder mod occ loc
58 = do { mod `seq` occ `seq` return () -- See notes with lookupOrig_help
59 ; traceIf (text "newGlobalBinder" <+> ppr mod <+> ppr occ <+> ppr loc)
60 ; name_supply <- getNameCache
61 ; let (name_supply', name) = allocateGlobalBinder
64 ; setNameCache name_supply'
69 -> Module -> OccName -> SrcLoc
71 allocateGlobalBinder name_supply mod occ loc
72 = case lookupOrigNameCache (nsNames name_supply) mod occ of
73 -- A hit in the cache! We are at the binding site of the name.
74 -- This is the moment when we know the SrcLoc
75 -- of the Name, so we set this field in the Name we return.
77 -- Then (bogus) multiple bindings of the same Name
78 -- get different SrcLocs can can be reported as such.
80 -- Possible other reason: it might be in the cache because we
81 -- encountered an occurrence before the binding site for an
82 -- implicitly-imported Name. Perhaps the current SrcLoc is
83 -- better... but not really: it'll still just say 'imported'
85 -- IMPORTANT: Don't mess with wired-in names.
86 -- Their wired-in-ness is in their NameSort
87 -- and their Module is correct.
89 Just name | isWiredInName name -> (name_supply, name)
90 | otherwise -> (new_name_supply, name')
92 uniq = nameUnique name
93 name' = mkExternalName uniq mod occ loc
94 new_cache = extendNameCache (nsNames name_supply) mod occ name'
95 new_name_supply = name_supply {nsNames = new_cache}
98 -- Build a completely new Name, and put it in the cache
99 Nothing -> (new_name_supply, name)
101 (us', us1) = splitUniqSupply (nsUniqs name_supply)
102 uniq = uniqFromSupply us1
103 name = mkExternalName uniq mod occ loc
104 new_cache = extendNameCache (nsNames name_supply) mod occ name
105 new_name_supply = name_supply {nsUniqs = us', nsNames = new_cache}
108 newImplicitBinder :: Name -- Base name
109 -> (OccName -> OccName) -- Occurrence name modifier
110 -> TcRnIf m n Name -- Implicit name
111 -- Called in BuildTyCl to allocate the implicit binders of type/class decls
112 -- For source type/class decls, this is the first occurrence
113 -- For iface ones, the LoadIface has alrady allocated a suitable name in the cache
114 newImplicitBinder base_name mk_sys_occ
115 = newGlobalBinder (nameModule base_name)
116 (mk_sys_occ (nameOccName base_name))
117 (nameSrcLoc base_name)
119 ifaceExportNames :: [IfaceExport] -> TcRnIf gbl lcl [AvailInfo]
120 ifaceExportNames exports = do
121 mod_avails <- mapM (\(mod,avails) -> mapM (lookupAvail mod) avails) exports
122 return (concat mod_avails)
124 -- Convert OccNames in GenAvailInfo to Names.
125 lookupAvail :: Module -> GenAvailInfo OccName -> TcRnIf a b AvailInfo
126 lookupAvail mod (Avail n) = do
127 n' <- lookupOrig mod n
129 lookupAvail mod (AvailTC p_occ occs) = do
130 p_name <- lookupOrig mod p_occ
131 let lookup_sub occ | occ == p_occ = return p_name
132 | otherwise = lookupOrig mod occ
133 subs <- mappM lookup_sub occs
134 return (AvailTC p_name subs)
135 -- Remember that 'occs' is all the exported things, including
136 -- the parent. It's possible to export just class ops without
137 -- the class, which shows up as C( op ) here. If the class was
138 -- exported too we'd have C( C, op )
140 lookupOrig :: Module -> OccName -> TcRnIf a b Name
142 = do { -- First ensure that mod and occ are evaluated
143 -- If not, chaos can ensue:
144 -- we read the name-cache
145 -- then pull on mod (say)
146 -- which does some stuff that modifies the name cache
147 -- This did happen, with tycon_mod in TcIface.tcIfaceAlt (DataAlt..)
148 mod `seq` occ `seq` return ()
149 ; traceIf (text "lookup_orig" <+> ppr mod <+> ppr occ)
151 ; name_cache <- getNameCache
152 ; case lookupOrigNameCache (nsNames name_cache) mod occ of {
153 Just name -> returnM name;
156 us = nsUniqs name_cache
157 uniq = uniqFromSupply us
158 name = mkExternalName uniq mod occ noSrcLoc
159 new_cache = extendNameCache (nsNames name_cache) mod occ name
161 case splitUniqSupply us of { (us',_) -> do
162 setNameCache name_cache{ nsUniqs = us', nsNames = new_cache }
166 newIPName :: IPName OccName -> TcRnIf m n (IPName Name)
167 newIPName occ_name_ip
168 = getNameCache `thenM` \ name_supply ->
170 ipcache = nsIPs name_supply
172 case lookupFM ipcache key of
173 Just name_ip -> returnM name_ip
174 Nothing -> setNameCache new_ns `thenM_`
177 (us', us1) = splitUniqSupply (nsUniqs name_supply)
178 uniq = uniqFromSupply us1
179 name_ip = mapIPName (mkIPName uniq) occ_name_ip
180 new_ipcache = addToFM ipcache key name_ip
181 new_ns = name_supply {nsUniqs = us', nsIPs = new_ipcache}
183 key = occ_name_ip -- Ensures that ?x and %x get distinct Names
186 Local helper functions (not exported)
189 lookupOrigNameCache :: OrigNameCache -> Module -> OccName -> Maybe Name
190 lookupOrigNameCache nc mod occ
191 | mod == dATA_TUP || mod == gHC_PRIM, -- Boxed tuples from one,
192 Just tup_info <- isTupleOcc_maybe occ -- unboxed from the other
193 = -- Special case for tuples; there are too many
194 -- of them to pre-populate the original-name cache
195 Just (mk_tup_name tup_info)
197 mk_tup_name (ns, boxity, arity)
198 | ns == tcName = tyConName (tupleTyCon boxity arity)
199 | ns == dataName = dataConName (tupleCon boxity arity)
200 | otherwise = Var.varName (dataConWorkId (tupleCon boxity arity))
202 lookupOrigNameCache nc mod occ -- The normal case
203 = case lookupModuleEnv nc mod of
205 Just occ_env -> lookupOccEnv occ_env occ
207 extendOrigNameCache :: OrigNameCache -> Name -> OrigNameCache
208 extendOrigNameCache nc name
209 = extendNameCache nc (nameModule name) (nameOccName name) name
211 extendNameCache :: OrigNameCache -> Module -> OccName -> Name -> OrigNameCache
212 extendNameCache nc mod occ name
213 = extendModuleEnv_C combine nc mod (unitOccEnv occ name)
215 combine occ_env _ = extendOccEnv occ_env occ name
217 getNameCache :: TcRnIf a b NameCache
218 getNameCache = do { HscEnv { hsc_NC = nc_var } <- getTopEnv;
221 setNameCache :: NameCache -> TcRnIf a b ()
222 setNameCache nc = do { HscEnv { hsc_NC = nc_var } <- getTopEnv;
223 writeMutVar nc_var nc }
228 initNameCache :: UniqSupply -> [Name] -> NameCache
229 initNameCache us names
230 = NameCache { nsUniqs = us,
231 nsNames = initOrigNames names,
234 initOrigNames :: [Name] -> OrigNameCache
235 initOrigNames names = foldl extendOrigNameCache emptyModuleEnv names
240 %************************************************************************
242 Type variables and local Ids
244 %************************************************************************
247 tcIfaceLclId :: FastString -> IfL Id
249 = do { lcl <- getLclEnv
250 ; case (lookupUFM (if_id_env lcl) occ) of
251 Just ty_var -> return ty_var
252 Nothing -> failIfM (text "Iface id out of scope: " <+> ppr occ)
255 extendIfaceIdEnv :: [Id] -> IfL a -> IfL a
256 extendIfaceIdEnv ids thing_inside
257 = do { env <- getLclEnv
258 ; let { id_env' = addListToUFM (if_id_env env) pairs
259 ; pairs = [(occNameFS (getOccName id), id) | id <- ids] }
260 ; setLclEnv (env { if_id_env = id_env' }) thing_inside }
263 tcIfaceTyVar :: FastString -> IfL TyVar
265 = do { lcl <- getLclEnv
266 ; case (lookupUFM (if_tv_env lcl) occ) of
267 Just ty_var -> return ty_var
268 Nothing -> failIfM (text "Iface type variable out of scope: " <+> ppr occ)
271 extendIfaceTyVarEnv :: [TyVar] -> IfL a -> IfL a
272 extendIfaceTyVarEnv tyvars thing_inside
273 = do { env <- getLclEnv
274 ; let { tv_env' = addListToUFM (if_tv_env env) pairs
275 ; pairs = [(occNameFS (getOccName tv), tv) | tv <- tyvars] }
276 ; setLclEnv (env { if_tv_env = tv_env' }) thing_inside }
280 %************************************************************************
282 Getting from RdrNames to Names
284 %************************************************************************
287 lookupIfaceTop :: OccName -> IfL Name
288 -- Look up a top-level name from the current Iface module
290 = do { env <- getLclEnv; lookupOrig (if_mod env) occ }
292 newIfaceName :: OccName -> IfL Name
294 = do { uniq <- newUnique
295 ; return $! mkInternalName uniq occ noSrcLoc }
297 newIfaceNames :: [OccName] -> IfL [Name]
299 = do { uniqs <- newUniqueSupply
300 ; return [ mkInternalName uniq occ noSrcLoc
301 | (occ,uniq) <- occs `zip` uniqsFromSupply uniqs] }