White space only
[ghc-hetmet.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, lookupIfaceTyVar,
11         tcIfaceTick,
12
13         ifaceExportNames,
14
15         -- Name-cache stuff
16         allocateGlobalBinder, initNameCache, 
17         getNameCache, mkNameCacheUpdater, NameCacheUpdater
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 PrelNames
30 import Module
31 import UniqFM
32 import FastString
33 import UniqSupply
34 import BasicTypes
35 import SrcLoc
36 import MkId
37
38 import Outputable
39 import Exception     ( evaluate )
40
41 import Data.IORef    ( atomicModifyIORef, readIORef )
42 import qualified Data.Map as Map
43 \end{code}
44
45
46 %*********************************************************
47 %*                                                      *
48         Allocating new Names in the Name Cache
49 %*                                                      *
50 %*********************************************************
51
52 \begin{code}
53 newGlobalBinder :: Module -> OccName -> SrcSpan -> 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
56 --
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
60
61 newGlobalBinder mod occ loc
62   = do mod `seq` occ `seq` return ()    -- See notes with lookupOrig
63 --     traceIf (text "newGlobalBinder" <+> ppr mod <+> ppr occ <+> ppr loc)
64        updNameCache $ \name_cache ->
65          allocateGlobalBinder name_cache mod occ loc
66
67 allocateGlobalBinder
68   :: NameCache 
69   -> Module -> OccName -> SrcSpan
70   -> (NameCache, Name)
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.
76         --
77         -- Then (bogus) multiple bindings of the same Name
78         -- get different SrcLocs can can be reported as such.
79         --
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'
84         --
85         -- IMPORTANT: Don't mess with wired-in names.  
86         --            Their wired-in-ness is in their NameSort
87         --            and their Module is correct.
88
89         Just name | isWiredInName name -> (name_supply, name)
90                   | otherwise -> (new_name_supply, name')
91                   where
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}              
96
97         -- Miss in the cache!
98         -- Build a completely new Name, and put it in the cache
99         Nothing -> (new_name_supply, name)
100                 where
101                   (uniq, us')     = takeUniqFromSupply (nsUniqs name_supply)
102                   name            = mkExternalName uniq mod occ loc
103                   new_cache       = extendNameCache (nsNames name_supply) mod occ name
104                   new_name_supply = name_supply {nsUniqs = us', nsNames = new_cache}
105
106
107 newImplicitBinder :: Name                       -- Base name
108                   -> (OccName -> OccName)       -- Occurrence name modifier
109                   -> TcRnIf m n Name            -- Implicit name
110 -- Called in BuildTyCl to allocate the implicit binders of type/class decls
111 -- For source type/class decls, this is the first occurrence
112 -- For iface ones, the LoadIface has alrady allocated a suitable name in the cache
113 newImplicitBinder base_name mk_sys_occ
114   | Just mod <- nameModule_maybe base_name
115   = newGlobalBinder mod occ loc
116   | otherwise           -- When typechecking a [d| decl bracket |], 
117                         -- TH generates types, classes etc with Internal names,
118                         -- so we follow suit for the implicit binders
119   = do  { uniq <- newUnique
120         ; return (mkInternalName uniq occ loc) }
121   where
122     occ = mk_sys_occ (nameOccName base_name)
123     loc = nameSrcSpan base_name
124
125 ifaceExportNames :: [IfaceExport] -> TcRnIf gbl lcl [AvailInfo]
126 ifaceExportNames exports = do
127   mod_avails <- mapM (\(mod,avails) -> mapM (lookupAvail mod) avails) exports
128   return (concat mod_avails)
129
130 -- Convert OccNames in GenAvailInfo to Names.
131 lookupAvail :: Module -> GenAvailInfo OccName -> TcRnIf a b AvailInfo
132 lookupAvail mod (Avail n) = do 
133   n' <- lookupOrig mod n
134   return (Avail n')
135 lookupAvail mod (AvailTC p_occ occs) = do
136   p_name <- lookupOrig mod p_occ
137   let lookup_sub occ | occ == p_occ = return p_name
138                      | otherwise    = lookupOrig mod occ
139   subs <- mapM lookup_sub occs
140   return (AvailTC p_name subs)
141         -- Remember that 'occs' is all the exported things, including
142         -- the parent.  It's possible to export just class ops without
143         -- the class, which shows up as C( op ) here. If the class was
144         -- exported too we'd have C( C, op )
145
146 lookupOrig :: Module -> OccName ->  TcRnIf a b Name
147 lookupOrig mod occ
148   = do  {       -- First ensure that mod and occ are evaluated
149                 -- If not, chaos can ensue:
150                 --      we read the name-cache
151                 --      then pull on mod (say)
152                 --      which does some stuff that modifies the name cache
153                 -- This did happen, with tycon_mod in TcIface.tcIfaceAlt (DataAlt..)
154           mod `seq` occ `seq` return () 
155 --      ; traceIf (text "lookup_orig" <+> ppr mod <+> ppr occ)
156
157         ; updNameCache $ \name_cache ->
158             case lookupOrigNameCache (nsNames name_cache) mod occ of {
159               Just name -> (name_cache, name);
160               Nothing   ->
161               case takeUniqFromSupply (nsUniqs name_cache) of {
162               (uniq, us) ->
163                   let
164                     name      = mkExternalName uniq mod occ noSrcSpan
165                     new_cache = extendNameCache (nsNames name_cache) mod occ name
166                   in (name_cache{ nsUniqs = us, nsNames = new_cache }, name)
167     }}}
168
169 newIPName :: IPName OccName -> TcRnIf m n (IPName Name)
170 newIPName occ_name_ip =
171   updNameCache $ \name_cache ->
172     let
173         ipcache = nsIPs name_cache
174         key = occ_name_ip  -- Ensures that ?x and %x get distinct Names
175     in
176     case Map.lookup key ipcache of
177       Just name_ip -> (name_cache, name_ip)
178       Nothing      -> (new_ns, name_ip)
179           where
180             (uniq, us') = takeUniqFromSupply (nsUniqs name_cache)
181             name_ip     = mapIPName (mkIPName uniq) occ_name_ip
182             new_ipcache = Map.insert key name_ip ipcache
183             new_ns      = name_cache {nsUniqs = us', nsIPs = new_ipcache}
184 \end{code}
185
186 %************************************************************************
187 %*                                                                      *
188                 Name cache access
189 %*                                                                      *
190 %************************************************************************
191
192 \begin{code}
193 lookupOrigNameCache :: OrigNameCache -> Module -> OccName -> Maybe Name
194 lookupOrigNameCache _ mod occ
195   -- XXX Why is gHC_UNIT not mentioned here?
196   | mod == gHC_TUPLE || mod == gHC_PRIM,                -- Boxed tuples from one, 
197     Just tup_info <- isTupleOcc_maybe occ       -- unboxed from the other
198   =     -- Special case for tuples; there are too many
199         -- of them to pre-populate the original-name cache
200     Just (mk_tup_name tup_info)
201   where
202     mk_tup_name (ns, boxity, arity)
203         | ns == tcName   = tyConName (tupleTyCon boxity arity)
204         | ns == dataName = dataConName (tupleCon boxity arity)
205         | otherwise      = Var.varName (dataConWorkId (tupleCon boxity arity))
206
207 lookupOrigNameCache nc mod occ  -- The normal case
208   = case lookupModuleEnv nc mod of
209         Nothing      -> Nothing
210         Just occ_env -> lookupOccEnv occ_env occ
211
212 extendOrigNameCache :: OrigNameCache -> Name -> OrigNameCache
213 extendOrigNameCache nc name 
214   = ASSERT2( isExternalName name, ppr name ) 
215     extendNameCache nc (nameModule name) (nameOccName name) name
216
217 extendNameCache :: OrigNameCache -> Module -> OccName -> Name -> OrigNameCache
218 extendNameCache nc mod occ name
219   = extendModuleEnvWith combine nc mod (unitOccEnv occ name)
220   where
221     combine _ occ_env = extendOccEnv occ_env occ name
222
223 getNameCache :: TcRnIf a b NameCache
224 getNameCache = do { HscEnv { hsc_NC = nc_var } <- getTopEnv; 
225                     readMutVar nc_var }
226
227 updNameCache :: (NameCache -> (NameCache, c)) -> TcRnIf a b c
228 updNameCache upd_fn = do
229   HscEnv { hsc_NC = nc_var } <- getTopEnv
230   atomicUpdMutVar' nc_var upd_fn
231
232 -- | A function that atomically updates the name cache given a modifier
233 -- function.  The second result of the modifier function will be the result
234 -- of the IO action.
235 type NameCacheUpdater c = (NameCache -> (NameCache, c)) -> IO c
236
237 -- | Return a function to atomically update the name cache.
238 mkNameCacheUpdater :: TcRnIf a b (NameCacheUpdater c)
239 mkNameCacheUpdater = do
240   nc_var <- hsc_NC `fmap` getTopEnv
241   let update_nc f = do r <- atomicModifyIORef nc_var f
242                        _ <- evaluate =<< readIORef nc_var
243                        return r
244   return update_nc
245 \end{code}
246
247
248 \begin{code}
249 initNameCache :: UniqSupply -> [Name] -> NameCache
250 initNameCache us names
251   = NameCache { nsUniqs = us,
252                 nsNames = initOrigNames names,
253                 nsIPs   = Map.empty }
254
255 initOrigNames :: [Name] -> OrigNameCache
256 initOrigNames names = foldl extendOrigNameCache emptyModuleEnv names
257 \end{code}
258
259
260
261 %************************************************************************
262 %*                                                                      *
263                 Type variables and local Ids
264 %*                                                                      *
265 %************************************************************************
266
267 \begin{code}
268 tcIfaceLclId :: FastString -> IfL Id
269 tcIfaceLclId occ
270   = do  { lcl <- getLclEnv
271         ; case (lookupUFM (if_id_env lcl) occ) of
272             Just ty_var -> return ty_var
273             Nothing     -> failIfM (text "Iface id out of scope: " <+> ppr occ)
274         }
275
276 extendIfaceIdEnv :: [Id] -> IfL a -> IfL a
277 extendIfaceIdEnv ids thing_inside
278   = do  { env <- getLclEnv
279         ; let { id_env' = addListToUFM (if_id_env env) pairs
280               ; pairs   = [(occNameFS (getOccName id), id) | id <- ids] }
281         ; setLclEnv (env { if_id_env = id_env' }) thing_inside }
282
283
284 tcIfaceTyVar :: FastString -> IfL TyVar
285 tcIfaceTyVar occ
286   = do  { lcl <- getLclEnv
287         ; case (lookupUFM (if_tv_env lcl) occ) of
288             Just ty_var -> return ty_var
289             Nothing     -> failIfM (text "Iface type variable out of scope: " <+> ppr occ)
290         }
291
292 lookupIfaceTyVar :: FastString -> IfL (Maybe TyVar)
293 lookupIfaceTyVar occ
294   = do  { lcl <- getLclEnv
295         ; return (lookupUFM (if_tv_env lcl) occ) }
296
297 extendIfaceTyVarEnv :: [TyVar] -> IfL a -> IfL a
298 extendIfaceTyVarEnv tyvars thing_inside
299   = do  { env <- getLclEnv
300         ; let { tv_env' = addListToUFM (if_tv_env env) pairs
301               ; pairs   = [(occNameFS (getOccName tv), tv) | tv <- tyvars] }
302         ; setLclEnv (env { if_tv_env = tv_env' }) thing_inside }
303 \end{code}
304
305
306 %************************************************************************
307 %*                                                                      *
308                 Getting from RdrNames to Names
309 %*                                                                      *
310 %************************************************************************
311
312 \begin{code}
313 lookupIfaceTop :: OccName -> IfL Name
314 -- Look up a top-level name from the current Iface module
315 lookupIfaceTop occ
316   = do  { env <- getLclEnv; lookupOrig (if_mod env) occ }
317
318 newIfaceName :: OccName -> IfL Name
319 newIfaceName occ
320   = do  { uniq <- newUnique
321         ; return $! mkInternalName uniq occ noSrcSpan }
322
323 newIfaceNames :: [OccName] -> IfL [Name]
324 newIfaceNames occs
325   = do  { uniqs <- newUniqueSupply
326         ; return [ mkInternalName uniq occ noSrcSpan
327                  | (occ,uniq) <- occs `zip` uniqsFromSupply uniqs] }
328 \end{code}
329
330 %************************************************************************
331 %*                                                                      *
332                 (Re)creating tick boxes
333 %*                                                                      *
334 %************************************************************************
335
336 \begin{code}
337 tcIfaceTick :: Module -> Int -> IfL Id
338 tcIfaceTick modName tickNo 
339   = do { uniq <- newUnique
340        ; return $ mkTickBoxOpId uniq modName tickNo
341        }
342 \end{code}
343
344