Remove the GHCi debugger's panicking isUnliftedType check
[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 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,ForeignHValue)]))
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=fhv} =
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 = "Prelude.return (Prelude.show " ++
178 showPpr dflags bname ++
179 ") :: Prelude.IO Prelude.String"
180 _ <- GHC.setSessionDynFlags dflags{log_action=noop_log}
181 txt_ <- withExtendedLinkEnv [(bname, fhv)]
182 (GHC.compileExprRemote expr)
183 let myprec = 10 -- application precedence. TODO Infix constructors
184 txt <- liftIO $ evalString hsc_env txt_
185 if not (null txt) then
186 return $ Just $ cparen (prec >= myprec && needsParens txt)
187 (text txt)
188 else return Nothing
189 `gfinally` do
190 setSession hsc_env
191 GHC.setSessionDynFlags dflags
192 cPprShowable prec NewtypeWrap{ty=new_ty,wrapped_term=t} =
193 cPprShowable prec t{ty=new_ty}
194 cPprShowable _ _ = return Nothing
195
196 needsParens ('"':_) = False -- some simple heuristics to see whether parens
197 -- are redundant in an arbitrary Show output
198 needsParens ('(':_) = False
199 needsParens txt = ' ' `elem` txt
200
201
202 bindToFreshName hsc_env ty userName = do
203 name <- newGrimName hsc_env userName
204 let id = mkVanillaGlobal name ty
205 new_ic = extendInteractiveContextWithIds (hsc_IC hsc_env) [id]
206 return (hsc_env {hsc_IC = new_ic }, name)
207
208 -- Create new uniques and give them sequentially numbered names
209 newGrimName :: MonadIO m => HscEnv -> String -> m Name
210 newGrimName hsc_env userName
211 = liftIO (newInteractiveBinder hsc_env occ noSrcSpan)
212 where
213 occ = mkOccName varName userName
214
215 pprTypeAndContents :: GhcMonad m => Id -> m SDoc
216 pprTypeAndContents id = do
217 dflags <- GHC.getSessionDynFlags
218 let pcontents = gopt Opt_PrintBindContents dflags
219 pprdId = (pprTyThing showToHeader . AnId) id
220 if pcontents
221 then do
222 let depthBound = 100
223 -- If the value is an exception, make sure we catch it and
224 -- show the exception, rather than propagating the exception out.
225 e_term <- gtry $ GHC.obtainTermFromId depthBound False id
226 docs_term <- case e_term of
227 Right term -> showTerm term
228 Left exn -> return (text "*** Exception:" <+>
229 text (show (exn :: SomeException)))
230 return $ pprdId <+> equals <+> docs_term
231 else return pprdId