IfaceEnv.lhs 10.4 KB
Newer Older
1
2
3
4
5
6
(c) The University of Glasgow 2002

\begin{code}
module IfaceEnv (
	newGlobalBinder, newIPName, newImplicitBinder, 
	lookupIfaceTop, lookupIfaceExt,
7
	lookupOrig, lookupIfaceTc,
8
9
	newIfaceName, newIfaceNames,
	extendIfaceIdEnv, extendIfaceTyVarEnv,
10
	tcIfaceLclId,     tcIfaceTyVar, 
11
12

	-- Name-cache stuff
13
	allocateGlobalBinder, initNameCache, 
14
15
16
17
18
19
   ) where

#include "HsVersions.h"

import TcRnMonad
import IfaceType	( IfaceExtName(..), IfaceTyCon(..), ifaceTyConName )
20
import TysWiredIn	( tupleTyCon, tupleCon )
21
import HscTypes		( NameCache(..), HscEnv(..), OrigNameCache )
22
import TyCon		( TyCon, tyConName )
23
import DataCon		( dataConWorkId, dataConName )
24
import Var		( TyVar, Id, varName )
25
import Name		( Name, nameUnique, nameModule, 
26
			  nameOccName, nameSrcLoc, 
27
			  getOccName, nameParent_maybe,
28
		  	  isWiredInName, mkIPName,
29
			  mkExternalName, mkInternalName )
30

31
32
import OccName		( OccName, isTupleOcc_maybe, tcName, dataName,
			  lookupOccEnv, unitOccEnv, extendOccEnv, extendOccEnvList )
33
import PrelNames	( gHC_PRIM, pREL_TUP )
34
import Module		( Module, emptyModuleEnv, 
35
			  lookupModuleEnv, extendModuleEnv_C )
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
import UniqSupply	( UniqSupply, splitUniqSupply, uniqFromSupply, uniqsFromSupply )
import FiniteMap	( emptyFM, lookupFM, addToFM )
import BasicTypes	( IPName(..), mapIPName )
import SrcLoc		( SrcLoc, noSrcLoc )
import Maybes		( orElse )

import Outputable
\end{code}


%*********************************************************
%*							*
	Allocating new Names in the Name Cache
%*							*
%*********************************************************

\begin{code}
newGlobalBinder :: Module -> OccName -> Maybe Name -> SrcLoc -> TcRnIf a b Name
-- Used for source code and interface files, to make the
-- Name for a thing, given its Module and OccName
--
-- The cache may already already have a binding for this thing,
-- because we may have seen an occurrence before, but now is the
-- moment when we know its Module and SrcLoc in their full glory

newGlobalBinder mod occ mb_parent loc
  = do	{ mod `seq` occ `seq` return ()	-- See notes with lookupOrig_help
    	; name_supply <- getNameCache
	; let (name_supply', name) = allocateGlobalBinder 
					name_supply mod occ
					mb_parent loc
	; setNameCache name_supply'
	; return name }

allocateGlobalBinder
  :: NameCache 
  -> Module -> OccName -> Maybe Name -> SrcLoc 
  -> (NameCache, Name)
allocateGlobalBinder name_supply mod occ mb_parent loc
75
  = case lookupOrigNameCache (nsNames name_supply) mod occ of
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
	-- A hit in the cache!  We are at the binding site of the name.
	-- This is the moment when we know the defining Module and SrcLoc
	-- of the Name, so we set these fields in the Name we return.
	--
	-- This is essential, to get the right Module in a Name.
	-- Also: then (bogus) multiple bindings of the same Name
	-- 		get different SrcLocs can can be reported as such.
	--
	-- Possible other reason: it might be in the cache because we
	-- 	encountered an occurrence before the binding site for an
	--	implicitly-imported Name.  Perhaps the current SrcLoc is
	--	better... but not really: it'll still just say 'imported'
	--
	-- IMPORTANT: Don't mess with wired-in names.  
	-- 	      Their wired-in-ness is in their NameSort
	--	      and their Module is correct.

	Just name | isWiredInName name -> (name_supply, name)
		  | otherwise -> (new_name_supply, name')
		  where
		    uniq      = nameUnique name
		    name'     = mkExternalName uniq mod occ mb_parent loc
		    new_cache = extend_name_cache (nsNames name_supply) mod occ name'
		    new_name_supply = name_supply {nsNames = new_cache}		     

	-- Miss in the cache!
	-- Build a completely new Name, and put it in the cache
	Nothing -> (new_name_supply, name)
		where
		  (us', us1)      = splitUniqSupply (nsUniqs name_supply)
		  uniq   	  = uniqFromSupply us1
		  name            = mkExternalName uniq mod occ mb_parent loc
		  new_cache       = extend_name_cache (nsNames name_supply) mod occ name
		  new_name_supply = name_supply {nsUniqs = us', nsNames = new_cache}


newImplicitBinder :: Name			-- Base name
	          -> (OccName -> OccName) 	-- Occurrence name modifier
	          -> TcRnIf m n Name		-- Implicit name
-- Called in BuildTyCl to allocate the implicit binders of type/class decls
-- For source type/class decls, this is the first occurrence
-- For iface ones, the LoadIface has alrady allocated a suitable name in the cache
--
-- An *implicit* name has the base-name as parent
newImplicitBinder base_name mk_sys_occ
  = newGlobalBinder (nameModule base_name)
		    (mk_sys_occ (nameOccName base_name))
		    (Just parent_name)
		    (nameSrcLoc base_name)    
  where
    parent_name = case nameParent_maybe base_name of
		    Just parent_name  -> parent_name
		    Nothing 	      -> base_name

130
131
lookupOrig :: Module -> OccName -> TcRnIf a b Name
-- Even if we get a miss in the original-name cache, we 
132
133
134
-- make a new External Name. 
-- We fake up 
-- 	SrcLoc to noSrcLoc
135
--	Parent no Nothing
136
-- They'll be overwritten, in due course, by LoadIface.loadDecl.
137

138
139
lookupOrig mod occ 
  = do 	{ 	-- First ensure that mod and occ are evaluated
140
141
142
143
144
145
146
147
		-- If not, chaos can ensue:
		-- 	we read the name-cache
		-- 	then pull on mod (say)
		--	which does some stuff that modifies the name cache
		-- This did happen, with tycon_mod in TcIface.tcIfaceAlt (DataAlt..)
	  mod `seq` occ `seq` return ()	
    
	; name_supply <- getNameCache
148
    	; case lookupOrigNameCache (nsNames name_supply) mod occ of {
149
150
151
152
153
	      Just name -> returnM name ;
	      Nothing   -> do 

	{ let { (us', us1)      = splitUniqSupply (nsUniqs name_supply)
	      ;	uniq   	  	= uniqFromSupply us1
154
155
	      ;	name            = mkExternalName uniq mod occ Nothing noSrcLoc
	      ;	new_cache       = extend_name_cache (nsNames name_supply) mod occ name
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
	      ;	new_name_supply = name_supply {nsUniqs = us', nsNames = new_cache}
	  }
	; setNameCache new_name_supply
	; return name }
    }}

newIPName :: IPName OccName -> TcRnIf m n (IPName Name)
newIPName occ_name_ip
  = getNameCache		`thenM` \ name_supply ->
    let
	ipcache = nsIPs name_supply
    in
    case lookupFM ipcache key of
	Just name_ip -> returnM name_ip
	Nothing      -> setNameCache new_ns 	`thenM_`
		        returnM name_ip
		  where
		     (us', us1)  = splitUniqSupply (nsUniqs name_supply)
		     uniq   	 = uniqFromSupply us1
		     name_ip	 = mapIPName (mkIPName uniq) occ_name_ip
		     new_ipcache = addToFM ipcache key name_ip
		     new_ns	 = name_supply {nsUniqs = us', nsIPs = new_ipcache}
    where 
	key = occ_name_ip	-- Ensures that ?x and %x get distinct Names
\end{code}

	Local helper functions (not exported)

\begin{code}
185
186
187
188
lookupOrigNameCache :: OrigNameCache -> Module -> OccName -> Maybe Name
lookupOrigNameCache nc mod occ
  | mod == pREL_TUP || mod == gHC_PRIM,		-- Boxed tuples from one, 
    Just tup_info <- isTupleOcc_maybe occ	-- unboxed from the other
189
190
191
192
193
194
195
196
197
  = 	-- Special case for tuples; there are too many
	-- of them to pre-populate the original-name cache
    Just (mk_tup_name tup_info)
  where
    mk_tup_name (ns, boxity, arity)
	| ns == tcName   = tyConName (tupleTyCon boxity arity)
	| ns == dataName = dataConName (tupleCon boxity arity)
	| otherwise      = varName (dataConWorkId (tupleCon boxity arity))

198
199
lookupOrigNameCache nc mod occ	-- The normal case
  = case lookupModuleEnv nc mod of
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
	Nothing      -> Nothing
	Just occ_env -> lookupOccEnv occ_env occ

extendOrigNameCache :: OrigNameCache -> Name -> OrigNameCache
extendOrigNameCache nc name 
  = extend_name_cache nc (nameModule name) (nameOccName name) name

extend_name_cache :: OrigNameCache -> Module -> OccName -> Name -> OrigNameCache
extend_name_cache nc mod occ name
  = extendModuleEnv_C combine nc mod (unitOccEnv occ name)
  where
    combine occ_env _ = extendOccEnv occ_env occ name

getNameCache :: TcRnIf a b NameCache
getNameCache = do { HscEnv { hsc_NC = nc_var } <- getTopEnv; 
		    readMutVar nc_var }

setNameCache :: NameCache -> TcRnIf a b ()
setNameCache nc = do { HscEnv { hsc_NC = nc_var } <- getTopEnv; 
		       writeMutVar nc_var nc }
\end{code}


\begin{code}
initNameCache :: UniqSupply -> [Name] -> NameCache
initNameCache us names
  = NameCache { nsUniqs = us,
		nsNames = initOrigNames names,
		nsIPs   = emptyFM }

initOrigNames :: [Name] -> OrigNameCache
initOrigNames names = foldl extendOrigNameCache emptyModuleEnv names
\end{code}


235

236
237
%************************************************************************
%*									*
238
		Type variables and local Ids
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
%*									*
%************************************************************************

\begin{code}
tcIfaceLclId :: OccName -> IfL Id
tcIfaceLclId occ
  = do	{ lcl <- getLclEnv
	; return (lookupOccEnv (if_id_env lcl) occ
		  `orElse` 
		  pprPanic "tcIfaceLclId" (ppr occ)) }

extendIfaceIdEnv :: [Id] -> IfL a -> IfL a
extendIfaceIdEnv ids thing_inside
  = do	{ env <- getLclEnv
	; let { id_env' = extendOccEnvList (if_id_env env) pairs
	      ;	pairs   = [(getOccName id, id) | id <- ids] }
	; setLclEnv (env { if_id_env = id_env' }) thing_inside }

257
258
259
260
261
262
263
264

tcIfaceTyVar :: OccName -> IfL TyVar
tcIfaceTyVar occ
  = do	{ lcl <- getLclEnv
	; return (lookupOccEnv (if_tv_env lcl) occ
		  `orElse`
		  pprPanic "tcIfaceTyVar" (ppr occ)) }

265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
extendIfaceTyVarEnv :: [TyVar] -> IfL a -> IfL a
extendIfaceTyVarEnv tyvars thing_inside
  = do	{ env <- getLclEnv
	; let { tv_env' = extendOccEnvList (if_tv_env env) pairs
	      ;	pairs   = [(getOccName tv, tv) | tv <- tyvars] }
	; setLclEnv (env { if_tv_env = tv_env' }) thing_inside }
\end{code}


%************************************************************************
%*									*
		Getting from RdrNames to Names
%*									*
%************************************************************************

\begin{code}
lookupIfaceTc :: IfaceTyCon -> IfL Name
lookupIfaceTc (IfaceTc ext) = lookupIfaceExt ext
lookupIfaceTc other_tc	    = return (ifaceTyConName other_tc)

lookupIfaceExt :: IfaceExtName -> IfL Name
lookupIfaceExt (ExtPkg  mod occ)   = lookupOrig mod occ
lookupIfaceExt (HomePkg mod occ _) = lookupOrig mod occ
lookupIfaceExt (LocalTop occ)	   = lookupIfaceTop occ
lookupIfaceExt (LocalTopSub occ _) = lookupIfaceTop occ

lookupIfaceTop :: OccName -> IfL Name
-- Look up a top-level name from the current Iface module
lookupIfaceTop occ
  = do	{ env <- getLclEnv; lookupOrig (if_mod env) occ }

newIfaceName :: OccName -> IfL Name
newIfaceName occ
  = do	{ uniq <- newUnique
	; return (mkInternalName uniq occ noSrcLoc) }

newIfaceNames :: [OccName] -> IfL [Name]
newIfaceNames occs
  = do	{ uniqs <- newUniqueSupply
	; return [ mkInternalName uniq occ noSrcLoc
		 | (occ,uniq) <- occs `zip` uniqsFromSupply uniqs] }
\end{code}