Debugger.hs 12 KB
Newer Older
mnislaih's avatar
mnislaih committed
1
2
3
4
5
6
7
8
-----------------------------------------------------------------------------
--
-- GHCi Interactive debugging commands 
--
-- Pepe Iborra (supported by Google SoC) 2006
--
-----------------------------------------------------------------------------

9
module Debugger (pprintClosureCommand, instantiateTyVarsToUnknown) where
mnislaih's avatar
mnislaih committed
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32

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 DataCon
import TcGadt
import GHC
import GhciMonad

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
51
-------------------------------------
-- | The :print & friends commands
-------------------------------------
pprintClosureCommand :: Bool -> Bool -> String -> GHCi ()
mnislaih's avatar
mnislaih committed
52
53
pprintClosureCommand bindThings force str = do 
  cms <- getSession
mnislaih's avatar
mnislaih committed
54
55
56
  newvarsNames <- io$ do 
           uniques <- liftM uniqsFromSupply (mkSplitUniqSupply 'q')
           return$ map (\u-> (mkSysTvName u (mkFastString "a"))) uniques
mnislaih's avatar
mnislaih committed
57
  mb_ids  <- io$ mapM (cleanUp cms newvarsNames) (words str)
58
59
  mb_new_ids <- mapM (io . go cms) (catMaybes mb_ids)
  io$ updateIds cms (catMaybes mb_new_ids)
mnislaih's avatar
mnislaih committed
60
61
62
63
64
65
66
67
68
69
 where 
   -- Find the Id, clean up 'Unknowns'
   cleanUp :: Session -> [Name] -> String -> IO (Maybe Id)
   cleanUp cms newNames str = do
     tythings <- GHC.parseName cms str >>= mapM (GHC.lookupName cms)
     return$ listToMaybe (map (stripUnknowns newNames) 
                              [ i | Just (AnId i) <- tythings]) 

   -- Do the obtainTerm--bindSuspensions-refineIdType dance
   -- Warning! This function got a good deal of side-effects
70
   go :: Session -> Id -> IO (Maybe Id)
mnislaih's avatar
mnislaih committed
71
   go cms id = do
72
73
74
75
76
77
78
79
80
     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                         
       showterm  <- pprTerm cms term'
       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
81
82
     -- Before leaving, we compare the type obtained to see if it's more specific
     -- Note how we need the Unknown-clear type returned by obtainTerm
83
84
85
86
       let Just reconstructedType = termType term  
       new_type  <- instantiateTyVarsToUnknown cms 
                    (mostSpecificType (idType id) reconstructedType)
       return . Just $ setIdType id new_type
mnislaih's avatar
mnislaih committed
87
88
89
90
91
92
93
94
95
96
97
98
99

   updateIds :: Session -> [Id] -> IO ()
   updateIds (Session ref) new_ids = do
     hsc_env <- readIORef ref
     let ictxt = hsc_IC hsc_env
         type_env = ic_type_env ictxt
         filtered_type_env = delListFromNameEnv type_env (map idName new_ids)
         new_type_env =  extendTypeEnvWithIds filtered_type_env new_ids
         new_ic = ictxt {ic_type_env = new_type_env }
     writeIORef ref (hsc_env {hsc_IC = new_ic })

isMoreSpecificThan :: Type -> Type -> Bool
ty `isMoreSpecificThan` ty1 
mnislaih's avatar
mnislaih committed
100
101
102
103
104
105
106
107
108
109
      | Just subst    <- tcUnifyTys bindOnlyTy1 [repType' ty] [repType' ty1] 
      , substFiltered <- filter (not.isTyVarTy) . varEnvElts . getTvSubstEnv $ subst
      , not . null $ substFiltered
      , all (flip notElemTvSubst subst) ty_vars
      = True
      | otherwise = False
      where bindOnlyTy1 tyv | tyv `elem` ty_vars = AvoidMe
                            | otherwise = BindMe
            ty_vars = varSetElems$ tyVarsOfType ty

mnislaih's avatar
mnislaih committed
110
111
112
113
114
115
116
mostSpecificType ty1 ty2 | ty1 `isMoreSpecificThan` ty2 = ty1
                         | otherwise = ty2

-- | 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
117
118
119
120
121
122
123
      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
124
          availNames   = map ((prefix++) . show) [1..] \\ alreadyUsedNames 
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
149
150
151
152
153
154
155
156
157
158
      availNames_var  <- newIORef availNames
      (t', stuff)     <- foldTerm (nameSuspensionsAndGetInfos availNames_var) t
      let (names, tys, hvals) = unzip3 stuff
      concrete_tys    <- mapM (instantiateTyVarsToUnknown cms) tys
      let ids = [ mkGlobalId VanillaGlobal name ty vanillaIdInfo
                  | (name,ty) <- zip names concrete_tys]
          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
mnislaih's avatar
mnislaih committed
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
pprTerm cms@(Session ref) = customPrintTerm customPrint
 where
  customPrint = \p-> customPrintShowable : customPrintTermBase p 
  customPrintShowable t@Term{ty=ty, dc=dc, val=val} = do
    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)
           case mb_txt of 
             Just txt -> return . Just . text . unsafeCoerce# $ txt
             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
197
198
--    Create new uniques and give them sequentially numbered names
--    newGrimName :: Session -> String -> IO Name
mnislaih's avatar
mnislaih committed
199
200
201
202
203
204
newGrimName cms userName  = do
    us <- mkSplitUniqSupply 'b'
    let unique  = uniqFromSupply us
        occname = mkOccName varName userName
        name    = mkInternalName unique occname noSrcLoc
    return name
mnislaih's avatar
mnislaih committed
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257

----------------------------------------------------------------------------
-- | Replace all the tyvars in a Term with the opaque type GHC.Base.Unknown
----------------------------------------------------------------------------
instantiateTyVarsToUnknown :: Session -> Type -> IO Type
instantiateTyVarsToUnknown cms ty
-- We have a GADT, so just fix its tyvars
    | Just (tycon, args) <- splitTyConApp_maybe ty
    , tycon /= funTyCon
    , isGADT tycon
    = mapM fixTyVars args >>= return . mkTyConApp tycon
-- We have a regular TyCon, so map recursively to its args
    | Just (tycon, args) <- splitTyConApp_maybe ty
    , tycon /= funTyCon
    = do unknownTyVar <- unknownTV
         args' <- mapM (instantiateTyVarsToUnknown cms) args
         return$ mkTyConApp tycon args'
-- we have a tyvar of kind *
    | Just tyvar <- getTyVar_maybe ty
    , ([],_) <- splitKindFunTys (tyVarKind tyvar) 
    = unknownTV
-- we have a higher kind tyvar, so insert an unknown of the appropriate kind
    | Just tyvar <- getTyVar_maybe ty
    , (args,_) <- splitKindFunTys (tyVarKind tyvar)
    = liftM mkTyConTy $ unknownTC !! length args
-- Base case
    | otherwise    = return ty 

 where unknownTV = do 
         Just (ATyCon unknown_tc) <- lookupName cms unknownTyConName
         return$ mkTyConTy unknown_tc
       unknownTC = [undefined, unknownTC1, unknownTC2, unknownTC3]
       unknownTC1 = do 
         Just (ATyCon unknown_tc) <- lookupName cms unknown1TyConName
         return unknown_tc
       unknownTC2 = do 
         Just (ATyCon unknown_tc) <- lookupName cms unknown2TyConName
         return unknown_tc
       unknownTC3 = do 
         Just (ATyCon unknown_tc) <- lookupName cms unknown3TyConName
         return unknown_tc
--       isGADT ty | pprTrace' "isGADT" (ppr ty <> colon <> ppr(isGadtSyntaxTyCon ty)) False = undefined
       isGADT tc | Just dcs <- tyConDataCons_maybe tc = any (not . null . dataConEqSpec) dcs
                 | otherwise = False
       fixTyVars ty 
           | Just (tycon, args) <- splitTyConApp_maybe ty
           = mapM fixTyVars args >>= return . mkTyConApp tycon
-- Fix the tyvar so that the interactive environment doesn't choke on it TODO 
           | Just tv <- getTyVar_maybe ty = return ty --TODO
           | otherwise = return ty

-- | The inverse function. Strip the GHC.Base.Unknowns in the type of the id, they correspond to tyvars. The caller must provide an infinite list of fresh names
stripUnknowns :: [Name] -> Id -> Id
258
stripUnknowns names id = setIdType id . fst . go names . idType 
mnislaih's avatar
mnislaih committed
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
                           $ id
 where 
   go tyvarsNames@(v:vv) ty 
    | Just (ty1,ty2) <- splitFunTy_maybe ty = let
               (ty1',vv') = go tyvarsNames ty1
               (ty2',vv'')= go vv' ty2
               in (mkFunTy ty1' ty2', vv'')
    | Just (ty1,ty2) <- splitAppTy_maybe ty = let
               (ty1',vv') = go tyvarsNames ty1
               (ty2',vv'')= go vv' ty2
               in (mkAppTy ty1' ty2', vv'')
    | Just (tycon, args) <- splitTyConApp_maybe ty 
    , Just (tycon', vv') <- (fixTycon tycon tyvarsNames)
    , (args',vv'') <- foldr (\arg (aa,vv) -> let (arg',vv') = go vv' arg 
                                             in (arg':aa,vv'))
                            ([],vv') args
    = (mkAppTys tycon' args',vv'')
    | Just (tycon, args) <- splitTyConApp_maybe ty
    , (args',vv') <- foldr (\arg (aa,vv) -> let (arg',vv') = go vv' arg 
                                            in (arg':aa,vv'))
                           ([],tyvarsNames) args
    = (mkTyConApp tycon args',vv')
    | otherwise = (ty, tyvarsNames)
    where  fixTycon tycon (v:vv) = do
               k <- lookup (tyConName tycon) kinds
               return (mkTyVarTy$ mkTyVar v k, vv)
           kinds = [ (unknownTyConName, liftedTypeKind)
                   , (unknown1TyConName, kind1)
                   , (unknown2TyConName, kind2)
                   , (unknown3TyConName, kind3)]
           kind1 = mkArrowKind liftedTypeKind liftedTypeKind
           kind2 = mkArrowKind kind1 liftedTypeKind
           kind3 = mkArrowKind kind2 liftedTypeKind