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
|
-----------------------------------------------------------------------------
--
-- 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) where
import Linker
import RtClosureInspect
import HscTypes
import IdInfo
--import Id
import Name
import Var hiding ( varName )
import VarSet
import VarEnv
import Name
import UniqSupply
import Type
import TcType
import TcGadt
import GHC
import Outputable
import Pretty ( Mode(..), showDocWith )
import FastString
import SrcLoc
import Control.Exception
import Control.Monad
import Data.List
import Data.Maybe
import Data.IORef
import System.IO
import GHC.Exts
#include "HsVersions.h"
-------------------------------------
-- | 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)
substs <- catMaybes `liftM` mapM (go session)
[id | AnId id <- tythings]
mapM (applySubstToEnv session . skolemSubst) substs
return ()
where
-- Do the obtainTerm--bindSuspensions-computeSubstitution dance
go :: Session -> Id -> IO (Maybe TvSubst)
go cms id = do
term_ <- obtainTerm cms force id
term <- tidyTermTyVars cms term_
term' <- if not bindThings then return term
else bindSuspensions cms term
showterm <- printTerm cms term'
unqual <- GHC.getPrintUnqual cms
let showSDocForUserOneLine unqual doc =
showDocWith LeftMode (doc (mkErrStyle unqual))
(putStrLn . showSDocForUserOneLine unqual) (ppr id <+> char '=' <+> showterm)
-- 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 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]
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
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..] \\ alreadyUsedNames
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 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,[])
}
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) = cPprTerm cPpr
where
cPpr = \p-> cPprShowable : cPprTermBase p
cPprShowable prec t@Term{ty=ty, dc=dc, val=val} = do
let hasType = isEmptyVarSet (tyVarsOfType ty) -- redundant
isEvaled = isFullyEvaluatedTerm t
if not isEvaled -- || not hasType
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 = 9 -- TODO Infix constructors
case mb_txt of
Just txt -> return . Just . text . unsafeCoerce#
$ txt
Nothing -> return Nothing
`finally` do
writeIORef ref hsc_env
GHC.setSessionDynFlags cms dflags
bindToFreshName hsc_env ty userName = do
name <- newGrimName cms userName
let ictxt = hsc_IC hsc_env
tmp_ids = ic_tmp_ids ictxt
id = mkGlobalId VanillaGlobal name 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 :: 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
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)
|
