From 568e6b65ac52a2bcdb0450cc265f52080f78ab08 Mon Sep 17 00:00:00 2001 From: Simon Marlow Date: Wed, 25 Apr 2007 14:50:25 +0000 Subject: [PATCH] remember the type of _result --- compiler/ghci/ByteCodeGen.lhs | 1 + compiler/ghci/ByteCodeInstr.lhs | 5 +++- compiler/main/GHC.hs | 57 +++++++++++++++++++++++++-------------- 3 files changed, 42 insertions(+), 21 deletions(-) diff --git a/compiler/ghci/ByteCodeGen.lhs b/compiler/ghci/ByteCodeGen.lhs index b09d739..444fe87 100644 --- a/compiler/ghci/ByteCodeGen.lhs +++ b/compiler/ghci/ByteCodeGen.lhs @@ -298,6 +298,7 @@ schemeER_wrk d p rhs { breakInfo_module = tickInfo_module tickInfo , breakInfo_number = tickNumber , breakInfo_vars = idOffSets + , breakInfo_resty = exprType (deAnnotate' newRhs) } let breakInstr = case arr of (BA arr#) -> BRK_FUN arr# tickNumber breakInfo return $ breakInstr `consOL` code diff --git a/compiler/ghci/ByteCodeInstr.lhs b/compiler/ghci/ByteCodeInstr.lhs index 3f57d18..adb47c8 100644 --- a/compiler/ghci/ByteCodeInstr.lhs +++ b/compiler/ghci/ByteCodeInstr.lhs @@ -13,6 +13,7 @@ module ByteCodeInstr ( import ByteCodeItbls ( ItblPtr ) +import Type import Outputable import Name import Id @@ -141,13 +142,15 @@ data BreakInfo { breakInfo_module :: Module , breakInfo_number :: Int , breakInfo_vars :: [(Id,Int)] + , breakInfo_resty :: Type } instance Outputable BreakInfo where ppr info = text "BreakInfo" <+> parens (ppr (breakInfo_module info) <+> ppr (breakInfo_number info) <+> - ppr (breakInfo_vars info)) + ppr (breakInfo_vars info) <+> + ppr (breakInfo_resty info)) -- ----------------------------------------------------------------------------- -- Printing bytecode instructions diff --git a/compiler/main/GHC.hs b/compiler/main/GHC.hs index 3c14bb7..c5e6fa0 100644 --- a/compiler/main/GHC.hs +++ b/compiler/main/GHC.hs @@ -2207,9 +2207,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 @@ -2315,31 +2318,33 @@ 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 - let tyvars = varSetElems (tyVarsOfTypes (map idType new_ids)) - new_tyvars = map mk_skol tyvars - new_tyvar_tys = map mkTyVarTy new_tyvars - mk_skol tyvar = mkTcTyVar (tyVarName tyvar) (tyVarKind tyvar) - (SkolemTv UnkSkol) - subst = mkTvSubst emptyInScopeSet (mkVarEnv (zip tyvars new_tyvar_tys)) - subst_id id = id `setIdType` substTy subst (idType id) - subst_ids = map subst_id new_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 []) + -- 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 + + let all_ids = result_id : ids + (id_tys, tyvarss) = mapAndUnzip (skolemiseTy.idType) all_ids + new_tyvars = unionVarSets tyvarss + new_ids = zipWith setIdType all_ids id_tys + let ictxt = hsc_IC hsc_env type_env = ic_type_env ictxt - all_new_ids = result_id : subst_ids - bound_names = map idName all_new_ids + bound_names = map idName new_ids -- Remove any shadowed bindings from the type_env; -- they are inaccessible but might, I suppose, cause -- a space leak if we leave them there @@ -2348,10 +2353,10 @@ extendEnvironment hsc_env apStack idsOffsets occs = do n <- old_bound_names, nameOccName name == nameOccName n ] ; filtered_type_env = delListFromNameEnv type_env shadowed - new_type_env = extendTypeEnvWithIds filtered_type_env all_new_ids + new_type_env = extendTypeEnvWithIds filtered_type_env new_ids old_tyvars = ic_tyvars ictxt new_ic = ictxt { ic_type_env = new_type_env, - ic_tyvars = extendVarSetList old_tyvars new_tyvars } + ic_tyvars = old_tyvars `unionVarSet` new_tyvars } Linker.extendLinkEnv (zip names hValues) Linker.extendLinkEnv [(result_name, unsafeCoerce# apStack)] return (hsc_env{hsc_IC = new_ic}, result_name:names) @@ -2365,6 +2370,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 UnkSkol) + ----------------------------------------------------------------------------- -- show a module and it's source/object filenames -- 1.7.10.4