compiler/ghci/Debugger.hs

   1 -----------------------------------------------------------------------------
   2 --
   3 -- GHCi Interactive debugging commands
   4 --
   5 -- Pepe Iborra (supported by Google SoC) 2006
   6 --
   7 -- ToDo: lots of violation of layering here.  This module should
   8 -- decide whether it is above the GHC API (import GHC and nothing
   9 -- else) or below it.
  10 --
  11 -----------------------------------------------------------------------------
  12
  13 module Debugger (pprintClosureCommand, showTerm, pprTypeAndContents) where
  14
  15 import Linker
  16 import RtClosureInspect
  17
  18 import HscTypes
  19 import IdInfo
  20 --import Id
  21 import Name
  22 import Var hiding ( varName )
  23 import VarSet
  24 import Name
  25 import UniqSupply
  26 import TcType
  27 import GHC
  28 import DynFlags
  29 import InteractiveEval
  30 import Outputable
  31 import SrcLoc
  32 import PprTyThing
  33
  34 import Control.Exception
  35 import Control.Monad
  36 import Data.List
  37 import Data.Maybe
  38 import Data.IORef
  39
  40 import System.IO
  41 import GHC.Exts
  42
  43 -------------------------------------
  44 -- | The :print & friends commands
  45 -------------------------------------
  46 pprintClosureCommand :: Session -> Bool -> Bool -> String -> IO ()
  47 pprintClosureCommand session bindThings force str = do
  48   tythings <- (catMaybes . concat) `liftM`
  49                  mapM (\w -> GHC.parseName session w >>=
  50                                 mapM (GHC.lookupName session))
  51                       (words str)
  52   let ids = [id | AnId id <- tythings]
  53
  54   -- Obtain the terms and the recovered type information
  55   (terms, substs) <- unzip `liftM` mapM (go session) ids
  56
  57   -- Apply the substitutions obtained after recovering the types
  58   modifySession session $ \hsc_env ->
  59          hsc_env{hsc_IC = foldr (flip substInteractiveContext)
  60                                 (hsc_IC hsc_env)
  61                                 (map skolemiseSubst substs)}
  62   -- Finally, print the Terms
  63   unqual  <- GHC.getPrintUnqual session
  64   docterms <- mapM (showTerm session) terms
  65   (printForUser stdout unqual . vcat)
  66         (zipWith (\id docterm -> ppr id <+> char '=' <+> docterm)
  67                  ids
  68                  docterms)
  69  where
  70
  71    -- Do the obtainTerm--bindSuspensions-computeSubstitution dance
  72    go :: Session -> Id -> IO (Term, TvSubst)
  73    go cms id = do
  74        term_    <- GHC.obtainTerm cms force id
  75        term     <- tidyTermTyVars cms term_
  76        term'    <- if not bindThings then return term
  77                      else bindSuspensions cms term
  78      -- Before leaving, we compare the type obtained to see if it's more specific
  79      --  Then, we extract a substitution,
  80      --  mapping the old tyvars to the reconstructed types.
  81        let Just reconstructed_type = termType term
  82            subst = computeRTTIsubst (idType id) (reconstructed_type)
  83        return (term',subst)
  84
  85    tidyTermTyVars :: Session -> Term -> IO Term
  86    tidyTermTyVars (Session ref) t = do
  87      hsc_env <- readIORef ref
  88      let env_tvs      = ic_tyvars (hsc_IC hsc_env)
  89          my_tvs       = termTyVars t
  90          tvs          = env_tvs `minusVarSet` my_tvs
  91          tyvarOccName = nameOccName . tyVarName
  92          tidyEnv      = (initTidyOccEnv (map tyvarOccName (varSetElems tvs))
  93                         , env_tvs `intersectVarSet` my_tvs)
  94      return$ mapTermType (snd . tidyOpenType tidyEnv) t
  95
  96 -- | Give names, and bind in the interactive environment, to all the suspensions
  97 --   included (inductively) in a term
  98 bindSuspensions :: Session -> Term -> IO Term
  99 bindSuspensions cms@(Session ref) t = do
 100       hsc_env <- readIORef ref
 101       inScope <- GHC.getBindings cms
 102       let ictxt        = hsc_IC hsc_env
 103           prefix       = "_t"
 104           alreadyUsedNames = map (occNameString . nameOccName . getName) inScope
 105           availNames   = map ((prefix++) . show) [(1::Int)..] \\ alreadyUsedNames
 106       availNames_var  <- newIORef availNames
 107       (t', stuff)     <- foldTerm (nameSuspensionsAndGetInfos availNames_var) t
 108       let (names, tys, hvals) = unzip3 stuff
 109       let tys' = map (fst.skolemiseTy) tys
 110       let ids = [ mkGlobalId VanillaGlobal name ty vanillaIdInfo
 111                 | (name,ty) <- zip names tys']
 112           new_tyvars   = tyVarsOfTypes tys'
 113           new_ic       = extendInteractiveContext ictxt ids new_tyvars
 114       extendLinkEnv (zip names hvals)
 115       writeIORef ref (hsc_env {hsc_IC = new_ic })
 116       return t'
 117      where
 118
 119 --    Processing suspensions. Give names and recopilate info
 120         nameSuspensionsAndGetInfos :: IORef [String] ->
 121                                        TermFold (IO (Term, [(Name,Type,HValue)]))
 122         nameSuspensionsAndGetInfos freeNames = TermFold
 123                       {
 124                         fSuspension = doSuspension freeNames
 125                       , fTerm = \ty dc v tt -> do
 126                                     tt' <- sequence tt
 127                                     let (terms,names) = unzip tt'
 128                                     return (Term ty dc v terms, concat names)
 129                       , fPrim    = \ty n ->return (Prim ty n,[])
 130                       , fNewtypeWrap  =
 131                                 \ty dc t -> do
 132                                     (term, names) <- t
 133                                     return (NewtypeWrap ty dc term, names)
 134                       }
 135         doSuspension freeNames ct mb_ty hval _name = do
 136           name <- atomicModifyIORef freeNames (\x->(tail x, head x))
 137           n <- newGrimName name
 138           let ty' = fromMaybe (error "unexpected") mb_ty
 139           return (Suspension ct mb_ty hval (Just n), [(n,ty',hval)])
 140
 141
 142 --  A custom Term printer to enable the use of Show instances
 143 showTerm :: Session -> Term -> IO SDoc
 144 showTerm cms@(Session ref) term = do
 145     dflags       <- GHC.getSessionDynFlags cms
 146     if dopt Opt_PrintEvldWithShow dflags
 147        then cPprTerm (liftM2 (++) (\_y->[cPprShowable]) cPprTermBase) term
 148        else cPprTerm cPprTermBase term
 149  where
 150   cPprShowable prec t@Term{ty=ty, val=val} =
 151     if not (isFullyEvaluatedTerm t)
 152      then return Nothing
 153      else do
 154         hsc_env <- readIORef ref
 155         dflags  <- GHC.getSessionDynFlags cms
 156         do
 157            (new_env, bname) <- bindToFreshName hsc_env ty "showme"
 158            writeIORef ref (new_env)
 159            let noop_log _ _ _ _ = return ()
 160                expr = "show " ++ showSDoc (ppr bname)
 161            GHC.setSessionDynFlags cms dflags{log_action=noop_log}
 162            mb_txt <- withExtendedLinkEnv [(bname, val)]
 163                                          (GHC.compileExpr cms expr)
 164            let myprec = 10 -- application precedence. TODO Infix constructors
 165            case mb_txt of
 166              Just txt_ | txt <- unsafeCoerce# txt_, not (null txt)
 167                        -> return $ Just$ cparen (prec >= myprec &&
 168                                                       needsParens txt)
 169                                                 (text txt)
 170              _  -> return Nothing
 171          `finally` do
 172            writeIORef ref hsc_env
 173            GHC.setSessionDynFlags cms dflags
 174   cPprShowable prec NewtypeWrap{ty=new_ty,wrapped_term=t} =
 175       cPprShowable prec t{ty=new_ty}
 176   cPprShowable _ _ = panic "cPprShowable - unreachable"
 177
 178   needsParens ('"':_) = False   -- some simple heuristics to see whether parens
 179                                 -- are redundant in an arbitrary Show output
 180   needsParens ('(':_) = False
 181   needsParens txt = ' ' `elem` txt
 182
 183
 184   bindToFreshName hsc_env ty userName = do
 185     name <- newGrimName userName
 186     let ictxt    = hsc_IC hsc_env
 187         tmp_ids  = ic_tmp_ids ictxt
 188         id       = mkGlobalId VanillaGlobal name (sigmaType ty) vanillaIdInfo
 189         new_ic   = ictxt { ic_tmp_ids = id : tmp_ids }
 190     return (hsc_env {hsc_IC = new_ic }, name)
 191
 192 --    Create new uniques and give them sequentially numbered names
 193 newGrimName :: String -> IO Name
 194 newGrimName userName  = do
 195     us <- mkSplitUniqSupply 'b'
 196     let unique  = uniqFromSupply us
 197         occname = mkOccName varName userName
 198         name    = mkInternalName unique occname noSrcSpan
 199     return name
 200
 201 pprTypeAndContents :: Session -> [Id] -> IO SDoc
 202 pprTypeAndContents session ids = do
 203   dflags  <- GHC.getSessionDynFlags session
 204   let pefas     = dopt Opt_PrintExplicitForalls dflags
 205       pcontents = dopt Opt_PrintBindContents dflags
 206   if pcontents
 207     then do
 208       let depthBound = 100
 209       terms      <- mapM (GHC.obtainTermB session depthBound False) ids
 210       docs_terms <- mapM (showTerm session) terms
 211       return $ vcat $ zipWith (\ty cts -> ty <+> equals <+> cts)
 212                              (map (pprTyThing pefas . AnId) ids)
 213                              docs_terms
 214     else return $  vcat $ map (pprTyThing pefas . AnId) ids