Debugger.hs 7.65 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
14
15
16
17
18
19
{-# OPTIONS_GHC -w #-}
-- The above warning supression flag is a temporary kludge.
-- While working on this module you are encouraged to remove it and fix
-- any warnings in the module. See
--     http://hackage.haskell.org/trac/ghc/wiki/WorkingConventions#Warnings
-- for details

20
module Debugger (pprintClosureCommand, showTerm) where
mnislaih's avatar
mnislaih committed
21
22
23
24
25
26
27

import Linker
import RtClosureInspect

import HscTypes
import IdInfo
--import Id
28
import Name
mnislaih's avatar
mnislaih committed
29
30
31
32
import Var hiding ( varName )
import VarSet
import Name 
import UniqSupply
33
import TcType
mnislaih's avatar
mnislaih committed
34
import GHC
mnislaih's avatar
mnislaih committed
35
import InteractiveEval
mnislaih's avatar
mnislaih committed
36
import Outputable
37
import Pretty                    ( Mode(..), showDocWith )
mnislaih's avatar
mnislaih committed
38
39
40
41
import SrcLoc

import Control.Exception
import Control.Monad
mnislaih's avatar
mnislaih committed
42
import Data.List
mnislaih's avatar
mnislaih committed
43
44
45
46
47
48
49
import Data.Maybe
import Data.IORef

import System.IO
import GHC.Exts

#include "HsVersions.h"
mnislaih's avatar
mnislaih committed
50
51
52
-------------------------------------
-- | The :print & friends commands
-------------------------------------
53
pprintClosureCommand :: Session -> Bool -> Bool -> String -> IO ()
mnislaih's avatar
mnislaih committed
54
pprintClosureCommand session bindThings force str = do
55
  tythings <- (catMaybes . concat) `liftM`
mnislaih's avatar
mnislaih committed
56
                 mapM (\w -> GHC.parseName session w >>=
57
                                mapM (GHC.lookupName session))
58
                      (words str)
59
60
61
62
63
64
65
66
67
  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
68
                                (map skolemiseSubst substs)}
69
70
71
72
73
74
75
76
77
78
  -- 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
79

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

94
95
96
97
98
99
   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
100
         tyvarOccName = nameOccName . tyVarName
101
102
103
104
         tidyEnv      = (initTidyOccEnv (map tyvarOccName (varSetElems tvs))
                        , env_tvs `intersectVarSet` my_tvs)
     return$ mapTermType (snd . tidyOpenType tidyEnv) t

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

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

mnislaih's avatar
mnislaih committed
180

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

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