Commit 121da25a authored by mnislaih's avatar mnislaih

Closure inspection in GHCi

The :print, :sprint and :force commands for GHCi.
This set of commands allows inspection of heap structures of the bindings in the interactive environment.
This is useful to observe lazyness and specially to inspect things with undespecified polymorphic types, as happens often in breakpoints.
parent 8bc615fd
...@@ -53,6 +53,248 @@ import GHC.Exts ...@@ -53,6 +53,248 @@ import GHC.Exts
#include "HsVersions.h" #include "HsVersions.h"
-------------------------------------
-- | The :print & friends commands
-------------------------------------
pprintClosureCommand :: Bool -> Bool -> String -> GHCi ()
pprintClosureCommand bindThings force str = do
cms <- getSession
let strs = words str
mbThings <- io$ ( mapM (GHC.lookupName cms) =<<)
. liftM concat
. mapM (GHC.parseName cms)
$ strs
newvarsNames <- io$ do
uniques <- liftM uniqsFromSupply (mkSplitUniqSupply 'q')
return$ map (\u-> (mkSysTvName u (mkFastString "a"))) uniques
let ids_ = [id | Just (AnId id) <- mbThings]
-- Clean up 'Unknown' types artificially injected into tyvars
ids = map (stripUnknowns newvarsNames) ids_
-- Obtain the terms
mb_terms <- io$ mapM (obtainTerm cms force) ids
-- Give names to suspensions and bind them in the local env
mb_terms' <- if bindThings
then io$ mapM (traverse (bindSuspensions cms)) mb_terms
else return mb_terms
ppr_terms <- io$ mapM (traverse (printTerm cms)) mb_terms'
let docs = [ ppr id <+> char '=' <+> t | (Just t,id) <- zip ppr_terms ids]
unqual <- io$ GHC.getPrintUnqual cms
io . putStrLn . showSDocForUser unqual $ Outputable.vcat docs
-- Type reconstruction may have obtained more defined types for some ids
-- So we refresh their types.
let new_ids0 = [ setIdType id ty | (id,Just t) <- zip ids mb_terms
, let Just ty = termType t
, ty `isMoreSpecificThan` idType id
]
new_ids <- io$ mapM (\x->liftM (setIdType x) . instantiateTyVarsToUnknown cms . idType $ x)
new_ids0
let Session ref = cms
hsc_env <- io$ readIORef ref
let ictxt = hsc_IC hsc_env
type_env = ic_type_env ictxt
filtered_type_env = delListFromNameEnv type_env (map idName new_ids)
new_type_env = extendTypeEnvWithIds filtered_type_env new_ids
new_ic = ictxt {ic_type_env = new_type_env }
io$ writeIORef ref (hsc_env {hsc_IC = new_ic })
where
isMoreSpecificThan :: Type -> Type -> Bool
ty `isMoreSpecificThan ` ty1
| Just subst <- tcUnifyTys bindOnlyTy1 [repType' ty] [repType' ty1]
, substFiltered <- filter (not.isTyVarTy) . varEnvElts . getTvSubstEnv $ subst
, not . null $ substFiltered
, all (flip notElemTvSubst subst) ty_vars
-- , pprTrace "subst" (ppr subst) True
= True
| otherwise = False
where bindOnlyTy1 tyv | tyv `elem` ty_vars = AvoidMe
| otherwise = BindMe
ty_vars = varSetElems$ tyVarsOfType ty
bindSuspensions :: Session -> Term -> IO Term
bindSuspensions cms@(Session ref) t = do
hsc_env <- readIORef ref
inScope <- GHC.getBindings cms
let ictxt = hsc_IC hsc_env
rn_env = ic_rn_local_env ictxt
type_env = ic_type_env ictxt
prefix = "_t"
alreadyUsedNames = map (occNameString . nameOccName . getName) inScope
availNames = [n | n <- map ((prefix++) . show) [1..]
, n `notElem` alreadyUsedNames ]
availNames_var <- newIORef availNames
(t', stuff) <- foldTerm (nameSuspensionsAndGetInfos availNames_var) t
let (names, tys, hvals) = unzip3 stuff
concrete_tys <- mapM (instantiateTyVarsToUnknown cms) tys
let ids = [ mkGlobalId VanillaGlobal name ty vanillaIdInfo
| (name,ty) <- zip names concrete_tys]
new_type_env = extendTypeEnvWithIds type_env ids
new_rn_env = extendLocalRdrEnv rn_env names
new_ic = ictxt { ic_rn_local_env = new_rn_env,
ic_type_env = new_type_env }
extendLinkEnv (zip names hvals)
writeIORef ref (hsc_env {hsc_IC = new_ic })
return t'
where
-- Processing suspensions. Give names and recopilate info
nameSuspensionsAndGetInfos :: IORef [String] -> TermFold (IO (Term, [(Name,Type,HValue)]))
nameSuspensionsAndGetInfos freeNames = TermFold
{
fSuspension = doSuspension freeNames
, fTerm = \ty dc v tt -> do
tt' <- sequence tt
let (terms,names) = unzip tt'
return (Term ty dc v terms, concat names)
, fPrim = \ty n ->return (Prim ty n,[])
}
doSuspension freeNames ct mb_ty hval Nothing = do
name <- atomicModifyIORef freeNames (\x->(tail x, head x))
n <- newGrimName cms name
let ty' = fromMaybe (error "unexpected") mb_ty
return (Suspension ct mb_ty hval (Just n), [(n,ty',hval)])
-- A custom Term printer to enable the use of Show instances
printTerm cms@(Session ref) = customPrintTerm customPrint
where
customPrint = \p-> customPrintShowable : customPrintTermBase p
customPrintShowable t@Term{ty=ty, dc=dc, val=val} = do
let hasType = isEmptyVarSet (tyVarsOfType ty) -- redundant
isEvaled = isFullyEvaluatedTerm t
if isEvaled -- && hasType
then do
hsc_env <- readIORef ref
dflags <- GHC.getSessionDynFlags cms
do
(new_env, bname) <- bindToFreshName hsc_env ty "showme"
writeIORef ref (new_env)
let noop_log _ _ _ _ = return ()
expr = "show " ++ showSDoc (ppr bname)
GHC.setSessionDynFlags cms dflags{log_action=noop_log}
mb_txt <- withExtendedLinkEnv [(bname, val)]
(GHC.compileExpr cms expr)
case mb_txt of
Just txt -> return . Just . text . unsafeCoerce# $ txt
Nothing -> return Nothing
`finally` do
writeIORef ref hsc_env
GHC.setSessionDynFlags cms dflags
else return Nothing
bindToFreshName hsc_env ty userName = do
name <- newGrimName cms userName
let ictxt = hsc_IC hsc_env
rn_env = ic_rn_local_env ictxt
type_env = ic_type_env ictxt
id = mkGlobalId VanillaGlobal name ty vanillaIdInfo
new_type_env = extendTypeEnv type_env (AnId id)
new_rn_env = extendLocalRdrEnv rn_env [name]
new_ic = ictxt { ic_rn_local_env = new_rn_env,
ic_type_env = new_type_env }
return (hsc_env {hsc_IC = new_ic }, name)
-- Create new uniques and give them sequentially numbered names
-- newGrimName :: Session -> String -> IO Name
newGrimName cms userName = do
us <- mkSplitUniqSupply 'b'
let unique = uniqFromSupply us
occname = mkOccName varName userName
name = mkInternalName unique occname noSrcLoc
return name
----------------------------------------------------------------------------
-- | Replace all the tyvars in a Term with the opaque type GHC.Base.Unknown
----------------------------------------------------------------------------
instantiateTyVarsToUnknown :: Session -> Type -> IO Type
instantiateTyVarsToUnknown cms ty
-- We have a GADT, so just fix its tyvars
| Just (tycon, args) <- splitTyConApp_maybe ty
, tycon /= funTyCon
, isGADT tycon
= mapM fixTyVars args >>= return . mkTyConApp tycon
-- We have a regular TyCon, so map recursively to its args
| Just (tycon, args) <- splitTyConApp_maybe ty
, tycon /= funTyCon
= do unknownTyVar <- unknownTV
args' <- mapM (instantiateTyVarsToUnknown cms) args
return$ mkTyConApp tycon args'
-- we have a tyvar of kind *
| Just tyvar <- getTyVar_maybe ty
, ([],_) <- splitKindFunTys (tyVarKind tyvar)
= unknownTV
-- we have a higher kind tyvar, so insert an unknown of the appropriate kind
| Just tyvar <- getTyVar_maybe ty
, (args,_) <- splitKindFunTys (tyVarKind tyvar)
= liftM mkTyConTy $ unknownTC !! length args
-- Base case
| otherwise = return ty
where unknownTV = do
Just (ATyCon unknown_tc) <- lookupName cms unknownTyConName
return$ mkTyConTy unknown_tc
unknownTC = [undefined, unknownTC1, unknownTC2, unknownTC3]
unknownTC1 = do
Just (ATyCon unknown_tc) <- lookupName cms unknown1TyConName
return unknown_tc
unknownTC2 = do
Just (ATyCon unknown_tc) <- lookupName cms unknown2TyConName
return unknown_tc
unknownTC3 = do
Just (ATyCon unknown_tc) <- lookupName cms unknown3TyConName
return unknown_tc
-- isGADT ty | pprTrace' "isGADT" (ppr ty <> colon <> ppr(isGadtSyntaxTyCon ty)) False = undefined
isGADT tc | Just dcs <- tyConDataCons_maybe tc = any (not . null . dataConEqSpec) dcs
| otherwise = False
fixTyVars ty
| Just (tycon, args) <- splitTyConApp_maybe ty
= mapM fixTyVars args >>= return . mkTyConApp tycon
-- Fix the tyvar so that the interactive environment doesn't choke on it TODO
| Just tv <- getTyVar_maybe ty = return ty --TODO
| otherwise = return ty
-- | The inverse function. Strip the GHC.Base.Unknowns in the type of the id, they correspond to tyvars. The caller must provide an infinite list of fresh names
stripUnknowns :: [Name] -> Id -> Id
stripUnknowns names id = setIdType id . sigmaType . fst . go names . idType
$ id
where
sigmaType ty = mkForAllTys (varSetElems$ tyVarsOfType (dropForAlls ty)) ty
go tyvarsNames@(v:vv) ty
| Just (ty1,ty2) <- splitFunTy_maybe ty = let
(ty1',vv') = go tyvarsNames ty1
(ty2',vv'')= go vv' ty2
in (mkFunTy ty1' ty2', vv'')
| Just (ty1,ty2) <- splitAppTy_maybe ty = let
(ty1',vv') = go tyvarsNames ty1
(ty2',vv'')= go vv' ty2
in (mkAppTy ty1' ty2', vv'')
| Just (tycon, args) <- splitTyConApp_maybe ty
, Just (tycon', vv') <- (fixTycon tycon tyvarsNames)
, (args',vv'') <- foldr (\arg (aa,vv) -> let (arg',vv') = go vv' arg
in (arg':aa,vv'))
([],vv') args
= (mkAppTys tycon' args',vv'')
| Just (tycon, args) <- splitTyConApp_maybe ty
, (args',vv') <- foldr (\arg (aa,vv) -> let (arg',vv') = go vv' arg
in (arg':aa,vv'))
([],tyvarsNames) args
= (mkTyConApp tycon args',vv')
| otherwise = (ty, tyvarsNames)
where fixTycon tycon (v:vv) = do
k <- lookup (tyConName tycon) kinds
return (mkTyVarTy$ mkTyVar v k, vv)
kinds = [ (unknownTyConName, liftedTypeKind)
, (unknown1TyConName, kind1)
, (unknown2TyConName, kind2)
, (unknown3TyConName, kind3)]
kind1 = mkArrowKind liftedTypeKind liftedTypeKind
kind2 = mkArrowKind kind1 liftedTypeKind
kind3 = mkArrowKind kind2 liftedTypeKind
stripUnknowns _ id = id
----------------------------- -----------------------------
-- | The :breakpoint command -- | The :breakpoint command
----------------------------- -----------------------------
......
...@@ -132,6 +132,9 @@ builtin_commands = [ ...@@ -132,6 +132,9 @@ builtin_commands = [
("ctags", keepGoing createCTagsFileCmd, False, completeFilename), ("ctags", keepGoing createCTagsFileCmd, False, completeFilename),
("type", keepGoing typeOfExpr, False, completeIdentifier), ("type", keepGoing typeOfExpr, False, completeIdentifier),
#if defined(GHCI) #if defined(GHCI)
("print", keepGoing (pprintClosureCommand True False), False, completeIdentifier),
("sprint", keepGoing (pprintClosureCommand False False),False, completeIdentifier),
("force", keepGoing (pprintClosureCommand False True), False, completeIdentifier),
("breakpoint",keepGoing bkptOptions, False, completeBkpt), ("breakpoint",keepGoing bkptOptions, False, completeBkpt),
#endif #endif
("kind", keepGoing kindOfType, False, completeIdentifier), ("kind", keepGoing kindOfType, False, completeIdentifier),
...@@ -170,6 +173,8 @@ helpText = ...@@ -170,6 +173,8 @@ helpText =
" :edit edit last module\n" ++ " :edit edit last module\n" ++
" :help, :? display this list of commands\n" ++ " :help, :? display this list of commands\n" ++
" :info [<name> ...] display information about the given names\n" ++ " :info [<name> ...] display information about the given names\n" ++
" :print [<name> ...] prints a value without forcing its computation\n" ++
" :sprint [<name> ...] prints a value without forcing its computation(simpler)\n" ++
" :load <filename> ... load module(s) and their dependents\n" ++ " :load <filename> ... load module(s) and their dependents\n" ++
" :module [+/-] [*]<mod> ... set the context for expression evaluation\n" ++ " :module [+/-] [*]<mod> ... set the context for expression evaluation\n" ++
" :main [<arguments> ...] run the main function with the given arguments\n" ++ " :main [<arguments> ...] run the main function with the given arguments\n" ++
......
...@@ -186,7 +186,8 @@ basicKnownKeyNames ...@@ -186,7 +186,8 @@ basicKnownKeyNames
otherwiseIdName, otherwiseIdName,
plusIntegerName, timesIntegerName, plusIntegerName, timesIntegerName,
eqStringName, assertName, breakpointName, breakpointCondName, eqStringName, assertName, breakpointName, breakpointCondName,
breakpointAutoName, opaqueTyConName, breakpointAutoName, opaqueTyConName, unknownTyConName,
unknown1TyConName, unknown2TyConName, unknown3TyConName,
assertErrorName, runSTRepName, assertErrorName, runSTRepName,
printName, fstName, sndName, printName, fstName, sndName,
...@@ -492,6 +493,10 @@ assertName = varQual gHC_BASE FSLIT("assert") assertIdKey ...@@ -492,6 +493,10 @@ assertName = varQual gHC_BASE FSLIT("assert") assertIdKey
breakpointName = varQual gHC_BASE FSLIT("breakpoint") breakpointIdKey breakpointName = varQual gHC_BASE FSLIT("breakpoint") breakpointIdKey
breakpointCondName= varQual gHC_BASE FSLIT("breakpointCond") breakpointCondIdKey breakpointCondName= varQual gHC_BASE FSLIT("breakpointCond") breakpointCondIdKey
breakpointAutoName= varQual gHC_BASE FSLIT("breakpointAuto") breakpointAutoIdKey breakpointAutoName= varQual gHC_BASE FSLIT("breakpointAuto") breakpointAutoIdKey
unknownTyConName = tcQual gHC_BASE FSLIT("Unknown") unknownTyConKey
unknown1TyConName = tcQual gHC_BASE FSLIT("Unknown1") unknown1TyConKey
unknown2TyConName = tcQual gHC_BASE FSLIT("Unknown2") unknown2TyConKey
unknown3TyConName = tcQual gHC_BASE FSLIT("Unknown3") unknown3TyConKey
opaqueTyConName = tcQual gHC_BASE FSLIT("Opaque") opaqueTyConKey opaqueTyConName = tcQual gHC_BASE FSLIT("Opaque") opaqueTyConKey
breakpointJumpName breakpointJumpName
...@@ -828,6 +833,11 @@ rightCoercionTyConKey = mkPreludeTyConUnique 96 ...@@ -828,6 +833,11 @@ rightCoercionTyConKey = mkPreludeTyConUnique 96
instCoercionTyConKey = mkPreludeTyConUnique 97 instCoercionTyConKey = mkPreludeTyConUnique 97
unsafeCoercionTyConKey = mkPreludeTyConUnique 98 unsafeCoercionTyConKey = mkPreludeTyConUnique 98
unknownTyConKey = mkPreludeTyConUnique 99
unknown1TyConKey = mkPreludeTyConUnique 100
unknown2TyConKey = mkPreludeTyConUnique 101
unknown3TyConKey = mkPreludeTyConUnique 102
opaqueTyConKey = mkPreludeTyConUnique 103 opaqueTyConKey = mkPreludeTyConUnique 103
---------------- Template Haskell ------------------- ---------------- Template Haskell -------------------
......
...@@ -48,7 +48,7 @@ module Type ( ...@@ -48,7 +48,7 @@ module Type (
splitTyConApp_maybe, splitTyConApp, splitTyConApp_maybe, splitTyConApp,
splitNewTyConApp_maybe, splitNewTyConApp, splitNewTyConApp_maybe, splitNewTyConApp,
repType, typePrimRep, coreView, tcView, kindView, repType, repType', typePrimRep, coreView, tcView, kindView,
mkForAllTy, mkForAllTys, splitForAllTy_maybe, splitForAllTys, mkForAllTy, mkForAllTys, splitForAllTy_maybe, splitForAllTys,
applyTy, applyTys, isForAllTy, dropForAlls, applyTy, applyTys, isForAllTy, dropForAlls,
...@@ -457,6 +457,16 @@ repType (TyConApp tc tys) ...@@ -457,6 +457,16 @@ repType (TyConApp tc tys)
repType (new_type_rep tc tys) repType (new_type_rep tc tys)
repType ty = ty repType ty = ty
-- repType' aims to be a more thorough version of repType
-- For now it simply looks through the TyConApp args too
repType' ty -- | pprTrace "repType'" (ppr ty $$ ppr (go1 ty)) False = undefined
| otherwise = go1 ty
where
go1 = go . repType
go (TyConApp tc tys) = mkTyConApp tc (map repType' tys)
go ty = ty
-- new_type_rep doesn't ask any questions: -- new_type_rep doesn't ask any questions:
-- it just expands newtype, whether recursive or not -- it just expands newtype, whether recursive or not
new_type_rep new_tycon tys = ASSERT( tys `lengthIs` tyConArity new_tycon ) new_type_rep new_tycon tys = ASSERT( tys `lengthIs` tyConArity new_tycon )
......
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