never executed always true always false
1 -----------------------------------------------------------------------------
2 --
3 -- GHCi Interactive debugging commands
4 --
5 -- Pepe Iborra (supported by Google SoC) 2006
6 --
7 -- ToDo: lots of violation of layering here. This module should
8 -- decide whether it is above the GHC API (import GHC and nothing
9 -- else) or below it.
10 --
11 -----------------------------------------------------------------------------
12
13 module GHC.Runtime.Debugger (pprintClosureCommand, showTerm, pprTypeAndContents) where
14
15 import GHC.Prelude
16
17 import GHC
18
19 import GHC.Driver.Session
20 import GHC.Driver.Ppr
21 import GHC.Driver.Monad
22 import GHC.Driver.Env
23
24 import GHC.Linker.Loader
25
26 import GHC.Runtime.Heap.Inspect
27 import GHC.Runtime.Interpreter
28 import GHC.Runtime.Context
29
30 import GHC.Iface.Syntax ( showToHeader )
31 import GHC.Iface.Env ( newInteractiveBinder )
32 import GHC.Core.Type
33
34 import GHC.Utils.Outputable
35 import GHC.Utils.Error
36 import GHC.Utils.Monad
37 import GHC.Utils.Exception
38 import GHC.Utils.Logger
39
40 import GHC.Types.Id
41 import GHC.Types.Id.Make (ghcPrimIds)
42 import GHC.Types.Name
43 import GHC.Types.Var hiding ( varName )
44 import GHC.Types.Var.Set
45 import GHC.Types.Unique.Set
46 import GHC.Types.TyThing.Ppr
47 import GHC.Types.TyThing
48
49 import Control.Monad
50 import Control.Monad.Catch as MC
51 import Data.List ( (\\), partition )
52 import Data.Maybe
53 import Data.IORef
54
55 -------------------------------------
56 -- | The :print & friends commands
57 -------------------------------------
58 pprintClosureCommand :: GhcMonad m => Bool -> Bool -> String -> m ()
59 pprintClosureCommand bindThings force str = do
60 tythings <- (catMaybes . concat) `liftM`
61 mapM (\w -> GHC.parseName w >>=
62 mapM GHC.lookupName)
63 (words str)
64
65 -- Sort out good and bad tythings for :print and friends
66 let (pprintables, unpprintables) = partition can_pprint tythings
67
68 -- Obtain the terms and the recovered type information
69 let ids = [id | AnId id <- pprintables]
70 (subst, terms) <- mapAccumLM go emptyTCvSubst ids
71
72 -- Apply the substitutions obtained after recovering the types
73 modifySession $ \hsc_env ->
74 hsc_env{hsc_IC = substInteractiveContext (hsc_IC hsc_env) subst}
75
76 -- Finally, print the Results
77 docterms <- mapM showTerm terms
78 let sdocTerms = zipWith (\id docterm -> ppr id <+> char '=' <+> docterm)
79 ids
80 docterms
81 printSDocs $ (no_pprint <$> unpprintables) ++ sdocTerms
82 where
83 -- Check whether a TyThing can be processed by :print and friends.
84 -- Take only Ids, exclude pseudoops, they don't have any HValues.
85 can_pprint :: TyThing -> Bool -- #19394
86 can_pprint (AnId x)
87 | x `notElem` ghcPrimIds = True
88 | otherwise = False
89 can_pprint _ = False
90
91 -- Create a short message for a TyThing, that cannot processed by :print
92 no_pprint :: TyThing -> SDoc
93 no_pprint tything = ppr tything <+>
94 text "is not eligible for the :print, :sprint or :force commands."
95
96 -- Helper to print out the results of :print and friends
97 printSDocs :: GhcMonad m => [SDoc] -> m ()
98 printSDocs sdocs = do
99 logger <- getLogger
100 unqual <- GHC.getPrintUnqual
101 liftIO $ printOutputForUser logger unqual $ vcat sdocs
102
103 -- Do the obtainTerm--bindSuspensions-computeSubstitution dance
104 go :: GhcMonad m => TCvSubst -> Id -> m (TCvSubst, Term)
105 go subst id = do
106 let id' = updateIdTypeAndMult (substTy subst) id
107 id_ty' = idType id'
108 term_ <- GHC.obtainTermFromId maxBound force id'
109 term <- tidyTermTyVars term_
110 term' <- if bindThings
111 then bindSuspensions term
112 else return term
113 -- Before leaving, we compare the type obtained to see if it's more specific
114 -- Then, we extract a substitution,
115 -- mapping the old tyvars to the reconstructed types.
116 let reconstructed_type = termType term
117 hsc_env <- getSession
118 case (improveRTTIType hsc_env id_ty' reconstructed_type) of
119 Nothing -> return (subst, term')
120 Just subst' -> do { logger <- getLogger
121 ; liftIO $
122 putDumpFileMaybe logger Opt_D_dump_rtti "RTTI"
123 FormatText
124 (fsep $ [text "RTTI Improvement for", ppr id,
125 text "old substitution:" , ppr subst,
126 text "new substitution:" , ppr subst'])
127 ; return (subst `unionTCvSubst` subst', term')}
128
129 tidyTermTyVars :: GhcMonad m => Term -> m Term
130 tidyTermTyVars t =
131 withSession $ \hsc_env -> do
132 let env_tvs = tyThingsTyCoVars $ ic_tythings $ hsc_IC hsc_env
133 my_tvs = termTyCoVars t
134 tvs = env_tvs `minusVarSet` my_tvs
135 tyvarOccName = nameOccName . tyVarName
136 tidyEnv = (initTidyOccEnv (map tyvarOccName (nonDetEltsUniqSet tvs))
137 -- It's OK to use nonDetEltsUniqSet here because initTidyOccEnv
138 -- forgets the ordering immediately by creating an env
139 , getUniqSet $ env_tvs `intersectVarSet` my_tvs)
140 return $ mapTermType (snd . tidyOpenType tidyEnv) t
141
142 -- | Give names, and bind in the interactive environment, to all the suspensions
143 -- included (inductively) in a term
144 bindSuspensions :: GhcMonad m => Term -> m Term
145 bindSuspensions t = do
146 hsc_env <- getSession
147 inScope <- GHC.getBindings
148 let ictxt = hsc_IC hsc_env
149 prefix = "_t"
150 alreadyUsedNames = map (occNameString . nameOccName . getName) inScope
151 availNames = map ((prefix++) . show) [(1::Int)..] \\ alreadyUsedNames
152 availNames_var <- liftIO $ newIORef availNames
153 (t', stuff) <- liftIO $ foldTerm (nameSuspensionsAndGetInfos hsc_env availNames_var) t
154 let (names, tys, fhvs) = unzip3 stuff
155 let ids = [ mkVanillaGlobal name ty
156 | (name,ty) <- zip names tys]
157 new_ic = extendInteractiveContextWithIds ictxt ids
158 interp = hscInterp hsc_env
159 liftIO $ extendLoadedEnv interp (zip names fhvs)
160 setSession hsc_env {hsc_IC = new_ic }
161 return t'
162 where
163
164 -- Processing suspensions. Give names and recopilate info
165 nameSuspensionsAndGetInfos :: HscEnv -> IORef [String]
166 -> TermFold (IO (Term, [(Name,Type,ForeignHValue)]))
167 nameSuspensionsAndGetInfos hsc_env freeNames = TermFold
168 {
169 fSuspension = doSuspension hsc_env freeNames
170 , fTerm = \ty dc v tt -> do
171 tt' <- sequence tt
172 let (terms,names) = unzip tt'
173 return (Term ty dc v terms, concat names)
174 , fPrim = \ty n ->return (Prim ty n,[])
175 , fNewtypeWrap =
176 \ty dc t -> do
177 (term, names) <- t
178 return (NewtypeWrap ty dc term, names)
179 , fRefWrap = \ty t -> do
180 (term, names) <- t
181 return (RefWrap ty term, names)
182 }
183 doSuspension hsc_env freeNames ct ty hval _name = do
184 name <- atomicModifyIORef' freeNames (\x->(tail x, head x))
185 n <- newGrimName hsc_env name
186 return (Suspension ct ty hval (Just n), [(n,ty,hval)])
187
188
189 -- A custom Term printer to enable the use of Show instances
190 showTerm :: GhcMonad m => Term -> m SDoc
191 showTerm term = do
192 dflags <- GHC.getSessionDynFlags
193 if gopt Opt_PrintEvldWithShow dflags
194 then cPprTerm (liftM2 (++) (\_y->[cPprShowable]) cPprTermBase) term
195 else cPprTerm cPprTermBase term
196 where
197 cPprShowable prec t@Term{ty=ty, val=fhv} =
198 if not (isFullyEvaluatedTerm t)
199 then return Nothing
200 else do
201 let set_session = do
202 hsc_env <- getSession
203 (new_env, bname) <- bindToFreshName hsc_env ty "showme"
204 setSession new_env
205
206 -- this disables logging of errors
207 let noop_log _ _ _ _ = return ()
208 pushLogHookM (const noop_log)
209
210 return (hsc_env, bname)
211
212 reset_session (old_env,_) = setSession old_env
213
214 MC.bracket set_session reset_session $ \(_,bname) -> do
215 hsc_env <- getSession
216 dflags <- GHC.getSessionDynFlags
217 let expr = "Prelude.return (Prelude.show " ++
218 showPpr dflags bname ++
219 ") :: Prelude.IO Prelude.String"
220 interp = hscInterp hsc_env
221 txt_ <- withExtendedLoadedEnv interp
222 [(bname, fhv)]
223 (GHC.compileExprRemote expr)
224 let myprec = 10 -- application precedence. TODO Infix constructors
225 txt <- liftIO $ evalString interp txt_
226 if not (null txt) then
227 return $ Just $ cparen (prec >= myprec && needsParens txt)
228 (text txt)
229 else return Nothing
230
231 cPprShowable prec NewtypeWrap{ty=new_ty,wrapped_term=t} =
232 cPprShowable prec t{ty=new_ty}
233 cPprShowable _ _ = return Nothing
234
235 needsParens ('"':_) = False -- some simple heuristics to see whether parens
236 -- are redundant in an arbitrary Show output
237 needsParens ('(':_) = False
238 needsParens txt = ' ' `elem` txt
239
240
241 bindToFreshName hsc_env ty userName = do
242 name <- newGrimName hsc_env userName
243 let id = mkVanillaGlobal name ty
244 new_ic = extendInteractiveContextWithIds (hsc_IC hsc_env) [id]
245 return (hsc_env {hsc_IC = new_ic }, name)
246
247 -- Create new uniques and give them sequentially numbered names
248 newGrimName :: MonadIO m => HscEnv -> String -> m Name
249 newGrimName hsc_env userName
250 = liftIO (newInteractiveBinder hsc_env occ noSrcSpan)
251 where
252 occ = mkOccName varName userName
253
254 pprTypeAndContents :: GhcMonad m => Id -> m SDoc
255 pprTypeAndContents id = do
256 dflags <- GHC.getSessionDynFlags
257 let pcontents = gopt Opt_PrintBindContents dflags
258 pprdId = (pprTyThing showToHeader . AnId) id
259 if pcontents
260 then do
261 let depthBound = 100
262 -- If the value is an exception, make sure we catch it and
263 -- show the exception, rather than propagating the exception out.
264 e_term <- MC.try $ GHC.obtainTermFromId depthBound False id
265 docs_term <- case e_term of
266 Right term -> showTerm term
267 Left exn -> return (text "*** Exception:" <+>
268 text (show (exn :: SomeException)))
269 return $ pprdId <+> equals <+> docs_term
270 else return pprdId