Debugger.hs 7.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, showTerm) 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
import Var hiding ( varName )
import VarSet
import Name 
import UniqSupply
26
import TcType
mnislaih's avatar
mnislaih committed
27
import GHC
28
import DynFlags
mnislaih's avatar
mnislaih committed
29
import InteractiveEval
mnislaih's avatar
mnislaih committed
30
import Outputable
31
import Pretty                    ( Mode(..), showDocWith )
mnislaih's avatar
mnislaih committed
32 33 34 35
import SrcLoc

import Control.Exception
import Control.Monad
mnislaih's avatar
mnislaih committed
36
import Data.List
mnislaih's avatar
mnislaih committed
37 38 39 40 41 42
import Data.Maybe
import Data.IORef

import System.IO
import GHC.Exts

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

  -- Obtain the terms and the recovered type information
  (terms, substs) <- unzip `liftM` mapM (go session) ids
  
  -- Apply the substitutions obtained after recovering the types
  modifySession session $ \hsc_env ->
         hsc_env{hsc_IC = foldr (flip substInteractiveContext)
                                (hsc_IC hsc_env)
mnislaih's avatar
mnislaih committed
61
                                (map skolemiseSubst substs)}
62 63 64 65 66 67 68 69 70 71
  -- Finally, print the Terms
  unqual  <- GHC.getPrintUnqual session
  let showSDocForUserOneLine unqual doc =
               showDocWith LeftMode (doc (mkErrStyle unqual))
  docterms <- mapM (showTerm session) terms
  (putStrLn . showSDocForUserOneLine unqual . vcat)
        (zipWith (\id docterm -> ppr id <+> char '=' <+> docterm)
                 ids
                 docterms)
 where
mnislaih's avatar
mnislaih committed
72

73
   -- Do the obtainTerm--bindSuspensions-computeSubstitution dance
74 75 76
   go :: Session -> Id -> IO (Term, TvSubst)
   go cms id = do
       term_    <- GHC.obtainTerm cms force id
77
       term     <- tidyTermTyVars cms term_
78 79
       term'    <- if not bindThings then return term
                     else bindSuspensions cms term                       
mnislaih's avatar
mnislaih committed
80
     -- Before leaving, we compare the type obtained to see if it's more specific
81
     --  Then, we extract a substitution,
82 83
     --  mapping the old tyvars to the reconstructed types.
       let Just reconstructed_type = termType term
84
           subst = computeRTTIsubst (idType id) (reconstructed_type)
85
       return (term',subst)
mnislaih's avatar
mnislaih committed
86

87 88 89 90 91 92
   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
mnislaih's avatar
mnislaih committed
93
         tyvarOccName = nameOccName . tyVarName
94 95 96 97
         tidyEnv      = (initTidyOccEnv (map tyvarOccName (varSetElems tvs))
                        , env_tvs `intersectVarSet` my_tvs)
     return$ mapTermType (snd . tidyOpenType tidyEnv) t

mnislaih's avatar
mnislaih committed
98 99 100
-- | Give names, and bind in the interactive environment, to all the suspensions
--   included (inductively) in a term
bindSuspensions :: Session -> Term -> IO Term
mnislaih's avatar
mnislaih committed
101
bindSuspensions cms@(Session ref) t = do
mnislaih's avatar
mnislaih committed
102 103 104 105 106
      hsc_env <- readIORef ref
      inScope <- GHC.getBindings cms
      let ictxt        = hsc_IC hsc_env
          prefix       = "_t"
          alreadyUsedNames = map (occNameString . nameOccName . getName) inScope
mnislaih's avatar
mnislaih committed
107
          availNames   = map ((prefix++) . show) [(1::Int)..] \\ alreadyUsedNames
mnislaih's avatar
mnislaih committed
108 109 110
      availNames_var  <- newIORef availNames
      (t', stuff)     <- foldTerm (nameSuspensionsAndGetInfos availNames_var) t
      let (names, tys, hvals) = unzip3 stuff
mnislaih's avatar
mnislaih committed
111
      let tys' = map (fst.skolemiseTy) tys
112 113 114
      let ids = [ mkGlobalId VanillaGlobal name ty vanillaIdInfo
                | (name,ty) <- zip names tys']
          new_tyvars   = tyVarsOfTypes tys'
115
          new_ic       = extendInteractiveContext ictxt ids new_tyvars
mnislaih's avatar
mnislaih committed
116 117 118
      extendLinkEnv (zip names hvals)
      writeIORef ref (hsc_env {hsc_IC = new_ic })
      return t'
119
     where
mnislaih's avatar
mnislaih committed
120 121

--    Processing suspensions. Give names and recopilate info
mnislaih's avatar
mnislaih committed
122
        nameSuspensionsAndGetInfos :: IORef [String] ->
123
                                       TermFold (IO (Term, [(Name,Type,HValue)]))
mnislaih's avatar
mnislaih committed
124
        nameSuspensionsAndGetInfos freeNames = TermFold
mnislaih's avatar
mnislaih committed
125 126
                      {
                        fSuspension = doSuspension freeNames
mnislaih's avatar
mnislaih committed
127 128 129
                      , fTerm = \ty dc v tt -> do
                                    tt' <- sequence tt
                                    let (terms,names) = unzip tt'
mnislaih's avatar
mnislaih committed
130 131
                                    return (Term ty dc v terms, concat names)
                      , fPrim    = \ty n ->return (Prim ty n,[])
132 133 134 135
                      , fNewtypeWrap  = 
                                \ty dc t -> do 
                                    (term, names) <- t
                                    return (NewtypeWrap ty dc term, names)
mnislaih's avatar
mnislaih committed
136
                      }
mnislaih's avatar
mnislaih committed
137
        doSuspension freeNames ct mb_ty hval _name = do
mnislaih's avatar
mnislaih committed
138
          name <- atomicModifyIORef freeNames (\x->(tail x, head x))
mnislaih's avatar
mnislaih committed
139
          n <- newGrimName name
mnislaih's avatar
mnislaih committed
140 141 142 143 144
          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
145
showTerm :: Session -> Term -> IO SDoc
146 147 148
showTerm cms@(Session ref) term = do
    dflags       <- GHC.getSessionDynFlags cms
    if dopt Opt_PrintEvldWithShow dflags
149
       then cPprTerm (liftM2 (++) (\_y->[cPprShowable]) cPprTermBase) term
150
       else cPprTerm cPprTermBase term
mnislaih's avatar
mnislaih committed
151
 where
152 153
  cPprShowable prec t@Term{ty=ty, val=val} =
    if not (isFullyEvaluatedTerm t)
mnislaih's avatar
mnislaih committed
154
     then return Nothing
mnislaih's avatar
mnislaih committed
155
     else do
mnislaih's avatar
mnislaih committed
156 157 158 159 160
        hsc_env <- readIORef ref
        dflags  <- GHC.getSessionDynFlags cms
        do
           (new_env, bname) <- bindToFreshName hsc_env ty "showme"
           writeIORef ref (new_env)
mnislaih's avatar
mnislaih committed
161
           let noop_log _ _ _ _ = return ()
mnislaih's avatar
mnislaih committed
162 163
               expr = "show " ++ showSDoc (ppr bname)
           GHC.setSessionDynFlags cms dflags{log_action=noop_log}
mnislaih's avatar
mnislaih committed
164
           mb_txt <- withExtendedLinkEnv [(bname, val)]
mnislaih's avatar
mnislaih committed
165
                                         (GHC.compileExpr cms expr)
166
           let myprec = 10 -- application precedence. TODO Infix constructors
mnislaih's avatar
mnislaih committed
167 168 169 170
           case mb_txt of
             Just txt_ | txt <- unsafeCoerce# txt_, not (null txt)
                       -> return $ Just$ cparen (prec >= myprec &&
                                                      needsParens txt)
171 172
                                                (text txt)
             _  -> return Nothing
mnislaih's avatar
mnislaih committed
173
         `finally` do
mnislaih's avatar
mnislaih committed
174
           writeIORef ref hsc_env
175 176 177 178 179
           GHC.setSessionDynFlags cms dflags
  cPprShowable prec NewtypeWrap{ty=new_ty,wrapped_term=t} = 
      cPprShowable prec t{ty=new_ty}
  cPprShowable _ _ = panic "cPprShowable - unreachable"

mnislaih's avatar
mnislaih committed
180
  needsParens ('"':_) = False   -- some simple heuristics to see whether parens
181
                                -- are redundant in an arbitrary Show output
mnislaih's avatar
mnislaih committed
182
  needsParens ('(':_) = False
183 184
  needsParens txt = ' ' `elem` txt

mnislaih's avatar
mnislaih committed
185

mnislaih's avatar
mnislaih committed
186
  bindToFreshName hsc_env ty userName = do
mnislaih's avatar
mnislaih committed
187
    name <- newGrimName userName
mnislaih's avatar
mnislaih committed
188
    let ictxt    = hsc_IC hsc_env
189
        tmp_ids  = ic_tmp_ids ictxt
190
        id       = mkGlobalId VanillaGlobal name (sigmaType ty) vanillaIdInfo
191
        new_ic   = ictxt { ic_tmp_ids = id : tmp_ids }
mnislaih's avatar
mnislaih committed
192 193
    return (hsc_env {hsc_IC = new_ic }, name)

mnislaih's avatar
mnislaih committed
194
--    Create new uniques and give them sequentially numbered names
mnislaih's avatar
mnislaih committed
195 196
newGrimName :: String -> IO Name
newGrimName userName  = do
mnislaih's avatar
mnislaih committed
197 198 199
    us <- mkSplitUniqSupply 'b'
    let unique  = uniqFromSupply us
        occname = mkOccName varName userName
200
        name    = mkInternalName unique occname noSrcSpan
mnislaih's avatar
mnislaih committed
201
    return name