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
|
-----------------------------------------------------------------------------
--
-- 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 HscTypes
import IdInfo
--import Id
import Name
import Var hiding ( varName )
import VarSet
import Name
import UniqSupply
import TcType
import GHC
import DynFlags
import InteractiveEval
import Outputable
import SrcLoc
import PprTyThing
import Exception
import Control.Monad
import Data.List
import Data.Maybe
import Data.IORef
import System.IO
import GHC.Exts
-------------------------------------
-- | The :print & friends commands
-------------------------------------
pprintClosureCommand :: Session -> Bool -> Bool -> String -> IO ()
pprintClosureCommand session bindThings force str = do
tythings <- (catMaybes . concat) `liftM`
mapM (\w -> GHC.parseName session w >>=
mapM (GHC.lookupName session))
(words str)
let ids = [id | AnId id <- tythings]
-- Obtain the terms and the recovered type information
(terms, substs) <- unzip `liftM` mapM (go session) ids
-- Apply the substitutions obtained after recovering the types
modifySession session $ \hsc_env ->
hsc_env{hsc_IC = foldr (flip substInteractiveContext)
(hsc_IC hsc_env)
(map skolemiseSubst substs)}
-- Finally, print the Terms
unqual <- GHC.getPrintUnqual session
docterms <- mapM (showTerm session) terms
(printForUser stdout unqual . vcat)
(zipWith (\id docterm -> ppr id <+> char '=' <+> docterm)
ids
docterms)
where
-- Do the obtainTerm--bindSuspensions-computeSubstitution dance
go :: Session -> Id -> IO (Term, TvSubst)
go cms id = do
term_ <- GHC.obtainTerm cms force id
term <- tidyTermTyVars cms term_
term' <- if bindThings &&
False == isUnliftedTypeKind (termType term)
then bindSuspensions cms 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
mb_subst <- withSession cms $ \hsc_env ->
improveRTTIType hsc_env (idType id) (reconstructed_type)
return (term', fromMaybe emptyTvSubst mb_subst)
tidyTermTyVars :: Session -> Term -> IO Term
tidyTermTyVars (Session ref) t = do
hsc_env <- readIORef ref
let env_tvs = ic_tyvars (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 :: Session -> Term -> IO Term
bindSuspensions cms@(Session ref) t = do
hsc_env <- readIORef ref
inScope <- GHC.getBindings cms
let ictxt = hsc_IC hsc_env
prefix = "_t"
alreadyUsedNames = map (occNameString . nameOccName . getName) inScope
availNames = map ((prefix++) . show) [(1::Int)..] \\ alreadyUsedNames
availNames_var <- newIORef availNames
(t', stuff) <- foldTerm (nameSuspensionsAndGetInfos availNames_var) t
let (names, tys, hvals) = unzip3 stuff
let tys' = map (fst.skolemiseTy) tys
let ids = [ mkGlobalId VanillaGlobal name ty vanillaIdInfo
| (name,ty) <- zip names tys']
new_tyvars = tyVarsOfTypes tys'
new_ic = extendInteractiveContext ictxt ids new_tyvars
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,[])
, 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 :: Session -> Term -> IO SDoc
showTerm cms@(Session ref) term = do
dflags <- GHC.getSessionDynFlags cms
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 <- 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)
let myprec = 10 -- application precedence. TODO Infix constructors
case mb_txt of
Just txt_ | txt <- unsafeCoerce# txt_, not (null txt)
-> return $ Just$ cparen (prec >= myprec &&
needsParens txt)
(text txt)
_ -> return Nothing
`finally` do
writeIORef ref hsc_env
GHC.setSessionDynFlags cms 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 ictxt = hsc_IC hsc_env
tmp_ids = ic_tmp_ids ictxt
id = mkGlobalId VanillaGlobal name (sigmaType ty) vanillaIdInfo
new_ic = ictxt { ic_tmp_ids = id : tmp_ids }
return (hsc_env {hsc_IC = new_ic }, name)
-- Create new uniques and give them sequentially numbered names
newGrimName :: String -> IO Name
newGrimName userName = do
us <- mkSplitUniqSupply 'b'
let unique = uniqFromSupply us
occname = mkOccName varName userName
name = mkInternalName unique occname noSrcSpan
return name
pprTypeAndContents :: Session -> [Id] -> IO SDoc
pprTypeAndContents session ids = do
dflags <- GHC.getSessionDynFlags session
let pefas = dopt Opt_PrintExplicitForalls dflags
pcontents = dopt Opt_PrintBindContents dflags
if pcontents
then do
let depthBound = 100
terms <- mapM (GHC.obtainTermB session depthBound False) ids
docs_terms <- mapM (showTerm session) terms
return $ vcat $ zipWith (\ty cts -> ty <+> equals <+> cts)
(map (pprTyThing pefas . AnId) ids)
docs_terms
else return $ vcat $ map (pprTyThing pefas . AnId) ids
|
