compiler/iface/IfaceEnv.lhs

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