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 Control.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            subst = unifyRTTI (idType id) (reconstructed_type)
  85        return (term',subst)
  86
  87    tidyTermTyVars :: Session -> Term -> IO Term
  88    tidyTermTyVars (Session ref) t = do
  89      hsc_env <- readIORef ref
  90      let env_tvs      = ic_tyvars (hsc_IC hsc_env)
  91          my_tvs       = termTyVars t
  92          tvs          = env_tvs `minusVarSet` my_tvs
  93          tyvarOccName = nameOccName . tyVarName
  94          tidyEnv      = (initTidyOccEnv (map tyvarOccName (varSetElems tvs))
  95                         , env_tvs `intersectVarSet` my_tvs)
  96      return$ mapTermType (snd . tidyOpenType tidyEnv) t
  97
  98 -- | Give names, and bind in the interactive environment, to all the suspensions
  99 --   included (inductively) in a term
 100 bindSuspensions :: Session -> Term -> IO Term
 101 bindSuspensions cms@(Session ref) t = do
 102       hsc_env <- readIORef ref
 103       inScope <- GHC.getBindings cms
 104       let ictxt        = hsc_IC hsc_env
 105           prefix       = "_t"
 106           alreadyUsedNames = map (occNameString . nameOccName . getName) inScope
 107           availNames   = map ((prefix++) . show) [(1::Int)..] \\ alreadyUsedNames
 108       availNames_var  <- newIORef availNames
 109       (t', stuff)     <- foldTerm (nameSuspensionsAndGetInfos availNames_var) t
 110       let (names, tys, hvals) = unzip3 stuff
 111       let tys' = map (fst.skolemiseTy) tys
 112       let ids = [ mkGlobalId VanillaGlobal name ty vanillaIdInfo
 113                 | (name,ty) <- zip names tys']
 114           new_tyvars   = tyVarsOfTypes tys'
 115           new_ic       = extendInteractiveContext ictxt ids new_tyvars
 116       extendLinkEnv (zip names hvals)
 117       writeIORef ref (hsc_env {hsc_IC = new_ic })
 118       return t'
 119      where
 120
 121 --    Processing suspensions. Give names and recopilate info
 122         nameSuspensionsAndGetInfos :: IORef [String] ->
 123                                        TermFold (IO (Term, [(Name,Type,HValue)]))
 124         nameSuspensionsAndGetInfos freeNames = TermFold
 125                       {
 126                         fSuspension = doSuspension freeNames
 127                       , fTerm = \ty dc v tt -> do
 128                                     tt' <- sequence tt
 129                                     let (terms,names) = unzip tt'
 130                                     return (Term ty dc v terms, concat names)
 131                       , fPrim    = \ty n ->return (Prim ty n,[])
 132                       , fNewtypeWrap  =
 133                                 \ty dc t -> do
 134                                     (term, names) <- t
 135                                     return (NewtypeWrap ty dc term, names)
 136                       , fRefWrap = \ty t -> do
 137                                     (term, names) <- t
 138                                     return (RefWrap ty term, names)
 139                       }
 140         doSuspension freeNames ct ty hval _name = do
 141           name <- atomicModifyIORef freeNames (\x->(tail x, head x))
 142           n <- newGrimName name
 143           return (Suspension ct ty hval (Just n), [(n,ty,hval)])
 144
 145
 146 --  A custom Term printer to enable the use of Show instances
 147 showTerm :: Session -> Term -> IO SDoc
 148 showTerm cms@(Session ref) term = do
 149     dflags       <- GHC.getSessionDynFlags cms
 150     if dopt Opt_PrintEvldWithShow dflags
 151        then cPprTerm (liftM2 (++) (\_y->[cPprShowable]) cPprTermBase) term
 152        else cPprTerm cPprTermBase term
 153  where
 154   cPprShowable prec t@Term{ty=ty, val=val} =
 155     if not (isFullyEvaluatedTerm t)
 156      then return Nothing
 157      else do
 158         hsc_env <- readIORef ref
 159         dflags  <- GHC.getSessionDynFlags cms
 160         do
 161            (new_env, bname) <- bindToFreshName hsc_env ty "showme"
 162            writeIORef ref (new_env)
 163            let noop_log _ _ _ _ = return ()
 164                expr = "show " ++ showSDoc (ppr bname)
 165            GHC.setSessionDynFlags cms dflags{log_action=noop_log}
 166            mb_txt <- withExtendedLinkEnv [(bname, val)]
 167                                          (GHC.compileExpr cms expr)
 168            let myprec = 10 -- application precedence. TODO Infix constructors
 169            case mb_txt of
 170              Just txt_ | txt <- unsafeCoerce# txt_, not (null txt)
 171                        -> return $ Just$ cparen (prec >= myprec &&
 172                                                       needsParens txt)
 173                                                 (text txt)
 174              _  -> return Nothing
 175          `finally` do
 176            writeIORef ref hsc_env
 177            GHC.setSessionDynFlags cms dflags
 178   cPprShowable prec NewtypeWrap{ty=new_ty,wrapped_term=t} =
 179       cPprShowable prec t{ty=new_ty}
 180   cPprShowable _ _ = return Nothing
 181
 182   needsParens ('"':_) = False   -- some simple heuristics to see whether parens
 183                                 -- are redundant in an arbitrary Show output
 184   needsParens ('(':_) = False
 185   needsParens txt = ' ' `elem` txt
 186
 187
 188   bindToFreshName hsc_env ty userName = do
 189     name <- newGrimName userName
 190     let ictxt    = hsc_IC hsc_env
 191         tmp_ids  = ic_tmp_ids ictxt
 192         id       = mkGlobalId VanillaGlobal name (sigmaType ty) vanillaIdInfo
 193         new_ic   = ictxt { ic_tmp_ids = id : tmp_ids }
 194     return (hsc_env {hsc_IC = new_ic }, name)
 195
 196 --    Create new uniques and give them sequentially numbered names
 197 newGrimName :: String -> IO Name
 198 newGrimName userName  = do
 199     us <- mkSplitUniqSupply 'b'
 200     let unique  = uniqFromSupply us
 201         occname = mkOccName varName userName
 202         name    = mkInternalName unique occname noSrcSpan
 203     return name
 204
 205 pprTypeAndContents :: Session -> [Id] -> IO SDoc
 206 pprTypeAndContents session ids = do
 207   dflags  <- GHC.getSessionDynFlags session
 208   let pefas     = dopt Opt_PrintExplicitForalls dflags
 209       pcontents = dopt Opt_PrintBindContents dflags
 210   if pcontents
 211     then do
 212       let depthBound = 100
 213       terms      <- mapM (GHC.obtainTermB session depthBound False) ids
 214       docs_terms <- mapM (showTerm session) terms
 215       return $ vcat $ zipWith (\ty cts -> ty <+> equals <+> cts)
 216                              (map (pprTyThing pefas . AnId) ids)
 217                              docs_terms
 218     else return $  vcat $ map (pprTyThing pefas . AnId) ids