compiler/iface/IfaceEnv.lhs

   1 (c) The University of Glasgow 2002
   2
   3 \begin{code}
   4 module IfaceEnv (
   5         newGlobalBinder, newIPName, newImplicitBinder,
   6         lookupIfaceTop, lookupIfaceExt,
   7         lookupOrig, lookupIfaceTc,
   8         newIfaceName, newIfaceNames,
   9         extendIfaceIdEnv, extendIfaceTyVarEnv, refineIfaceIdEnv,
  10         tcIfaceLclId,     tcIfaceTyVar,
  11
  12         lookupAvail, ifaceExportNames,
  13
  14         -- Name-cache stuff
  15         allocateGlobalBinder, initNameCache,
  16    ) where
  17
  18 #include "HsVersions.h"
  19
  20 import TcRnMonad
  21 import IfaceType        ( IfaceExtName(..), IfaceTyCon(..), ifaceTyConName )
  22 import TysWiredIn       ( tupleTyCon, tupleCon )
  23 import HscTypes         ( NameCache(..), HscEnv(..), GenAvailInfo(..),
  24                           IfaceExport, OrigNameCache )
  25 import Type             ( mkOpenTvSubst, substTy )
  26 import TyCon            ( TyCon, tyConName )
  27 import Unify            ( TypeRefinement )
  28 import DataCon          ( dataConWorkId, dataConName )
  29 import Var              ( TyVar, Id, varName, setIdType, idType )
  30 import Name             ( Name, nameUnique, nameModule,
  31                           nameOccName, nameSrcLoc,
  32                           getOccName, nameParent_maybe,
  33                           isWiredInName, mkIPName,
  34                           mkExternalName, mkInternalName )
  35 import NameSet          ( NameSet, emptyNameSet, addListToNameSet )
  36 import OccName          ( OccName, isTupleOcc_maybe, tcName, dataName, mapOccEnv, occNameFS,
  37                           lookupOccEnv, unitOccEnv, extendOccEnv, extendOccEnvList )
  38 import PrelNames        ( gHC_PRIM, pREL_TUP )
  39 import Module           ( Module, emptyModuleEnv,
  40                           lookupModuleEnv, extendModuleEnv_C )
  41 import UniqFM           ( lookupUFM, addListToUFM )
  42 import FastString       ( FastString )
  43 import UniqSupply       ( UniqSupply, splitUniqSupply, uniqFromSupply, uniqsFromSupply )
  44 import FiniteMap        ( emptyFM, lookupFM, addToFM )
  45 import BasicTypes       ( IPName(..), mapIPName )
  46 import SrcLoc           ( SrcLoc, noSrcLoc )
  47
  48 import Outputable
  49 \end{code}
  50
  51
  52 %*********************************************************
  53 %*                                                      *
  54         Allocating new Names in the Name Cache
  55 %*                                                      *
  56 %*********************************************************
  57
  58 \begin{code}
  59 newGlobalBinder :: Module -> OccName -> Maybe Name -> SrcLoc -> TcRnIf a b Name
  60 -- Used for source code and interface files, to make the
  61 -- Name for a thing, given its Module and OccName
  62 --
  63 -- The cache may already already have a binding for this thing,
  64 -- because we may have seen an occurrence before, but now is the
  65 -- moment when we know its Module and SrcLoc in their full glory
  66
  67 newGlobalBinder mod occ mb_parent loc
  68   = do  { mod `seq` occ `seq` return () -- See notes with lookupOrig_help
  69         -- ; traceIf (text "newGlobalBinder" <+> ppr mod <+> ppr occ <+> ppr loc)
  70         ; name_supply <- getNameCache
  71         ; let (name_supply', name) = allocateGlobalBinder
  72                                         name_supply mod occ
  73                                         mb_parent loc
  74         ; setNameCache name_supply'
  75         ; return name }
  76
  77 allocateGlobalBinder
  78   :: NameCache
  79   -> Module -> OccName -> Maybe Name -> SrcLoc
  80   -> (NameCache, Name)
  81 allocateGlobalBinder name_supply mod occ mb_parent loc
  82   = case lookupOrigNameCache (nsNames name_supply) mod occ of
  83         -- A hit in the cache!  We are at the binding site of the name.
  84         -- This is the moment when we know the defining parent and SrcLoc
  85         -- of the Name, so we set these fields in the Name we return.
  86         --
  87         -- Then (bogus) multiple bindings of the same Name
  88         -- get different SrcLocs can can be reported as such.
  89         --
  90         -- Possible other reason: it might be in the cache because we
  91         --      encountered an occurrence before the binding site for an
  92         --      implicitly-imported Name.  Perhaps the current SrcLoc is
  93         --      better... but not really: it'll still just say 'imported'
  94         --
  95         -- IMPORTANT: Don't mess with wired-in names.
  96         --            Their wired-in-ness is in their NameSort
  97         --            and their Module is correct.
  98
  99         Just name | isWiredInName name -> (name_supply, name)
 100                   | otherwise -> (new_name_supply, name')
 101                   where
 102                     uniq      = nameUnique name
 103                     name'     = mkExternalName uniq mod occ mb_parent loc
 104                     new_cache = extend_name_cache (nsNames name_supply) mod occ name'
 105                     new_name_supply = name_supply {nsNames = new_cache}
 106
 107         -- Miss in the cache!
 108         -- Build a completely new Name, and put it in the cache
 109         Nothing -> (new_name_supply, name)
 110                 where
 111                   (us', us1)      = splitUniqSupply (nsUniqs name_supply)
 112                   uniq            = uniqFromSupply us1
 113                   name            = mkExternalName uniq mod occ mb_parent loc
 114                   new_cache       = extend_name_cache (nsNames name_supply) mod occ name
 115                   new_name_supply = name_supply {nsUniqs = us', nsNames = new_cache}
 116
 117
 118 newImplicitBinder :: Name                       -- Base name
 119                   -> (OccName -> OccName)       -- Occurrence name modifier
 120                   -> TcRnIf m n Name            -- Implicit name
 121 -- Called in BuildTyCl to allocate the implicit binders of type/class decls
 122 -- For source type/class decls, this is the first occurrence
 123 -- For iface ones, the LoadIface has alrady allocated a suitable name in the cache
 124 --
 125 -- An *implicit* name has the base-name as parent
 126 newImplicitBinder base_name mk_sys_occ
 127   = newGlobalBinder (nameModule base_name)
 128                     (mk_sys_occ (nameOccName base_name))
 129                     (Just parent_name)
 130                     (nameSrcLoc base_name)
 131   where
 132     parent_name = case nameParent_maybe base_name of
 133                     Just parent_name  -> parent_name
 134                     Nothing           -> base_name
 135
 136 ifaceExportNames :: [IfaceExport] -> TcRnIf gbl lcl NameSet
 137 ifaceExportNames exports
 138   = foldlM do_one emptyNameSet exports
 139   where
 140     do_one acc (mod, exports)  = foldlM (do_avail mod) acc exports
 141     do_avail mod acc avail = do { ns <- lookupAvail mod avail
 142                                 ; return (addListToNameSet acc ns) }
 143
 144 lookupAvail :: Module -> GenAvailInfo OccName -> TcRnIf a b [Name]
 145 -- Find all the names arising from an import
 146 -- Make sure the parent info is correct, even though we may not
 147 -- yet have read the interface for this module
 148 lookupAvail mod (Avail n) = do { n' <- lookupOrig mod n;
 149                                ; return [n'] }
 150 lookupAvail mod (AvailTC p_occ occs)
 151   = do { p_name <- lookupOrig mod p_occ
 152        ; let lookup_sub occ | occ == p_occ = return p_name
 153                             | otherwise    = lookup_orig mod occ (Just p_name)
 154        ; mappM lookup_sub occs }
 155         -- Remember that 'occs' is all the exported things, including
 156         -- the parent.  It's possible to export just class ops without
 157         -- the class, via C( op ). If the class was exported too we'd
 158         -- have C( C, op )
 159
 160         -- The use of lookupOrigSub here (rather than lookupOrig)
 161         -- ensures that the subordinate names record their parent;
 162         -- and that in turn ensures that the GlobalRdrEnv
 163         -- has the correct parent for all the names in its range.
 164         -- For imported things, we may only suck in the interface later, if ever.
 165         -- Reason for all this:
 166         --   Suppose module M exports type A.T, and constructor A.MkT
 167         --   Then, we know that A.MkT is a subordinate name of A.T,
 168         --   even though we aren't at the binding site of A.T
 169         --   And it's important, because we may simply re-export A.T
 170         --   without ever sucking in the declaration itself.
 171
 172
 173 lookupOrig :: Module -> OccName -> TcRnIf a b Name
 174 -- Even if we get a miss in the original-name cache, we
 175 -- make a new External Name.
 176 -- We fake up
 177 --      SrcLoc to noSrcLoc
 178 --      Parent no Nothing
 179 -- They'll be overwritten, in due course, by LoadIface.loadDecl.
 180 lookupOrig mod occ = lookup_orig mod occ Nothing
 181
 182 lookup_orig :: Module -> OccName ->  Maybe Name -> TcRnIf a b Name
 183 -- Used when we know the parent of the thing we are looking up
 184 lookup_orig mod occ mb_parent
 185   = do  {       -- First ensure that mod and occ are evaluated
 186                 -- If not, chaos can ensue:
 187                 --      we read the name-cache
 188                 --      then pull on mod (say)
 189                 --      which does some stuff that modifies the name cache
 190                 -- This did happen, with tycon_mod in TcIface.tcIfaceAlt (DataAlt..)
 191           mod `seq` occ `seq` return ()
 192
 193         ; name_supply <- getNameCache
 194         ; case lookupOrigNameCache (nsNames name_supply) mod occ of {
 195               Just name -> returnM name ;
 196               Nothing   -> do
 197
 198         { let { (us', us1)      = splitUniqSupply (nsUniqs name_supply)
 199               ; uniq            = uniqFromSupply us1
 200               ; name            = mkExternalName uniq mod occ mb_parent noSrcLoc
 201               ; new_cache       = extend_name_cache (nsNames name_supply) mod occ name
 202               ; new_name_supply = name_supply {nsUniqs = us', nsNames = new_cache}
 203           }
 204         ; setNameCache new_name_supply
 205         ; return name }
 206     }}
 207
 208 newIPName :: IPName OccName -> TcRnIf m n (IPName Name)
 209 newIPName occ_name_ip
 210   = getNameCache                `thenM` \ name_supply ->
 211     let
 212         ipcache = nsIPs name_supply
 213     in
 214     case lookupFM ipcache key of
 215         Just name_ip -> returnM name_ip
 216         Nothing      -> setNameCache new_ns     `thenM_`
 217                         returnM name_ip
 218                   where
 219                      (us', us1)  = splitUniqSupply (nsUniqs name_supply)
 220                      uniq        = uniqFromSupply us1
 221                      name_ip     = mapIPName (mkIPName uniq) occ_name_ip
 222                      new_ipcache = addToFM ipcache key name_ip
 223                      new_ns      = name_supply {nsUniqs = us', nsIPs = new_ipcache}
 224     where
 225         key = occ_name_ip       -- Ensures that ?x and %x get distinct Names
 226 \end{code}
 227
 228         Local helper functions (not exported)
 229
 230 \begin{code}
 231 lookupOrigNameCache :: OrigNameCache -> Module -> OccName -> Maybe Name
 232 lookupOrigNameCache nc mod occ
 233   | mod == pREL_TUP || mod == gHC_PRIM,         -- Boxed tuples from one,
 234     Just tup_info <- isTupleOcc_maybe occ       -- unboxed from the other
 235   =     -- Special case for tuples; there are too many
 236         -- of them to pre-populate the original-name cache
 237     Just (mk_tup_name tup_info)
 238   where
 239     mk_tup_name (ns, boxity, arity)
 240         | ns == tcName   = tyConName (tupleTyCon boxity arity)
 241         | ns == dataName = dataConName (tupleCon boxity arity)
 242         | otherwise      = varName (dataConWorkId (tupleCon boxity arity))
 243
 244 lookupOrigNameCache nc mod occ  -- The normal case
 245   = case lookupModuleEnv nc mod of
 246         Nothing      -> Nothing
 247         Just occ_env -> lookupOccEnv occ_env occ
 248
 249 extendOrigNameCache :: OrigNameCache -> Name -> OrigNameCache
 250 extendOrigNameCache nc name
 251   = extend_name_cache nc (nameModule name) (nameOccName name) name
 252
 253 extend_name_cache :: OrigNameCache -> Module -> OccName -> Name -> OrigNameCache
 254 extend_name_cache nc mod occ name
 255   = extendModuleEnv_C combine nc mod (unitOccEnv occ name)
 256   where
 257     combine occ_env _ = extendOccEnv occ_env occ name
 258
 259 getNameCache :: TcRnIf a b NameCache
 260 getNameCache = do { HscEnv { hsc_NC = nc_var } <- getTopEnv;
 261                     readMutVar nc_var }
 262
 263 setNameCache :: NameCache -> TcRnIf a b ()
 264 setNameCache nc = do { HscEnv { hsc_NC = nc_var } <- getTopEnv;
 265                        writeMutVar nc_var nc }
 266 \end{code}
 267
 268
 269 \begin{code}
 270 initNameCache :: UniqSupply -> [Name] -> NameCache
 271 initNameCache us names
 272   = NameCache { nsUniqs = us,
 273                 nsNames = initOrigNames names,
 274                 nsIPs   = emptyFM }
 275
 276 initOrigNames :: [Name] -> OrigNameCache
 277 initOrigNames names = foldl extendOrigNameCache emptyModuleEnv names
 278 \end{code}
 279
 280
 281
 282 %************************************************************************
 283 %*                                                                      *
 284                 Type variables and local Ids
 285 %*                                                                      *
 286 %************************************************************************
 287
 288 \begin{code}
 289 tcIfaceLclId :: FastString -> IfL Id
 290 tcIfaceLclId occ
 291   = do  { lcl <- getLclEnv
 292         ; case (lookupUFM (if_id_env lcl) occ) of
 293             Just ty_var -> return ty_var
 294             Nothing     -> failIfM (text "Iface id out of scope: " <+> ppr occ)
 295         }
 296
 297 refineIfaceIdEnv :: TypeRefinement -> IfL a -> IfL a
 298 refineIfaceIdEnv (tv_subst, _) thing_inside
 299   = do  { env <- getLclEnv
 300         ; let { id_env' = mapOccEnv refine_id (if_id_env env)
 301               ; refine_id id = setIdType id (substTy subst (idType id))
 302               ; subst = mkOpenTvSubst tv_subst }
 303         ; setLclEnv (env { if_id_env = id_env' }) thing_inside }
 304
 305 extendIfaceIdEnv :: [Id] -> IfL a -> IfL a
 306 extendIfaceIdEnv ids thing_inside
 307   = do  { env <- getLclEnv
 308         ; let { id_env' = addListToUFM (if_id_env env) pairs
 309               ; pairs   = [(occNameFS (getOccName id), id) | id <- ids] }
 310         ; setLclEnv (env { if_id_env = id_env' }) thing_inside }
 311
 312
 313 tcIfaceTyVar :: FastString -> IfL TyVar
 314 tcIfaceTyVar occ
 315   = do  { lcl <- getLclEnv
 316         ; case (lookupUFM (if_tv_env lcl) occ) of
 317             Just ty_var -> return ty_var
 318             Nothing     -> failIfM (text "Iface type variable out of scope: " <+> ppr occ)
 319         }
 320
 321 extendIfaceTyVarEnv :: [TyVar] -> IfL a -> IfL a
 322 extendIfaceTyVarEnv tyvars thing_inside
 323   = do  { env <- getLclEnv
 324         ; let { tv_env' = addListToUFM (if_tv_env env) pairs
 325               ; pairs   = [(occNameFS (getOccName tv), tv) | tv <- tyvars] }
 326         ; setLclEnv (env { if_tv_env = tv_env' }) thing_inside }
 327 \end{code}
 328
 329
 330 %************************************************************************
 331 %*                                                                      *
 332                 Getting from RdrNames to Names
 333 %*                                                                      *
 334 %************************************************************************
 335
 336 \begin{code}
 337 lookupIfaceTc :: IfaceTyCon -> IfL Name
 338 lookupIfaceTc (IfaceTc ext) = lookupIfaceExt ext
 339 lookupIfaceTc other_tc      = return (ifaceTyConName other_tc)
 340
 341 lookupIfaceExt :: IfaceExtName -> IfL Name
 342 lookupIfaceExt (ExtPkg  mod occ)   = lookupOrig mod occ
 343 lookupIfaceExt (HomePkg mod occ _) = lookupOrig mod occ
 344 lookupIfaceExt (LocalTop occ)      = lookupIfaceTop occ
 345 lookupIfaceExt (LocalTopSub occ _) = lookupIfaceTop occ
 346
 347 lookupIfaceTop :: OccName -> IfL Name
 348 -- Look up a top-level name from the current Iface module
 349 lookupIfaceTop occ
 350   = do  { env <- getLclEnv; lookupOrig (if_mod env) occ }
 351
 352 newIfaceName :: OccName -> IfL Name
 353 newIfaceName occ
 354   = do  { uniq <- newUnique
 355         ; return (mkInternalName uniq occ noSrcLoc) }
 356
 357 newIfaceNames :: [OccName] -> IfL [Name]
 358 newIfaceNames occs
 359   = do  { uniqs <- newUniqueSupply
 360         ; return [ mkInternalName uniq occ noSrcLoc
 361                  | (occ,uniq) <- occs `zip` uniqsFromSupply uniqs] }
 362 \end{code}