Debugger.hs 8.66 KB
Newer Older
mnislaih's avatar
mnislaih committed
1
2
3
4
5
6
-----------------------------------------------------------------------------
--
-- GHCi Interactive debugging commands 
--
-- Pepe Iborra (supported by Google SoC) 2006
--
7
8
9
10
-- ToDo: lots of violation of layering here.  This module should
-- decide whether it is above the GHC API (import GHC and nothing
-- else) or below it.
-- 
mnislaih's avatar
mnislaih committed
11
12
-----------------------------------------------------------------------------

13
module Debugger (pprintClosureCommand, showTerm, pprTypeAndContents) where
mnislaih's avatar
mnislaih committed
14
15
16
17
18
19
20

import Linker
import RtClosureInspect

import HscTypes
import IdInfo
--import Id
21
import Name
mnislaih's avatar
mnislaih committed
22
23
24
25
import Var hiding ( varName )
import VarSet
import Name 
import UniqSupply
26
import TcType
mnislaih's avatar
mnislaih committed
27
import GHC
28
import DynFlags
mnislaih's avatar
mnislaih committed
29
import InteractiveEval
mnislaih's avatar
mnislaih committed
30
31
import Outputable
import SrcLoc
32
import PprTyThing
mnislaih's avatar
mnislaih committed
33
34
35

import Control.Exception
import Control.Monad
mnislaih's avatar
mnislaih committed
36
import Data.List
mnislaih's avatar
mnislaih committed
37
38
39
40
41
42
import Data.Maybe
import Data.IORef

import System.IO
import GHC.Exts

mnislaih's avatar
mnislaih committed
43
44
45
-------------------------------------
-- | The :print & friends commands
-------------------------------------
46
pprintClosureCommand :: Session -> Bool -> Bool -> String -> IO ()
mnislaih's avatar
mnislaih committed
47
pprintClosureCommand session bindThings force str = do
48
  tythings <- (catMaybes . concat) `liftM`
mnislaih's avatar
mnislaih committed
49
                 mapM (\w -> GHC.parseName session w >>=
50
                                mapM (GHC.lookupName session))
51
                      (words str)
52
53
54
55
56
57
58
59
60
  let ids = [id | AnId id <- tythings]

  -- Obtain the terms and the recovered type information
  (terms, substs) <- unzip `liftM` mapM (go session) ids
  
  -- Apply the substitutions obtained after recovering the types
  modifySession session $ \hsc_env ->
         hsc_env{hsc_IC = foldr (flip substInteractiveContext)
                                (hsc_IC hsc_env)
mnislaih's avatar
mnislaih committed
61
                                (map skolemiseSubst substs)}
62
63
64
  -- Finally, print the Terms
  unqual  <- GHC.getPrintUnqual session
  docterms <- mapM (showTerm session) terms
65
  (printForUser stdout unqual . vcat)
66
67
68
69
        (zipWith (\id docterm -> ppr id <+> char '=' <+> docterm)
                 ids
                 docterms)
 where
mnislaih's avatar
mnislaih committed
70

71
   -- Do the obtainTerm--bindSuspensions-computeSubstitution dance
72
73
74
   go :: Session -> Id -> IO (Term, TvSubst)
   go cms id = do
       term_    <- GHC.obtainTerm cms force id
75
       term     <- tidyTermTyVars cms term_
76
77
78
79
       term'    <- if bindThings && 
                      Just False == isUnliftedTypeKind `fmap` termType term
                     then bindSuspensions cms term
                     else return term
mnislaih's avatar
mnislaih committed
80
     -- Before leaving, we compare the type obtained to see if it's more specific
81
     --  Then, we extract a substitution,
82
83
     --  mapping the old tyvars to the reconstructed types.
       let Just reconstructed_type = termType term
mnislaih's avatar
mnislaih committed
84
           subst = unifyRTTI (idType id) (reconstructed_type)
85
       return (term',subst)
mnislaih's avatar
mnislaih committed
86

87
88
89
90
91
92
   tidyTermTyVars :: Session -> Term -> IO Term
   tidyTermTyVars (Session ref) t = do
     hsc_env <- readIORef ref
     let env_tvs      = ic_tyvars (hsc_IC hsc_env)
         my_tvs       = termTyVars t
         tvs          = env_tvs `minusVarSet` my_tvs
mnislaih's avatar
mnislaih committed
93
         tyvarOccName = nameOccName . tyVarName
94
95
96
97
         tidyEnv      = (initTidyOccEnv (map tyvarOccName (varSetElems tvs))
                        , env_tvs `intersectVarSet` my_tvs)
     return$ mapTermType (snd . tidyOpenType tidyEnv) t

mnislaih's avatar
mnislaih committed
98
99
100
-- | Give names, and bind in the interactive environment, to all the suspensions
--   included (inductively) in a term
bindSuspensions :: Session -> Term -> IO Term
mnislaih's avatar
mnislaih committed
101
bindSuspensions cms@(Session ref) t = do
mnislaih's avatar
mnislaih committed
102
103
104
105
106
      hsc_env <- readIORef ref
      inScope <- GHC.getBindings cms
      let ictxt        = hsc_IC hsc_env
          prefix       = "_t"
          alreadyUsedNames = map (occNameString . nameOccName . getName) inScope
mnislaih's avatar
mnislaih committed
107
          availNames   = map ((prefix++) . show) [(1::Int)..] \\ alreadyUsedNames
mnislaih's avatar
mnislaih committed
108
109
110
      availNames_var  <- newIORef availNames
      (t', stuff)     <- foldTerm (nameSuspensionsAndGetInfos availNames_var) t
      let (names, tys, hvals) = unzip3 stuff
mnislaih's avatar
mnislaih committed
111
      let tys' = map (fst.skolemiseTy) tys
112
113
114
      let ids = [ mkGlobalId VanillaGlobal name ty vanillaIdInfo
                | (name,ty) <- zip names tys']
          new_tyvars   = tyVarsOfTypes tys'
115
          new_ic       = extendInteractiveContext ictxt ids new_tyvars
mnislaih's avatar
mnislaih committed
116
117
118
      extendLinkEnv (zip names hvals)
      writeIORef ref (hsc_env {hsc_IC = new_ic })
      return t'
119
     where
mnislaih's avatar
mnislaih committed
120
121

--    Processing suspensions. Give names and recopilate info
mnislaih's avatar
mnislaih committed
122
        nameSuspensionsAndGetInfos :: IORef [String] ->
123
                                       TermFold (IO (Term, [(Name,Type,HValue)]))
mnislaih's avatar
mnislaih committed
124
        nameSuspensionsAndGetInfos freeNames = TermFold
mnislaih's avatar
mnislaih committed
125
126
                      {
                        fSuspension = doSuspension freeNames
mnislaih's avatar
mnislaih committed
127
128
129
                      , fTerm = \ty dc v tt -> do
                                    tt' <- sequence tt
                                    let (terms,names) = unzip tt'
mnislaih's avatar
mnislaih committed
130
131
                                    return (Term ty dc v terms, concat names)
                      , fPrim    = \ty n ->return (Prim ty n,[])
132
133
134
135
                      , fNewtypeWrap  = 
                                \ty dc t -> do 
                                    (term, names) <- t
                                    return (NewtypeWrap ty dc term, names)
136
137
138
                      , fRefWrap = \ty t -> do
                                    (term, names) <- t 
                                    return (RefWrap ty term, names)
mnislaih's avatar
mnislaih committed
139
                      }
mnislaih's avatar
mnislaih committed
140
        doSuspension freeNames ct mb_ty hval _name = do
mnislaih's avatar
mnislaih committed
141
          name <- atomicModifyIORef freeNames (\x->(tail x, head x))
mnislaih's avatar
mnislaih committed
142
          n <- newGrimName name
mnislaih's avatar
mnislaih committed
143
144
145
146
147
          let ty' = fromMaybe (error "unexpected") mb_ty
          return (Suspension ct mb_ty hval (Just n), [(n,ty',hval)])


--  A custom Term printer to enable the use of Show instances
mnislaih's avatar
mnislaih committed
148
showTerm :: Session -> Term -> IO SDoc
149
150
151
showTerm cms@(Session ref) term = do
    dflags       <- GHC.getSessionDynFlags cms
    if dopt Opt_PrintEvldWithShow dflags
152
       then cPprTerm (liftM2 (++) (\_y->[cPprShowable]) cPprTermBase) term
153
       else cPprTerm cPprTermBase term
mnislaih's avatar
mnislaih committed
154
 where
155
156
  cPprShowable prec t@Term{ty=ty, val=val} =
    if not (isFullyEvaluatedTerm t)
mnislaih's avatar
mnislaih committed
157
     then return Nothing
mnislaih's avatar
mnislaih committed
158
     else do
mnislaih's avatar
mnislaih committed
159
160
161
162
163
        hsc_env <- readIORef ref
        dflags  <- GHC.getSessionDynFlags cms
        do
           (new_env, bname) <- bindToFreshName hsc_env ty "showme"
           writeIORef ref (new_env)
mnislaih's avatar
mnislaih committed
164
           let noop_log _ _ _ _ = return ()
mnislaih's avatar
mnislaih committed
165
166
               expr = "show " ++ showSDoc (ppr bname)
           GHC.setSessionDynFlags cms dflags{log_action=noop_log}
mnislaih's avatar
mnislaih committed
167
           mb_txt <- withExtendedLinkEnv [(bname, val)]
mnislaih's avatar
mnislaih committed
168
                                         (GHC.compileExpr cms expr)
169
           let myprec = 10 -- application precedence. TODO Infix constructors
mnislaih's avatar
mnislaih committed
170
171
172
173
           case mb_txt of
             Just txt_ | txt <- unsafeCoerce# txt_, not (null txt)
                       -> return $ Just$ cparen (prec >= myprec &&
                                                      needsParens txt)
174
175
                                                (text txt)
             _  -> return Nothing
mnislaih's avatar
mnislaih committed
176
         `finally` do
mnislaih's avatar
mnislaih committed
177
           writeIORef ref hsc_env
178
179
180
           GHC.setSessionDynFlags cms dflags
  cPprShowable prec NewtypeWrap{ty=new_ty,wrapped_term=t} = 
      cPprShowable prec t{ty=new_ty}
181
182
  cPprShowable prec RefWrap{wrapped_term=t} = cPprShowable prec t
  cPprShowable _ _ = return Nothing
183

mnislaih's avatar
mnislaih committed
184
  needsParens ('"':_) = False   -- some simple heuristics to see whether parens
185
                                -- are redundant in an arbitrary Show output
mnislaih's avatar
mnislaih committed
186
  needsParens ('(':_) = False
187
188
  needsParens txt = ' ' `elem` txt

mnislaih's avatar
mnislaih committed
189

mnislaih's avatar
mnislaih committed
190
  bindToFreshName hsc_env ty userName = do
mnislaih's avatar
mnislaih committed
191
    name <- newGrimName userName
mnislaih's avatar
mnislaih committed
192
    let ictxt    = hsc_IC hsc_env
193
        tmp_ids  = ic_tmp_ids ictxt
194
        id       = mkGlobalId VanillaGlobal name (sigmaType ty) vanillaIdInfo
195
        new_ic   = ictxt { ic_tmp_ids = id : tmp_ids }
mnislaih's avatar
mnislaih committed
196
197
    return (hsc_env {hsc_IC = new_ic }, name)

mnislaih's avatar
mnislaih committed
198
--    Create new uniques and give them sequentially numbered names
mnislaih's avatar
mnislaih committed
199
200
newGrimName :: String -> IO Name
newGrimName userName  = do
mnislaih's avatar
mnislaih committed
201
202
203
    us <- mkSplitUniqSupply 'b'
    let unique  = uniqFromSupply us
        occname = mkOccName varName userName
204
        name    = mkInternalName unique occname noSrcSpan
mnislaih's avatar
mnislaih committed
205
    return name
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220

pprTypeAndContents :: Session -> [Id] -> IO SDoc
pprTypeAndContents session ids = do
  dflags  <- GHC.getSessionDynFlags session
  let pefas     = dopt Opt_PrintExplicitForalls dflags
      pcontents = dopt Opt_PrintBindContents dflags
  if pcontents 
    then do
      let depthBound = 100
      terms      <- mapM (GHC.obtainTermB session depthBound False) ids
      docs_terms <- mapM (showTerm session) terms
      return $ vcat $ zipWith (\ty cts -> ty <+> equals <+> cts)
                             (map (pprTyThing pefas . AnId) ids)
                             docs_terms
    else return $  vcat $ map (pprTyThing pefas . AnId) ids