e09ff41d129e66f0ce731902a15ad3d3bbf8e31c
[ghc.git] / compiler / iface / IfaceEnv.lhs
1 (c) The University of Glasgow 2002-2006
2
3 \begin{code}
4 module IfaceEnv (
5         newGlobalBinder, newIPName, newImplicitBinder, 
6         lookupIfaceTop,
7         lookupOrig, lookupOrigNameCache, extendNameCache,
8         newIfaceName, newIfaceNames,
9         extendIfaceIdEnv, extendIfaceTyVarEnv, 
10         tcIfaceLclId,     tcIfaceTyVar, 
11         tcIfaceTick,
12
13         ifaceExportNames,
14
15         -- Name-cache stuff
16         allocateGlobalBinder, initNameCache, 
17         getNameCache, setNameCache
18    ) where
19
20 #include "HsVersions.h"
21
22 import TcRnMonad
23 import TysWiredIn
24 import HscTypes
25 import TyCon
26 import DataCon
27 import Var
28 import Name
29 import OccName
30 import PrelNames
31 import Module
32 import LazyUniqFM
33 import FastString
34 import UniqSupply
35 import FiniteMap
36 import BasicTypes
37 import SrcLoc
38 import MkId
39
40 import Outputable
41 \end{code}
42
43
44 %*********************************************************
45 %*                                                      *
46         Allocating new Names in the Name Cache
47 %*                                                      *
48 %*********************************************************
49
50 \begin{code}
51 newGlobalBinder :: Module -> OccName -> SrcSpan -> TcRnIf a b Name
52 -- Used for source code and interface files, to make the
53 -- Name for a thing, given its Module and OccName
54 --
55 -- The cache may already already have a binding for this thing,
56 -- because we may have seen an occurrence before, but now is the
57 -- moment when we know its Module and SrcLoc in their full glory
58
59 newGlobalBinder mod occ loc
60   = do  { mod `seq` occ `seq` return () -- See notes with lookupOrig_help
61 --      ; traceIf (text "newGlobalBinder" <+> ppr mod <+> ppr occ <+> ppr loc)
62         ; name_supply <- getNameCache
63         ; let (name_supply', name) = allocateGlobalBinder 
64                                         name_supply mod occ
65                                         loc
66         ; setNameCache name_supply'
67         ; return name }
68
69 allocateGlobalBinder
70   :: NameCache 
71   -> Module -> OccName -> SrcSpan
72   -> (NameCache, Name)
73 allocateGlobalBinder name_supply mod occ loc
74   = case lookupOrigNameCache (nsNames name_supply) mod occ of
75         -- A hit in the cache!  We are at the binding site of the name.
76         -- This is the moment when we know the SrcLoc
77         -- of the Name, so we set this field in the Name we return.
78         --
79         -- Then (bogus) multiple bindings of the same Name
80         -- get different SrcLocs can can be reported as such.
81         --
82         -- Possible other reason: it might be in the cache because we
83         --      encountered an occurrence before the binding site for an
84         --      implicitly-imported Name.  Perhaps the current SrcLoc is
85         --      better... but not really: it'll still just say 'imported'
86         --
87         -- IMPORTANT: Don't mess with wired-in names.  
88         --            Their wired-in-ness is in their NameSort
89         --            and their Module is correct.
90
91         Just name | isWiredInName name -> (name_supply, name)
92                   | otherwise -> (new_name_supply, name')
93                   where
94                     uniq      = nameUnique name
95                     name'     = mkExternalName uniq mod occ loc
96                     new_cache = extendNameCache (nsNames name_supply) mod occ name'
97                     new_name_supply = name_supply {nsNames = new_cache}              
98
99         -- Miss in the cache!
100         -- Build a completely new Name, and put it in the cache
101         Nothing -> (new_name_supply, name)
102                 where
103                   (us', us1)      = splitUniqSupply (nsUniqs name_supply)
104                   uniq            = uniqFromSupply us1
105                   name            = mkExternalName uniq mod occ loc
106                   new_cache       = extendNameCache (nsNames name_supply) mod occ name
107                   new_name_supply = name_supply {nsUniqs = us', nsNames = new_cache}
108
109
110 newImplicitBinder :: Name                       -- Base name
111                   -> (OccName -> OccName)       -- Occurrence name modifier
112                   -> TcRnIf m n Name            -- Implicit name
113 -- Called in BuildTyCl to allocate the implicit binders of type/class decls
114 -- For source type/class decls, this is the first occurrence
115 -- For iface ones, the LoadIface has alrady allocated a suitable name in the cache
116 newImplicitBinder base_name mk_sys_occ
117   | Just mod <- nameModule_maybe base_name
118   = newGlobalBinder mod occ loc
119   | otherwise           -- When typechecking a [d| decl bracket |], 
120                         -- TH generates types, classes etc with Internal names,
121                         -- so we follow suit for the implicit binders
122   = do  { uniq <- newUnique
123         ; return (mkInternalName uniq occ loc) }
124   where
125     occ = mk_sys_occ (nameOccName base_name)
126     loc = nameSrcSpan base_name
127
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)
132
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
137   return (Avail 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 )
148
149 lookupOrig :: Module -> OccName ->  TcRnIf a b Name
150 lookupOrig mod occ
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)
159     
160         ; name_cache <- getNameCache
161         ; case lookupOrigNameCache (nsNames name_cache) mod occ of {
162               Just name -> return name;
163               Nothing   ->
164               let
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
169               in
170               case splitUniqSupply us of { (us',_) -> do
171                 setNameCache name_cache{ nsUniqs = us', nsNames = new_cache }
172                 return name
173     }}}
174
175 newIPName :: IPName OccName -> TcRnIf m n (IPName Name)
176 newIPName occ_name_ip = do
177     name_supply <- getNameCache
178     let
179         ipcache = nsIPs name_supply
180     case lookupFM ipcache key of
181         Just name_ip -> return name_ip
182         Nothing      -> do setNameCache new_ns
183                            return name_ip
184                   where
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}
190     where 
191         key = occ_name_ip       -- Ensures that ?x and %x get distinct Names
192 \end{code}
193
194 %************************************************************************
195 %*                                                                      *
196                 Name cache access
197 %*                                                                      *
198 %************************************************************************
199
200 \begin{code}
201 lookupOrigNameCache :: OrigNameCache -> Module -> OccName -> Maybe Name
202 lookupOrigNameCache _ mod occ
203   -- XXX Why is gHC_UNIT not mentioned here?
204   | mod == gHC_TUPLE || mod == gHC_PRIM,                -- Boxed tuples from one, 
205     Just tup_info <- isTupleOcc_maybe occ       -- unboxed from the other
206   =     -- Special case for tuples; there are too many
207         -- of them to pre-populate the original-name cache
208     Just (mk_tup_name tup_info)
209   where
210     mk_tup_name (ns, boxity, arity)
211         | ns == tcName   = tyConName (tupleTyCon boxity arity)
212         | ns == dataName = dataConName (tupleCon boxity arity)
213         | otherwise      = Var.varName (dataConWorkId (tupleCon boxity arity))
214
215 lookupOrigNameCache nc mod occ  -- The normal case
216   = case lookupModuleEnv nc mod of
217         Nothing      -> Nothing
218         Just occ_env -> lookupOccEnv occ_env occ
219
220 extendOrigNameCache :: OrigNameCache -> Name -> OrigNameCache
221 extendOrigNameCache nc name 
222   = ASSERT2( isExternalName name, ppr name ) 
223     extendNameCache nc (nameModule name) (nameOccName name) name
224
225 extendNameCache :: OrigNameCache -> Module -> OccName -> Name -> OrigNameCache
226 extendNameCache nc mod occ name
227   = extendModuleEnv_C combine nc mod (unitOccEnv occ name)
228   where
229     combine occ_env _ = extendOccEnv occ_env occ name
230
231 getNameCache :: TcRnIf a b NameCache
232 getNameCache = do { HscEnv { hsc_NC = nc_var } <- getTopEnv; 
233                     readMutVar nc_var }
234
235 setNameCache :: NameCache -> TcRnIf a b ()
236 setNameCache nc = do { HscEnv { hsc_NC = nc_var } <- getTopEnv; 
237                        writeMutVar nc_var nc }
238 \end{code}
239
240
241 \begin{code}
242 initNameCache :: UniqSupply -> [Name] -> NameCache
243 initNameCache us names
244   = NameCache { nsUniqs = us,
245                 nsNames = initOrigNames names,
246                 nsIPs   = emptyFM }
247
248 initOrigNames :: [Name] -> OrigNameCache
249 initOrigNames names = foldl extendOrigNameCache emptyModuleEnv names
250 \end{code}
251
252
253
254 %************************************************************************
255 %*                                                                      *
256                 Type variables and local Ids
257 %*                                                                      *
258 %************************************************************************
259
260 \begin{code}
261 tcIfaceLclId :: FastString -> IfL Id
262 tcIfaceLclId occ
263   = do  { lcl <- getLclEnv
264         ; case (lookupUFM (if_id_env lcl) occ) of
265             Just ty_var -> return ty_var
266             Nothing     -> failIfM (text "Iface id out of scope: " <+> ppr occ)
267         }
268
269 extendIfaceIdEnv :: [Id] -> IfL a -> IfL a
270 extendIfaceIdEnv ids thing_inside
271   = do  { env <- getLclEnv
272         ; let { id_env' = addListToUFM (if_id_env env) pairs
273               ; pairs   = [(occNameFS (getOccName id), id) | id <- ids] }
274         ; setLclEnv (env { if_id_env = id_env' }) thing_inside }
275
276
277 tcIfaceTyVar :: FastString -> IfL TyVar
278 tcIfaceTyVar occ
279   = do  { lcl <- getLclEnv
280         ; case (lookupUFM (if_tv_env lcl) occ) of
281             Just ty_var -> return ty_var
282             Nothing     -> failIfM (text "Iface type variable out of scope: " <+> ppr occ)
283         }
284
285 extendIfaceTyVarEnv :: [TyVar] -> IfL a -> IfL a
286 extendIfaceTyVarEnv tyvars thing_inside
287   = do  { env <- getLclEnv
288         ; let { tv_env' = addListToUFM (if_tv_env env) pairs
289               ; pairs   = [(occNameFS (getOccName tv), tv) | tv <- tyvars] }
290         ; setLclEnv (env { if_tv_env = tv_env' }) thing_inside }
291 \end{code}
292
293
294 %************************************************************************
295 %*                                                                      *
296                 Getting from RdrNames to Names
297 %*                                                                      *
298 %************************************************************************
299
300 \begin{code}
301 lookupIfaceTop :: OccName -> IfL Name
302 -- Look up a top-level name from the current Iface module
303 lookupIfaceTop occ
304   = do  { env <- getLclEnv; lookupOrig (if_mod env) occ }
305
306 newIfaceName :: OccName -> IfL Name
307 newIfaceName occ
308   = do  { uniq <- newUnique
309         ; return $! mkInternalName uniq occ noSrcSpan }
310
311 newIfaceNames :: [OccName] -> IfL [Name]
312 newIfaceNames occs
313   = do  { uniqs <- newUniqueSupply
314         ; return [ mkInternalName uniq occ noSrcSpan
315                  | (occ,uniq) <- occs `zip` uniqsFromSupply uniqs] }
316 \end{code}
317
318 %************************************************************************
319 %*                                                                      *
320                 (Re)creating tick boxes
321 %*                                                                      *
322 %************************************************************************
323
324 \begin{code}
325 tcIfaceTick :: Module -> Int -> IfL Id
326 tcIfaceTick modName tickNo 
327   = do { uniq <- newUnique
328        ; return $ mkTickBoxOpId uniq modName tickNo
329        }
330 \end{code}
331
332