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
import TcType
import TcGadt
import GHC
-
+import GhciMonad
+import InteractiveEval
import Outputable
import Pretty ( Mode(..), showDocWith )
import FastString
import GHC.Exts
#include "HsVersions.h"
-
-------------------------------------
-- | The :print & friends commands
-------------------------------------
(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
-- 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
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'
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)
termTyVars,
-- unsafeDeepSeq,
cvReconstructType,
+ computeRTTIsubst,
sigmaType
) where
(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
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)]
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)
| (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
{-
InteractiveContext(..), emptyInteractiveContext,
icPrintUnqual, mkPrintUnqualified, extendInteractiveContext,
+ substInteractiveContext,
ModIface(..), mkIfaceDepCache, mkIfaceVerCache, mkIfaceFixCache,
emptyIfaceDepCache,
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
import System.Time ( ClockTime )
import Data.IORef
import Data.Array ( Array, array )
+import Data.List
\end{code}
-- 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}
%************************************************************************
isModuleInterpreted,
compileExpr, dynCompileExpr,
lookupName,
- obtainTerm, obtainTerm1
+ obtainTerm, obtainTerm1, reconstructType,
+ skolemiseSubst, skolemiseTy
#endif
) where
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)
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)
-- -----------------------------------------------------------------------------
-- After stopping at a breakpoint, add free variables to the environment
-
+result_fs = FSLIT("_result")
+
bindLocalsAtBreakpoint
:: HscEnv
-> HValue
-- 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"
-- 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
(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
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)
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 */
projects / ghc-hetmet.git / commitdiff