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