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 GhcMonad
  19 import HscTypes
  20 import Id
  21 import Name
  22 import Var hiding ( varName )
  23 import VarSet
  24 import UniqSupply
  25 import TcType
  26 import GHC
  27 import InteractiveEval
  28 import Outputable
  29 import PprTyThing
  30 import MonadUtils
  31
  32 import Control.Monad
  33 import Data.List
  34 import Data.Maybe
  35 import Data.IORef
  36
  37 import System.IO
  38 import GHC.Exts
  39
  40 -------------------------------------
  41 -- | The :print & friends commands
  42 -------------------------------------
  43 pprintClosureCommand :: GhcMonad m => Bool -> Bool -> String -> m ()
  44 pprintClosureCommand bindThings force str = do
  45   tythings <- (catMaybes . concat) `liftM`
  46                  mapM (\w -> GHC.parseName w >>=
  47                                 mapM GHC.lookupName)
  48                       (words str)
  49   let ids = [id | AnId id <- tythings]
  50
  51   -- Obtain the terms and the recovered type information
  52   (subst, terms) <- mapAccumLM go emptyTvSubst ids
  53
  54   -- Apply the substitutions obtained after recovering the types
  55   modifySession $ \hsc_env ->
  56     hsc_env{hsc_IC = substInteractiveContext (hsc_IC hsc_env) subst}
  57
  58   -- Finally, print the Terms
  59   unqual  <- GHC.getPrintUnqual
  60   docterms <- mapM showTerm terms
  61   liftIO $ (printForUser stdout unqual . vcat)
  62            (zipWith (\id docterm -> ppr id <+> char '=' <+> docterm)
  63                     ids
  64                     docterms)
  65  where
  66    -- Do the obtainTerm--bindSuspensions-computeSubstitution dance
  67    go :: GhcMonad m => TvSubst -> Id -> m (TvSubst, Term)
  68    go subst id = do
  69        let id' = id `setIdType` substTy subst (idType id)
  70        term_    <- GHC.obtainTermFromId maxBound force id'
  71        term     <- tidyTermTyVars term_
  72        term'    <- if bindThings &&
  73                       False == isUnliftedTypeKind (termType term)
  74                      then bindSuspensions term
  75                      else return term
  76      -- Before leaving, we compare the type obtained to see if it's more specific
  77      --  Then, we extract a substitution,
  78      --  mapping the old tyvars to the reconstructed types.
  79        let reconstructed_type = termType term
  80        hsc_env <- getSession
  81        case (improveRTTIType hsc_env (idType id) (reconstructed_type)) of
  82          Nothing     -> return (subst, term')
  83          Just subst' -> do { traceOptIf Opt_D_dump_rtti
  84                                (fsep $ [text "RTTI Improvement for", ppr id,
  85                                 text "is the substitution:" , ppr subst'])
  86                            ; return (subst `unionTvSubst` subst', term')}
  87
  88    tidyTermTyVars :: GhcMonad m => Term -> m Term
  89    tidyTermTyVars t =
  90      withSession $ \hsc_env -> do
  91      let env_tvs      = tyVarsOfTypes (map idType (ic_tmp_ids (hsc_IC hsc_env)))
  92          my_tvs       = termTyVars t
  93          tvs          = env_tvs `minusVarSet` my_tvs
  94          tyvarOccName = nameOccName . tyVarName
  95          tidyEnv      = (initTidyOccEnv (map tyvarOccName (varSetElems tvs))
  96                         , env_tvs `intersectVarSet` my_tvs)
  97      return$ mapTermType (snd . tidyOpenType tidyEnv) t
  98
  99 -- | Give names, and bind in the interactive environment, to all the suspensions
 100 --   included (inductively) in a term
 101 bindSuspensions :: GhcMonad m => Term -> m Term
 102 bindSuspensions t = do
 103       hsc_env <- getSession
 104       inScope <- GHC.getBindings
 105       let ictxt        = hsc_IC hsc_env
 106           prefix       = "_t"
 107           alreadyUsedNames = map (occNameString . nameOccName . getName) inScope
 108           availNames   = map ((prefix++) . show) [(1::Int)..] \\ alreadyUsedNames
 109       availNames_var  <- liftIO $ newIORef availNames
 110       (t', stuff)     <- liftIO $ foldTerm (nameSuspensionsAndGetInfos availNames_var) t
 111       let (names, tys, hvals) = unzip3 stuff
 112       let ids = [ mkVanillaGlobal name ty
 113                 | (name,ty) <- zip names tys]
 114           new_ic = extendInteractiveContext ictxt ids
 115       liftIO $ extendLinkEnv (zip names hvals)
 116       modifySession $ \_ -> hsc_env {hsc_IC = new_ic }
 117       return t'
 118      where
 119
 120 --    Processing suspensions. Give names and recopilate info
 121         nameSuspensionsAndGetInfos :: IORef [String] ->
 122                                        TermFold (IO (Term, [(Name,Type,HValue)]))
 123         nameSuspensionsAndGetInfos freeNames = TermFold
 124                       {
 125                         fSuspension = doSuspension freeNames
 126                       , fTerm = \ty dc v tt -> do
 127                                     tt' <- sequence tt
 128                                     let (terms,names) = unzip tt'
 129                                     return (Term ty dc v terms, concat names)
 130                       , fPrim    = \ty n ->return (Prim ty n,[])
 131                       , fNewtypeWrap  =
 132                                 \ty dc t -> do
 133                                     (term, names) <- t
 134                                     return (NewtypeWrap ty dc term, names)
 135                       , fRefWrap = \ty t -> do
 136                                     (term, names) <- t
 137                                     return (RefWrap ty term, names)
 138                       }
 139         doSuspension freeNames ct ty hval _name = do
 140           name <- atomicModifyIORef freeNames (\x->(tail x, head x))
 141           n <- newGrimName name
 142           return (Suspension ct ty hval (Just n), [(n,ty,hval)])
 143
 144
 145 --  A custom Term printer to enable the use of Show instances
 146 showTerm :: GhcMonad m => Term -> m SDoc
 147 showTerm term = do
 148     dflags       <- GHC.getSessionDynFlags
 149     if dopt Opt_PrintEvldWithShow dflags
 150        then cPprTerm (liftM2 (++) (\_y->[cPprShowable]) cPprTermBase) term
 151        else cPprTerm cPprTermBase term
 152  where
 153   cPprShowable prec t@Term{ty=ty, val=val} =
 154     if not (isFullyEvaluatedTerm t)
 155      then return Nothing
 156      else do
 157         hsc_env <- getSession
 158         dflags  <- GHC.getSessionDynFlags
 159         do
 160            (new_env, bname) <- bindToFreshName hsc_env ty "showme"
 161            setSession new_env
 162                       -- XXX: this tries to disable logging of errors
 163                       -- does this still do what it is intended to do
 164                       -- with the changed error handling and logging?
 165            let noop_log _ _ _ _ = return ()
 166                expr = "show " ++ showSDoc (ppr bname)
 167            _ <- GHC.setSessionDynFlags dflags{log_action=noop_log}
 168            txt_ <- withExtendedLinkEnv [(bname, val)]
 169                                          (GHC.compileExpr expr)
 170            let myprec = 10 -- application precedence. TODO Infix constructors
 171            let txt = unsafeCoerce# txt_
 172            if not (null txt) then
 173              return $ Just$ cparen (prec >= myprec &&
 174                                          needsParens txt)
 175                                    (text txt)
 176             else return Nothing
 177          `gfinally` do
 178            setSession hsc_env
 179            GHC.setSessionDynFlags dflags
 180   cPprShowable prec NewtypeWrap{ty=new_ty,wrapped_term=t} =
 181       cPprShowable prec t{ty=new_ty}
 182   cPprShowable _ _ = return Nothing
 183
 184   needsParens ('"':_) = False   -- some simple heuristics to see whether parens
 185                                 -- are redundant in an arbitrary Show output
 186   needsParens ('(':_) = False
 187   needsParens txt = ' ' `elem` txt
 188
 189
 190   bindToFreshName hsc_env ty userName = do
 191     name <- newGrimName userName
 192     let ictxt    = hsc_IC hsc_env
 193         tmp_ids  = ic_tmp_ids ictxt
 194         id       = mkVanillaGlobal name ty
 195         new_ic   = ictxt { ic_tmp_ids = id : tmp_ids }
 196     return (hsc_env {hsc_IC = new_ic }, name)
 197
 198 --    Create new uniques and give them sequentially numbered names
 199 newGrimName :: MonadIO m => String -> m Name
 200 newGrimName userName  = do
 201     us <- liftIO $ mkSplitUniqSupply 'b'
 202     let unique  = uniqFromSupply us
 203         occname = mkOccName varName userName
 204         name    = mkInternalName unique occname noSrcSpan
 205     return name
 206
 207 pprTypeAndContents :: GhcMonad m => [Id] -> m SDoc
 208 pprTypeAndContents ids = do
 209   dflags  <- GHC.getSessionDynFlags
 210   let pefas     = dopt Opt_PrintExplicitForalls dflags
 211       pcontents = dopt Opt_PrintBindContents dflags
 212   if pcontents
 213     then do
 214       let depthBound = 100
 215       terms      <- mapM (GHC.obtainTermFromId depthBound False) ids
 216       docs_terms <- mapM showTerm terms
 217       return $ vcat $ zipWith (\ty cts -> ty <+> equals <+> cts)
 218                              (map (pprTyThing pefas . AnId) ids)
 219                              docs_terms
 220     else return $  vcat $ map (pprTyThing pefas . AnId) ids
 221
 222 --------------------------------------------------------------
 223 -- Utils
 224
 225 traceOptIf :: GhcMonad m => DynFlag -> SDoc -> m ()
 226 traceOptIf flag doc = do
 227   dflags <- GHC.getSessionDynFlags
 228   when (dopt flag dflags) $ liftIO $ printForUser stderr alwaysQualify doc