Debugger.hs 7.53 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
62
63
 where 

   -- Do the obtainTerm--bindSuspensions-refineIdType dance
   -- Warning! This function got a good deal of side-effects
64
   go :: Session -> Id -> IO (Maybe TvSubst)
mnislaih's avatar
mnislaih committed
65
   go cms id = do
66
67
68
69
     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                         
70
       showterm  <- printTerm cms term'
71
72
73
74
       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
75
     -- Before leaving, we compare the type obtained to see if it's more specific
76
77
78
79
80
     --  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
81

82
83
84
85
86
87
88
89
   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
90
          ids'     = map (\id -> id `setIdType` substTy subst (idType id)) ids
91
92
93
          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
94
95
96
97
98

-- | 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
99
100
101
102
103
104
      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
105
          availNames   = map ((prefix++) . show) [1..] \\ alreadyUsedNames 
mnislaih's avatar
mnislaih committed
106
107
108
      availNames_var  <- newIORef availNames
      (t', stuff)     <- foldTerm (nameSuspensionsAndGetInfos availNames_var) t
      let (names, tys, hvals) = unzip3 stuff
109
110
111
112
      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
113
          new_type_env = extendTypeEnvWithIds type_env ids 
114
115
116
          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
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
      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
141
printTerm cms@(Session ref) = cPprTerm cPpr
mnislaih's avatar
mnislaih committed
142
 where
143
144
  cPpr = \p-> cPprShowable : cPprTermBase p 
  cPprShowable prec t@Term{ty=ty, dc=dc, val=val} = do
mnislaih's avatar
mnislaih committed
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
    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)
160
           let myprec = 9 -- TODO Infix constructors
mnislaih's avatar
mnislaih committed
161
           case mb_txt of 
162
163
             Just txt -> return . Just . text . unsafeCoerce# 
                           $ txt
mnislaih's avatar
mnislaih committed
164
165
166
167
168
169
170
171
172
173
174
             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)
175
        new_ic       = ictxt { ic_type_env     = new_type_env }
mnislaih's avatar
mnislaih committed
176
177
    return (hsc_env {hsc_IC = new_ic }, name)

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

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) 
                      (SkolemTv UnkSkol)