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, substs) <- unzip `liftM` mapM go ids
  57
  58   -- Apply the substitutions obtained after recovering the types
  59   modifySession $ \hsc_env ->
  60          hsc_env{hsc_IC = foldr (flip substInteractiveContext)
  61                                 (hsc_IC hsc_env)
  62                                 (map skolemiseSubst substs)}
  63   -- Finally, print the Terms
  64   unqual  <- GHC.getPrintUnqual
  65   docterms <- mapM showTerm terms
  66   liftIO $ (printForUser stdout unqual . vcat)
  67            (zipWith (\id docterm -> ppr id <+> char '=' <+> docterm)
  68                     ids
  69                     docterms)
  70  where
  71
  72    -- Do the obtainTerm--bindSuspensions-computeSubstitution dance
  73    go :: GhcMonad m => Id -> m (Term, TvSubst)
  74    go id = do
  75        term_    <- GHC.obtainTerm 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        return (term', fromMaybe emptyTvSubst mb_subst)
  88
  89    tidyTermTyVars :: GhcMonad m => Term -> m Term
  90    tidyTermTyVars t =
  91      withSession $ \hsc_env -> do
  92      let env_tvs      = ic_tyvars (hsc_IC hsc_env)
  93          my_tvs       = termTyVars t
  94          tvs          = env_tvs `minusVarSet` my_tvs
  95          tyvarOccName = nameOccName . tyVarName
  96          tidyEnv      = (initTidyOccEnv (map tyvarOccName (varSetElems tvs))
  97                         , env_tvs `intersectVarSet` my_tvs)
  98      return$ mapTermType (snd . tidyOpenType tidyEnv) t
  99
 100 -- | Give names, and bind in the interactive environment, to all the suspensions
 101 --   included (inductively) in a term
 102 bindSuspensions :: GhcMonad m => Term -> m Term
 103 bindSuspensions t = do
 104       hsc_env <- getSession
 105       inScope <- GHC.getBindings
 106       let ictxt        = hsc_IC hsc_env
 107           prefix       = "_t"
 108           alreadyUsedNames = map (occNameString . nameOccName . getName) inScope
 109           availNames   = map ((prefix++) . show) [(1::Int)..] \\ alreadyUsedNames
 110       availNames_var  <- liftIO $ newIORef availNames
 111       (t', stuff)     <- liftIO $ foldTerm (nameSuspensionsAndGetInfos availNames_var) t
 112       let (names, tys, hvals) = unzip3 stuff
 113       let tys' = map (fst.skolemiseTy) tys
 114       let ids = [ mkGlobalId VanillaGlobal name ty vanillaIdInfo
 115                 | (name,ty) <- zip names tys']
 116           new_tyvars   = tyVarsOfTypes tys'
 117           new_ic       = extendInteractiveContext ictxt ids new_tyvars
 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       = mkGlobalId VanillaGlobal name (sigmaType ty) vanillaIdInfo
 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.obtainTermB 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