1 (c) The University of Glasgow 2002-2006
5 -- The above warning supression flag is a temporary kludge.
6 -- While working on this module you are encouraged to remove it and fix
7 -- any warnings in the module. See
8 -- http://hackage.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#Warnings
12 newGlobalBinder, newIPName, newImplicitBinder,
14 lookupOrig, lookupOrigNameCache, extendNameCache,
15 newIfaceName, newIfaceNames,
16 extendIfaceIdEnv, extendIfaceTyVarEnv,
17 tcIfaceLclId, tcIfaceTyVar,
23 allocateGlobalBinder, initNameCache,
24 getNameCache, setNameCache
27 #include "HsVersions.h"
51 %*********************************************************
53 Allocating new Names in the Name Cache
55 %*********************************************************
58 newGlobalBinder :: Module -> OccName -> SrcSpan -> TcRnIf a b Name
59 -- Used for source code and interface files, to make the
60 -- Name for a thing, given its Module and OccName
62 -- The cache may already already have a binding for this thing,
63 -- because we may have seen an occurrence before, but now is the
64 -- moment when we know its Module and SrcLoc in their full glory
66 newGlobalBinder mod occ loc
67 = do { mod `seq` occ `seq` return () -- See notes with lookupOrig_help
68 -- ; traceIf (text "newGlobalBinder" <+> ppr mod <+> ppr occ <+> ppr loc)
69 ; name_supply <- getNameCache
70 ; let (name_supply', name) = allocateGlobalBinder
73 ; setNameCache name_supply'
78 -> Module -> OccName -> SrcSpan
80 allocateGlobalBinder name_supply mod occ loc
81 = case lookupOrigNameCache (nsNames name_supply) mod occ of
82 -- A hit in the cache! We are at the binding site of the name.
83 -- This is the moment when we know the SrcLoc
84 -- of the Name, so we set this field in the Name we return.
86 -- Then (bogus) multiple bindings of the same Name
87 -- get different SrcLocs can can be reported as such.
89 -- Possible other reason: it might be in the cache because we
90 -- encountered an occurrence before the binding site for an
91 -- implicitly-imported Name. Perhaps the current SrcLoc is
92 -- better... but not really: it'll still just say 'imported'
94 -- IMPORTANT: Don't mess with wired-in names.
95 -- Their wired-in-ness is in their NameSort
96 -- and their Module is correct.
98 Just name | isWiredInName name -> (name_supply, name)
99 | otherwise -> (new_name_supply, name')
101 uniq = nameUnique name
102 name' = mkExternalName uniq mod occ loc
103 new_cache = extendNameCache (nsNames name_supply) mod occ name'
104 new_name_supply = name_supply {nsNames = new_cache}
106 -- Miss in the cache!
107 -- Build a completely new Name, and put it in the cache
108 Nothing -> (new_name_supply, name)
110 (us', us1) = splitUniqSupply (nsUniqs name_supply)
111 uniq = uniqFromSupply us1
112 name = mkExternalName uniq mod occ loc
113 new_cache = extendNameCache (nsNames name_supply) mod occ name
114 new_name_supply = name_supply {nsUniqs = us', nsNames = new_cache}
117 newImplicitBinder :: Name -- Base name
118 -> (OccName -> OccName) -- Occurrence name modifier
119 -> TcRnIf m n Name -- Implicit name
120 -- Called in BuildTyCl to allocate the implicit binders of type/class decls
121 -- For source type/class decls, this is the first occurrence
122 -- For iface ones, the LoadIface has alrady allocated a suitable name in the cache
123 newImplicitBinder base_name mk_sys_occ
124 = newGlobalBinder (nameModule base_name)
125 (mk_sys_occ (nameOccName base_name))
126 (nameSrcSpan base_name)
128 ifaceExportNames :: [IfaceExport] -> TcRnIf gbl lcl [AvailInfo]
129 ifaceExportNames exports = do
130 mod_avails <- mapM (\(mod,avails) -> mapM (lookupAvail mod) avails) exports
131 return (concat mod_avails)
133 -- Convert OccNames in GenAvailInfo to Names.
134 lookupAvail :: Module -> GenAvailInfo OccName -> TcRnIf a b AvailInfo
135 lookupAvail mod (Avail n) = do
136 n' <- lookupOrig mod n
138 lookupAvail mod (AvailTC p_occ occs) = do
139 p_name <- lookupOrig mod p_occ
140 let lookup_sub occ | occ == p_occ = return p_name
141 | otherwise = lookupOrig mod occ
142 subs <- mapM lookup_sub occs
143 return (AvailTC p_name subs)
144 -- Remember that 'occs' is all the exported things, including
145 -- the parent. It's possible to export just class ops without
146 -- the class, which shows up as C( op ) here. If the class was
147 -- exported too we'd have C( C, op )
149 lookupOrig :: Module -> OccName -> TcRnIf a b Name
151 = do { -- First ensure that mod and occ are evaluated
152 -- If not, chaos can ensue:
153 -- we read the name-cache
154 -- then pull on mod (say)
155 -- which does some stuff that modifies the name cache
156 -- This did happen, with tycon_mod in TcIface.tcIfaceAlt (DataAlt..)
157 mod `seq` occ `seq` return ()
158 -- ; traceIf (text "lookup_orig" <+> ppr mod <+> ppr occ)
160 ; name_cache <- getNameCache
161 ; case lookupOrigNameCache (nsNames name_cache) mod occ of {
162 Just name -> return name;
165 us = nsUniqs name_cache
166 uniq = uniqFromSupply us
167 name = mkExternalName uniq mod occ noSrcSpan
168 new_cache = extendNameCache (nsNames name_cache) mod occ name
170 case splitUniqSupply us of { (us',_) -> do
171 setNameCache name_cache{ nsUniqs = us', nsNames = new_cache }
175 newIPName :: IPName OccName -> TcRnIf m n (IPName Name)
176 newIPName occ_name_ip = do
177 name_supply <- getNameCache
179 ipcache = nsIPs name_supply
180 case lookupFM ipcache key of
181 Just name_ip -> return name_ip
182 Nothing -> do setNameCache new_ns
185 (us', us1) = splitUniqSupply (nsUniqs name_supply)
186 uniq = uniqFromSupply us1
187 name_ip = mapIPName (mkIPName uniq) occ_name_ip
188 new_ipcache = addToFM ipcache key name_ip
189 new_ns = name_supply {nsUniqs = us', nsIPs = new_ipcache}
191 key = occ_name_ip -- Ensures that ?x and %x get distinct Names
194 Local helper functions (not exported)
197 lookupOrigNameCache :: OrigNameCache -> Module -> OccName -> Maybe Name
198 lookupOrigNameCache nc mod occ
199 | mod == dATA_TUP || mod == gHC_PRIM, -- Boxed tuples from one,
200 Just tup_info <- isTupleOcc_maybe occ -- unboxed from the other
201 = -- Special case for tuples; there are too many
202 -- of them to pre-populate the original-name cache
203 Just (mk_tup_name tup_info)
205 mk_tup_name (ns, boxity, arity)
206 | ns == tcName = tyConName (tupleTyCon boxity arity)
207 | ns == dataName = dataConName (tupleCon boxity arity)
208 | otherwise = Var.varName (dataConWorkId (tupleCon boxity arity))
210 lookupOrigNameCache nc mod occ -- The normal case
211 = case lookupModuleEnv nc mod of
213 Just occ_env -> lookupOccEnv occ_env occ
215 extendOrigNameCache :: OrigNameCache -> Name -> OrigNameCache
216 extendOrigNameCache nc name
217 = extendNameCache nc (nameModule name) (nameOccName name) name
219 extendNameCache :: OrigNameCache -> Module -> OccName -> Name -> OrigNameCache
220 extendNameCache nc mod occ name
221 = extendModuleEnv_C combine nc mod (unitOccEnv occ name)
223 combine occ_env _ = extendOccEnv occ_env occ name
225 getNameCache :: TcRnIf a b NameCache
226 getNameCache = do { HscEnv { hsc_NC = nc_var } <- getTopEnv;
229 setNameCache :: NameCache -> TcRnIf a b ()
230 setNameCache nc = do { HscEnv { hsc_NC = nc_var } <- getTopEnv;
231 writeMutVar nc_var nc }
236 initNameCache :: UniqSupply -> [Name] -> NameCache
237 initNameCache us names
238 = NameCache { nsUniqs = us,
239 nsNames = initOrigNames names,
242 initOrigNames :: [Name] -> OrigNameCache
243 initOrigNames names = foldl extendOrigNameCache emptyModuleEnv names
248 %************************************************************************
250 Type variables and local Ids
252 %************************************************************************
255 tcIfaceLclId :: FastString -> IfL Id
257 = do { lcl <- getLclEnv
258 ; case (lookupUFM (if_id_env lcl) occ) of
259 Just ty_var -> return ty_var
260 Nothing -> failIfM (text "Iface id out of scope: " <+> ppr occ)
263 extendIfaceIdEnv :: [Id] -> IfL a -> IfL a
264 extendIfaceIdEnv ids thing_inside
265 = do { env <- getLclEnv
266 ; let { id_env' = addListToUFM (if_id_env env) pairs
267 ; pairs = [(occNameFS (getOccName id), id) | id <- ids] }
268 ; setLclEnv (env { if_id_env = id_env' }) thing_inside }
271 tcIfaceTyVar :: FastString -> IfL TyVar
273 = do { lcl <- getLclEnv
274 ; case (lookupUFM (if_tv_env lcl) occ) of
275 Just ty_var -> return ty_var
276 Nothing -> failIfM (text "Iface type variable out of scope: " <+> ppr occ)
279 extendIfaceTyVarEnv :: [TyVar] -> IfL a -> IfL a
280 extendIfaceTyVarEnv tyvars thing_inside
281 = do { env <- getLclEnv
282 ; let { tv_env' = addListToUFM (if_tv_env env) pairs
283 ; pairs = [(occNameFS (getOccName tv), tv) | tv <- tyvars] }
284 ; setLclEnv (env { if_tv_env = tv_env' }) thing_inside }
288 %************************************************************************
290 Getting from RdrNames to Names
292 %************************************************************************
295 lookupIfaceTop :: OccName -> IfL Name
296 -- Look up a top-level name from the current Iface module
298 = do { env <- getLclEnv; lookupOrig (if_mod env) occ }
300 newIfaceName :: OccName -> IfL Name
302 = do { uniq <- newUnique
303 ; return $! mkInternalName uniq occ noSrcSpan }
305 newIfaceNames :: [OccName] -> IfL [Name]
307 = do { uniqs <- newUniqueSupply
308 ; return [ mkInternalName uniq occ noSrcSpan
309 | (occ,uniq) <- occs `zip` uniqsFromSupply uniqs] }
312 %************************************************************************
314 (Re)creating tick boxes
316 %************************************************************************
319 tcIfaceTick :: Module -> Int -> IfL Id
320 tcIfaceTick modName tickNo
321 = do { uniq <- newUnique
322 ; return $ mkTickBoxOpId uniq modName tickNo