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

import Linker
import RtClosureInspect

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

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

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

import System.IO
import GHC.Exts

#include "HsVersions.h"

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

63
   -- Do the obtainTerm--bindSuspensions-computeSubstitution dance
64
   go :: Session -> Id -> IO (Maybe TvSubst)
65
66
67
68
   go cms id = do 
     mb_term <- obtainTerm cms force id 
     maybe (return Nothing) `flip` mb_term $ \term_ -> do
       term      <- tidyTermTyVars cms term_
69
70
       term'     <- if not bindThings then return term 
                     else bindSuspensions cms term                         
71
       showterm  <- printTerm cms term'
72
73
74
75
       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
76
     -- Before leaving, we compare the type obtained to see if it's more specific
77
78
79
     --  Then, we extract a substitution, 
     --  mapping the old tyvars to the reconstructed types.
       let Just reconstructed_type = termType term
80

81
82
     -- tcUnifyTys doesn't look through forall's, so we drop them from 
     -- the original type, instead of sigma-typing the reconstructed type
83
84
85
86
87
88
     -- 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]  

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

92
93
94
95
96
97
98
99
   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
100
          ids'     = map (\id -> id `setIdType` substTy subst (idType id)) ids
101
          type_env'= extendTypeEnvWithIds type_env ids'
102
          subst_dom= varEnvKeys$ getTvSubstEnv subst
103
104
105
106
107
          subst_ran= varEnvElts$ getTvSubstEnv subst
          new_tvs  = [ tv | t <- subst_ran, let Just tv = getTyVar_maybe t]  
          ic_tyvars'= (`delVarSetListByKey` subst_dom) 
                    . (`extendVarSetList`   new_tvs)
                        $ ic_tyvars ictxt
108
          ictxt'   = ictxt { ic_type_env = type_env'
109
                           , ic_tyvars   = ic_tyvars' }
110
      writeIORef ref (hsc_env {hsc_IC = ictxt'})
mnislaih's avatar
mnislaih committed
111

112
113
          where delVarSetListByKey = foldl' delVarSetByKey

114
115
116
117
118
119
120
121
122
123
124
   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
         tyvarOccName = nameOccName . tyVarName 
         tidyEnv      = (initTidyOccEnv (map tyvarOccName (varSetElems tvs))
                        , env_tvs `intersectVarSet` my_tvs)
     return$ mapTermType (snd . tidyOpenType tidyEnv) t

mnislaih's avatar
mnislaih committed
125
126
127
128
-- | 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
129
130
131
132
133
134
      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
135
          availNames   = map ((prefix++) . show) [1..] \\ alreadyUsedNames 
mnislaih's avatar
mnislaih committed
136
137
138
      availNames_var  <- newIORef availNames
      (t', stuff)     <- foldTerm (nameSuspensionsAndGetInfos availNames_var) t
      let (names, tys, hvals) = unzip3 stuff
139
140
141
142
      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
143
          new_type_env = extendTypeEnvWithIds type_env ids 
144
145
146
          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
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
      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
171
printTerm cms@(Session ref) = cPprTerm cPpr
mnislaih's avatar
mnislaih committed
172
 where
173
174
  cPpr = \p-> cPprShowable : cPprTermBase p 
  cPprShowable prec t@Term{ty=ty, dc=dc, val=val} = do
mnislaih's avatar
mnislaih committed
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
    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)
190
           let myprec = 9 -- TODO Infix constructors
mnislaih's avatar
mnislaih committed
191
           case mb_txt of 
192
193
             Just txt -> return . Just . text . unsafeCoerce# 
                           $ txt
mnislaih's avatar
mnislaih committed
194
195
196
197
198
199
200
201
202
203
204
             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)
205
        new_ic       = ictxt { ic_type_env     = new_type_env }
mnislaih's avatar
mnislaih committed
206
207
    return (hsc_env {hsc_IC = new_ic }, name)

mnislaih's avatar
mnislaih committed
208
209
--    Create new uniques and give them sequentially numbered names
--    newGrimName :: Session -> String -> IO Name
mnislaih's avatar
mnislaih committed
210
211
212
213
214
215
newGrimName cms userName  = do
    us <- mkSplitUniqSupply 'b'
    let unique  = uniqFromSupply us
        occname = mkOccName varName userName
        name    = mkInternalName unique occname noSrcLoc
    return name
216
217
218
219
220
221
222

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) 
223
                      (SkolemTv RuntimeUnkSkol)