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