X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2Fiface%2FIfaceEnv.lhs;h=40b7d31f138aefdb9756f7a0766aa8c92af77320;hb=f5ca07d670fd2fcd196aa670890257117a015728;hp=e98763703fa5d2b82b2291ab1bd6ef0ccefa4542;hpb=f714e6b642fd614a9971717045ae47c3d871275e;p=ghc-hetmet.git diff --git a/ghc/compiler/iface/IfaceEnv.lhs b/ghc/compiler/iface/IfaceEnv.lhs index e987637..40b7d31 100644 --- a/ghc/compiler/iface/IfaceEnv.lhs +++ b/ghc/compiler/iface/IfaceEnv.lhs @@ -6,41 +6,38 @@ module IfaceEnv ( lookupIfaceTop, lookupIfaceExt, lookupOrig, lookupIfaceTc, newIfaceName, newIfaceNames, - extendIfaceIdEnv, extendIfaceTyVarEnv, - tcIfaceGlobal, tcIfaceTyCon, tcIfaceClass, tcIfaceExtId, - tcIfaceTyVar, tcIfaceDataCon, tcIfaceLclId, + extendIfaceIdEnv, extendIfaceTyVarEnv, refineIfaceIdEnv, + tcIfaceLclId, tcIfaceTyVar, + + lookupAvail, ifaceExportNames, -- Name-cache stuff - allocateGlobalBinder, initNameCache + allocateGlobalBinder, initNameCache, ) where #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(..), GenAvailInfo(..), + IfaceExport, OrigNameCache ) +import Type ( mkOpenTvSubst, substTy ) import TyCon ( TyCon, tyConName ) -import Class ( Class ) -import DataCon ( DataCon, dataConWorkId, dataConName ) -import Var ( TyVar, Id, varName ) +import Unify ( TypeRefinement ) +import DataCon ( dataConWorkId, dataConName ) +import Var ( TyVar, Id, varName, setIdType, idType ) import Name ( Name, nameUnique, nameModule, - nameOccName, nameSrcLoc, + nameOccName, nameSrcLoc, getOccName, nameParent_maybe, - isWiredInName, nameIsLocalOrFrom, mkIPName, + isWiredInName, mkIPName, mkExternalName, mkInternalName ) -import NameEnv -import OccName ( OccName, isTupleOcc_maybe, tcName, dataName, +import NameSet ( NameSet, emptyNameSet, addListToNameSet ) +import OccName ( OccName, isTupleOcc_maybe, tcName, dataName, mapOccEnv, 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, emptyModuleEnv, + lookupModuleEnv, extendModuleEnv_C ) import UniqSupply ( UniqSupply, splitUniqSupply, uniqFromSupply, uniqsFromSupply ) import FiniteMap ( emptyFM, lookupFM, addToFM ) import BasicTypes ( IPName(..), mapIPName ) @@ -68,6 +65,7 @@ newGlobalBinder :: Module -> OccName -> Maybe Name -> SrcLoc -> TcRnIf a b Name newGlobalBinder mod occ mb_parent loc = do { mod `seq` occ `seq` return () -- See notes with lookupOrig_help + -- ; traceIf (text "newGlobalBinder" <+> ppr mod <+> ppr occ <+> ppr loc) ; name_supply <- getNameCache ; let (name_supply', name) = allocateGlobalBinder name_supply mod occ @@ -80,14 +78,13 @@ 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 + -- This is the moment when we know the defining parent and SrcLoc -- of the Name, so we set these fields in the Name we return. -- - -- This is essential, to get the right Module in a Name. - -- Also: then (bogus) multiple bindings of the same Name - -- get different SrcLocs can can be reported as such. + -- Then (bogus) multiple bindings of the same Name + -- get different SrcLocs can can be reported as such. -- -- Possible other reason: it might be in the cache because we -- encountered an occurrence before the binding site for an @@ -135,21 +132,56 @@ 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 +ifaceExportNames :: [IfaceExport] -> TcRnIf gbl lcl NameSet +ifaceExportNames exports + = foldlM do_one emptyNameSet exports + where + do_one acc (mod, exports) = foldlM (do_avail mod) acc exports + do_avail mod acc avail = do { ns <- lookupAvail mod avail + ; return (addListToNameSet acc ns) } + +lookupAvail :: Module -> GenAvailInfo OccName -> TcRnIf a b [Name] +-- Find all the names arising from an import +-- Make sure the parent info is correct, even though we may not +-- yet have read the interface for this module +lookupAvail mod (Avail n) = do { n' <- lookupOrig mod n; + ; return [n'] } +lookupAvail mod (AvailTC p_occ occs) + = do { p_name <- lookupOrig mod p_occ + ; let lookup_sub occ | occ == p_occ = return p_name + | otherwise = lookup_orig mod occ (Just p_name) + ; mappM lookup_sub occs } + -- Remember that 'occs' is all the exported things, including + -- the parent. It's possible to export just class ops without + -- the class, via C( op ). If the class was exported too we'd + -- have C( C, op ) + + -- The use of lookupOrigSub here (rather than lookupOrig) + -- ensures that the subordinate names record their parent; + -- and that in turn ensures that the GlobalRdrEnv + -- has the correct parent for all the names in its range. + -- For imported things, we may only suck in the interface later, if ever. + -- Reason for all this: + -- Suppose module M exports type A.T, and constructor A.MkT + -- Then, we know that A.MkT is a subordinate name of A.T, + -- even though we aren't at the binding site of A.T + -- And it's important, because we may simply re-export A.T + -- without ever sucking in the declaration itself. + + +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 -- SrcLoc to noSrcLoc -- Parent no Nothing -- They'll be overwritten, in due course, by LoadIface.loadDecl. +lookupOrig mod occ = lookup_orig mod occ Nothing -lookupOrig mod_name occ - = do { -- First ensure that mod_name and occ are evaluated +lookup_orig :: Module -> OccName -> Maybe Name -> TcRnIf a b Name +-- Used when we know the parent of the thing we are looking up +lookup_orig mod occ mb_parent + = 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 +190,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 mb_parent 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 +227,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 +240,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 +277,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 +292,14 @@ 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)) } - +refineIfaceIdEnv :: TypeRefinement -> IfL a -> IfL a +refineIfaceIdEnv (tv_subst, _) thing_inside + = do { env <- getLclEnv + ; let { id_env' = mapOccEnv refine_id (if_id_env env) + ; refine_id id = setIdType id (substTy subst (idType id)) + ; subst = mkOpenTvSubst tv_subst } + ; setLclEnv (env { if_id_env = id_env' }) thing_inside } + extendIfaceIdEnv :: [Id] -> IfL a -> IfL a extendIfaceIdEnv ids thing_inside = do { env <- getLclEnv @@ -333,6 +307,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