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,
  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   = newGlobalBinder (nameModule base_name)
 118                     (mk_sys_occ (nameOccName base_name))
 119                     (nameSrcSpan base_name)
 120
 121 ifaceExportNames :: [IfaceExport] -> TcRnIf gbl lcl [AvailInfo]
 122 ifaceExportNames exports = do
 123   mod_avails <- mapM (\(mod,avails) -> mapM (lookupAvail mod) avails) exports
 124   return (concat mod_avails)
 125
 126 -- Convert OccNames in GenAvailInfo to Names.
 127 lookupAvail :: Module -> GenAvailInfo OccName -> TcRnIf a b AvailInfo
 128 lookupAvail mod (Avail n) = do
 129   n' <- lookupOrig mod n
 130   return (Avail n')
 131 lookupAvail mod (AvailTC p_occ occs) = do
 132   p_name <- lookupOrig mod p_occ
 133   let lookup_sub occ | occ == p_occ = return p_name
 134                      | otherwise    = lookupOrig mod occ
 135   subs <- mapM lookup_sub occs
 136   return (AvailTC p_name subs)
 137         -- Remember that 'occs' is all the exported things, including
 138         -- the parent.  It's possible to export just class ops without
 139         -- the class, which shows up as C( op ) here. If the class was
 140         -- exported too we'd have C( C, op )
 141
 142 lookupOrig :: Module -> OccName ->  TcRnIf a b Name
 143 lookupOrig mod occ
 144   = do  {       -- First ensure that mod and occ are evaluated
 145                 -- If not, chaos can ensue:
 146                 --      we read the name-cache
 147                 --      then pull on mod (say)
 148                 --      which does some stuff that modifies the name cache
 149                 -- This did happen, with tycon_mod in TcIface.tcIfaceAlt (DataAlt..)
 150           mod `seq` occ `seq` return ()
 151 --      ; traceIf (text "lookup_orig" <+> ppr mod <+> ppr occ)
 152
 153         ; name_cache <- getNameCache
 154         ; case lookupOrigNameCache (nsNames name_cache) mod occ of {
 155               Just name -> return name;
 156               Nothing   ->
 157               let
 158                 us        = nsUniqs name_cache
 159                 uniq      = uniqFromSupply us
 160                 name      = mkExternalName uniq mod occ noSrcSpan
 161                 new_cache = extendNameCache (nsNames name_cache) mod occ name
 162               in
 163               case splitUniqSupply us of { (us',_) -> do
 164                 setNameCache name_cache{ nsUniqs = us', nsNames = new_cache }
 165                 return name
 166     }}}
 167
 168 newIPName :: IPName OccName -> TcRnIf m n (IPName Name)
 169 newIPName occ_name_ip = do
 170     name_supply <- getNameCache
 171     let
 172         ipcache = nsIPs name_supply
 173     case lookupFM ipcache key of
 174         Just name_ip -> return name_ip
 175         Nothing      -> do setNameCache new_ns
 176                            return name_ip
 177                   where
 178                      (us', us1)  = splitUniqSupply (nsUniqs name_supply)
 179                      uniq        = uniqFromSupply us1
 180                      name_ip     = mapIPName (mkIPName uniq) occ_name_ip
 181                      new_ipcache = addToFM ipcache key name_ip
 182                      new_ns      = name_supply {nsUniqs = us', nsIPs = new_ipcache}
 183     where
 184         key = occ_name_ip       -- Ensures that ?x and %x get distinct Names
 185 \end{code}
 186
 187 %************************************************************************
 188 %*                                                                      *
 189                 Name cache access
 190 %*                                                                      *
 191 %************************************************************************
 192
 193 \begin{code}
 194 lookupOrigNameCache :: OrigNameCache -> Module -> OccName -> Maybe Name
 195 lookupOrigNameCache _ mod occ
 196   -- XXX Why is gHC_UNIT not mentioned here?
 197   | mod == gHC_TUPLE || mod == gHC_PRIM,                -- Boxed tuples from one,
 198     Just tup_info <- isTupleOcc_maybe occ       -- unboxed from the other
 199   =     -- Special case for tuples; there are too many
 200         -- of them to pre-populate the original-name cache
 201     Just (mk_tup_name tup_info)
 202   where
 203     mk_tup_name (ns, boxity, arity)
 204         | ns == tcName   = tyConName (tupleTyCon boxity arity)
 205         | ns == dataName = dataConName (tupleCon boxity arity)
 206         | otherwise      = Var.varName (dataConWorkId (tupleCon boxity arity))
 207
 208 lookupOrigNameCache nc mod occ  -- The normal case
 209   = case lookupModuleEnv nc mod of
 210         Nothing      -> Nothing
 211         Just occ_env -> lookupOccEnv occ_env occ
 212
 213 extendOrigNameCache :: OrigNameCache -> Name -> OrigNameCache
 214 extendOrigNameCache nc name
 215   = ASSERT2( isExternalName name, ppr name )
 216     extendNameCache nc (nameModule name) (nameOccName name) name
 217
 218 extendNameCache :: OrigNameCache -> Module -> OccName -> Name -> OrigNameCache
 219 extendNameCache nc mod occ name
 220   = extendModuleEnv_C combine nc mod (unitOccEnv occ name)
 221   where
 222     combine occ_env _ = extendOccEnv occ_env occ name
 223
 224 getNameCache :: TcRnIf a b NameCache
 225 getNameCache = do { HscEnv { hsc_NC = nc_var } <- getTopEnv;
 226                     readMutVar nc_var }
 227
 228 setNameCache :: NameCache -> TcRnIf a b ()
 229 setNameCache nc = do { HscEnv { hsc_NC = nc_var } <- getTopEnv;
 230                        writeMutVar nc_var nc }
 231 \end{code}
 232
 233
 234 \begin{code}
 235 initNameCache :: UniqSupply -> [Name] -> NameCache
 236 initNameCache us names
 237   = NameCache { nsUniqs = us,
 238                 nsNames = initOrigNames names,
 239                 nsIPs   = emptyFM }
 240
 241 initOrigNames :: [Name] -> OrigNameCache
 242 initOrigNames names = foldl extendOrigNameCache emptyModuleEnv names
 243 \end{code}
 244
 245
 246
 247 %************************************************************************
 248 %*                                                                      *
 249                 Type variables and local Ids
 250 %*                                                                      *
 251 %************************************************************************
 252
 253 \begin{code}
 254 tcIfaceLclId :: FastString -> IfL Id
 255 tcIfaceLclId occ
 256   = do  { lcl <- getLclEnv
 257         ; case (lookupUFM (if_id_env lcl) occ) of
 258             Just ty_var -> return ty_var
 259             Nothing     -> failIfM (text "Iface id out of scope: " <+> ppr occ)
 260         }
 261
 262 extendIfaceIdEnv :: [Id] -> IfL a -> IfL a
 263 extendIfaceIdEnv ids thing_inside
 264   = do  { env <- getLclEnv
 265         ; let { id_env' = addListToUFM (if_id_env env) pairs
 266               ; pairs   = [(occNameFS (getOccName id), id) | id <- ids] }
 267         ; setLclEnv (env { if_id_env = id_env' }) thing_inside }
 268
 269
 270 tcIfaceTyVar :: FastString -> IfL TyVar
 271 tcIfaceTyVar occ
 272   = do  { lcl <- getLclEnv
 273         ; case (lookupUFM (if_tv_env lcl) occ) of
 274             Just ty_var -> return ty_var
 275             Nothing     -> failIfM (text "Iface type variable out of scope: " <+> ppr occ)
 276         }
 277
 278 extendIfaceTyVarEnv :: [TyVar] -> IfL a -> IfL a
 279 extendIfaceTyVarEnv tyvars thing_inside
 280   = do  { env <- getLclEnv
 281         ; let { tv_env' = addListToUFM (if_tv_env env) pairs
 282               ; pairs   = [(occNameFS (getOccName tv), tv) | tv <- tyvars] }
 283         ; setLclEnv (env { if_tv_env = tv_env' }) thing_inside }
 284 \end{code}
 285
 286
 287 %************************************************************************
 288 %*                                                                      *
 289                 Getting from RdrNames to Names
 290 %*                                                                      *
 291 %************************************************************************
 292
 293 \begin{code}
 294 lookupIfaceTop :: OccName -> IfL Name
 295 -- Look up a top-level name from the current Iface module
 296 lookupIfaceTop occ
 297   = do  { env <- getLclEnv; lookupOrig (if_mod env) occ }
 298
 299 newIfaceName :: OccName -> IfL Name
 300 newIfaceName occ
 301   = do  { uniq <- newUnique
 302         ; return $! mkInternalName uniq occ noSrcSpan }
 303
 304 newIfaceNames :: [OccName] -> IfL [Name]
 305 newIfaceNames occs
 306   = do  { uniqs <- newUniqueSupply
 307         ; return [ mkInternalName uniq occ noSrcSpan
 308                  | (occ,uniq) <- occs `zip` uniqsFromSupply uniqs] }
 309 \end{code}
 310
 311 %************************************************************************
 312 %*                                                                      *
 313                 (Re)creating tick boxes
 314 %*                                                                      *
 315 %************************************************************************
 316
 317 \begin{code}
 318 tcIfaceTick :: Module -> Int -> IfL Id
 319 tcIfaceTick modName tickNo
 320   = do { uniq <- newUnique
 321        ; return $ mkTickBoxOpId uniq modName tickNo
 322        }
 323 \end{code}
 324
 325