Avoid linear lookup in unload_wkr in the Linker
[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 Linker
18 import RtClosureInspect
19
20 import GHCi
21 import GHCi.RemoteTypes
22 import GhcMonad
23 import HscTypes
24 import Id
25 import IfaceSyn ( showToHeader )
26 import IfaceEnv( newInteractiveBinder )
27 import Name
28 import Var hiding ( varName )
29 import VarSet
30 import UniqSet
31 import Type
32 import GHC
33 import Outputable
34 import PprTyThing
35 import ErrUtils
36 import MonadUtils
37 import DynFlags
38 import Exception
39
40 import Control.Monad
41 import Data.List
42 import Data.Maybe
43 import Data.IORef
44
45 import GHC.Exts
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 { traceOptIf Opt_D_dump_rtti
92 (fsep $ [text "RTTI Improvement for", ppr id,
93 text "is the substitution:" , ppr subst'])
94 ; return (subst `unionTCvSubst` subst', term')}
95
96 tidyTermTyVars :: GhcMonad m => Term -> m Term
97 tidyTermTyVars t =
98 withSession $ \hsc_env -> do
99 let env_tvs = tyThingsTyCoVars $ ic_tythings $ hsc_IC hsc_env
100 my_tvs = termTyCoVars t
101 tvs = env_tvs `minusVarSet` my_tvs
102 tyvarOccName = nameOccName . tyVarName
103 tidyEnv = (initTidyOccEnv (map tyvarOccName (nonDetEltsUniqSet tvs))
104 -- It's OK to use nonDetEltsUniqSet here because initTidyOccEnv
105 -- forgets the ordering immediately by creating an env
106 , getUniqSet $ env_tvs `intersectVarSet` my_tvs)
107 return $ mapTermType (snd . tidyOpenType tidyEnv) t
108
109 -- | Give names, and bind in the interactive environment, to all the suspensions
110 -- included (inductively) in a term
111 bindSuspensions :: GhcMonad m => Term -> m Term
112 bindSuspensions t = do
113 hsc_env <- getSession
114 inScope <- GHC.getBindings
115 let ictxt = hsc_IC hsc_env
116 prefix = "_t"
117 alreadyUsedNames = map (occNameString . nameOccName . getName) inScope
118 availNames = map ((prefix++) . show) [(1::Int)..] \\ alreadyUsedNames
119 availNames_var <- liftIO $ newIORef availNames
120 (t', stuff) <- liftIO $ foldTerm (nameSuspensionsAndGetInfos hsc_env availNames_var) t
121 let (names, tys, hvals) = unzip3 stuff
122 let ids = [ mkVanillaGlobal name ty
123 | (name,ty) <- zip names tys]
124 new_ic = extendInteractiveContextWithIds ictxt ids
125 fhvs <- liftIO $ mapM (mkFinalizedHValue hsc_env <=< mkRemoteRef) hvals
126 liftIO $ extendLinkEnv (zip names fhvs)
127 setSession hsc_env {hsc_IC = new_ic }
128 return t'
129 where
130
131 -- Processing suspensions. Give names and recopilate info
132 nameSuspensionsAndGetInfos :: HscEnv -> IORef [String]
133 -> TermFold (IO (Term, [(Name,Type,HValue)]))
134 nameSuspensionsAndGetInfos hsc_env freeNames = TermFold
135 {
136 fSuspension = doSuspension hsc_env freeNames
137 , fTerm = \ty dc v tt -> do
138 tt' <- sequence tt
139 let (terms,names) = unzip tt'
140 return (Term ty dc v terms, concat names)
141 , fPrim = \ty n ->return (Prim ty n,[])
142 , fNewtypeWrap =
143 \ty dc t -> do
144 (term, names) <- t
145 return (NewtypeWrap ty dc term, names)
146 , fRefWrap = \ty t -> do
147 (term, names) <- t
148 return (RefWrap ty term, names)
149 }
150 doSuspension hsc_env freeNames ct ty hval _name = do
151 name <- atomicModifyIORef' freeNames (\x->(tail x, head x))
152 n <- newGrimName hsc_env name
153 return (Suspension ct ty hval (Just n), [(n,ty,hval)])
154
155
156 -- A custom Term printer to enable the use of Show instances
157 showTerm :: GhcMonad m => Term -> m SDoc
158 showTerm term = do
159 dflags <- GHC.getSessionDynFlags
160 if gopt Opt_PrintEvldWithShow dflags
161 then cPprTerm (liftM2 (++) (\_y->[cPprShowable]) cPprTermBase) term
162 else cPprTerm cPprTermBase term
163 where
164 cPprShowable prec t@Term{ty=ty, val=val} =
165 if not (isFullyEvaluatedTerm t)
166 then return Nothing
167 else do
168 hsc_env <- getSession
169 dflags <- GHC.getSessionDynFlags
170 do
171 (new_env, bname) <- bindToFreshName hsc_env ty "showme"
172 setSession new_env
173 -- XXX: this tries to disable logging of errors
174 -- does this still do what it is intended to do
175 -- with the changed error handling and logging?
176 let noop_log _ _ _ _ _ _ = return ()
177 expr = "show " ++ showPpr dflags bname
178 _ <- GHC.setSessionDynFlags dflags{log_action=noop_log}
179 fhv <- liftIO $ mkFinalizedHValue hsc_env =<< mkRemoteRef val
180 txt_ <- withExtendedLinkEnv [(bname, fhv)]
181 (GHC.compileExpr expr)
182 let myprec = 10 -- application precedence. TODO Infix constructors
183 let txt = unsafeCoerce# txt_ :: [a]
184 if not (null txt) then
185 return $ Just $ cparen (prec >= myprec && needsParens txt)
186 (text txt)
187 else return Nothing
188 `gfinally` do
189 setSession hsc_env
190 GHC.setSessionDynFlags dflags
191 cPprShowable prec NewtypeWrap{ty=new_ty,wrapped_term=t} =
192 cPprShowable prec t{ty=new_ty}
193 cPprShowable _ _ = return Nothing
194
195 needsParens ('"':_) = False -- some simple heuristics to see whether parens
196 -- are redundant in an arbitrary Show output
197 needsParens ('(':_) = False
198 needsParens txt = ' ' `elem` txt
199
200
201 bindToFreshName hsc_env ty userName = do
202 name <- newGrimName hsc_env userName
203 let id = mkVanillaGlobal name ty
204 new_ic = extendInteractiveContextWithIds (hsc_IC hsc_env) [id]
205 return (hsc_env {hsc_IC = new_ic }, name)
206
207 -- Create new uniques and give them sequentially numbered names
208 newGrimName :: MonadIO m => HscEnv -> String -> m Name
209 newGrimName hsc_env userName
210 = liftIO (newInteractiveBinder hsc_env occ noSrcSpan)
211 where
212 occ = mkOccName varName userName
213
214 pprTypeAndContents :: GhcMonad m => Id -> m SDoc
215 pprTypeAndContents id = do
216 dflags <- GHC.getSessionDynFlags
217 let pcontents = gopt Opt_PrintBindContents dflags
218 pprdId = (pprTyThing showToHeader . AnId) id
219 if pcontents
220 then do
221 let depthBound = 100
222 -- If the value is an exception, make sure we catch it and
223 -- show the exception, rather than propagating the exception out.
224 e_term <- gtry $ GHC.obtainTermFromId depthBound False id
225 docs_term <- case e_term of
226 Right term -> showTerm term
227 Left exn -> return (text "*** Exception:" <+>
228 text (show (exn :: SomeException)))
229 return $ pprdId <+> equals <+> docs_term
230 else return pprdId
231
232 --------------------------------------------------------------
233 -- Utils
234
235 traceOptIf :: GhcMonad m => DumpFlag -> SDoc -> m ()
236 traceOptIf flag doc = do
237 dflags <- GHC.getSessionDynFlags
238 when (dopt flag dflags) $ liftIO $ printInfoForUser dflags alwaysQualify doc