(c) The University of Glasgow 20022006
\begin{code}
module IfaceEnv (
newGlobalBinder, newIPName, newImplicitBinder,
lookupIfaceTop,
lookupOrig, lookupOrigNameCache, extendNameCache,
newIfaceName, newIfaceNames,
extendIfaceIdEnv, extendIfaceTyVarEnv,
tcIfaceLclId, tcIfaceTyVar, lookupIfaceTyVar,
tcIfaceTick,
ifaceExportNames,
allocateGlobalBinder, initNameCache,
getNameCache, mkNameCacheUpdater, NameCacheUpdater
) where
#include "HsVersions.h"
import TcRnMonad
import TysWiredIn
import HscTypes
import TyCon
import DataCon
import Var
import Name
import PrelNames
import Module
import UniqFM
import FastString
import UniqSupply
import BasicTypes
import SrcLoc
import MkId
import Outputable
import Exception ( evaluate )
import Data.IORef ( atomicModifyIORef, readIORef )
import qualified Data.Map as Map
\end{code}
%*********************************************************
%* *
Allocating new Names in the Name Cache
%* *
%*********************************************************
\begin{code}
newGlobalBinder :: Module -> OccName -> SrcSpan -> TcRnIf a b Name
newGlobalBinder mod occ loc
= do mod `seq` occ `seq` return ()
updNameCache $ \name_cache ->
allocateGlobalBinder name_cache mod occ loc
allocateGlobalBinder
:: NameCache
-> Module -> OccName -> SrcSpan
-> (NameCache, Name)
allocateGlobalBinder name_supply mod occ loc
= case lookupOrigNameCache (nsNames name_supply) mod occ of
Just name | isWiredInName name -> (name_supply, name)
| otherwise -> (new_name_supply, name')
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}
Nothing -> (new_name_supply, name)
where
(us', us1) = splitUniqSupply (nsUniqs name_supply)
uniq = uniqFromSupply us1
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}
newImplicitBinder :: Name
-> (OccName -> OccName)
-> TcRnIf m n Name
newImplicitBinder base_name mk_sys_occ
| Just mod <- nameModule_maybe base_name
= newGlobalBinder mod occ loc
| otherwise
= do { uniq <- newUnique
; return (mkInternalName uniq occ loc) }
where
occ = mk_sys_occ (nameOccName base_name)
loc = nameSrcSpan base_name
ifaceExportNames :: [IfaceExport] -> TcRnIf gbl lcl [AvailInfo]
ifaceExportNames exports = do
mod_avails <- mapM (\(mod,avails) -> mapM (lookupAvail mod) avails) exports
return (concat mod_avails)
lookupAvail :: Module -> GenAvailInfo OccName -> TcRnIf a b AvailInfo
lookupAvail mod (Avail n) = do
n' <- lookupOrig mod n
return (Avail n')
lookupAvail mod (AvailTC p_occ occs) = do
p_name <- lookupOrig mod p_occ
let lookup_sub occ | occ == p_occ = return p_name
| otherwise = lookupOrig mod occ
subs <- mapM lookup_sub occs
return (AvailTC p_name subs)
lookupOrig :: Module -> OccName -> TcRnIf a b Name
lookupOrig mod occ
= do {
mod `seq` occ `seq` return ()
; updNameCache $ \name_cache ->
case lookupOrigNameCache (nsNames name_cache) mod occ of {
Just name -> (name_cache, name);
Nothing ->
let
us = nsUniqs name_cache
uniq = uniqFromSupply us
name = mkExternalName uniq mod occ noSrcSpan
new_cache = extendNameCache (nsNames name_cache) mod occ name
in
case splitUniqSupply us of { (us',_) -> do
(name_cache{ nsUniqs = us', nsNames = new_cache }, name)
}}}
newIPName :: IPName OccName -> TcRnIf m n (IPName Name)
newIPName occ_name_ip =
updNameCache $ \name_cache ->
let
ipcache = nsIPs name_cache
key = occ_name_ip
in
case Map.lookup key ipcache of
Just name_ip -> (name_cache, name_ip)
Nothing -> (new_ns, name_ip)
where
(us', us1) = splitUniqSupply (nsUniqs name_cache)
uniq = uniqFromSupply us1
name_ip = mapIPName (mkIPName uniq) occ_name_ip
new_ipcache = Map.insert key name_ip ipcache
new_ns = name_cache {nsUniqs = us', nsIPs = new_ipcache}
\end{code}
%************************************************************************
%* *
Name cache access
%* *
%************************************************************************
\begin{code}
lookupOrigNameCache :: OrigNameCache -> Module -> OccName -> Maybe Name
lookupOrigNameCache _ mod occ
| mod == gHC_TUPLE || mod == gHC_PRIM,
Just tup_info <- isTupleOcc_maybe occ
=
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 = Var.varName (dataConWorkId (tupleCon boxity arity))
lookupOrigNameCache nc mod occ
= case lookupModuleEnv nc mod of
Nothing -> Nothing
Just occ_env -> lookupOccEnv occ_env occ
extendOrigNameCache :: OrigNameCache -> Name -> OrigNameCache
extendOrigNameCache nc name
= ASSERT2( isExternalName name, ppr name )
extendNameCache nc (nameModule name) (nameOccName name) name
extendNameCache :: OrigNameCache -> Module -> OccName -> Name -> OrigNameCache
extendNameCache nc mod occ name
= extendModuleEnvWith 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 }
updNameCache :: (NameCache -> (NameCache, c)) -> TcRnIf a b c
updNameCache upd_fn = do
HscEnv { hsc_NC = nc_var } <- getTopEnv
atomicUpdMutVar' nc_var upd_fn
type NameCacheUpdater c = (NameCache -> (NameCache, c)) -> IO c
mkNameCacheUpdater :: TcRnIf a b (NameCacheUpdater c)
mkNameCacheUpdater = do
nc_var <- hsc_NC `fmap` getTopEnv
let update_nc f = do r <- atomicModifyIORef nc_var f
_ <- evaluate =<< readIORef nc_var
return r
return update_nc
\end{code}
\begin{code}
initNameCache :: UniqSupply -> [Name] -> NameCache
initNameCache us names
= NameCache { nsUniqs = us,
nsNames = initOrigNames names,
nsIPs = Map.empty }
initOrigNames :: [Name] -> OrigNameCache
initOrigNames names = foldl extendOrigNameCache emptyModuleEnv names
\end{code}
%************************************************************************
%* *
Type variables and local Ids
%* *
%************************************************************************
\begin{code}
tcIfaceLclId :: FastString -> IfL Id
tcIfaceLclId occ
= do { lcl <- getLclEnv
; case (lookupUFM (if_id_env lcl) occ) of
Just ty_var -> return ty_var
Nothing -> failIfM (text "Iface id out of scope: " <+> ppr occ)
}
extendIfaceIdEnv :: [Id] -> IfL a -> IfL a
extendIfaceIdEnv ids thing_inside
= do { env <- getLclEnv
; let { id_env' = addListToUFM (if_id_env env) pairs
; pairs = [(occNameFS (getOccName id), id) | id <- ids] }
; setLclEnv (env { if_id_env = id_env' }) thing_inside }
tcIfaceTyVar :: FastString -> IfL TyVar
tcIfaceTyVar occ
= do { lcl <- getLclEnv
; case (lookupUFM (if_tv_env lcl) occ) of
Just ty_var -> return ty_var
Nothing -> failIfM (text "Iface type variable out of scope: " <+> ppr occ)
}
lookupIfaceTyVar :: FastString -> IfL (Maybe TyVar)
lookupIfaceTyVar occ
= do { lcl <- getLclEnv
; return (lookupUFM (if_tv_env lcl) occ) }
extendIfaceTyVarEnv :: [TyVar] -> IfL a -> IfL a
extendIfaceTyVarEnv tyvars thing_inside
= do { env <- getLclEnv
; let { tv_env' = addListToUFM (if_tv_env env) pairs
; pairs = [(occNameFS (getOccName tv), tv) | tv <- tyvars] }
; setLclEnv (env { if_tv_env = tv_env' }) thing_inside }
\end{code}
%************************************************************************
%* *
Getting from RdrNames to Names
%* *
%************************************************************************
\begin{code}
lookupIfaceTop :: OccName -> IfL Name
lookupIfaceTop occ
= do { env <- getLclEnv; lookupOrig (if_mod env) occ }
newIfaceName :: OccName -> IfL Name
newIfaceName occ
= do { uniq <- newUnique
; return $! mkInternalName uniq occ noSrcSpan }
newIfaceNames :: [OccName] -> IfL [Name]
newIfaceNames occs
= do { uniqs <- newUniqueSupply
; return [ mkInternalName uniq occ noSrcSpan
| (occ,uniq) <- occs `zip` uniqsFromSupply uniqs] }
\end{code}
%************************************************************************
%* *
(Re)creating tick boxes
%* *
%************************************************************************
\begin{code}
tcIfaceTick :: Module -> Int -> IfL Id
tcIfaceTick modName tickNo
= do { uniq <- newUnique
; return $ mkTickBoxOpId uniq modName tickNo
}
\end{code}