Debugger.hs 7.52 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) 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
import Outputable
31
import Pretty                    ( Mode(..), showDocWith )
mnislaih's avatar
mnislaih committed
32
33
34
35
import SrcLoc

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
65
66
67
68
69
70
71
  -- Finally, print the Terms
  unqual  <- GHC.getPrintUnqual session
  let showSDocForUserOneLine unqual doc =
               showDocWith LeftMode (doc (mkErrStyle unqual))
  docterms <- mapM (showTerm session) terms
  (putStrLn . showSDocForUserOneLine unqual . vcat)
        (zipWith (\id docterm -> ppr id <+> char '=' <+> docterm)
                 ids
                 docterms)
 where
mnislaih's avatar
mnislaih committed
72

73
   -- Do the obtainTerm--bindSuspensions-computeSubstitution dance
74
75
76
   go :: Session -> Id -> IO (Term, TvSubst)
   go cms id = do
       term_    <- GHC.obtainTerm cms force id
77
       term     <- tidyTermTyVars cms term_
78
79
       term'    <- if not bindThings then return term
                     else bindSuspensions cms 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
84
85
           Just subst = computeRTTIsubst (idType id) (reconstructed_type)
       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
132
                                    return (Term ty dc v terms, concat names)
                      , fPrim    = \ty n ->return (Prim ty n,[])
                      }
mnislaih's avatar
mnislaih committed
133
        doSuspension freeNames ct mb_ty hval _name = do
mnislaih's avatar
mnislaih committed
134
          name <- atomicModifyIORef freeNames (\x->(tail x, head x))
mnislaih's avatar
mnislaih committed
135
          n <- newGrimName name
mnislaih's avatar
mnislaih committed
136
137
138
139
140
          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
141
showTerm :: Session -> Term -> IO SDoc
142
143
144
145
146
showTerm cms@(Session ref) term = do
    dflags       <- GHC.getSessionDynFlags cms
    if dopt Opt_PrintEvldWithShow dflags
       then cPprTerm (liftM2 (++) cPprShowable cPprTermBase) term
       else cPprTerm cPprTermBase term
mnislaih's avatar
mnislaih committed
147
 where
148
  cPprShowable _y = [\prec ty _ val tt ->
mnislaih's avatar
mnislaih committed
149
    if not (all isFullyEvaluatedTerm tt)
mnislaih's avatar
mnislaih committed
150
     then return Nothing
mnislaih's avatar
mnislaih committed
151
     else do
mnislaih's avatar
mnislaih committed
152
153
154
155
156
        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
157
           let noop_log _ _ _ _ = return ()
mnislaih's avatar
mnislaih committed
158
159
               expr = "show " ++ showSDoc (ppr bname)
           GHC.setSessionDynFlags cms dflags{log_action=noop_log}
mnislaih's avatar
mnislaih committed
160
           mb_txt <- withExtendedLinkEnv [(bname, val)]
mnislaih's avatar
mnislaih committed
161
                                         (GHC.compileExpr cms expr)
162
           let myprec = 10 -- application precedence. TODO Infix constructors
mnislaih's avatar
mnislaih committed
163
164
165
166
           case mb_txt of
             Just txt_ | txt <- unsafeCoerce# txt_, not (null txt)
                       -> return $ Just$ cparen (prec >= myprec &&
                                                      needsParens txt)
167
168
                                                (text txt)
             _  -> return Nothing
mnislaih's avatar
mnislaih committed
169
         `finally` do
mnislaih's avatar
mnislaih committed
170
           writeIORef ref hsc_env
171
           GHC.setSessionDynFlags cms dflags]
mnislaih's avatar
mnislaih committed
172
  needsParens ('"':_) = False   -- some simple heuristics to see whether parens
173
                                -- are redundant in an arbitrary Show output
mnislaih's avatar
mnislaih committed
174
  needsParens ('(':_) = False
175
176
  needsParens txt = ' ' `elem` txt

mnislaih's avatar
mnislaih committed
177

mnislaih's avatar
mnislaih committed
178
  bindToFreshName hsc_env ty userName = do
mnislaih's avatar
mnislaih committed
179
    name <- newGrimName userName
mnislaih's avatar
mnislaih committed
180
    let ictxt    = hsc_IC hsc_env
181
        tmp_ids  = ic_tmp_ids ictxt
182
        id       = mkGlobalId VanillaGlobal name (sigmaType ty) vanillaIdInfo
183
        new_ic   = ictxt { ic_tmp_ids = id : tmp_ids }
mnislaih's avatar
mnislaih committed
184
185
    return (hsc_env {hsc_IC = new_ic }, name)

mnislaih's avatar
mnislaih committed
186
--    Create new uniques and give them sequentially numbered names
mnislaih's avatar
mnislaih committed
187
188
newGrimName :: String -> IO Name
newGrimName userName  = do
mnislaih's avatar
mnislaih committed
189
190
191
    us <- mkSplitUniqSupply 'b'
    let unique  = uniqFromSupply us
        occname = mkOccName varName userName
192
        name    = mkInternalName unique occname noSrcSpan
mnislaih's avatar
mnislaih committed
193
    return name