Debugger.hs 7.34 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) where
mnislaih's avatar
mnislaih committed
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35

import Linker
import RtClosureInspect

import PrelNames
import HscTypes
import IdInfo
--import Id
import Var hiding ( varName )
import VarSet
import VarEnv
import Name 
import NameEnv
import RdrName
import UniqSupply
import Type
import TyCon
import TcGadt
import GHC
import GhciMonad

import Outputable
36
import Pretty                    ( Mode(..), showDocWith )
mnislaih's avatar
mnislaih committed
37
38
39
40
41
import FastString
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
50
import Data.Maybe
import Data.IORef

import System.IO
import GHC.Exts

#include "HsVersions.h"

mnislaih's avatar
mnislaih committed
51
52
53
54
-------------------------------------
-- | The :print & friends commands
-------------------------------------
pprintClosureCommand :: Bool -> Bool -> String -> GHCi ()
mnislaih's avatar
mnislaih committed
55
56
pprintClosureCommand bindThings force str = do 
  cms <- getSession
57
58
59
60
61
62
63
64
  tythings <- (catMaybes . concat) `liftM`
                 mapM (\w -> io(GHC.parseName cms w >>= 
                                mapM (GHC.lookupName cms)))
                      (words str)
  substs <- catMaybes `liftM` mapM (io . go cms) 
                                   [id | AnId id <- tythings]
  mapM (io . applySubstToEnv cms) substs
  return ()
mnislaih's avatar
mnislaih committed
65
66
67
68
 where 

   -- Do the obtainTerm--bindSuspensions-refineIdType dance
   -- Warning! This function got a good deal of side-effects
69
   go :: Session -> Id -> IO (Maybe TvSubst)
mnislaih's avatar
mnislaih committed
70
   go cms id = do
71
72
73
74
     mb_term <- obtainTerm cms force id
     maybe (return Nothing) `flip` mb_term $ \term -> do
       term'     <- if not bindThings then return term 
                     else bindSuspensions cms term                         
75
       showterm  <- printTerm cms term'
76
77
78
79
       unqual    <- GHC.getPrintUnqual cms
       let showSDocForUserOneLine unqual doc = 
               showDocWith LeftMode (doc (mkErrStyle unqual))
       (putStrLn . showSDocForUserOneLine unqual) (ppr id <+> char '=' <+> showterm)
mnislaih's avatar
mnislaih committed
80
     -- Before leaving, we compare the type obtained to see if it's more specific
81
82
83
84
85
     --  Then, we extract a substitution, 
     --  mapping the old tyvars to the reconstructed types.
       let Just reconstructed_type = termType term
           mb_subst = tcUnifyTys (const BindMe) [idType id] [reconstructed_type]
       ASSERT (isJust mb_subst) return mb_subst
mnislaih's avatar
mnislaih committed
86

87
88
89
90
91
92
93
94
95
96
97
98
   applySubstToEnv :: Session -> TvSubst -> IO ()
   applySubstToEnv cms subst | isEmptyTvSubst subst = return ()
   applySubstToEnv cms@(Session ref) subst = do
      hsc_env <- readIORef ref
      inScope <- GHC.getBindings cms
      let ictxt    = hsc_IC hsc_env
          type_env = ic_type_env ictxt
          ids      = typeEnvIds type_env
          ids'     = map (\id -> setIdType id (substTy subst (idType id))) ids
          type_env'= extendTypeEnvWithIds type_env ids'
          ictxt'   = ictxt { ic_type_env = type_env' }
      writeIORef ref (hsc_env {hsc_IC = ictxt'})
mnislaih's avatar
mnislaih committed
99
100
101
102
103

-- | Give names, and bind in the interactive environment, to all the suspensions
--   included (inductively) in a term
bindSuspensions :: Session -> Term -> IO Term
bindSuspensions cms@(Session ref) t = do 
mnislaih's avatar
mnislaih committed
104
105
106
107
108
109
110
      hsc_env <- readIORef ref
      inScope <- GHC.getBindings cms
      let ictxt        = hsc_IC hsc_env
          rn_env       = ic_rn_local_env ictxt
          type_env     = ic_type_env ictxt
          prefix       = "_t"
          alreadyUsedNames = map (occNameString . nameOccName . getName) inScope
mnislaih's avatar
mnislaih committed
111
          availNames   = map ((prefix++) . show) [1..] \\ alreadyUsedNames 
mnislaih's avatar
mnislaih committed
112
113
114
115
      availNames_var  <- newIORef availNames
      (t', stuff)     <- foldTerm (nameSuspensionsAndGetInfos availNames_var) t
      let (names, tys, hvals) = unzip3 stuff
      let ids = [ mkGlobalId VanillaGlobal name ty vanillaIdInfo
116
                  | (name,ty) <- zip names tys]
mnislaih's avatar
mnislaih committed
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
          new_type_env = extendTypeEnvWithIds type_env ids 
          new_rn_env   = extendLocalRdrEnv rn_env names
          new_ic       = ictxt { ic_rn_local_env = new_rn_env, 
                                 ic_type_env     = new_type_env }
      extendLinkEnv (zip names hvals)
      writeIORef ref (hsc_env {hsc_IC = new_ic })
      return t'
     where    

--    Processing suspensions. Give names and recopilate info
        nameSuspensionsAndGetInfos :: IORef [String] -> TermFold (IO (Term, [(Name,Type,HValue)]))
        nameSuspensionsAndGetInfos freeNames = TermFold 
                      {
                        fSuspension = doSuspension freeNames
                      , fTerm = \ty dc v tt -> do 
                                    tt' <- sequence tt 
                                    let (terms,names) = unzip tt' 
                                    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
145
printTerm cms@(Session ref) = cPprTerm cPpr
mnislaih's avatar
mnislaih committed
146
 where
147
148
  cPpr = \p-> cPprShowable : cPprTermBase p 
  cPprShowable prec t@Term{ty=ty, dc=dc, val=val} = do
mnislaih's avatar
mnislaih committed
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
    let hasType = isEmptyVarSet (tyVarsOfType ty)  -- redundant
        isEvaled = isFullyEvaluatedTerm t
    if not isEvaled -- || not hasType
     then return Nothing
     else do 
        hsc_env <- readIORef ref
        dflags  <- GHC.getSessionDynFlags cms
        do
           (new_env, bname) <- bindToFreshName hsc_env ty "showme"
           writeIORef ref (new_env)
           let noop_log _ _ _ _ = return () 
               expr = "show " ++ showSDoc (ppr bname)
           GHC.setSessionDynFlags cms dflags{log_action=noop_log}
           mb_txt <- withExtendedLinkEnv [(bname, val)] 
                                         (GHC.compileExpr cms expr)
164
           let myprec = 9 -- TODO Infix constructors
mnislaih's avatar
mnislaih committed
165
           case mb_txt of 
166
167
             Just txt -> return . Just . text . unsafeCoerce# 
                           $ txt
mnislaih's avatar
mnislaih committed
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
             Nothing  -> return Nothing
         `finally` do 
           writeIORef ref hsc_env
           GHC.setSessionDynFlags cms dflags
     
  bindToFreshName hsc_env ty userName = do
    name <- newGrimName cms userName 
    let ictxt    = hsc_IC hsc_env
        rn_env   = ic_rn_local_env ictxt
        type_env = ic_type_env ictxt
        id       = mkGlobalId VanillaGlobal name ty vanillaIdInfo
        new_type_env = extendTypeEnv type_env (AnId id)
        new_rn_env   = extendLocalRdrEnv rn_env [name]
        new_ic       = ictxt { ic_rn_local_env = new_rn_env, 
                               ic_type_env     = new_type_env }
    return (hsc_env {hsc_IC = new_ic }, name)

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