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