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