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