1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
|
-----------------------------------------------------------------------------
--
-- GHCi Interactive debugging commands
--
-- Pepe Iborra (supported by Google SoC) 2006
--
-- ToDo: lots of violation of layering here. This module should
-- decide whether it is above the GHC API (import GHC and nothing
-- else) or below it.
--
-----------------------------------------------------------------------------
module Debugger (pprintClosureCommand, showTerm, pprTypeAndContents) where
import Linker
import RtClosureInspect
import GhcMonad
import HscTypes
import Id
import Name
import Var hiding ( varName )
import VarSet
import UniqSupply
import TcType
import GHC
import Outputable
import PprTyThing
import MonadUtils
import Control.Monad
import Data.List
import Data.Maybe
import Data.IORef
import System.IO
import GHC.Exts
-------------------------------------
-- | The :print & friends commands
-------------------------------------
pprintClosureCommand :: GhcMonad m => Bool -> Bool -> String -> m ()
pprintClosureCommand bindThings force str = do
tythings <- (catMaybes . concat) `liftM`
mapM (\w -> GHC.parseName w >>=
mapM GHC.lookupName)
(words str)
let ids = [id | AnId id <- tythings]
-- Obtain the terms and the recovered type information
(subst, terms) <- mapAccumLM go emptyTvSubst ids
-- Apply the substitutions obtained after recovering the types
modifySession $ \hsc_env ->
hsc_env{hsc_IC = substInteractiveContext (hsc_IC hsc_env) subst}
-- Finally, print the Terms
unqual <- GHC.getPrintUnqual
docterms <- mapM showTerm terms
liftIO $ (printForUser stdout unqual . vcat)
(zipWith (\id docterm -> ppr id <+> char '=' <+> docterm)
ids
docterms)
where
-- Do the obtainTerm--bindSuspensions-computeSubstitution dance
go :: GhcMonad m => TvSubst -> Id -> m (TvSubst, Term)
go subst id = do
let id' = id `setIdType` substTy subst (idType id)
term_ <- GHC.obtainTermFromId maxBound force id'
term <- tidyTermTyVars term_
term' <- if bindThings &&
False == isUnliftedTypeKind (termType term)
then bindSuspensions term
else return term
-- Before leaving, we compare the type obtained to see if it's more specific
-- Then, we extract a substitution,
-- mapping the old tyvars to the reconstructed types.
let reconstructed_type = termType term
hsc_env <- getSession
case (improveRTTIType hsc_env (idType id) (reconstructed_type)) of
Nothing -> return (subst, term')
Just subst' -> do { traceOptIf Opt_D_dump_rtti
(fsep $ [text "RTTI Improvement for", ppr id,
text "is the substitution:" , ppr subst'])
; return (subst `unionTvSubst` subst', term')}
tidyTermTyVars :: GhcMonad m => Term -> m Term
tidyTermTyVars t =
withSession $ \hsc_env -> do
let env_tvs = tyThingsTyVars $ ic_tythings $ hsc_IC hsc_env
my_tvs = termTyVars t
tvs = env_tvs `minusVarSet` my_tvs
tyvarOccName = nameOccName . tyVarName
tidyEnv = (initTidyOccEnv (map tyvarOccName (varSetElems tvs))
, env_tvs `intersectVarSet` my_tvs)
return$ mapTermType (snd . tidyOpenType tidyEnv) t
-- | Give names, and bind in the interactive environment, to all the suspensions
-- included (inductively) in a term
bindSuspensions :: GhcMonad m => Term -> m Term
bindSuspensions t = do
hsc_env <- getSession
inScope <- GHC.getBindings
let ictxt = hsc_IC hsc_env
prefix = "_t"
alreadyUsedNames = map (occNameString . nameOccName . getName) inScope
availNames = map ((prefix++) . show) [(1::Int)..] \\ alreadyUsedNames
availNames_var <- liftIO $ newIORef availNames
(t', stuff) <- liftIO $ foldTerm (nameSuspensionsAndGetInfos availNames_var) t
let (names, tys, hvals) = unzip3 stuff
let ids = [ mkVanillaGlobal name ty
| (name,ty) <- zip names tys]
new_ic = extendInteractiveContext ictxt (map AnId ids)
liftIO $ extendLinkEnv (zip names hvals)
modifySession $ \_ -> 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,[])
, fNewtypeWrap =
\ty dc t -> do
(term, names) <- t
return (NewtypeWrap ty dc term, names)
, fRefWrap = \ty t -> do
(term, names) <- t
return (RefWrap ty term, names)
}
doSuspension freeNames ct ty hval _name = do
name <- atomicModifyIORef freeNames (\x->(tail x, head x))
n <- newGrimName name
return (Suspension ct ty hval (Just n), [(n,ty,hval)])
-- A custom Term printer to enable the use of Show instances
showTerm :: GhcMonad m => Term -> m SDoc
showTerm term = do
dflags <- GHC.getSessionDynFlags
if dopt Opt_PrintEvldWithShow dflags
then cPprTerm (liftM2 (++) (\_y->[cPprShowable]) cPprTermBase) term
else cPprTerm cPprTermBase term
where
cPprShowable prec t@Term{ty=ty, val=val} =
if not (isFullyEvaluatedTerm t)
then return Nothing
else do
hsc_env <- getSession
dflags <- GHC.getSessionDynFlags
do
(new_env, bname) <- bindToFreshName hsc_env ty "showme"
setSession new_env
-- XXX: this tries to disable logging of errors
-- does this still do what it is intended to do
-- with the changed error handling and logging?
let noop_log _ _ _ _ = return ()
expr = "show " ++ showSDoc (ppr bname)
_ <- GHC.setSessionDynFlags dflags{log_action=noop_log}
txt_ <- withExtendedLinkEnv [(bname, val)]
(GHC.compileExpr expr)
let myprec = 10 -- application precedence. TODO Infix constructors
let txt = unsafeCoerce# txt_
if not (null txt) then
return $ Just $ cparen (prec >= myprec && needsParens txt)
(text txt)
else return Nothing
`gfinally` do
setSession hsc_env
GHC.setSessionDynFlags dflags
cPprShowable prec NewtypeWrap{ty=new_ty,wrapped_term=t} =
cPprShowable prec t{ty=new_ty}
cPprShowable _ _ = return Nothing
needsParens ('"':_) = False -- some simple heuristics to see whether parens
-- are redundant in an arbitrary Show output
needsParens ('(':_) = False
needsParens txt = ' ' `elem` txt
bindToFreshName hsc_env ty userName = do
name <- newGrimName userName
let id = AnId $ mkVanillaGlobal name ty
new_ic = extendInteractiveContext (hsc_IC hsc_env) [id]
return (hsc_env {hsc_IC = new_ic }, name)
-- Create new uniques and give them sequentially numbered names
newGrimName :: MonadIO m => String -> m Name
newGrimName userName = do
us <- liftIO $ mkSplitUniqSupply 'b'
let unique = uniqFromSupply us
occname = mkOccName varName userName
name = mkInternalName unique occname noSrcSpan
return name
pprTypeAndContents :: GhcMonad m => Id -> m SDoc
pprTypeAndContents id = do
dflags <- GHC.getSessionDynFlags
let pefas = dopt Opt_PrintExplicitForalls dflags
pcontents = dopt Opt_PrintBindContents dflags
pprdId = (pprTyThing pefas . AnId) id
if pcontents
then do
let depthBound = 100
term <- GHC.obtainTermFromId depthBound False id
docs_term <- showTerm term
return $ pprdId <+> equals <+> docs_term
else return pprdId
--------------------------------------------------------------
-- Utils
traceOptIf :: GhcMonad m => DynFlag -> SDoc -> m ()
traceOptIf flag doc = do
dflags <- GHC.getSessionDynFlags
when (dopt flag dflags) $ liftIO $ printForUser stderr alwaysQualify doc
|
