IfaceEnv.lhs 11.7 KB
Newer Older
Simon Marlow's avatar
Simon Marlow committed
1
(c) The University of Glasgow 2002-2006
2
3
4

\begin{code}
module IfaceEnv (
batterseapower's avatar
batterseapower committed
5
	newGlobalBinder, newImplicitBinder, 
6
7
	lookupIfaceTop,
	lookupOrig, lookupOrigNameCache, extendNameCache,
batterseapower's avatar
batterseapower committed
8
	newIPName, newIfaceName, newIfaceNames,
9
	extendIfaceIdEnv, extendIfaceTyVarEnv, 
10
	tcIfaceLclId, tcIfaceTyVar, lookupIfaceTyVar,
11
	tcIfaceTick,
12

13
	ifaceExportNames,
14

15
	-- Name-cache stuff
16
17
	allocateGlobalBinder, allocateIPName, initNameCache, updNameCache,
        getNameCache, mkNameCacheUpdater, NameCacheUpdater(..)
18
19
20
21
22
   ) where

#include "HsVersions.h"

import TcRnMonad
Simon Marlow's avatar
Simon Marlow committed
23
24
25
import TysWiredIn
import HscTypes
import TyCon
batterseapower's avatar
batterseapower committed
26
import Type
Simon Marlow's avatar
Simon Marlow committed
27
28
29
import DataCon
import Var
import Name
30
import Avail
Simon Marlow's avatar
Simon Marlow committed
31
32
import PrelNames
import Module
33
import UniqFM
Simon Marlow's avatar
Simon Marlow committed
34
35
36
import FastString
import UniqSupply
import SrcLoc
37
import MkId
batterseapower's avatar
batterseapower committed
38
import BasicTypes
39
40

import Outputable
41
import Exception     ( evaluate )
42

43
import Data.IORef    ( atomicModifyIORef, readIORef )
44
import qualified Data.Map as Map
45
46
47
48
49
50
51
52
53
54
\end{code}


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

\begin{code}
55
newGlobalBinder :: Module -> OccName -> SrcSpan -> TcRnIf a b Name
56
57
58
59
60
61
62
-- 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

63
newGlobalBinder mod occ loc
64
65
66
67
  = do mod `seq` occ `seq` return ()	-- See notes with lookupOrig
--     traceIf (text "newGlobalBinder" <+> ppr mod <+> ppr occ <+> ppr loc)
       updNameCache $ \name_cache ->
         allocateGlobalBinder name_cache mod occ loc
68
69
70

allocateGlobalBinder
  :: 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
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
        -- A hit in the cache!  We are at the binding site of the name.
        -- This is the moment when we know the SrcLoc
        -- of the Name, so we set this field in the Name we return.
        --
        -- 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)
                  | mod /= iNTERACTIVE -> (new_name_supply, name')
                     -- Note [interactive name cache]
                  where
                    uniq            = nameUnique name
                    name'           = mkExternalName uniq mod occ loc
                    new_cache       = extendNameCache (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
        _ -> (new_name_supply, name)
                  where
                    (uniq, us')     = takeUniqFromSupply (nsUniqs name_supply)
                    name            = mkExternalName uniq mod occ loc
                    new_cache       = extendNameCache (nsNames name_supply) mod occ name
                    new_name_supply = name_supply {nsUniqs = us', nsNames = new_cache}

{- Note [interactive name cache]

In GHCi we always create Names with the same Module, ":Interactive".
However, we want to be able to shadow older declarations with newer
ones, and we don't want the Name cache giving us back the same Unique
for the new Name as for the old, hence this special case.

See also Note [Outputable Orig RdrName] in HscTypes.
-}
118
119
120
121
122
123
124
125

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
newImplicitBinder base_name mk_sys_occ
126
127
128
129
130
131
132
133
134
135
  | Just mod <- nameModule_maybe base_name
  = newGlobalBinder mod occ loc
  | otherwise	  	-- When typechecking a [d| decl bracket |], 
    			-- TH generates types, classes etc with Internal names,
			-- so we follow suit for the implicit binders
  = do	{ uniq <- newUnique
	; return (mkInternalName uniq occ loc) }
  where
    occ = mk_sys_occ (nameOccName base_name)
    loc = nameSrcSpan base_name
136

137
ifaceExportNames :: [IfaceExport] -> TcRnIf gbl lcl [AvailInfo]
138
ifaceExportNames exports = return exports
139
140
141

lookupOrig :: Module -> OccName ->  TcRnIf a b Name
lookupOrig mod occ
142
  = do 	{ 	-- First ensure that mod and occ are evaluated
143
144
145
146
147
148
		-- 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 ()	
149
--	; traceIf (text "lookup_orig" <+> ppr mod <+> ppr occ)
150
151
152
153

        ; updNameCache $ \name_cache ->
            case lookupOrigNameCache (nsNames name_cache) mod occ of {
	      Just name -> (name_cache, name);
154
	      Nothing   ->
155
156
157
158
159
160
              case takeUniqFromSupply (nsUniqs name_cache) of {
              (uniq, us) ->
                  let
                    name      = mkExternalName uniq mod occ noSrcSpan
                    new_cache = extendNameCache (nsNames name_cache) mod occ name
                  in (name_cache{ nsUniqs = us, nsNames = new_cache }, name)
161
    }}}
162

163
164
165
166
167
168
169
170
171
172
173
174
allocateIPName :: NameCache -> FastString -> (NameCache, IPName Name)
allocateIPName name_cache ip = case Map.lookup ip ipcache of
    Just name_ip -> (name_cache, name_ip)
    Nothing      -> (new_ns, name_ip)
       where
         (us_here, us') = splitUniqSupply (nsUniqs name_cache)
         tycon_u:datacon_u:dc_wrk_u:co_ax_u:_ = uniqsFromSupply us_here
         name_ip     = mkIPName ip tycon_u datacon_u dc_wrk_u co_ax_u
         new_ipcache = Map.insert ip name_ip ipcache
         new_ns      = name_cache {nsUniqs = us', nsIPs = new_ipcache}
  where ipcache = nsIPs name_cache

batterseapower's avatar
batterseapower committed
175
newIPName :: FastString -> TcRnIf m n (IPName Name)
176
newIPName ip = updNameCache $ flip allocateIPName ip
177
178
\end{code}

batterseapower's avatar
batterseapower committed
179
180
181
182
183
%************************************************************************
%*									*
		Name cache access
%*									*
%************************************************************************
184
185

\begin{code}
186
lookupOrigNameCache :: OrigNameCache -> Module -> OccName -> Maybe Name
Ian Lynagh's avatar
Ian Lynagh committed
187
lookupOrigNameCache _ mod occ
batterseapower's avatar
batterseapower committed
188
189
  -- Don't need to mention gHC_UNIT here because it is explicitly
  -- included in TysWiredIn.wiredInTyCons
190
  | mod == gHC_TUPLE || mod == gHC_PRIM,		-- Boxed tuples from one, 
191
    Just tup_info <- isTupleOcc_maybe occ	-- unboxed from the other
192
193
194
195
  = 	-- Special case for tuples; there are too many
	-- of them to pre-populate the original-name cache
    Just (mk_tup_name tup_info)
  where
batterseapower's avatar
batterseapower committed
196
197
198
199
    mk_tup_name (ns, sort, arity)
	| ns == tcName   = tyConName (tupleTyCon sort arity)
	| ns == dataName = dataConName (tupleCon sort arity)
	| otherwise      = Var.varName (dataConWorkId (tupleCon sort arity))
200

201
202
lookupOrigNameCache nc mod occ	-- The normal case
  = case lookupModuleEnv nc mod of
203
204
205
206
207
	Nothing      -> Nothing
	Just occ_env -> lookupOccEnv occ_env occ

extendOrigNameCache :: OrigNameCache -> Name -> OrigNameCache
extendOrigNameCache nc name 
208
209
  = ASSERT2( isExternalName name, ppr name ) 
    extendNameCache nc (nameModule name) (nameOccName name) name
210

211
212
extendNameCache :: OrigNameCache -> Module -> OccName -> Name -> OrigNameCache
extendNameCache nc mod occ name
213
  = extendModuleEnvWith combine nc mod (unitOccEnv occ name)
214
  where
215
    combine _ occ_env = extendOccEnv occ_env occ name
216
217
218
219
220

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

221
222
223
224
225
updNameCache :: (NameCache -> (NameCache, c)) -> TcRnIf a b c
updNameCache upd_fn = do
  HscEnv { hsc_NC = nc_var } <- getTopEnv
  atomicUpdMutVar' nc_var upd_fn

226
227
228
-- | A function that atomically updates the name cache given a modifier
-- function.  The second result of the modifier function will be the result
-- of the IO action.
229
data NameCacheUpdater = NCU { updateNameCache :: forall c. (NameCache -> (NameCache, c)) -> IO c }
230

231
-- | Return a function to atomically update the name cache.
232
mkNameCacheUpdater :: TcRnIf a b NameCacheUpdater
233
mkNameCacheUpdater = do
234
  nc_var <- hsc_NC `fmap` getTopEnv
235
236
237
  let update_nc f = do r <- atomicModifyIORef nc_var f
                       _ <- evaluate =<< readIORef nc_var
                       return r
238
  return (NCU update_nc)
239
240
241
242
243
244
245
246
\end{code}


\begin{code}
initNameCache :: UniqSupply -> [Name] -> NameCache
initNameCache us names
  = NameCache { nsUniqs = us,
		nsNames = initOrigNames names,
batterseapower's avatar
batterseapower committed
247
                nsIPs   = Map.empty }
248
249
250
251
252
253

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


254

255
256
%************************************************************************
%*									*
257
		Type variables and local Ids
258
259
260
261
%*									*
%************************************************************************

\begin{code}
262
tcIfaceLclId :: FastString -> IfL Id
263
264
tcIfaceLclId occ
  = do	{ lcl <- getLclEnv
265
	; case (lookupUFM (if_id_env lcl) occ) of
266
267
268
            Just ty_var -> return ty_var
            Nothing     -> failIfM (text "Iface id out of scope: " <+> ppr occ)
        }
269
270
271
272

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

277

278
tcIfaceTyVar :: FastString -> IfL TyVar
279
280
tcIfaceTyVar occ
  = do	{ lcl <- getLclEnv
281
	; case (lookupUFM (if_tv_env lcl) occ) of
282
283
284
            Just ty_var -> return ty_var
            Nothing     -> failIfM (text "Iface type variable out of scope: " <+> ppr occ)
        }
285

286
287
288
289
290
lookupIfaceTyVar :: FastString -> IfL (Maybe TyVar)
lookupIfaceTyVar occ
  = do	{ lcl <- getLclEnv
	; return (lookupUFM (if_tv_env lcl) occ) }

291
292
293
extendIfaceTyVarEnv :: [TyVar] -> IfL a -> IfL a
extendIfaceTyVarEnv tyvars thing_inside
  = do	{ env <- getLclEnv
294
295
	; let { tv_env' = addListToUFM (if_tv_env env) pairs
	      ;	pairs   = [(occNameFS (getOccName tv), tv) | tv <- tyvars] }
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
	; setLclEnv (env { if_tv_env = tv_env' }) thing_inside }
\end{code}


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

\begin{code}
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
315
	; return $! mkInternalName uniq occ noSrcSpan }
316
317
318
319

newIfaceNames :: [OccName] -> IfL [Name]
newIfaceNames occs
  = do	{ uniqs <- newUniqueSupply
320
	; return [ mkInternalName uniq occ noSrcSpan
321
322
		 | (occ,uniq) <- occs `zip` uniqsFromSupply uniqs] }
\end{code}
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338

%************************************************************************
%*									*
		(Re)creating tick boxes
%*									*
%************************************************************************

\begin{code}
tcIfaceTick :: Module -> Int -> IfL Id
tcIfaceTick modName tickNo 
  = do { uniq <- newUnique
       ; return $ mkTickBoxOpId uniq modName tickNo
       }
\end{code}