Less Tc inside simplCore (Phase 1 for #14391)
[ghc.git] / compiler / iface / IfaceEnv.hs
1 -- (c) The University of Glasgow 2002-2006
2
3 {-# LANGUAGE CPP, RankNTypes #-}
4
5 module IfaceEnv (
6 newGlobalBinder, newInteractiveBinder,
7 externaliseName,
8 lookupIfaceTop,
9 lookupOrig, lookupOrigIO, lookupOrigNameCache, extendNameCache,
10 newIfaceName, newIfaceNames,
11 extendIfaceIdEnv, extendIfaceTyVarEnv,
12 tcIfaceLclId, tcIfaceTyVar, lookupIfaceVar,
13 lookupIfaceTyVar, extendIfaceEnvs,
14 setNameModule,
15
16 ifaceExportNames,
17
18 -- Name-cache stuff
19 allocateGlobalBinder, updNameCacheTc,
20 mkNameCacheUpdater, NameCacheUpdater(..),
21 ) where
22
23 #include "HsVersions.h"
24
25 import GhcPrelude
26
27 import TcRnMonad
28 import HscTypes
29 import Type
30 import Var
31 import Name
32 import Avail
33 import Module
34 import FastString
35 import FastStringEnv
36 import IfaceType
37 import NameCache
38 import UniqSupply
39 import SrcLoc
40
41 import Outputable
42 import Data.List ( partition )
43
44 {-
45 *********************************************************
46 * *
47 Allocating new Names in the Name Cache
48 * *
49 *********************************************************
50
51 See Also: Note [The Name Cache] in NameCache
52 -}
53
54 newGlobalBinder :: Module -> OccName -> SrcSpan -> TcRnIf a b Name
55 -- Used for source code and interface files, to make the
56 -- Name for a thing, given its Module and OccName
57 -- See Note [The Name Cache]
58 --
59 -- The cache may already already have a binding for this thing,
60 -- because we may have seen an occurrence before, but now is the
61 -- moment when we know its Module and SrcLoc in their full glory
62
63 newGlobalBinder mod occ loc
64 = do { name <- updNameCacheTc mod occ $ \name_cache ->
65 allocateGlobalBinder name_cache mod occ loc
66 ; traceIf (text "newGlobalBinder" <+>
67 (vcat [ ppr mod <+> ppr occ <+> ppr loc, ppr name]))
68 ; return name }
69
70 newInteractiveBinder :: HscEnv -> OccName -> SrcSpan -> IO Name
71 -- Works in the IO monad, and gets the Module
72 -- from the interactive context
73 newInteractiveBinder hsc_env occ loc
74 = do { let mod = icInteractiveModule (hsc_IC hsc_env)
75 ; updNameCacheIO hsc_env mod occ $ \name_cache ->
76 allocateGlobalBinder name_cache mod occ loc }
77
78 allocateGlobalBinder
79 :: NameCache
80 -> Module -> OccName -> SrcSpan
81 -> (NameCache, Name)
82 -- See Note [The Name Cache]
83 allocateGlobalBinder name_supply mod occ loc
84 = case lookupOrigNameCache (nsNames name_supply) mod occ of
85 -- A hit in the cache! We are at the binding site of the name.
86 -- This is the moment when we know the SrcLoc
87 -- of the Name, so we set this field in the Name we return.
88 --
89 -- Then (bogus) multiple bindings of the same Name
90 -- get different SrcLocs can can be reported as such.
91 --
92 -- Possible other reason: it might be in the cache because we
93 -- encountered an occurrence before the binding site for an
94 -- implicitly-imported Name. Perhaps the current SrcLoc is
95 -- better... but not really: it'll still just say 'imported'
96 --
97 -- IMPORTANT: Don't mess with wired-in names.
98 -- Their wired-in-ness is in their NameSort
99 -- and their Module is correct.
100
101 Just name | isWiredInName name
102 -> (name_supply, name)
103 | otherwise
104 -> (new_name_supply, name')
105 where
106 uniq = nameUnique name
107 name' = mkExternalName uniq mod occ loc
108 -- name' is like name, but with the right SrcSpan
109 new_cache = extendNameCache (nsNames name_supply) mod occ name'
110 new_name_supply = name_supply {nsNames = new_cache}
111
112 -- Miss in the cache!
113 -- Build a completely new Name, and put it in the cache
114 _ -> (new_name_supply, name)
115 where
116 (uniq, us') = takeUniqFromSupply (nsUniqs name_supply)
117 name = mkExternalName uniq mod occ loc
118 new_cache = extendNameCache (nsNames name_supply) mod occ name
119 new_name_supply = name_supply {nsUniqs = us', nsNames = new_cache}
120
121 ifaceExportNames :: [IfaceExport] -> TcRnIf gbl lcl [AvailInfo]
122 ifaceExportNames exports = return exports
123
124 -- | A function that atomically updates the name cache given a modifier
125 -- function. The second result of the modifier function will be the result
126 -- of the IO action.
127 newtype NameCacheUpdater
128 = NCU { updateNameCache :: forall c. (NameCache -> (NameCache, c)) -> IO c }
129
130 mkNameCacheUpdater :: TcRnIf a b NameCacheUpdater
131 mkNameCacheUpdater = do { hsc_env <- getTopEnv
132 ; return (NCU (updNameCache hsc_env)) }
133
134 updNameCacheTc :: Module -> OccName -> (NameCache -> (NameCache, c))
135 -> TcRnIf a b c
136 updNameCacheTc mod occ upd_fn = do {
137 hsc_env <- getTopEnv
138 ; liftIO $ updNameCacheIO hsc_env mod occ upd_fn }
139
140
141 updNameCacheIO :: HscEnv -> Module -> OccName
142 -> (NameCache -> (NameCache, c))
143 -> IO c
144 updNameCacheIO hsc_env mod occ upd_fn = do {
145
146 -- First ensure that mod and occ are evaluated
147 -- If not, chaos can ensue:
148 -- we read the name-cache
149 -- then pull on mod (say)
150 -- which does some stuff that modifies the name cache
151 -- This did happen, with tycon_mod in TcIface.tcIfaceAlt (DataAlt..)
152
153 mod `seq` occ `seq` return ()
154 ; updNameCache hsc_env upd_fn }
155
156
157 {-
158 ************************************************************************
159 * *
160 Name cache access
161 * *
162 ************************************************************************
163 -}
164
165 -- | Look up the 'Name' for a given 'Module' and 'OccName'.
166 -- Consider alternatively using 'lookupIfaceTop' if you're in the 'IfL' monad
167 -- and 'Module' is simply that of the 'ModIface' you are typechecking.
168 lookupOrig :: Module -> OccName -> TcRnIf a b Name
169 lookupOrig mod occ
170 = do { traceIf (text "lookup_orig" <+> ppr mod <+> ppr occ)
171
172 ; updNameCacheTc mod occ $ lookupNameCache mod occ }
173
174 lookupOrigIO :: HscEnv -> Module -> OccName -> IO Name
175 lookupOrigIO hsc_env mod occ
176 = updNameCacheIO hsc_env mod occ $ lookupNameCache mod occ
177
178 lookupNameCache :: Module -> OccName -> NameCache -> (NameCache, Name)
179 -- Lookup up the (Module,OccName) in the NameCache
180 -- If you find it, return it; if not, allocate a fresh original name and extend
181 -- the NameCache.
182 -- Reason: this may the first occurrence of (say) Foo.bar we have encountered.
183 -- If we need to explore its value we will load Foo.hi; but meanwhile all we
184 -- need is a Name for it.
185 lookupNameCache mod occ name_cache =
186 case lookupOrigNameCache (nsNames name_cache) mod occ of {
187 Just name -> (name_cache, name);
188 Nothing ->
189 case takeUniqFromSupply (nsUniqs name_cache) of {
190 (uniq, us) ->
191 let
192 name = mkExternalName uniq mod occ noSrcSpan
193 new_cache = extendNameCache (nsNames name_cache) mod occ name
194 in (name_cache{ nsUniqs = us, nsNames = new_cache }, name) }}
195
196 externaliseName :: Module -> Name -> TcRnIf m n Name
197 -- Take an Internal Name and make it an External one,
198 -- with the same unique
199 externaliseName mod name
200 = do { let occ = nameOccName name
201 loc = nameSrcSpan name
202 uniq = nameUnique name
203 ; occ `seq` return () -- c.f. seq in newGlobalBinder
204 ; updNameCacheTc mod occ $ \ ns ->
205 let name' = mkExternalName uniq mod occ loc
206 ns' = ns { nsNames = extendNameCache (nsNames ns) mod occ name' }
207 in (ns', name') }
208
209 -- | Set the 'Module' of a 'Name'.
210 setNameModule :: Maybe Module -> Name -> TcRnIf m n Name
211 setNameModule Nothing n = return n
212 setNameModule (Just m) n =
213 newGlobalBinder m (nameOccName n) (nameSrcSpan n)
214
215 {-
216 ************************************************************************
217 * *
218 Type variables and local Ids
219 * *
220 ************************************************************************
221 -}
222
223 tcIfaceLclId :: FastString -> IfL Id
224 tcIfaceLclId occ
225 = do { lcl <- getLclEnv
226 ; case (lookupFsEnv (if_id_env lcl) occ) of
227 Just ty_var -> return ty_var
228 Nothing -> failIfM (text "Iface id out of scope: " <+> ppr occ)
229 }
230
231 extendIfaceIdEnv :: [Id] -> IfL a -> IfL a
232 extendIfaceIdEnv ids thing_inside
233 = do { env <- getLclEnv
234 ; let { id_env' = extendFsEnvList (if_id_env env) pairs
235 ; pairs = [(occNameFS (getOccName id), id) | id <- ids] }
236 ; setLclEnv (env { if_id_env = id_env' }) thing_inside }
237
238
239 tcIfaceTyVar :: FastString -> IfL TyVar
240 tcIfaceTyVar occ
241 = do { lcl <- getLclEnv
242 ; case (lookupFsEnv (if_tv_env lcl) occ) of
243 Just ty_var -> return ty_var
244 Nothing -> failIfM (text "Iface type variable out of scope: " <+> ppr occ)
245 }
246
247 lookupIfaceTyVar :: IfaceTvBndr -> IfL (Maybe TyVar)
248 lookupIfaceTyVar (occ, _)
249 = do { lcl <- getLclEnv
250 ; return (lookupFsEnv (if_tv_env lcl) occ) }
251
252 lookupIfaceVar :: IfaceBndr -> IfL (Maybe TyCoVar)
253 lookupIfaceVar (IfaceIdBndr (occ, _))
254 = do { lcl <- getLclEnv
255 ; return (lookupFsEnv (if_id_env lcl) occ) }
256 lookupIfaceVar (IfaceTvBndr (occ, _))
257 = do { lcl <- getLclEnv
258 ; return (lookupFsEnv (if_tv_env lcl) occ) }
259
260 extendIfaceTyVarEnv :: [TyVar] -> IfL a -> IfL a
261 extendIfaceTyVarEnv tyvars thing_inside
262 = do { env <- getLclEnv
263 ; let { tv_env' = extendFsEnvList (if_tv_env env) pairs
264 ; pairs = [(occNameFS (getOccName tv), tv) | tv <- tyvars] }
265 ; setLclEnv (env { if_tv_env = tv_env' }) thing_inside }
266
267 extendIfaceEnvs :: [TyCoVar] -> IfL a -> IfL a
268 extendIfaceEnvs tcvs thing_inside
269 = extendIfaceTyVarEnv tvs $
270 extendIfaceIdEnv cvs $
271 thing_inside
272 where
273 (tvs, cvs) = partition isTyVar tcvs
274
275 {-
276 ************************************************************************
277 * *
278 Getting from RdrNames to Names
279 * *
280 ************************************************************************
281 -}
282
283 -- | Look up a top-level name from the current Iface module
284 lookupIfaceTop :: OccName -> IfL Name
285 lookupIfaceTop occ
286 = do { env <- getLclEnv; lookupOrig (if_mod env) occ }
287
288 newIfaceName :: OccName -> IfL Name
289 newIfaceName occ
290 = do { uniq <- newUnique
291 ; return $! mkInternalName uniq occ noSrcSpan }
292
293 newIfaceNames :: [OccName] -> IfL [Name]
294 newIfaceNames occs
295 = do { uniqs <- newUniqueSupply
296 ; return [ mkInternalName uniq occ noSrcSpan
297 | (occ,uniq) <- occs `zip` uniqsFromSupply uniqs] }