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