ghc/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, lookupImplicitOrig, lookupIfaceTc,
   8         newIfaceName, newIfaceNames,
   9         extendIfaceIdEnv, extendIfaceTyVarEnv,
  10         tcIfaceGlobal, tcIfaceTyCon, tcIfaceClass, tcIfaceExtId,
  11         tcIfaceTyVar, tcIfaceDataCon, tcIfaceLclId,
  12
  13         -- Name-cache stuff
  14         allocateGlobalBinder, extendOrigNameCache, initNameCache
  15    ) where
  16
  17 #include "HsVersions.h"
  18
  19 import {-# SOURCE #-}   TcIface( tcImportDecl )
  20
  21 import TcRnMonad
  22 import IfaceType        ( IfaceExtName(..), IfaceTyCon(..), ifaceTyConName )
  23 import HscTypes         ( NameCache(..), HscEnv(..),
  24                           TyThing, tyThingClass, tyThingTyCon,
  25                           ExternalPackageState(..), OrigNameCache, lookupType )
  26 import TyCon            ( TyCon, tyConName )
  27 import Class            ( Class )
  28 import DataCon          ( DataCon, dataConWorkId, dataConName )
  29 import Var              ( TyVar, Id, varName )
  30 import Name             ( Name, nameUnique, nameModule, nameModuleName,
  31                           nameOccName, nameSrcLoc,
  32                           getOccName, nameParent_maybe,
  33                           isWiredInName, nameIsLocalOrFrom, mkIPName,
  34                           mkExternalName, mkInternalName )
  35 import NameEnv
  36 import OccName          ( OccName, isTupleOcc_maybe, tcName, dataName,
  37                           lookupOccEnv, unitOccEnv, extendOccEnv, extendOccEnvList )
  38 import PrelNames        ( gHC_PRIM_Name, pREL_TUP_Name )
  39 import TysWiredIn       ( intTyCon, boolTyCon, charTyCon, listTyCon, parrTyCon,
  40                           tupleTyCon, tupleCon )
  41 import HscTypes         ( ExternalPackageState, NameCache, TyThing(..) )
  42 import Module           ( Module, ModuleName, moduleName, mkPackageModule,
  43                           emptyModuleEnv, lookupModuleEnvByName, extendModuleEnv_C )
  44 import UniqSupply       ( UniqSupply, splitUniqSupply, uniqFromSupply, uniqsFromSupply )
  45 import FiniteMap        ( emptyFM, lookupFM, addToFM )
  46 import BasicTypes       ( IPName(..), mapIPName )
  47 import SrcLoc           ( SrcLoc, noSrcLoc )
  48 import Maybes           ( orElse )
  49
  50 import Outputable
  51 \end{code}
  52
  53
  54 %*********************************************************
  55 %*                                                      *
  56         Allocating new Names in the Name Cache
  57 %*                                                      *
  58 %*********************************************************
  59
  60 \begin{code}
  61 newGlobalBinder :: Module -> OccName -> Maybe Name -> SrcLoc -> TcRnIf a b Name
  62 -- Used for source code and interface files, to make the
  63 -- Name for a thing, given its Module and OccName
  64 --
  65 -- The cache may already already have a binding for this thing,
  66 -- because we may have seen an occurrence before, but now is the
  67 -- moment when we know its Module and SrcLoc in their full glory
  68
  69 newGlobalBinder mod occ mb_parent loc
  70   = do  { mod `seq` occ `seq` return () -- See notes with lookupOrig_help
  71         ; name_supply <- getNameCache
  72         ; let (name_supply', name) = allocateGlobalBinder
  73                                         name_supply mod occ
  74                                         mb_parent loc
  75         ; setNameCache name_supply'
  76         ; return name }
  77
  78 allocateGlobalBinder
  79   :: NameCache
  80   -> Module -> OccName -> Maybe Name -> SrcLoc
  81   -> (NameCache, Name)
  82 allocateGlobalBinder name_supply mod occ mb_parent loc
  83   = case lookupOrigNameCache (nsNames name_supply) (moduleName mod) occ of
  84         -- A hit in the cache!  We are at the binding site of the name.
  85         -- This is the moment when we know the defining Module and SrcLoc
  86         -- of the Name, so we set these fields in the Name we return.
  87         --
  88         -- This is essential, to get the right Module in a Name.
  89         -- Also: then (bogus) multiple bindings of the same Name
  90         --              get different SrcLocs can can be reported as such.
  91         --
  92         -- Possible other reason: it might be in the cache because we
  93         --      encountered an occurrence before the binding site for an
  94         --      implicitly-imported Name.  Perhaps the current SrcLoc is
  95         --      better... but not really: it'll still just say 'imported'
  96         --
  97         -- IMPORTANT: Don't mess with wired-in names.
  98         --            Their wired-in-ness is in their NameSort
  99         --            and their Module is correct.
 100
 101         Just name | isWiredInName name -> (name_supply, name)
 102                   | otherwise -> (new_name_supply, name')
 103                   where
 104                     uniq      = nameUnique name
 105                     name'     = mkExternalName uniq mod occ mb_parent loc
 106                     new_cache = extend_name_cache (nsNames name_supply) mod occ name'
 107                     new_name_supply = name_supply {nsNames = new_cache}
 108
 109         -- Miss in the cache!
 110         -- Build a completely new Name, and put it in the cache
 111         Nothing -> (new_name_supply, name)
 112                 where
 113                   (us', us1)      = splitUniqSupply (nsUniqs name_supply)
 114                   uniq            = uniqFromSupply us1
 115                   name            = mkExternalName uniq mod occ mb_parent loc
 116                   new_cache       = extend_name_cache (nsNames name_supply) mod occ name
 117                   new_name_supply = name_supply {nsUniqs = us', nsNames = new_cache}
 118
 119
 120 newImplicitBinder :: Name                       -- Base name
 121                   -> (OccName -> OccName)       -- Occurrence name modifier
 122                   -> TcRnIf m n Name            -- Implicit name
 123 -- Called in BuildTyCl to allocate the implicit binders of type/class decls
 124 -- For source type/class decls, this is the first occurrence
 125 -- For iface ones, the LoadIface has alrady allocated a suitable name in the cache
 126 --
 127 -- An *implicit* name has the base-name as parent
 128 newImplicitBinder base_name mk_sys_occ
 129   = newGlobalBinder (nameModule base_name)
 130                     (mk_sys_occ (nameOccName base_name))
 131                     (Just parent_name)
 132                     (nameSrcLoc base_name)
 133   where
 134     parent_name = case nameParent_maybe base_name of
 135                     Just parent_name  -> parent_name
 136                     Nothing           -> base_name
 137
 138 lookupOrig :: ModuleName -> OccName -> TcRnIf a b Name
 139 -- This one starts with a ModuleName, not a Module, because
 140 -- we may be simply looking at an occurrence M.x in an interface file.
 141 -- We may enounter this well before finding the binding site for M.x
 142 --
 143 -- So, even if we get a miss in the original-name cache, we
 144 -- make a new External Name.
 145 -- We fake up
 146 --      Module to AnotherPackage
 147 --      SrcLoc to noSrcLoc
 148 -- They'll be overwritten, in due course, by LoadIface.loadDecl.
 149 lookupOrig mod_name occ = lookupOrig_help mod_name occ Nothing
 150
 151 lookupImplicitOrig :: Name -> OccName -> TcRnIf m n Name
 152 -- Same as lookupOrig, but install (Just parent) as the
 153 -- parent Name.   This is used when looking at the exports
 154 -- of an interface:
 155 --   Suppose module M exports type A.T, and constructor A.MkT
 156 --   Then, we know that A.MkT is an implicit name of A.T,
 157 --   even though we aren't at the binding site of A.T
 158 --   And it's important, because we may simply re-export A.T
 159 --   without ever sucking in the declaration itself.
 160 lookupImplicitOrig name occ
 161   = lookupOrig_help (nameModuleName name) occ (Just name)
 162
 163 lookupOrig_help :: ModuleName -> OccName -> Maybe Name -> TcRnIf a b Name
 164 -- Local helper, not exported
 165 lookupOrig_help mod_name occ mb_parent
 166   = do  {       -- First ensure that mod_name and occ are evaluated
 167                 -- If not, chaos can ensue:
 168                 --      we read the name-cache
 169                 --      then pull on mod (say)
 170                 --      which does some stuff that modifies the name cache
 171                 -- This did happen, with tycon_mod in TcIface.tcIfaceAlt (DataAlt..)
 172           mod `seq` occ `seq` return ()
 173
 174         ; name_supply <- getNameCache
 175         ; case lookupOrigNameCache (nsNames name_supply) mod_name occ of {
 176               Just name -> returnM name ;
 177               Nothing   -> do
 178
 179         { let { (us', us1)      = splitUniqSupply (nsUniqs name_supply)
 180               ; uniq            = uniqFromSupply us1
 181               ; name            = mkExternalName uniq tmp_mod occ mb_parent noSrcLoc
 182               ; new_cache       = extend_name_cache (nsNames name_supply) tmp_mod occ name
 183               ; new_name_supply = name_supply {nsUniqs = us', nsNames = new_cache}
 184               ; tmp_mod         = mkPackageModule mod_name
 185                         -- Guess at the package-ness for now, becuase we don't know whether
 186                         -- this imported module is from the home package or not.
 187                         -- If we ever need it, we'll open its interface, and update the cache
 188                         -- with a better name (newGlobalBinder)
 189           }
 190         ; setNameCache new_name_supply
 191         ; return name }
 192     }}
 193
 194 newIPName :: IPName OccName -> TcRnIf m n (IPName Name)
 195 newIPName occ_name_ip
 196   = getNameCache                `thenM` \ name_supply ->
 197     let
 198         ipcache = nsIPs name_supply
 199     in
 200     case lookupFM ipcache key of
 201         Just name_ip -> returnM name_ip
 202         Nothing      -> setNameCache new_ns     `thenM_`
 203                         returnM name_ip
 204                   where
 205                      (us', us1)  = splitUniqSupply (nsUniqs name_supply)
 206                      uniq        = uniqFromSupply us1
 207                      name_ip     = mapIPName (mkIPName uniq) occ_name_ip
 208                      new_ipcache = addToFM ipcache key name_ip
 209                      new_ns      = name_supply {nsUniqs = us', nsIPs = new_ipcache}
 210     where
 211         key = occ_name_ip       -- Ensures that ?x and %x get distinct Names
 212 \end{code}
 213
 214         Local helper functions (not exported)
 215
 216 \begin{code}
 217 lookupOrigNameCache :: OrigNameCache -> ModuleName -> OccName -> Maybe Name
 218 lookupOrigNameCache nc mod_name occ
 219   | mod_name == pREL_TUP_Name || mod_name == gHC_PRIM_Name,     -- Boxed tuples from one,
 220     Just tup_info <- isTupleOcc_maybe occ                       -- unboxed from the other
 221   =     -- Special case for tuples; there are too many
 222         -- of them to pre-populate the original-name cache
 223     Just (mk_tup_name tup_info)
 224   where
 225     mk_tup_name (ns, boxity, arity)
 226         | ns == tcName   = tyConName (tupleTyCon boxity arity)
 227         | ns == dataName = dataConName (tupleCon boxity arity)
 228         | otherwise      = varName (dataConWorkId (tupleCon boxity arity))
 229
 230 lookupOrigNameCache nc mod_name occ     -- The normal case
 231   = case lookupModuleEnvByName nc mod_name of
 232         Nothing      -> Nothing
 233         Just occ_env -> lookupOccEnv occ_env occ
 234
 235 extendOrigNameCache :: OrigNameCache -> Name -> OrigNameCache
 236 extendOrigNameCache nc name
 237   = extend_name_cache nc (nameModule name) (nameOccName name) name
 238
 239 extend_name_cache :: OrigNameCache -> Module -> OccName -> Name -> OrigNameCache
 240 extend_name_cache nc mod occ name
 241   = extendModuleEnv_C combine nc mod (unitOccEnv occ name)
 242   where
 243     combine occ_env _ = extendOccEnv occ_env occ name
 244
 245 getNameCache :: TcRnIf a b NameCache
 246 getNameCache = do { HscEnv { hsc_NC = nc_var } <- getTopEnv;
 247                     readMutVar nc_var }
 248
 249 setNameCache :: NameCache -> TcRnIf a b ()
 250 setNameCache nc = do { HscEnv { hsc_NC = nc_var } <- getTopEnv;
 251                        writeMutVar nc_var nc }
 252 \end{code}
 253
 254
 255 \begin{code}
 256 initNameCache :: UniqSupply -> [Name] -> NameCache
 257 initNameCache us names
 258   = NameCache { nsUniqs = us,
 259                 nsNames = initOrigNames names,
 260                 nsIPs   = emptyFM }
 261
 262 initOrigNames :: [Name] -> OrigNameCache
 263 initOrigNames names = foldl extendOrigNameCache emptyModuleEnv names
 264 \end{code}
 265
 266
 267 %************************************************************************
 268 %*                                                                      *
 269                 Getting from Names to TyThings
 270 %*                                                                      *
 271 %************************************************************************
 272
 273 \begin{code}
 274 tcIfaceGlobal :: Name -> IfM a TyThing
 275 tcIfaceGlobal name
 276   = do  { eps <- getEps
 277         ; hpt <- getHpt
 278         ; case lookupType hpt (eps_PTE eps) name of {
 279             Just thing -> return thing ;
 280             Nothing    ->
 281
 282         setLclEnv () $ do       -- This gets us back to IfG, mainly to
 283                                 -- pacify get_type_env; rather untidy
 284         { env <- getGblEnv
 285         ; case if_rec_types env of
 286             Just (mod, get_type_env)
 287                 | nameIsLocalOrFrom mod name
 288                 -> do           -- It's defined in the module being compiled
 289                 { type_env <- get_type_env
 290                 ; case lookupNameEnv type_env name of
 291                         Just thing -> return thing
 292                         Nothing    -> pprPanic "tcIfaceGlobal (local): not found:"
 293                                                 (ppr name $$ ppr type_env) }
 294
 295             other -> tcImportDecl name  -- It's imported; go get it
 296     }}}
 297
 298 tcIfaceTyCon :: IfaceTyCon -> IfL TyCon
 299 tcIfaceTyCon IfaceIntTc = return intTyCon
 300 tcIfaceTyCon IfaceBoolTc = return boolTyCon
 301 tcIfaceTyCon IfaceCharTc = return charTyCon
 302 tcIfaceTyCon IfaceListTc = return listTyCon
 303 tcIfaceTyCon IfacePArrTc = return parrTyCon
 304 tcIfaceTyCon (IfaceTupTc bx ar) = return (tupleTyCon bx ar)
 305 tcIfaceTyCon (IfaceTc ext_nm) = do { name <- lookupIfaceExt ext_nm
 306                                    ; thing <- tcIfaceGlobal name
 307                                    ; return (tyThingTyCon thing) }
 308
 309 tcIfaceClass :: IfaceExtName -> IfL Class
 310 tcIfaceClass rdr_name = do { name <- lookupIfaceExt rdr_name
 311                            ; thing <- tcIfaceGlobal name
 312                            ; return (tyThingClass thing) }
 313
 314 tcIfaceDataCon :: IfaceExtName -> IfL DataCon
 315 tcIfaceDataCon gbl = do { name <- lookupIfaceExt gbl
 316                         ; thing <- tcIfaceGlobal name
 317                         ; case thing of
 318                                 ADataCon dc -> return dc
 319                                 other   -> pprPanic "tcIfaceExtDC" (ppr gbl $$ ppr name$$ ppr thing) }
 320
 321 tcIfaceExtId :: IfaceExtName -> IfL Id
 322 tcIfaceExtId gbl = do { name <- lookupIfaceExt gbl
 323                       ; thing <- tcIfaceGlobal name
 324                       ; case thing of
 325                           AnId id -> return id
 326                           other   -> pprPanic "tcIfaceExtId" (ppr gbl $$ ppr name$$ ppr thing) }
 327
 328 ------------------------------------------
 329 tcIfaceLclId :: OccName -> IfL Id
 330 tcIfaceLclId occ
 331   = do  { lcl <- getLclEnv
 332         ; return (lookupOccEnv (if_id_env lcl) occ
 333                   `orElse`
 334                   pprPanic "tcIfaceLclId" (ppr occ)) }
 335
 336 tcIfaceTyVar :: OccName -> IfL TyVar
 337 tcIfaceTyVar occ
 338   = do  { lcl <- getLclEnv
 339         ; return (lookupOccEnv (if_tv_env lcl) occ
 340                   `orElse`
 341                   pprPanic "tcIfaceTyVar" (ppr occ)) }
 342
 343 extendIfaceIdEnv :: [Id] -> IfL a -> IfL a
 344 extendIfaceIdEnv ids thing_inside
 345   = do  { env <- getLclEnv
 346         ; let { id_env' = extendOccEnvList (if_id_env env) pairs
 347               ; pairs   = [(getOccName id, id) | id <- ids] }
 348         ; setLclEnv (env { if_id_env = id_env' }) thing_inside }
 349
 350 extendIfaceTyVarEnv :: [TyVar] -> IfL a -> IfL a
 351 extendIfaceTyVarEnv tyvars thing_inside
 352   = do  { env <- getLclEnv
 353         ; let { tv_env' = extendOccEnvList (if_tv_env env) pairs
 354               ; pairs   = [(getOccName tv, tv) | tv <- tyvars] }
 355         ; setLclEnv (env { if_tv_env = tv_env' }) thing_inside }
 356 \end{code}
 357
 358
 359 %************************************************************************
 360 %*                                                                      *
 361                 Getting from RdrNames to Names
 362 %*                                                                      *
 363 %************************************************************************
 364
 365 IfaceDecls etc are populated with RdrNames.  The RdrNames may either be
 366
 367   Orig or Unqual        when the interface is read from a file
 368
 369   Exact                 when the interface is kept by GHCi, and is now
 370                         being re-linked with the type environment
 371
 372 At an occurrence site, to convert the RdrName to Name:
 373   Unqual        look up in LocalRdrEnv
 374   Orig          look up in OrigNameCache
 375   Exact         return the Name
 376
 377 At a binding site, to bind the RdrName
 378   Unqual                we extend the LocalRdrEnv
 379   Orig or Unqual        we don't extend the LocalRdrEnv (no need)
 380
 381 First, we deal with the RdrName -> Name mapping
 382
 383 \begin{code}
 384 lookupIfaceTc :: IfaceTyCon -> IfL Name
 385 lookupIfaceTc (IfaceTc ext) = lookupIfaceExt ext
 386 lookupIfaceTc other_tc      = return (ifaceTyConName other_tc)
 387
 388 lookupIfaceExt :: IfaceExtName -> IfL Name
 389 lookupIfaceExt (ExtPkg  mod occ)   = lookupOrig mod occ
 390 lookupIfaceExt (HomePkg mod occ _) = lookupOrig mod occ
 391 lookupIfaceExt (LocalTop occ)      = lookupIfaceTop occ
 392 lookupIfaceExt (LocalTopSub occ _) = lookupIfaceTop occ
 393
 394 lookupIfaceTop :: OccName -> IfL Name
 395 -- Look up a top-level name from the current Iface module
 396 lookupIfaceTop occ
 397   = do  { env <- getLclEnv; lookupOrig (if_mod env) occ }
 398
 399 newIfaceName :: OccName -> IfL Name
 400 newIfaceName occ
 401   = do  { uniq <- newUnique
 402         ; return (mkInternalName uniq occ noSrcLoc) }
 403
 404 newIfaceNames :: [OccName] -> IfL [Name]
 405 newIfaceNames occs
 406   = do  { uniqs <- newUniqueSupply
 407         ; return [ mkInternalName uniq occ noSrcLoc
 408                  | (occ,uniq) <- occs `zip` uniqsFromSupply uniqs] }
 409 \end{code}