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