X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2Fmain%2FGHC.hs;h=f1ab876af440bda9c776aa563316eb35a5796a36;hb=cf997f8083f529e71bb4b5030eb9fc8cf0aaa7f7;hp=c440eb4448de769493c28fb750ed7f2cabe61e8c;hpb=367b0590cc0d8ba3d1561c85b366a183b8a71d24;p=ghc-hetmet.git diff --git a/compiler/main/GHC.hs b/compiler/main/GHC.hs index c440eb4..f1ab876 100644 --- a/compiler/main/GHC.hs +++ b/compiler/main/GHC.hs @@ -194,7 +194,6 @@ module GHC ( import RtClosureInspect ( cvObtainTerm, Term ) import TcRnDriver ( tcRnLookupRdrName, tcRnGetInfo, tcRnLookupName, getModuleExports ) -import VarEnv ( emptyTidyEnv ) import GHC.Exts ( unsafeCoerce#, Ptr ) import Foreign.StablePtr( deRefStablePtr, StablePtr, newStablePtr, freeStablePtr ) import Foreign ( poke ) @@ -204,7 +203,6 @@ import Linker ( HValue ) import Data.Dynamic ( Dynamic ) import ByteCodeInstr -import DebuggerTys import IdInfo import HscMain ( hscParseIdentifier, hscTcExpr, hscKcType, hscStmt ) import BreakArray @@ -215,8 +213,11 @@ import NameSet import RdrName import HsSyn import Type hiding (typeKind) +import TcType hiding (typeKind) import Id import Var hiding (setIdType) +import VarEnv +import VarSet import TysPrim ( alphaTyVars ) import TyCon import Class @@ -2036,8 +2037,15 @@ getNamesInScope s = withSession s $ \hsc_env -> do getRdrNamesInScope :: Session -> IO [RdrName] getRdrNamesInScope s = withSession s $ \hsc_env -> do - let env = ic_rn_gbl_env (hsc_IC hsc_env) - return (concat (map greToRdrNames (globalRdrEnvElts env))) + let + ic = hsc_IC hsc_env + gbl_rdrenv = ic_rn_gbl_env ic + ids = typeEnvIds (ic_type_env ic) + gbl_names = concat (map greToRdrNames (globalRdrEnvElts gbl_rdrenv)) + lcl_names = map (mkRdrUnqual.nameOccName.idName) ids + -- + return (gbl_names ++ lcl_names) + -- ToDo: move to RdrName greToRdrNames :: GlobalRdrElt -> [RdrName] @@ -2205,9 +2213,12 @@ handleRunStatus ref final_ic final_names resume_ic breakMVar statusMVar status = hsc_env <- readIORef ref mod_info <- getHomeModuleInfo hsc_env (moduleName (breakInfo_module info)) let breaks = minf_modBreaks (expectJust "handlRunStatus" mod_info) - let occs = modBreaks_vars breaks ! breakInfo_number info - (new_hsc_env, names) <- extendEnvironment hsc_env apStack - (breakInfo_vars info) occs + let index = breakInfo_number info + occs = modBreaks_vars breaks ! index + span = modBreaks_locs breaks ! index + (new_hsc_env, names) <- extendEnvironment hsc_env apStack span + (breakInfo_vars info) + (breakInfo_resty info) occs writeIORef ref new_hsc_env let res = ResumeHandle breakMVar statusMVar final_names final_ic resume_ic names @@ -2313,40 +2324,48 @@ getIdValFromApStack apStack (identifier, stackDepth) = do extendEnvironment :: HscEnv -> a -- the AP_STACK object built by the interpreter + -> SrcSpan -> [(Id, Int)] -- free variables and offsets into the AP_STACK + -> Type -> [OccName] -- names for the variables (from the source code) -> IO (HscEnv, [Name]) -extendEnvironment hsc_env apStack idsOffsets occs = do +extendEnvironment hsc_env apStack span idsOffsets result_ty occs = do idsVals <- mapM (getIdValFromApStack apStack) idsOffsets let (ids, hValues) = unzip idsVals new_ids <- zipWithM mkNewId occs ids let names = map idName ids - Just (ATyCon unknown_tc) <- tcRnLookupName hsc_env unknownTyConName - let result_name = mkSystemVarName (mkBuiltinUnique 33) FSLIT("_result") - result_id = Id.mkLocalId result_name (mkTyConApp unknown_tc []) - let ictxt = hsc_IC hsc_env - rn_env = ic_rn_local_env ictxt - type_env = ic_type_env ictxt - all_new_ids = result_id : new_ids - bound_names = map idName all_new_ids - new_rn_env = extendLocalRdrEnv rn_env bound_names - -- Remove any shadowed bindings from the type_env; - -- they are inaccessible but might, I suppose, cause - -- a space leak if we leave them there - shadowed = [ n | name <- bound_names, - let rdr_name = mkRdrUnqual (nameOccName name), - Just n <- [lookupLocalRdrEnv rn_env rdr_name] ] - filtered_type_env = delListFromNameEnv type_env shadowed - new_type_env = extendTypeEnvWithIds filtered_type_env all_new_ids - new_ic = ictxt { ic_rn_local_env = new_rn_env, - ic_type_env = new_type_env } + + -- make an Id for _result. We use the Unique of the FastString "_result"; + -- we don't care about uniqueness here, because there will only be one + -- _result in scope at any time. + let result_fs = FSLIT("_result") + result_name = mkInternalName (getUnique result_fs) + (mkVarOccFS result_fs) (srcSpanStart span) + result_id = Id.mkLocalId result_name result_ty + + -- for each Id we're about to bind in the local envt: + -- - skolemise the type variables in its type, so they can't + -- be randomly unified with other types. These type variables + -- can only be resolved by type reconstruction in RtClosureInspect + -- - tidy the type variables + -- - globalise the Id (Ids are supposed to be Global, apparently). + -- + let all_ids = result_id : ids + (id_tys, tyvarss) = mapAndUnzip (skolemiseTy.idType) all_ids + (_,tidy_tys) = tidyOpenTypes emptyTidyEnv id_tys + new_tyvars = unionVarSets tyvarss + new_ids = zipWith setIdType all_ids tidy_tys + global_ids = map (globaliseId VanillaGlobal) new_ids + + let ictxt = extendInteractiveContext (hsc_IC hsc_env) + global_ids new_tyvars + Linker.extendLinkEnv (zip names hValues) Linker.extendLinkEnv [(result_name, unsafeCoerce# apStack)] - return (hsc_env{hsc_IC = new_ic}, result_name:names) + return (hsc_env{hsc_IC = ictxt}, result_name:names) where mkNewId :: OccName -> Id -> IO Id mkNewId occ id = do - ty <- instantiateTyVarsToUnknown hsc_env let uniq = idUnique id loc = nameSrcLoc (idName id) name = mkInternalName uniq occ loc @@ -2354,6 +2373,18 @@ extendEnvironment hsc_env apStack idsOffsets occs = do new_id = Id.mkGlobalId VanillaGlobal name ty (idInfo id) return new_id +skolemiseTy :: Type -> (Type, TyVarSet) +skolemiseTy ty = (substTy subst ty, mkVarSet new_tyvars) + where env = mkVarEnv (zip tyvars new_tyvar_tys) + subst = mkTvSubst emptyInScopeSet env + tyvars = varSetElems (tyVarsOfType ty) + new_tyvars = map skolemiseTyVar tyvars + new_tyvar_tys = map mkTyVarTy new_tyvars + +skolemiseTyVar :: TyVar -> TyVar +skolemiseTyVar tyvar = mkTcTyVar (tyVarName tyvar) (tyVarKind tyvar) + (SkolemTv RuntimeUnkSkol) + ----------------------------------------------------------------------------- -- show a module and it's source/object filenames