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 \begin{code}
 366 lookupIfaceTc :: IfaceTyCon -> IfL Name
 367 lookupIfaceTc (IfaceTc ext) = lookupIfaceExt ext
 368 lookupIfaceTc other_tc      = return (ifaceTyConName other_tc)
 369
 370 lookupIfaceExt :: IfaceExtName -> IfL Name
 371 lookupIfaceExt (ExtPkg  mod occ)   = lookupOrig mod occ
 372 lookupIfaceExt (HomePkg mod occ _) = lookupOrig mod occ
 373 lookupIfaceExt (LocalTop occ)      = lookupIfaceTop occ
 374 lookupIfaceExt (LocalTopSub occ _) = lookupIfaceTop occ
 375
 376 lookupIfaceTop :: OccName -> IfL Name
 377 -- Look up a top-level name from the current Iface module
 378 lookupIfaceTop occ
 379   = do  { env <- getLclEnv; lookupOrig (if_mod env) occ }
 380
 381 newIfaceName :: OccName -> IfL Name
 382 newIfaceName occ
 383   = do  { uniq <- newUnique
 384         ; return (mkInternalName uniq occ noSrcLoc) }
 385
 386 newIfaceNames :: [OccName] -> IfL [Name]
 387 newIfaceNames occs
 388   = do  { uniqs <- newUniqueSupply
 389         ; return [ mkInternalName uniq occ noSrcLoc
 390                  | (occ,uniq) <- occs `zip` uniqsFromSupply uniqs] }
 391 \end{code}