Debugger.hs 9.43 KB
Newer Older
1 2
{-# LANGUAGE MagicHash #-}

mnislaih's avatar
mnislaih committed
3 4
-----------------------------------------------------------------------------
--
5
-- GHCi Interactive debugging commands
mnislaih's avatar
mnislaih committed
6 7 8
--
-- Pepe Iborra (supported by Google SoC) 2006
--
9 10 11
-- 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.
12
--
mnislaih's avatar
mnislaih committed
13 14
-----------------------------------------------------------------------------

15
module Debugger (pprintClosureCommand, showTerm, pprTypeAndContents) where
mnislaih's avatar
mnislaih committed
16

17 18
import GhcPrelude

mnislaih's avatar
mnislaih committed
19 20 21
import Linker
import RtClosureInspect

22 23
import GHCi
import GHCi.RemoteTypes
24
import GhcMonad
mnislaih's avatar
mnislaih committed
25
import HscTypes
26
import Id
27
import IfaceSyn ( showToHeader )
28
import IfaceEnv( newInteractiveBinder )
29
import Name
mnislaih's avatar
mnislaih committed
30 31
import Var hiding ( varName )
import VarSet
David Feuer's avatar
David Feuer committed
32
import UniqSet
Simon Peyton Jones's avatar
Simon Peyton Jones committed
33
import Type
mnislaih's avatar
mnislaih committed
34 35
import GHC
import Outputable
36
import PprTyThing
37
import ErrUtils
38
import MonadUtils
39
import DynFlags
40
import Exception
mnislaih's avatar
mnislaih committed
41 42

import Control.Monad
mnislaih's avatar
mnislaih committed
43
import Data.List
mnislaih's avatar
mnislaih committed
44 45 46
import Data.Maybe
import Data.IORef

mnislaih's avatar
mnislaih committed
47 48 49
-------------------------------------
-- | The :print & friends commands
-------------------------------------
50 51
pprintClosureCommand :: GhcMonad m => Bool -> Bool -> String -> m ()
pprintClosureCommand bindThings force str = do
52
  tythings <- (catMaybes . concat) `liftM`
53 54
                 mapM (\w -> GHC.parseName w >>=
                                mapM GHC.lookupName)
55
                      (words str)
56 57 58
  let ids = [id | AnId id <- tythings]

  -- Obtain the terms and the recovered type information
59
  (subst, terms) <- mapAccumLM go emptyTCvSubst ids
pepe's avatar
pepe committed
60

61
  -- Apply the substitutions obtained after recovering the types
62
  modifySession $ \hsc_env ->
63 64
    hsc_env{hsc_IC = substInteractiveContext (hsc_IC hsc_env) subst}

65
  -- Finally, print the Terms
66 67
  unqual  <- GHC.getPrintUnqual
  docterms <- mapM showTerm terms
68 69
  dflags <- getDynFlags
  liftIO $ (printOutputForUser dflags unqual . vcat)
70 71 72
           (zipWith (\id docterm -> ppr id <+> char '=' <+> docterm)
                    ids
                    docterms)
73
 where
74
   -- Do the obtainTerm--bindSuspensions-computeSubstitution dance
75
   go :: GhcMonad m => TCvSubst -> Id -> m (TCvSubst, Term)
76
   go subst id = do
77
       let id' = id `setIdType` substTy subst (idType id)
78
       term_    <- GHC.obtainTermFromId maxBound force id'
79
       term     <- tidyTermTyVars term_
pepe's avatar
pepe committed
80
       term'    <- if bindThings &&
Richard Eisenberg's avatar
Richard Eisenberg committed
81
                      (not (isUnliftedType (termType term)))
82
                     then bindSuspensions term
83
                     else return term
mnislaih's avatar
mnislaih committed
84
     -- Before leaving, we compare the type obtained to see if it's more specific
85
     --  Then, we extract a substitution,
86
     --  mapping the old tyvars to the reconstructed types.
mnislaih's avatar
mnislaih committed
87
       let reconstructed_type = termType term
88 89 90 91 92 93
       hsc_env <- getSession
       case (improveRTTIType hsc_env (idType id) (reconstructed_type)) of
         Nothing     -> return (subst, term')
         Just subst' -> do { traceOptIf Opt_D_dump_rtti
                               (fsep $ [text "RTTI Improvement for", ppr id,
                                text "is the substitution:" , ppr subst'])
94
                           ; return (subst `unionTCvSubst` subst', term')}
mnislaih's avatar
mnislaih committed
95

96 97 98
   tidyTermTyVars :: GhcMonad m => Term -> m Term
   tidyTermTyVars t =
     withSession $ \hsc_env -> do
99 100
     let env_tvs      = tyThingsTyCoVars $ ic_tythings $ hsc_IC hsc_env
         my_tvs       = termTyCoVars t
101
         tvs          = env_tvs `minusVarSet` my_tvs
mnislaih's avatar
mnislaih committed
102
         tyvarOccName = nameOccName . tyVarName
David Feuer's avatar
David Feuer committed
103 104
         tidyEnv      = (initTidyOccEnv (map tyvarOccName (nonDetEltsUniqSet tvs))
           -- It's OK to use nonDetEltsUniqSet here because initTidyOccEnv
105
           -- forgets the ordering immediately by creating an env
David Feuer's avatar
David Feuer committed
106 107
                        , getUniqSet $ env_tvs `intersectVarSet` my_tvs)
     return $ mapTermType (snd . tidyOpenType tidyEnv) t
108

mnislaih's avatar
mnislaih committed
109 110
-- | Give names, and bind in the interactive environment, to all the suspensions
--   included (inductively) in a term
111 112 113 114
bindSuspensions :: GhcMonad m => Term -> m Term
bindSuspensions t = do
      hsc_env <- getSession
      inScope <- GHC.getBindings
mnislaih's avatar
mnislaih committed
115 116 117
      let ictxt        = hsc_IC hsc_env
          prefix       = "_t"
          alreadyUsedNames = map (occNameString . nameOccName . getName) inScope
mnislaih's avatar
mnislaih committed
118
          availNames   = map ((prefix++) . show) [(1::Int)..] \\ alreadyUsedNames
119
      availNames_var  <- liftIO $ newIORef availNames
120
      (t', stuff)     <- liftIO $ foldTerm (nameSuspensionsAndGetInfos hsc_env availNames_var) t
121
      let (names, tys, fhvs) = unzip3 stuff
122
      let ids = [ mkVanillaGlobal name ty
123
                | (name,ty) <- zip names tys]
124
          new_ic = extendInteractiveContextWithIds ictxt ids
125
      liftIO $ extendLinkEnv (zip names fhvs)
126
      setSession hsc_env {hsc_IC = new_ic }
mnislaih's avatar
mnislaih committed
127
      return t'
128
     where
mnislaih's avatar
mnislaih committed
129 130

--    Processing suspensions. Give names and recopilate info
131
        nameSuspensionsAndGetInfos :: HscEnv -> IORef [String]
132
                                   -> TermFold (IO (Term, [(Name,Type,ForeignHValue)]))
133
        nameSuspensionsAndGetInfos hsc_env freeNames = TermFold
mnislaih's avatar
mnislaih committed
134
                      {
135
                        fSuspension = doSuspension hsc_env freeNames
mnislaih's avatar
mnislaih committed
136 137 138
                      , fTerm = \ty dc v tt -> do
                                    tt' <- sequence tt
                                    let (terms,names) = unzip tt'
mnislaih's avatar
mnislaih committed
139 140
                                    return (Term ty dc v terms, concat names)
                      , fPrim    = \ty n ->return (Prim ty n,[])
141 142
                      , fNewtypeWrap  =
                                \ty dc t -> do
143 144
                                    (term, names) <- t
                                    return (NewtypeWrap ty dc term, names)
145
                      , fRefWrap = \ty t -> do
146
                                    (term, names) <- t
147
                                    return (RefWrap ty term, names)
mnislaih's avatar
mnislaih committed
148
                      }
149
        doSuspension hsc_env freeNames ct ty hval _name = do
150
          name <- atomicModifyIORef' freeNames (\x->(tail x, head x))
151
          n <- newGrimName hsc_env name
mnislaih's avatar
mnislaih committed
152
          return (Suspension ct ty hval (Just n), [(n,ty,hval)])
mnislaih's avatar
mnislaih committed
153 154 155


--  A custom Term printer to enable the use of Show instances
156 157 158
showTerm :: GhcMonad m => Term -> m SDoc
showTerm term = do
    dflags       <- GHC.getSessionDynFlags
ian@well-typed.com's avatar
ian@well-typed.com committed
159
    if gopt Opt_PrintEvldWithShow dflags
160
       then cPprTerm (liftM2 (++) (\_y->[cPprShowable]) cPprTermBase) term
161
       else cPprTerm cPprTermBase term
mnislaih's avatar
mnislaih committed
162
 where
163
  cPprShowable prec t@Term{ty=ty, val=fhv} =
164
    if not (isFullyEvaluatedTerm t)
mnislaih's avatar
mnislaih committed
165
     then return Nothing
mnislaih's avatar
mnislaih committed
166
     else do
167 168
        hsc_env <- getSession
        dflags  <- GHC.getSessionDynFlags
mnislaih's avatar
mnislaih committed
169 170
        do
           (new_env, bname) <- bindToFreshName hsc_env ty "showme"
171 172 173 174
           setSession new_env
                      -- XXX: this tries to disable logging of errors
                      -- does this still do what it is intended to do
                      -- with the changed error handling and logging?
175
           let noop_log _ _ _ _ _ _ = return ()
176 177 178
               expr = "Prelude.return (Prelude.show " ++
                         showPpr dflags bname ++
                      ") :: Prelude.IO Prelude.String"
179
           _ <- GHC.setSessionDynFlags dflags{log_action=noop_log}
180
           txt_ <- withExtendedLinkEnv [(bname, fhv)]
181
                                       (GHC.compileExprRemote expr)
182
           let myprec = 10 -- application precedence. TODO Infix constructors
183
           txt <- liftIO $ evalString hsc_env txt_
184
           if not (null txt) then
dterei's avatar
dterei committed
185 186
             return $ Just $ cparen (prec >= myprec && needsParens txt)
                                    (text txt)
187 188 189 190
            else return Nothing
         `gfinally` do
           setSession hsc_env
           GHC.setSessionDynFlags dflags
191
  cPprShowable prec NewtypeWrap{ty=new_ty,wrapped_term=t} =
192
      cPprShowable prec t{ty=new_ty}
193
  cPprShowable _ _ = return Nothing
194

mnislaih's avatar
mnislaih committed
195
  needsParens ('"':_) = False   -- some simple heuristics to see whether parens
196
                                -- are redundant in an arbitrary Show output
mnislaih's avatar
mnislaih committed
197
  needsParens ('(':_) = False
198 199
  needsParens txt = ' ' `elem` txt

mnislaih's avatar
mnislaih committed
200

mnislaih's avatar
mnislaih committed
201
  bindToFreshName hsc_env ty userName = do
202 203
    name <- newGrimName hsc_env userName
    let id       = mkVanillaGlobal name ty
204
        new_ic   = extendInteractiveContextWithIds (hsc_IC hsc_env) [id]
mnislaih's avatar
mnislaih committed
205 206
    return (hsc_env {hsc_IC = new_ic }, name)

mnislaih's avatar
mnislaih committed
207
--    Create new uniques and give them sequentially numbered names
208 209 210 211 212
newGrimName :: MonadIO m => HscEnv -> String -> m Name
newGrimName hsc_env userName
  = liftIO (newInteractiveBinder hsc_env occ noSrcSpan)
  where
    occ = mkOccName varName userName
213

214 215
pprTypeAndContents :: GhcMonad m => Id -> m SDoc
pprTypeAndContents id = do
216
  dflags  <- GHC.getSessionDynFlags
unknown's avatar
unknown committed
217
  let pcontents = gopt Opt_PrintBindContents dflags
218
      pprdId    = (pprTyThing showToHeader . AnId) id
219
  if pcontents
220 221
    then do
      let depthBound = 100
222 223 224 225 226 227 228
      -- If the value is an exception, make sure we catch it and
      -- show the exception, rather than propagating the exception out.
      e_term <- gtry $ GHC.obtainTermFromId depthBound False id
      docs_term <- case e_term of
                      Right term -> showTerm term
                      Left  exn  -> return (text "*** Exception:" <+>
                                            text (show (exn :: SomeException)))
229 230
      return $ pprdId <+> equals <+> docs_term
    else return pprdId
pepe's avatar
pepe committed
231 232

--------------------------------------------------------------
233
-- Utils
pepe's avatar
pepe committed
234

235
traceOptIf :: GhcMonad m => DumpFlag -> SDoc -> m ()
pepe's avatar
pepe committed
236 237
traceOptIf flag doc = do
  dflags <- GHC.getSessionDynFlags
238
  when (dopt flag dflags) $ liftIO $ printInfoForUser dflags alwaysQualify doc