From 012496177fb63d96a9636cb2b151c44c30c4d572 Mon Sep 17 00:00:00 2001 From: Pepe Iborra Date: Sat, 14 Jul 2007 11:49:46 +0000 Subject: [PATCH] Automatic RTTI for ghci bindings With this patch, ghci runs rtti (bounded in the term treewith a max. depth of 10) automatically after evaluating any expression in the interactive env. In addition, a rtti step is performed on the local bindings in a breakpoint, before returning control to the user Let's see how well this works in practice --- compiler/ghci/Debugger.hs | 49 +++++------------------------- compiler/ghci/RtClosureInspect.hs | 33 +++++++++++++++------ compiler/main/HscTypes.lhs | 22 ++++++++++++-- compiler/main/InteractiveEval.hs | 59 ++++++++++++++++++++++++++++--------- 4 files changed, 97 insertions(+), 66 deletions(-) diff --git a/compiler/ghci/Debugger.hs b/compiler/ghci/Debugger.hs index 8491069..20bdbf6 100644 --- a/compiler/ghci/Debugger.hs +++ b/compiler/ghci/Debugger.hs @@ -28,7 +28,8 @@ import Type import TcType import TcGadt import GHC - +import GhciMonad +import InteractiveEval import Outputable import Pretty ( Mode(..), showDocWith ) import FastString @@ -44,7 +45,6 @@ import System.IO import GHC.Exts #include "HsVersions.h" - ------------------------------------- -- | The :print & friends commands ------------------------------------- @@ -56,8 +56,10 @@ pprintClosureCommand session bindThings force str = do (words str) substs <- catMaybes `liftM` mapM (go session) [id | AnId id <- tythings] - mapM (applySubstToEnv session . skolemSubst) substs - return () + modifySession session $ \hsc_env -> + hsc_env{hsc_IC = foldr (flip substInteractiveContext) + (hsc_IC hsc_env) + (map skolemiseSubst substs)} where -- Do the obtainTerm--bindSuspensions-computeSubstitution dance @@ -77,38 +79,11 @@ pprintClosureCommand session bindThings force str = do -- Then, we extract a substitution, -- mapping the old tyvars to the reconstructed types. let Just reconstructed_type = termType term - - -- tcUnifyTys doesn't look through forall's, so we drop them from - -- the original type, instead of sigma-typing the reconstructed type - -- In addition, we strip newtypes too, since the reconstructed type might - -- not have recovered them all - mb_subst = tcUnifyTys (const BindMe) - [repType' $ dropForAlls$ idType id] - [repType' $ reconstructed_type] + mb_subst = computeRTTIsubst (idType id) (reconstructed_type) ASSERT2 (isJust mb_subst, ppr reconstructed_type $$ (ppr$ idType id)) return mb_subst - applySubstToEnv :: Session -> TvSubst -> IO () - applySubstToEnv cms subst | isEmptyTvSubst subst = return () - applySubstToEnv cms@(Session ref) subst = do - hsc_env <- readIORef ref - inScope <- GHC.getBindings cms - let ictxt = hsc_IC hsc_env - ids = ic_tmp_ids ictxt - ids' = map (\id -> id `setIdType` substTy subst (idType id)) ids - subst_dom= varEnvKeys$ getTvSubstEnv subst - subst_ran= varEnvElts$ getTvSubstEnv subst - new_tvs = [ tv | Just tv <- map getTyVar_maybe subst_ran] - ic_tyvars'= (`delVarSetListByKey` subst_dom) - . (`extendVarSetList` new_tvs) - $ ic_tyvars ictxt - ictxt' = ictxt { ic_tmp_ids = ids' - , ic_tyvars = ic_tyvars' } - writeIORef ref (hsc_env {hsc_IC = ictxt'}) - - where delVarSetListByKey = foldl' delVarSetByKey - tidyTermTyVars :: Session -> Term -> IO Term tidyTermTyVars (Session ref) t = do hsc_env <- readIORef ref @@ -133,7 +108,7 @@ bindSuspensions cms@(Session ref) t = do availNames_var <- newIORef availNames (t', stuff) <- foldTerm (nameSuspensionsAndGetInfos availNames_var) t let (names, tys, hvals) = unzip3 stuff - let tys' = map mk_skol_ty tys + let tys' = map (fst.skolemiseTy) tys let ids = [ mkGlobalId VanillaGlobal name ty vanillaIdInfo | (name,ty) <- zip names tys'] new_tyvars = tyVarsOfTypes tys' @@ -214,11 +189,3 @@ newGrimName cms userName = do occname = mkOccName varName userName name = mkInternalName unique occname noSrcSpan return name - -skolemSubst subst = subst `setTvSubstEnv` - mapVarEnv mk_skol_ty (getTvSubstEnv subst) -mk_skol_ty ty | tyvars <- varSetElems (tyVarsOfType ty) - , tyvars' <- map (mkTyVarTy . mk_skol_tv) tyvars - = substTyWith tyvars tyvars' ty -mk_skol_tv tv = mkTcTyVar (tyVarName tv) (tyVarKind tv) - (SkolemTv RuntimeUnkSkol) diff --git a/compiler/ghci/RtClosureInspect.hs b/compiler/ghci/RtClosureInspect.hs index 3ea2ba9..3ffc8c2 100644 --- a/compiler/ghci/RtClosureInspect.hs +++ b/compiler/ghci/RtClosureInspect.hs @@ -26,6 +26,7 @@ module RtClosureInspect( termTyVars, -- unsafeDeepSeq, cvReconstructType, + computeRTTIsubst, sigmaType ) where @@ -582,7 +583,7 @@ cvReconstructType hsc_env force mb_ty hval = runTR_maybe hsc_env $ do (ty',rev_subst) <- instScheme (sigmaType ty) addConstraint tv ty' search (isMonomorphic `fmap` zonkTcType tv) - (uncurry go) + (\(ty,a) -> go ty a) [(tv, hval)] max_depth substTy rev_subst `fmap` zonkTcType tv @@ -591,9 +592,9 @@ cvReconstructType hsc_env force mb_ty hval = runTR_maybe hsc_env $ do search stop expand [] depth = return () search stop expand x 0 = fail$ "Failed to reconstruct a type after " ++ show max_depth ++ " steps" - search stop expand (x:xx) d = do + search stop expand (x:xx) d = unlessM stop $ do new <- expand x - unlessM stop $ search stop expand (xx ++ new) $! (pred d) + search stop expand (xx ++ new) $! (pred d) -- returns unification tasks,since we are going to want a breadth-first search go :: Type -> HValue -> TR [(Type, HValue)] @@ -602,19 +603,20 @@ cvReconstructType hsc_env force mb_ty hval = runTR_maybe hsc_env $ do case tipe clos of Indirection _ -> go tv $! (ptrs clos ! 0) Constr -> do - mb_dcname <- dataConInfoPtrToName (infoPtr clos) - case mb_dcname of - Left tag -> do + Right dcname <- dataConInfoPtrToName (infoPtr clos) + (_,mb_dc) <- tryTcErrs (tcLookupDataCon dcname) + case mb_dc of + Nothing-> do + -- TODO: Check this case vars <- replicateM (length$ elems$ ptrs clos) (newVar (liftedTypeKind)) subTerms <- sequence [ appArr (go tv) (ptrs clos) i | (i, tv) <- zip [0..] vars] forM [0..length (elems $ ptrs clos)] $ \i -> do - tv <- newVar openTypeKind + tv <- newVar liftedTypeKind return$ appArr (\e->(tv,e)) (ptrs clos) i - Right name -> do - dc <- tcLookupDataCon name + Just dc -> do let extra_args = length(dataConRepArgTys dc) - length(dataConOrigArgTys dc) subTtypes <- mapMif (not . isMonomorphic) @@ -629,6 +631,19 @@ cvReconstructType hsc_env force mb_ty hval = runTR_maybe hsc_env $ do | (i,t) <- drop extra_args $ zip [0..] subTtypes] otherwise -> return [] + -- This helper computes the difference between a base type t and the + -- improved rtti_t computed by RTTI + -- The main difference between RTTI types and their normal counterparts + -- is that the former are _not_ polymorphic, thus polymorphism must + -- be stripped. Syntactically, forall's must be stripped +computeRTTIsubst ty rtti_ty = + -- In addition, we strip newtypes too, since the reconstructed type might + -- not have recovered them all + tcUnifyTys (const BindMe) + [repType' $ dropForAlls$ ty] + [repType' $ rtti_ty] +-- TODO stripping newtypes shouldn't be necessary, test + -- Dealing with newtypes {- diff --git a/compiler/main/HscTypes.lhs b/compiler/main/HscTypes.lhs index f36b205..bb7acef 100644 --- a/compiler/main/HscTypes.lhs +++ b/compiler/main/HscTypes.lhs @@ -29,6 +29,7 @@ module HscTypes ( InteractiveContext(..), emptyInteractiveContext, icPrintUnqual, mkPrintUnqualified, extendInteractiveContext, + substInteractiveContext, ModIface(..), mkIfaceDepCache, mkIfaceVerCache, mkIfaceFixCache, emptyIfaceDepCache, @@ -92,9 +93,9 @@ import Rules ( RuleBase ) import CoreSyn ( CoreBind ) import VarEnv import VarSet -import Var +import Var hiding ( setIdType ) import Id -import Type ( TyThing(..) ) +import Type import Class ( Class, classSelIds, classATs, classTyCon ) import TyCon @@ -120,6 +121,7 @@ import StringBuffer ( StringBuffer ) import System.Time ( ClockTime ) import Data.IORef import Data.Array ( Array, array ) +import Data.List \end{code} @@ -691,6 +693,22 @@ extendInteractiveContext ictxt ids tyvars -- NB. must be this way around, because we want -- new ids to shadow existing bindings. ic_tyvars = ic_tyvars ictxt `unionVarSet` tyvars } + + +substInteractiveContext :: InteractiveContext -> TvSubst -> InteractiveContext +substInteractiveContext ictxt subst | isEmptyTvSubst subst = ictxt +substInteractiveContext ictxt@InteractiveContext{ic_tmp_ids=ids} subst = + let ids' = map (\id -> id `setIdType` substTy subst (idType id)) ids + subst_dom= varEnvKeys$ getTvSubstEnv subst + subst_ran= varEnvElts$ getTvSubstEnv subst + new_tvs = [ tv | Just tv <- map getTyVar_maybe subst_ran] + ic_tyvars'= (`delVarSetListByKey` subst_dom) + . (`extendVarSetList` new_tvs) + $ ic_tyvars ictxt + in ictxt { ic_tmp_ids = ids' + , ic_tyvars = ic_tyvars' } + + where delVarSetListByKey = foldl' delVarSetByKey \end{code} %************************************************************************ diff --git a/compiler/main/InteractiveEval.hs b/compiler/main/InteractiveEval.hs index f1e6079..3de25ce 100644 --- a/compiler/main/InteractiveEval.hs +++ b/compiler/main/InteractiveEval.hs @@ -28,7 +28,8 @@ module InteractiveEval ( isModuleInterpreted, compileExpr, dynCompileExpr, lookupName, - obtainTerm, obtainTerm1 + obtainTerm, obtainTerm1, reconstructType, + skolemiseSubst, skolemiseTy #endif ) where @@ -163,7 +164,7 @@ runStmt (Session ref) expr step let thing_to_run = unsafeCoerce# hval :: IO [HValue] status <- sandboxIO statusMVar thing_to_run - + let ic = hsc_IC hsc_env bindings = (ic_tmp_ids ic, ic_tyvars ic) @@ -205,8 +206,9 @@ handleRunStatus expr ref bindings final_ids breakMVar statusMVar status final_ids emptyVarSet -- the bound Ids never have any free TyVars final_names = map idName final_ids - writeIORef ref hsc_env{hsc_IC=final_ic} Linker.extendLinkEnv (zip final_names hvals) + hsc_env' <- rttiEnvironment hsc_env{hsc_IC=final_ic} + writeIORef ref hsc_env' return (RunOk final_names) @@ -420,7 +422,8 @@ moveHist fn (Session ref) = do -- ----------------------------------------------------------------------------- -- After stopping at a breakpoint, add free variables to the environment - +result_fs = FSLIT("_result") + bindLocalsAtBreakpoint :: HscEnv -> HValue @@ -475,7 +478,8 @@ bindLocalsAtBreakpoint hsc_env apStack (Just info) = do -- So that we don't fall over in a heap when this happens, just don't -- bind any free variables instead, and we emit a warning. mb_hValues <- mapM (getIdValFromApStack apStack) offsets - let filtered_ids = [ id | (id, Just _) <- zip ids mb_hValues ] + let (filtered_hvs, filtered_ids) = + unzip [ (hv, id) | (id, Just hv) <- zip ids mb_hValues ] when (any isNothing mb_hValues) $ debugTraceMsg (hsc_dflags hsc_env) 1 $ text "Warning: _result has been evaluated, some bindings have been lost" @@ -486,8 +490,7 @@ bindLocalsAtBreakpoint hsc_env apStack (Just info) = do -- 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) + let result_name = mkInternalName (getUnique result_fs) (mkVarOccFS result_fs) span result_id = Id.mkGlobalId VanillaGlobal result_name result_ty vanillaIdInfo @@ -504,14 +507,13 @@ bindLocalsAtBreakpoint hsc_env apStack (Just info) = do (id_tys, tyvarss) = mapAndUnzip (skolemiseTy.idType) all_ids (_,tidy_tys) = tidyOpenTypes emptyTidyEnv id_tys new_tyvars = unionVarSets tyvarss - final_ids = zipWith setIdType all_ids tidy_tys - - let ictxt0 = hsc_IC hsc_env - ictxt1 = extendInteractiveContext ictxt0 final_ids new_tyvars - + let final_ids = zipWith setIdType all_ids tidy_tys + ictxt0 = hsc_IC hsc_env + ictxt1 = extendInteractiveContext ictxt0 final_ids new_tyvars Linker.extendLinkEnv [ (name,hval) | (name, Just hval) <- zip names mb_hValues ] Linker.extendLinkEnv [(result_name, unsafeCoerce# apStack)] - return (hsc_env{ hsc_IC = ictxt1 }, result_name:names, span) + hsc_env1 <- rttiEnvironment hsc_env{ hsc_IC = ictxt1 } + return (hsc_env1, result_name:names, span) where mkNewId :: OccName -> Id -> IO Id mkNewId occ id = do @@ -522,6 +524,26 @@ bindLocalsAtBreakpoint hsc_env apStack (Just info) = do new_id = Id.mkGlobalId VanillaGlobal name ty (idInfo id) return new_id +rttiEnvironment :: HscEnv -> IO HscEnv +rttiEnvironment hsc_env@HscEnv{hsc_IC=ic} = do + let InteractiveContext{ic_tmp_ids=tmp_ids, ic_tyvars = tyvars} = ic + incompletelyTypedIds = + [id | id <- tmp_ids + , not $ null [v | v <- varSetElems$ tyVarsOfType (idType id) + , isSkolemTyVar v] + , (occNameFS.nameOccName.idName) id /= result_fs] + tys <- reconstructType hsc_env False `mapM` incompletelyTypedIds + -- map termType `fmap` (obtainTerm hsc_env False `mapM` incompletelyTypedIds) + + let substs = [computeRTTIsubst ty ty' + | (ty, Just ty') <- zip (map idType incompletelyTypedIds) tys] + ic' = foldr (flip substInteractiveContext) ic + (map skolemiseSubst $ catMaybes substs) + return hsc_env{hsc_IC=ic'} + +skolemiseSubst subst = subst `setTvSubstEnv` + mapVarEnv (fst.skolemiseTy) (getTvSubstEnv subst) + skolemiseTy :: Type -> (Type, TyVarSet) skolemiseTy ty = (substTy subst ty, mkVarSet new_tyvars) where env = mkVarEnv (zip tyvars new_tyvar_tys) @@ -819,12 +841,21 @@ isModuleInterpreted s mod_summary = withSession s $ \hsc_env -> where obj_linkable = isObjectLinkable (expectJust "showModule" (hm_linkable mod_info)) +---------------------------------------------------------------------------- +-- RTTI primitives + obtainTerm1 :: HscEnv -> Bool -> Maybe Type -> a -> IO Term -obtainTerm1 hsc_env force mb_ty x = cvObtainTerm hsc_env force mb_ty (unsafeCoerce# x) +obtainTerm1 hsc_env force mb_ty x = + cvObtainTerm hsc_env force mb_ty (unsafeCoerce# x) obtainTerm :: HscEnv -> Bool -> Id -> IO Term obtainTerm hsc_env force id = do hv <- Linker.getHValue hsc_env (varName id) cvObtainTerm hsc_env force (Just$ idType id) hv +-- Uses RTTI to reconstruct the type of an Id, making it less polymorphic +reconstructType :: HscEnv -> Bool -> Id -> IO (Maybe Type) +reconstructType hsc_env force id = do + hv <- Linker.getHValue hsc_env (varName id) + cvReconstructType hsc_env force (Just$ idType id) hv #endif /* GHCI */ -- 1.7.10.4