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