Debugger.hs 7.9 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

import Linker
import RtClosureInspect

import HscTypes
import IdInfo
--import Id
import Var hiding ( varName )
import VarSet
import VarEnv
import Name 
import UniqSupply
import Type
27
import TcType
mnislaih's avatar
mnislaih committed
28
29
30
31
import TcGadt
import GHC

import Outputable
32
import Pretty                    ( Mode(..), showDocWith )
mnislaih's avatar
mnislaih committed
33
34
35
36
37
import FastString
import SrcLoc

import Control.Exception
import Control.Monad
mnislaih's avatar
mnislaih committed
38
import Data.List
mnislaih's avatar
mnislaih committed
39
40
41
42
43
44
45
46
import Data.Maybe
import Data.IORef

import System.IO
import GHC.Exts

#include "HsVersions.h"

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

62
   -- Do the obtainTerm--bindSuspensions-computeSubstitution dance
63
   go :: Session -> Id -> IO (Maybe TvSubst)
mnislaih's avatar
mnislaih committed
64
   go cms id = do
65
66
67
68
     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                         
69
       showterm  <- printTerm cms term'
70
71
72
73
       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
74
     -- Before leaving, we compare the type obtained to see if it's more specific
75
76
77
     --  Then, we extract a substitution, 
     --  mapping the old tyvars to the reconstructed types.
       let Just reconstructed_type = termType term
78

79
80
     -- tcUnifyTys doesn't look through forall's, so we drop them from 
     -- the original type, instead of sigma-typing the reconstructed type
81
82
83
84
85
86
     -- In addition, we strip newtypes too, since the reconstructed type might
     --   not have recovered them all
           mb_subst = tcUnifyTys (const BindMe) 
                                 [repType' $ dropForAlls$ idType id] 
                                 [repType' $ reconstructed_type]  

87
88
       ASSERT2 (isJust mb_subst, ppr reconstructed_type $$ (ppr$ idType id)) 
        return mb_subst
mnislaih's avatar
mnislaih committed
89

90
91
92
93
94
95
96
97
   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
98
          ids'     = map (\id -> id `setIdType` substTy subst (idType id)) ids
99
100
101
          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
102
103
104
105
106

-- | 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
107
108
109
110
111
112
      hsc_env <- readIORef ref
      inScope <- GHC.getBindings cms
      let ictxt        = hsc_IC hsc_env
          type_env     = ic_type_env ictxt
          prefix       = "_t"
          alreadyUsedNames = map (occNameString . nameOccName . getName) inScope
mnislaih's avatar
mnislaih committed
113
          availNames   = map ((prefix++) . show) [1..] \\ alreadyUsedNames 
mnislaih's avatar
mnislaih committed
114
115
116
      availNames_var  <- newIORef availNames
      (t', stuff)     <- foldTerm (nameSuspensionsAndGetInfos availNames_var) t
      let (names, tys, hvals) = unzip3 stuff
117
118
119
120
      let tys' = map mk_skol_ty tys
      let ids = [ mkGlobalId VanillaGlobal name ty vanillaIdInfo
                | (name,ty) <- zip names tys']
          new_tyvars   = tyVarsOfTypes tys'
mnislaih's avatar
mnislaih committed
121
          new_type_env = extendTypeEnvWithIds type_env ids 
122
123
124
          old_tyvars   = ic_tyvars ictxt
          new_ic       = ictxt { ic_type_env = new_type_env,
                                 ic_tyvars   = old_tyvars `unionVarSet` new_tyvars }
mnislaih's avatar
mnislaih committed
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
      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
149
printTerm cms@(Session ref) = cPprTerm cPpr
mnislaih's avatar
mnislaih committed
150
 where
151
152
  cPpr = \p-> cPprShowable : cPprTermBase p 
  cPprShowable prec t@Term{ty=ty, dc=dc, val=val} = do
mnislaih's avatar
mnislaih committed
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
    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)
168
           let myprec = 9 -- TODO Infix constructors
mnislaih's avatar
mnislaih committed
169
           case mb_txt of 
170
171
             Just txt -> return . Just . text . unsafeCoerce# 
                           $ txt
mnislaih's avatar
mnislaih committed
172
173
174
175
176
177
178
179
180
181
182
             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
        type_env = ic_type_env ictxt
        id       = mkGlobalId VanillaGlobal name ty vanillaIdInfo
        new_type_env = extendTypeEnv type_env (AnId id)
183
        new_ic       = ictxt { ic_type_env     = new_type_env }
mnislaih's avatar
mnislaih committed
184
185
    return (hsc_env {hsc_IC = new_ic }, name)

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

skolemSubst subst = subst `setTvSubstEnv` 
                      mapVarEnv mk_skol_ty (getTvSubstEnv subst)
mk_skol_ty ty | tyvars  <- varSetElems (tyVarsOfType ty)
              , tyvars' <- map (mkTyVarTy . mk_skol_tv) tyvars
              = substTyWith tyvars tyvars' ty
mk_skol_tv tv = mkTcTyVar (tyVarName tv) (tyVarKind tv) 
201
                      (SkolemTv RuntimeUnkSkol)