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

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

import System.IO
import GHC.Exts

mnislaih's avatar
mnislaih committed
42
43
44
-------------------------------------
-- | The :print & friends commands
-------------------------------------
45
pprintClosureCommand :: Session -> Bool -> Bool -> String -> IO ()
mnislaih's avatar
mnislaih committed
46
pprintClosureCommand session bindThings force str = do
47
  tythings <- (catMaybes . concat) `liftM`
mnislaih's avatar
mnislaih committed
48
                 mapM (\w -> GHC.parseName session w >>=
49
                                mapM (GHC.lookupName session))
50
                      (words str)
51
52
53
54
55
56
57
58
59
  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
60
                                (map skolemiseSubst substs)}
61
62
63
64
65
66
67
68
69
70
  -- 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
71

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

86
87
88
89
90
91
   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
92
         tyvarOccName = nameOccName . tyVarName
93
94
95
96
         tidyEnv      = (initTidyOccEnv (map tyvarOccName (varSetElems tvs))
                        , env_tvs `intersectVarSet` my_tvs)
     return$ mapTermType (snd . tidyOpenType tidyEnv) t

mnislaih's avatar
mnislaih committed
97
98
99
-- | 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
100
bindSuspensions cms@(Session ref) t = do
mnislaih's avatar
mnislaih committed
101
102
103
104
105
      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
106
          availNames   = map ((prefix++) . show) [(1::Int)..] \\ alreadyUsedNames
mnislaih's avatar
mnislaih committed
107
108
109
      availNames_var  <- newIORef availNames
      (t', stuff)     <- foldTerm (nameSuspensionsAndGetInfos availNames_var) t
      let (names, tys, hvals) = unzip3 stuff
mnislaih's avatar
mnislaih committed
110
      let tys' = map (fst.skolemiseTy) tys
111
112
113
      let ids = [ mkGlobalId VanillaGlobal name ty vanillaIdInfo
                | (name,ty) <- zip names tys']
          new_tyvars   = tyVarsOfTypes tys'
114
          new_ic       = extendInteractiveContext ictxt ids new_tyvars
mnislaih's avatar
mnislaih committed
115
116
117
      extendLinkEnv (zip names hvals)
      writeIORef ref (hsc_env {hsc_IC = new_ic })
      return t'
118
     where
mnislaih's avatar
mnislaih committed
119
120

--    Processing suspensions. Give names and recopilate info
mnislaih's avatar
mnislaih committed
121
        nameSuspensionsAndGetInfos :: IORef [String] ->
122
                                       TermFold (IO (Term, [(Name,Type,HValue)]))
mnislaih's avatar
mnislaih committed
123
        nameSuspensionsAndGetInfos freeNames = TermFold
mnislaih's avatar
mnislaih committed
124
125
                      {
                        fSuspension = doSuspension freeNames
mnislaih's avatar
mnislaih committed
126
127
128
                      , fTerm = \ty dc v tt -> do
                                    tt' <- sequence tt
                                    let (terms,names) = unzip tt'
mnislaih's avatar
mnislaih committed
129
130
131
                                    return (Term ty dc v terms, concat names)
                      , fPrim    = \ty n ->return (Prim ty n,[])
                      }
mnislaih's avatar
mnislaih committed
132
        doSuspension freeNames ct mb_ty hval _name = do
mnislaih's avatar
mnislaih committed
133
          name <- atomicModifyIORef freeNames (\x->(tail x, head x))
mnislaih's avatar
mnislaih committed
134
          n <- newGrimName name
mnislaih's avatar
mnislaih committed
135
136
137
138
139
          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
140
showTerm :: Session -> Term -> IO SDoc
mnislaih's avatar
mnislaih committed
141
showTerm cms@(Session ref) = cPprTerm cPpr
mnislaih's avatar
mnislaih committed
142
 where
mnislaih's avatar
mnislaih committed
143
  cPpr = \p-> cPprShowable : cPprTermBase p
mnislaih's avatar
mnislaih committed
144
145
  cPprShowable prec ty _ val tt = 
    if not (all isFullyEvaluatedTerm tt)
mnislaih's avatar
mnislaih committed
146
     then return Nothing
mnislaih's avatar
mnislaih committed
147
     else do
mnislaih's avatar
mnislaih committed
148
149
150
151
152
        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
153
           let noop_log _ _ _ _ = return ()
mnislaih's avatar
mnislaih committed
154
155
               expr = "show " ++ showSDoc (ppr bname)
           GHC.setSessionDynFlags cms dflags{log_action=noop_log}
mnislaih's avatar
mnislaih committed
156
           mb_txt <- withExtendedLinkEnv [(bname, val)]
mnislaih's avatar
mnislaih committed
157
                                         (GHC.compileExpr cms expr)
158
           let myprec = 10 -- application precedence. TODO Infix constructors
mnislaih's avatar
mnislaih committed
159
160
161
162
           case mb_txt of
             Just txt_ | txt <- unsafeCoerce# txt_, not (null txt)
                       -> return $ Just$ cparen (prec >= myprec &&
                                                      needsParens txt)
163
164
                                                (text txt)
             _  -> return Nothing
mnislaih's avatar
mnislaih committed
165
         `finally` do
mnislaih's avatar
mnislaih committed
166
167
           writeIORef ref hsc_env
           GHC.setSessionDynFlags cms dflags
mnislaih's avatar
mnislaih committed
168
  needsParens ('"':_) = False   -- some simple heuristics to see whether parens
169
                                -- are redundant in an arbitrary Show output
mnislaih's avatar
mnislaih committed
170
  needsParens ('(':_) = False
171
172
  needsParens txt = ' ' `elem` txt

mnislaih's avatar
mnislaih committed
173

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

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