X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2Fiface%2FIfaceEnv.lhs;h=d639e96ace8581ff5a3ed9dd1581a638db6f81b0;hb=ef5b4b146aa172d8ac10f39b5eb3d7a0f948d8f1;hp=8cfaf66db7af2322b195fdf1c48b549ba237e1f5;hpb=98744cef7b82e7eefbb1c6f1d8b9e28c415939c4;p=ghc-hetmet.git diff --git a/ghc/compiler/iface/IfaceEnv.lhs b/ghc/compiler/iface/IfaceEnv.lhs index 8cfaf66..d639e96 100644 --- a/ghc/compiler/iface/IfaceEnv.lhs +++ b/ghc/compiler/iface/IfaceEnv.lhs @@ -7,8 +7,7 @@ module IfaceEnv ( lookupOrig, lookupIfaceTc, newIfaceName, newIfaceNames, extendIfaceIdEnv, extendIfaceTyVarEnv, - tcIfaceGlobal, tcIfaceTyCon, tcIfaceClass, tcIfaceExtId, - tcIfaceTyVar, tcIfaceDataCon, tcIfaceLclId, + tcIfaceLclId, tcIfaceTyVar, -- Name-cache stuff allocateGlobalBinder, initNameCache @@ -16,31 +15,23 @@ module IfaceEnv ( #include "HsVersions.h" -import {-# SOURCE #-} TcIface( tcImportDecl ) - import TcRnMonad import IfaceType ( IfaceExtName(..), IfaceTyCon(..), ifaceTyConName ) -import HscTypes ( NameCache(..), HscEnv(..), - TyThing, tyThingClass, tyThingTyCon, - ExternalPackageState(..), OrigNameCache, lookupType ) +import TysWiredIn ( tupleTyCon, tupleCon ) +import HscTypes ( NameCache(..), HscEnv(..), OrigNameCache ) import TyCon ( TyCon, tyConName ) -import Class ( Class ) -import DataCon ( DataCon, dataConWorkId, dataConName ) +import DataCon ( dataConWorkId, dataConName ) import Var ( TyVar, Id, varName ) -import Name ( Name, nameUnique, nameModule, nameModuleName, +import Name ( Name, nameUnique, nameModule, nameOccName, nameSrcLoc, getOccName, nameParent_maybe, - isWiredInName, nameIsLocalOrFrom, mkIPName, + isWiredInName, mkIPName, mkExternalName, mkInternalName ) -import NameEnv import OccName ( OccName, isTupleOcc_maybe, tcName, dataName, lookupOccEnv, unitOccEnv, extendOccEnv, extendOccEnvList ) -import PrelNames ( gHC_PRIM_Name, pREL_TUP_Name ) -import TysWiredIn ( intTyCon, boolTyCon, charTyCon, listTyCon, parrTyCon, - tupleTyCon, tupleCon ) -import HscTypes ( ExternalPackageState, NameCache, TyThing(..) ) -import Module ( Module, ModuleName, moduleName, mkPackageModule, - emptyModuleEnv, lookupModuleEnvByName, extendModuleEnv_C ) +import PrelNames ( gHC_PRIM, pREL_TUP ) +import Module ( Module, mkModule, emptyModuleEnv, + lookupModuleEnv, extendModuleEnv_C ) import UniqSupply ( UniqSupply, splitUniqSupply, uniqFromSupply, uniqsFromSupply ) import FiniteMap ( emptyFM, lookupFM, addToFM ) import BasicTypes ( IPName(..), mapIPName ) @@ -80,7 +71,7 @@ allocateGlobalBinder -> Module -> OccName -> Maybe Name -> SrcLoc -> (NameCache, Name) allocateGlobalBinder name_supply mod occ mb_parent loc - = case lookupOrigNameCache (nsNames name_supply) (moduleName mod) occ of + = case lookupOrigNameCache (nsNames name_supply) mod occ of -- A hit in the cache! We are at the binding site of the name. -- This is the moment when we know the defining Module and SrcLoc -- of the Name, so we set these fields in the Name we return. @@ -135,12 +126,8 @@ newImplicitBinder base_name mk_sys_occ Just parent_name -> parent_name Nothing -> base_name -lookupOrig :: ModuleName -> OccName -> TcRnIf a b Name --- This one starts with a ModuleName, not a Module, because --- we may be simply looking at an occurrence M.x in an interface file. --- We may enounter this well before finding the binding site for M.x --- --- So, even if we get a miss in the original-name cache, we +lookupOrig :: Module -> OccName -> TcRnIf a b Name +-- Even if we get a miss in the original-name cache, we -- make a new External Name. -- We fake up -- Module to AnotherPackage @@ -148,8 +135,8 @@ lookupOrig :: ModuleName -> OccName -> TcRnIf a b Name -- Parent no Nothing -- They'll be overwritten, in due course, by LoadIface.loadDecl. -lookupOrig mod_name occ - = do { -- First ensure that mod_name and occ are evaluated +lookupOrig mod occ + = do { -- First ensure that mod and occ are evaluated -- If not, chaos can ensue: -- we read the name-cache -- then pull on mod (say) @@ -158,20 +145,15 @@ lookupOrig mod_name occ mod `seq` occ `seq` return () ; name_supply <- getNameCache - ; case lookupOrigNameCache (nsNames name_supply) mod_name occ of { + ; case lookupOrigNameCache (nsNames name_supply) mod occ of { Just name -> returnM name ; Nothing -> do { let { (us', us1) = splitUniqSupply (nsUniqs name_supply) ; uniq = uniqFromSupply us1 - ; name = mkExternalName uniq tmp_mod occ Nothing noSrcLoc - ; new_cache = extend_name_cache (nsNames name_supply) tmp_mod occ name + ; name = mkExternalName uniq mod occ Nothing noSrcLoc + ; new_cache = extend_name_cache (nsNames name_supply) mod occ name ; new_name_supply = name_supply {nsUniqs = us', nsNames = new_cache} - ; tmp_mod = mkPackageModule mod_name - -- Guess at the package-ness for now, becuase we don't know whether - -- this imported module is from the home package or not. - -- If we ever need it, we'll open its interface, and update the cache - -- with a better name (newGlobalBinder) } ; setNameCache new_name_supply ; return name } @@ -200,10 +182,10 @@ newIPName occ_name_ip Local helper functions (not exported) \begin{code} -lookupOrigNameCache :: OrigNameCache -> ModuleName -> OccName -> Maybe Name -lookupOrigNameCache nc mod_name occ - | mod_name == pREL_TUP_Name || mod_name == gHC_PRIM_Name, -- Boxed tuples from one, - Just tup_info <- isTupleOcc_maybe occ -- unboxed from the other +lookupOrigNameCache :: OrigNameCache -> Module -> OccName -> Maybe Name +lookupOrigNameCache nc mod occ + | mod == pREL_TUP || mod == gHC_PRIM, -- Boxed tuples from one, + Just tup_info <- isTupleOcc_maybe occ -- unboxed from the other = -- Special case for tuples; there are too many -- of them to pre-populate the original-name cache Just (mk_tup_name tup_info) @@ -213,8 +195,8 @@ lookupOrigNameCache nc mod_name occ | ns == dataName = dataConName (tupleCon boxity arity) | otherwise = varName (dataConWorkId (tupleCon boxity arity)) -lookupOrigNameCache nc mod_name occ -- The normal case - = case lookupModuleEnvByName nc mod_name of +lookupOrigNameCache nc mod occ -- The normal case + = case lookupModuleEnv nc mod of Nothing -> Nothing Just occ_env -> lookupOccEnv occ_env occ @@ -250,68 +232,14 @@ initOrigNames names = foldl extendOrigNameCache emptyModuleEnv names \end{code} + %************************************************************************ %* * - Getting from Names to TyThings + Type variables and local Ids %* * %************************************************************************ \begin{code} -tcIfaceGlobal :: Name -> IfM a TyThing -tcIfaceGlobal name - = do { eps <- getEps - ; hpt <- getHpt - ; case lookupType hpt (eps_PTE eps) name of { - Just thing -> return thing ; - Nothing -> - - setLclEnv () $ do -- This gets us back to IfG, mainly to - -- pacify get_type_env; rather untidy - { env <- getGblEnv - ; case if_rec_types env of - Just (mod, get_type_env) - | nameIsLocalOrFrom mod name - -> do -- It's defined in the module being compiled - { type_env <- get_type_env - ; case lookupNameEnv type_env name of - Just thing -> return thing - Nothing -> pprPanic "tcIfaceGlobal (local): not found:" - (ppr name $$ ppr type_env) } - - other -> tcImportDecl name -- It's imported; go get it - }}} - -tcIfaceTyCon :: IfaceTyCon -> IfL TyCon -tcIfaceTyCon IfaceIntTc = return intTyCon -tcIfaceTyCon IfaceBoolTc = return boolTyCon -tcIfaceTyCon IfaceCharTc = return charTyCon -tcIfaceTyCon IfaceListTc = return listTyCon -tcIfaceTyCon IfacePArrTc = return parrTyCon -tcIfaceTyCon (IfaceTupTc bx ar) = return (tupleTyCon bx ar) -tcIfaceTyCon (IfaceTc ext_nm) = do { name <- lookupIfaceExt ext_nm - ; thing <- tcIfaceGlobal name - ; return (tyThingTyCon thing) } - -tcIfaceClass :: IfaceExtName -> IfL Class -tcIfaceClass rdr_name = do { name <- lookupIfaceExt rdr_name - ; thing <- tcIfaceGlobal name - ; return (tyThingClass thing) } - -tcIfaceDataCon :: IfaceExtName -> IfL DataCon -tcIfaceDataCon gbl = do { name <- lookupIfaceExt gbl - ; thing <- tcIfaceGlobal name - ; case thing of - ADataCon dc -> return dc - other -> pprPanic "tcIfaceExtDC" (ppr gbl $$ ppr name$$ ppr thing) } - -tcIfaceExtId :: IfaceExtName -> IfL Id -tcIfaceExtId gbl = do { name <- lookupIfaceExt gbl - ; thing <- tcIfaceGlobal name - ; case thing of - AnId id -> return id - other -> pprPanic "tcIfaceExtId" (ppr gbl $$ ppr name$$ ppr thing) } - ------------------------------------------- tcIfaceLclId :: OccName -> IfL Id tcIfaceLclId occ = do { lcl <- getLclEnv @@ -319,13 +247,6 @@ tcIfaceLclId occ `orElse` pprPanic "tcIfaceLclId" (ppr occ)) } -tcIfaceTyVar :: OccName -> IfL TyVar -tcIfaceTyVar occ - = do { lcl <- getLclEnv - ; return (lookupOccEnv (if_tv_env lcl) occ - `orElse` - pprPanic "tcIfaceTyVar" (ppr occ)) } - extendIfaceIdEnv :: [Id] -> IfL a -> IfL a extendIfaceIdEnv ids thing_inside = do { env <- getLclEnv @@ -333,6 +254,14 @@ extendIfaceIdEnv ids thing_inside ; pairs = [(getOccName id, id) | id <- ids] } ; setLclEnv (env { if_id_env = id_env' }) thing_inside } + +tcIfaceTyVar :: OccName -> IfL TyVar +tcIfaceTyVar occ + = do { lcl <- getLclEnv + ; return (lookupOccEnv (if_tv_env lcl) occ + `orElse` + pprPanic "tcIfaceTyVar" (ppr occ)) } + extendIfaceTyVarEnv :: [TyVar] -> IfL a -> IfL a extendIfaceTyVarEnv tyvars thing_inside = do { env <- getLclEnv