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