testsuite: Mark T4808 as broken in threaded2 way
[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 then bindSuspensions term
82 else return term
83 -- Before leaving, we compare the type obtained to see if it's more specific
84 -- Then, we extract a substitution,
85 -- mapping the old tyvars to the reconstructed types.
86 let reconstructed_type = termType term
87 hsc_env <- getSession
88 case (improveRTTIType hsc_env (idType id) (reconstructed_type)) of
89 Nothing -> return (subst, term')
90 Just subst' -> do { dflags <- GHC.getSessionDynFlags
91 ; liftIO $
92 dumpIfSet_dyn dflags Opt_D_dump_rtti "RTTI"
93 (fsep $ [text "RTTI Improvement for", ppr id,
94 text "is the substitution:" , ppr subst'])
95 ; return (subst `unionTCvSubst` subst', term')}
96
97 tidyTermTyVars :: GhcMonad m => Term -> m Term
98 tidyTermTyVars t =
99 withSession $ \hsc_env -> do
100 let env_tvs = tyThingsTyCoVars $ ic_tythings $ hsc_IC hsc_env
101 my_tvs = termTyCoVars t
102 tvs = env_tvs `minusVarSet` my_tvs
103 tyvarOccName = nameOccName . tyVarName
104 tidyEnv = (initTidyOccEnv (map tyvarOccName (nonDetEltsUniqSet tvs))
105 -- It's OK to use nonDetEltsUniqSet here because initTidyOccEnv
106 -- forgets the ordering immediately by creating an env
107 , getUniqSet $ env_tvs `intersectVarSet` my_tvs)
108 return $ mapTermType (snd . tidyOpenType tidyEnv) t
109
110 -- | Give names, and bind in the interactive environment, to all the suspensions
111 -- included (inductively) in a term
112 bindSuspensions :: GhcMonad m => Term -> m Term
113 bindSuspensions t = do
114 hsc_env <- getSession
115 inScope <- GHC.getBindings
116 let ictxt = hsc_IC hsc_env
117 prefix = "_t"
118 alreadyUsedNames = map (occNameString . nameOccName . getName) inScope
119 availNames = map ((prefix++) . show) [(1::Int)..] \\ alreadyUsedNames
120 availNames_var <- liftIO $ newIORef availNames
121 (t', stuff) <- liftIO $ foldTerm (nameSuspensionsAndGetInfos hsc_env availNames_var) t
122 let (names, tys, fhvs) = unzip3 stuff
123 let ids = [ mkVanillaGlobal name ty
124 | (name,ty) <- zip names tys]
125 new_ic = extendInteractiveContextWithIds ictxt ids
126 dl = hsc_dynLinker hsc_env
127 liftIO $ extendLinkEnv dl (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 dl = hsc_dynLinker hsc_env
182 _ <- GHC.setSessionDynFlags dflags{log_action=noop_log}
183 txt_ <- withExtendedLinkEnv dl
184 [(bname, fhv)]
185 (GHC.compileExprRemote expr)
186 let myprec = 10 -- application precedence. TODO Infix constructors
187 txt <- liftIO $ evalString hsc_env txt_
188 if not (null txt) then
189 return $ Just $ cparen (prec >= myprec && needsParens txt)
190 (text txt)
191 else return Nothing
192 `gfinally` do
193 setSession hsc_env
194 GHC.setSessionDynFlags dflags
195 cPprShowable prec NewtypeWrap{ty=new_ty,wrapped_term=t} =
196 cPprShowable prec t{ty=new_ty}
197 cPprShowable _ _ = return Nothing
198
199 needsParens ('"':_) = False -- some simple heuristics to see whether parens
200 -- are redundant in an arbitrary Show output
201 needsParens ('(':_) = False
202 needsParens txt = ' ' `elem` txt
203
204
205 bindToFreshName hsc_env ty userName = do
206 name <- newGrimName hsc_env userName
207 let id = mkVanillaGlobal name ty
208 new_ic = extendInteractiveContextWithIds (hsc_IC hsc_env) [id]
209 return (hsc_env {hsc_IC = new_ic }, name)
210
211 -- Create new uniques and give them sequentially numbered names
212 newGrimName :: MonadIO m => HscEnv -> String -> m Name
213 newGrimName hsc_env userName
214 = liftIO (newInteractiveBinder hsc_env occ noSrcSpan)
215 where
216 occ = mkOccName varName userName
217
218 pprTypeAndContents :: GhcMonad m => Id -> m SDoc
219 pprTypeAndContents id = do
220 dflags <- GHC.getSessionDynFlags
221 let pcontents = gopt Opt_PrintBindContents dflags
222 pprdId = (pprTyThing showToHeader . AnId) id
223 if pcontents
224 then do
225 let depthBound = 100
226 -- If the value is an exception, make sure we catch it and
227 -- show the exception, rather than propagating the exception out.
228 e_term <- gtry $ GHC.obtainTermFromId depthBound False id
229 docs_term <- case e_term of
230 Right term -> showTerm term
231 Left exn -> return (text "*** Exception:" <+>
232 text (show (exn :: SomeException)))
233 return $ pprdId <+> equals <+> docs_term
234 else return pprdId