Commit 01249617 authored by mnislaih's avatar mnislaih
Browse files

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
parent 876db7ed
......@@ -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)
......@@ -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
{-
......
......@@ -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}
%************************************************************************
......
......@@ -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 */
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment